coolbutuseless

Toy WASM interpreter in base R

Fri, 29 Jul 2022 18:05:00 +1000

WASM

One of the big buzzes at #RStudioConf2022 was the whiff of serverless “Shiny” in both python and R by harnessing WASM.

WASM (a.k.a. WebAssembly) is a portable binary-code format initially targetted at running code in a web browser at near-native speeds.

This post is a small exploration into what a WASM binary actually looks like and how it is structured.

I also create a toy interpreter for WASM in R. Note: You would never do this in real-life - it’s just for a bit of fun (maybe because I had so much fun with the virtual machine interpreter for AnotherWorld)

C function to calculate `factorial(n)`

This is a classic bit of C code for calculating n! i.e. n * (n-1) * (n-2) * ... * 1

int factorial(int n) {
  if (n == 0)
    return 1;
  else
    return n * factorial(n-1);
}

`factorial(n)` in WAT (human readable WASM text)

There is a human-readable version of WASM called “WAT” which has a structure similar to S-expressions.

The above C code would be compiled to WASM/WAT as follows:

(func (param i64) (result i64)
  local.get 0             # put arg[0] on stack
  i64.eqz                 # compare top of stack to zero
  if (result i64)         # if it is zero
      i64.const 1         # put 1 on stack
  else       
      local.get 0         # put arg[0] on stack
      local.get 0         # put arg[0] on stack
      i64.const 1         # put 1 on stack
      i64.sub             # subtract the top 2 values in stack
      call 0              # Call function #0 (return value is on the stack)
      i64.mul             # Multiply 
  end)'

Compile WAT to WASM

The WebAssembly Binary Toolkit (WABT) can be used to compile the WAT file into a binary WASM file

brew install wabt
wat2wasm helloworld.wat   # Creates 'helloworld.wasm'

# helloworld.wasm
00 61 73 6d 01 00 00 00 01 06 01 60 01 7e 01 7e 03 02 01 00 0a 17 01 15 00 20 00 50 04 7e 42 01 05 20 00 20 00 42 01 7d 10 00 7e 0b 0b

WASM raw bytes

With some googling and using the reference list of WASM bytecodes it is possible to deconstruct and understand the bytes in the *.wasm file for the factorial(n) function

  0x00, 0x61, 0x73, 0x6D, # magick = \0asm
  0x01, 0x00, 0x00, 0x00, # version = 1
  
  # The 'type' section contains function signatures.
  0x01, 0x06 ,     # section "type". 6 bytes
  0x01,            # Num types = 1 i.e. just a single 'function' type defined here
  0x60,            # Function (begin definition)
  0x01,            # Number of parameters = 1
  0x7e,            #  param types: i64
  0x01,            # Number of results = 1
  0x7e,            #  result types: i64
  
  # The 'function' section stores indexes of the function signature
  0x03, 0x02,      # section "function". section size = 2 bytes
  0x01,            # Number of functions
  0x00,            # Index of function
  
  # The 'code' section contains the actual function code
  0x0A, 0x17,      # Section "code".  section size = 0x17 = 23 bytes
  0x01,            # Number of functions = 1 
  0x15,            # Function body size = 0x15 = 21 bytes
  0x00,            # Number of local declarations = 0
  0x20, 0x00,      #   local.get 0
  0x50,            #   i64.eqz
  0x04, 0x7E,      #   if i64
  0x42, 0x01,      #     i64.const 1
  0x05,            #   else
  0x20, 0x00,      #     local.get 0
  0x20, 0x00,      #     local get 0
  0x42, 0x01,      #     i64.const 1
  0x7D,            #     i64.sub
  0x10, 0x00,      #     call 0
  0x7E,            #     i64.mul
  0x0B,            #   end
  0x0B             # end

WASM virtual stack machine

WASM bytecode is intended to be run on a virtual stack machine.

A simple way of implementing a stack machine in R is to have a giant switch statement and a stack implementation. The switch statement chooses what operations to do based upon the bytecode.

I’m cheating a little bit here and have hand-parsed the code split at the if-else statement into two blocks.

Other cheats:

you would normally need 64bit integers (i.e. i64 type in WASM) to interpret the factorial() code in WASM, but as long as you don’t give it a large number it will be fine.
integers in WASM are encoded as LEB128 variable length integers but since the code sizes are all small, every integer fits in 7-bits which means that no encoding/decoding is necessary.

Warnings

This unoptimized interpreter is going to be terribly slow.

Stack

Stack implementations don’t come much more naive than this.

The stack variable itself is just going to exist in the global environment.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Naive stack
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
stack <- c()

# Pop a value of the stack
stack_pop <- function() {
  res   <- stack[1]
  stack <<- stack[-1]
  res
}

# Push a value on the stack
stack_push <- function(val) {
  stack <<- c(val, stack)
}

Define the functions

The major cheat here is that i’ve pre-parsed the function into initial code in the function and the two code blocks that are executed depending on the if/else statement.

There may be multiple functions in general, so all_funcs is a list of all the functions in the code, and the correct function is extracted during a call opcode (i.e. 0x10)

all_funcs <- list(
  func <- list(
    args = c(),
    start = c(
      0x20, 0x00,      #   local.get 0
      0x50,            #   i64.eqz
      0x04, 0x7E       #   if i64
    ),
    if_branch = c(
      0x42, 0x01       #     i64.const 1
    ),
    else_branch = c(
      0x20, 0x00,      #     local.get 0
      0x20, 0x00,      #     local get 0
      0x42, 0x01,      #     i64.const 1
      0x7D,            #     i64.sub
      0x10, 0x00,      #     call 0
      0x7E             #     i64.mul
    )
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#" Recursively interpret the given function
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
interp_wasm <- function(func) {
  
  # Set the bytecode to be the starting code of the function
  byte_idx <- 1
  bytecode <- func$start
  
  # Helper function to read 'n' bytes from the bytecode
  read_bytes <- function(n) {
    res <- bytecode[byte_idx + seq(n) - 1]
    byte_idx <<- byte_idx + n
    res
  }
  
  # For each opcode, determine what to do within a giant `switch` statement
  while(byte_idx <= length(bytecode)) {
    opcode <- read_bytes(1)
    opcode <- sprintf("0x%02x", opcode)
    switch(
      opcode, 
      '0x04' = { # if
        type = read_bytes(1) # value type that if() operates on. ignored
        value = stack_pop()  # get the value. treat as boolean.
        if (value == 1) {
          # Jump the bytecode into the respective TRUE/FALSE branch
          bytecode <- func$if_branch
          byte_idx <- 1
        } else {
          bytecode <- func$else_branch
          byte_idx <- 1
        }
      },
      '0x10' = { # call
        # Select the function to call, setup the arguments and call it
        func_idx <- read_bytes(1)
        next_func <- all_funcs[[func_idx + 1]]
        arg <- stack_pop()
        next_func$args <- arg
        if (verbose) message("factorial(", arg, ")")
        interp_wasm(next_func)
      },
      '0x20' = { # local.get idx
        # Push a local variable onto the stack.
        # In this simple case all local vars are just the args to the function
        idx <- read_bytes(1)
        value <- func$args[idx + 1]
        stack_push(value)
      },
      '0x42' = { # i64 const
        # Push a constant onto the stack
        value <- read_bytes(1)
        stack_push(value)
      },
      '0x50' = { # i64.eqz
        # Is value at top of stack == 0?  No/Yes = 0/1
        value <- stack_pop()
        result <- value == 0
        stack_push(result)
      },
      '0x7d' = { # i64.sub
        # Subtract the two values at the top of the stack
        val2 <- stack_pop()
        val1 <- stack_pop()
        result <- val1 - val2
        stack_push(result)
      },
      '0x7e' = { # i64.mul
        # Multiply the 2 values at the top of the stack
        val2 <- stack_pop()
        val1 <- stack_pop()
        result <- val1 * val2
        stack_push(result)
      }
    )
    
    if (verbose) {
      message(opcode, " -> stack: ", deparse(stack))
    }
  }
  return(stack[1])
}

`factorial(3)` running in WASM

# Select the factorial function
func <- all_funcs[[1]]

# Set the argument to be '3'
func$args <- 3

# interpret the code
verbose <- FALSE
interp_wasm(func)
#> [1] 6

`factorial(3)` running in WASM (verbose)

func$args <- 4
verbose <- TRUE
interp_wasm(func)
#> 0x20 -> stack: c(4, 6)
#> 0x50 -> stack: c(0, 6)
#> 0x04 -> stack: 6
#> 0x20 -> stack: c(4, 6)
#> 0x20 -> stack: c(4, 4, 6)
#> 0x42 -> stack: c(1, 4, 4, 6)
#> 0x7d -> stack: c(3, 4, 6)
#> factorial(3)
#> 0x20 -> stack: c(3, 4, 6)
#> 0x50 -> stack: c(0, 4, 6)
#> 0x04 -> stack: c(4, 6)
#> 0x20 -> stack: c(3, 4, 6)
#> 0x20 -> stack: c(3, 3, 4, 6)
#> 0x42 -> stack: c(1, 3, 3, 4, 6)
#> 0x7d -> stack: c(2, 3, 4, 6)
#> factorial(2)
#> 0x20 -> stack: c(2, 3, 4, 6)
#> 0x50 -> stack: c(0, 3, 4, 6)
#> 0x04 -> stack: c(3, 4, 6)
#> 0x20 -> stack: c(2, 3, 4, 6)
#> 0x20 -> stack: c(2, 2, 3, 4, 6)
#> 0x42 -> stack: c(1, 2, 2, 3, 4, 6)
#> 0x7d -> stack: c(1, 2, 3, 4, 6)
#> factorial(1)
#> 0x20 -> stack: c(1, 2, 3, 4, 6)
#> 0x50 -> stack: c(0, 2, 3, 4, 6)
#> 0x04 -> stack: c(2, 3, 4, 6)
#> 0x20 -> stack: c(1, 2, 3, 4, 6)
#> 0x20 -> stack: c(1, 1, 2, 3, 4, 6)
#> 0x42 -> stack: c(1, 1, 1, 2, 3, 4, 6)
#> 0x7d -> stack: c(0, 1, 2, 3, 4, 6)
#> factorial(0)
#> 0x20 -> stack: c(0, 1, 2, 3, 4, 6)
#> 0x50 -> stack: c(1, 1, 2, 3, 4, 6)
#> 0x04 -> stack: c(1, 2, 3, 4, 6)
#> 0x42 -> stack: c(1, 1, 2, 3, 4, 6)
#> 0x10 -> stack: c(1, 1, 2, 3, 4, 6)
#> 0x7e -> stack: c(1, 2, 3, 4, 6)
#> 0x10 -> stack: c(1, 2, 3, 4, 6)
#> 0x7e -> stack: c(2, 3, 4, 6)
#> 0x10 -> stack: c(2, 3, 4, 6)
#> 0x7e -> stack: c(6, 4, 6)
#> 0x10 -> stack: c(6, 4, 6)
#> 0x7e -> stack: c(24, 6)
#> [1] 24

What’s next?

Nothing really.

An actual WASM stack machine would need signed & unsigned 64 bit integers. You could use {bit64} to support this, if you really wanted to.

There are ~250 standard opcodes, and another ~250 SSE opcodes. I have no appetite for implementing all these - but it could be fun at some future date.

Please steal/adapt the code if you’re interested.

AnotherWorld game written + playable in R (with {nara} and {eventloop})

Fri, 29 Jul 2022 17:07:00 +1000

`AnotherWorld` playable game in R

This is the full code for a playable R version of the 16-bit game AnotherWorld

The game plays in realtime using 2 key packages:

{nara} for manipulation of nativeRaster images as a fast in-memory drawing canvas
{eventloop} for event-driven interaction - allowing for keyboard feedback while rendering the game with sound.

You can play this game today in R!!

However, there are still some graphics bugs etc to work out.

Please file an issue on github if you think something is definitely wrong!

Gameplay in R

A live capture of playing the game in R

Installation

Install the dependencies
- {nara}
- {eventloop}
Retrieve the anotherworld game code from github
- Note that this is not a package, but just a collection of R scripts and code. This should make it easier to hack on, extend and adapt.

library(remotes)

# Install dependencies
remotes::install_github('coolbutuseless/eventloop')
remotes::install_github('coolbutuseless/nara')

# Install packages
install.packages('audio')
install.packages('beepr')

# Grab a copy of the code (this is not distributed as a package)
system("git clone https://github.com/coolbutuseless/anotherworld")
setwd('anotherworld')

Controls

After your experiment on Earth goes awry, you are transported to another world where you must survive and, hopefully, escape!

Run game with source('game.R')
- Set PART variable first to the section you want to play.
Control game with arrow keys and space bar (for action)
Press ‘p’ to pause
Press ‘ESC’ to quit
When you finish a section the game does not automatically advance to the next section.

Play the game

16001 “Introduction”: cinematic introduction. No user interactivity
16002 “Water”: If you want to get to playing the game, this is the section to run.
- Hint: Press “Up” at the start when it looks like you’re underwater.
16003 “Jail”
16004 “City”
16005 “Arena”
16006 “Luxe”
16007 “Final”

PART <- 16001  # <------- select the part of the game to play
source('game.R')

GamePlay

Game walkthrough on the Amiga

This looks pretty similar to the R version as it’s running on the same in-game virtual machine.

Click the image below to watch it on youtube.

Screenshots of the R version

ToDo

Controls still feel a bit “sticky”. This feels like a bug in my code.
Incorporate display of pre-rendered bitmaps which are part of the in-game data
- You’ll notice some scenes are a little blank because these bitmaps aren’t drawn yet.
Still some rendering anomalies
See if I can get sound playback with {audio} package working correctly
While there are sound effects in the R version, there is currently no music as it hasn’t been looked into yet.

Requirements

macOS

Running this on macOS requires XQuartz to have been installed in order to support the x11() device.

Linux

R needs to have been compiled with x11() and Cairo support.

Limitation - WindowsOS

The WindowsOS version of R does not currently have support for the onIdle callback and therefore does not support event-driven interactive graphics as implemented in the {eventloop} package.

If you are a windows developer capable of adding support for an onIdle callback to R itself, please get in touch!

Limitation - Flickering Cursor

The cursor icon in an {eventloop} window will flicker because of some hard-coded behaviour in R’s double-buffered x11() graphics device.

{eventloop} makes use of the x11() graphics device with a double-buffered backend based on Cairo (x11(type = 'dbcairo')).

The double-buffering within the graphics device is coordinated through use of dev.hold() and dev.flush() calls.

Whenever dev.hold() is called, the cursor will be set to the busy cursor (usually a stopwatch on macOS), and when dev.flush() is called the cursor reverts to a normal pointer arrow.

Since dev.hold() and dev.flush() are called when drawing every single frame, the cursor will flicker between these two images.

The interim solution is to not have the cursor over the window when interacting with the app. This only really works when the app solely relies on keyboard feedback (like this game of AnotherWorld).

The more complicated solution will involve crafting a patch to R itself to make the cursor change behaviour user-configurable rather than hard-coded.

If you are are an R developer capable of crafting such a patch to R , please get in touch with me!

Reference Source Code

The reference code for this port was the JavaScript code from github/cyxx/another_js.

Further details have been extracted from the C code from Fabien’s C++ Interpreter.

Challenges

0-based vs 1-based indexing

Javascript and C code used for reference both use 0-based indexing, whereas R uses 1-based indexing.

To try and avoid editing all references to array indexint to +1, I created a new class cindex which has 1-based indexing in R.

There still a lot of refacoring to do, and many structures are still indexed by a character string representation of the hexadecimal version of the index or address i.e. ugly.

bitwise operations

JS and C both use & and | for bitwise operations, whereas R uses them for logical operations.

I created a set of infix operators (%|% etc) to mimic the bitwise operators in C.

‘Bytekiller’ compression

Data in the original game is compressed with ‘bytekiller’ which is a very very old skool data compression algorithm.

Pacman game written in R with {nara} and {eventloop}

Tue, 26 Jul 2022 07:07:00 +1000

Pacman-style game in R

This is the full code for a playable, pacman-style game in R.

The game plays in realtime using 2 key packages:

{nara} for manipulation of nativeRaster images as a fast in-memory drawing canvas
{eventloop} for event-driven interaction - allowing for keyboard feedback while rendering the game with sound.

Gameplay

Controls

The aim of this pacman-style game is to eat all 288 dots before you lose your 5 pacman lives.

Run game with source('game.R')
Control pacman with arrow keys (or WASD).
Score 10 points for each dot consume.
Lose 100 points for every collision with a ghost.
Maximum possible score: 2880 for consume all dots and never colliding with a ghost.
There are no power-ups. Ghosts cannot die. Every collision with a ghost will take one of your lives.
The portal between the left and right side of the board, as present on a regular pacman game, is not included here.

Installation

Install the dependencies
- {nara}
- {eventloop}
Retrieve the pacman game code from github
- Note that this is not a package, but just a collection of R scripts and code. This should make it easier to hack on, extend and adapt.

library(remotes)

# Packages required for interactive rendering
remotes::install_githb("coolbutuseless/eventloop")
remotes::install_githb("coolbutuseless/nara")

# Grab a copy of the pacman game code
x <- remotes::remote_download(remotes::github_remote('coolbutuseless/pacman'))
untar(x, exdir = 'pacman')
setwd('pacman')
source('game.R')

Requirements

macOS

Running this on macOS requires XQuartz to have been installed in order to support the x11() device.

Linux

R needs to have been compiled with x11() and Cairo support.

Limitation - WindowsOS

The WindowsOS version of R does not currently have support for the onIdle callback and therefore does not support event-driven interactive graphics as implemented in the {eventloop} package.

If you are a windows developor capable of adding support for an onIdle callback to R itself, please get in touch!

Limitation - Flickering Cursor

The cursor icon in an {eventloop} window will flicker because of some hard-coded behaviour in R’s double-buffered x11() graphics device.

{eventloop} makes use of the x11() graphics device with a double-buffered backend based on Cairo (x11(type = 'dbcairo')).

The double-buffering within the graphics device is coordinated through use of dev.hold() and dev.flush() calls.

Whenever dev.hold() is called, the cursor will be set to the busy cursor (usually a stopwatch on macOS), and when dev.flush() is called the cursor reverts to a normal pointer arrow.

Since dev.hold() and dev.flush() are called when drawing every single frame, the cursor will flicker between these two images.

The interim solution is to not have the cursor over the window when interacting with the app. This only really works when the app solely relies on keyboard feedback (like this pacman game).

The more complicated solution will involve crafting a patch to R itself to make the cursor change behaviour user-configurable rather than hard-coded.

If you are are an R developer capable of crafting such a patch to R , please get in touch with me!

Introducing {nara} for nativeRaster handling for fast in-memory rendering buffers

Mon, 25 Jul 2022 15:15:00 +1000

nara

{nara} provides tools for working with R’s nativeRaster image format to enable fast double-buffered graphics rendering.

Why?

nativeRaster buffers are fast enough to use for rendering at speed >30 frames-per-second.
This makes them useful for games and other interactive applications.

Example

An example graphics demo is this non-playable version of pacman created and running in R in realtime (see the vignette):

Details

{nara}:

is an off-screen rendering buffer.
is fast to render.
uses in-place operations to avoid memory allocations.
is focussed on rendering discrete pixels, so
- no anti-aliasing is done.
- all dimensions are rounded to integer values prior to rendering.

What is a `nativeRaster` and why is it fast?

A nativeRaster is a built-in datatype in R.

It is an integer matrix where each integer represents the RGBA colour at a single pixel. The 32-bit integer at each location is interpreted within R to be four colour channels (RGBA) represented by 8 bits each.

This way of encoding colour information is closer to the internal representation used by graphics devices, and therefore can be faster to render, save and load (as fewer data conversion steps are needed).

In-place operation

{nara} is targeted at fast rendering (>30fps), and tries to minimise R function calls and memory allocations.

When updating nativeRaster objects with this package, all changes are done in place on the current object i.e. a new object is not created.

Anti-aliasing/Interpolation

No anti-aliasing is done by the draw methods in this package.

No interpolation is done - x and y values for drawing coordinates are converted to integers.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/nara')

Vignettes

Static Rendering: Example

The following is a rendering of a single scene with multiple elements.

The interesting thing about this scene that drawing all the objects into the nativeRaster image and rendering to screen can take as little as 5 millseconds.

This means that this scene could render at around 200 frames-per-second.

library(grid)
library(nara)
set.seed(1)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create 'nr' image
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
w  <- 10
h  <- 8
nr <- nr_new(w * 30, h * 30, fill = 'grey98')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw a grid of squares
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
colours <- viridisLite::inferno(w * h)
coords  <- expand.grid(y = seq(0, h-1) * 30 + 1, x = seq(0, w-1) * 30 + 1)
nr_rect(nr, x = coords$x, y = coords$y, w = 27, h = 27, colour = NA, fill = colours)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw a bunch of dinos
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_blit(nr, dino[[1]], x = sample(300, 15), y = sample(200, 15))


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add an image read from file (with alpha transparency)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
img <- png::readPNG(system.file("img", "Rlogo.png", package="png"), native = TRUE)
nr_blit(nr, img, 1, 1)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add a polygon
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
thetas <- seq(pi/6, 2*pi, pi/3)
x <- 50 * cos(thetas) + 240
y <- 50 * sin(thetas) + 180
nr_polygon(nr, x = x, y = y, fill = '#556688c0', col = 'blue')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add text to the image
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_text(nr, "Hello #RStats", 180, 1, fontsize = 16)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Copy image to the device
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.raster(nr, interpolate = FALSE)

Static Rendering: Displaying Sprites

Included with {nara} are 16 frames of cartoon dinosaur animation from the BubbleBobble video game - see dino data.

Blit the first dino frame onto a native raster canvas.

library(grid)

nr <- nr_new(100, 30, 'grey80')
nr_blit(nr, dino[[1]], 2, 1)
grid.raster(nr, interpolate = FALSE)

Dynamic (realtime) Rendering: Walking Dino

The reason to use {nara} is that operations are fast enough that nativeRaster can be used as an in-memory buffer for a double-bufferred rendering system.

Double-buffered rendering is where two buffers are used for rendering with one buffer being shown to the user, and the other existing in memory as a place to render.

In this example, the dino sprite is renderd to a nativeRaster image. This in-memory buffer is then displayed to the user using grid.raster().

By altering the position and animation frame every time the dino is shown, smooth animation is possible.

This simple code runs at well over 100 frames-per-second.

It is unlikely your screen will refresh this fast, but it does indicate that there is plenty of headroom for more complicated computations for each frame.

library(grid)

# Setup a fast graphics device that can render quickly
x11(type = 'cairo', antialias = 'none')
dev.control('inhibit')

# Create the in-memory nativeRaster canvas
nr <- nr_new(100, 30, 'grey80')

# Clear, blit and render => animation!
for (i in -30:110) {
  nr_fill(nr, 'grey80')                    # Clear the nativeRaster
  nr_blit(nr, dino[[(i %% 16) + 1]], i, 1) # copy dino to nativeRaster
  grid.raster(nr, interpolate = FALSE)     # copy nativeRaster to screen
  Sys.sleep(0.02)                          # Stop animation running too fast.
}

Live screen recording

Dino Multi-Ball

You can quickly blit (i.e. copy) a sprite into multiple locations on the nativeraster with nr_blit().

In this example 100 random positions and velocities are first created. A character sprite is then blitted to each of these 100 locations.

The positions are updated using the velocities, and the next frame is rendered. In this way multiple sprites are rendered and animated on screen.

library(grid)

# Setup a fast graphics device that can render quickly
x11(type = 'dbcairo', antialias = 'none', width = 8, height = 6)
dev.control('inhibit')

# Number of sprites
N <- 100

# Window size
w <- 400 
h <- 300 

# location and movement vector of all the sprites
x  <- sample(w -25, N, replace = TRUE)
y  <- sample(h - 25, N, replace = TRUE)
vx <- sample(seq(-5, 5), N, replace = TRUE)
vy <- sample(seq(-5, 5)[-6], N, replace = TRUE)

# Create an empty nativeraster with a grey background
nr <- nr_new(w, h, 'grey80')


for (frame in 1:1000) {
  # Clear the nativeraster and blit in all the dinosaurs
  nr_fill(nr, 'grey80') 
  nr_blit(nr, dino[[(frame) %% 16 + 1]], x, y)
  
  # Draw the nativeraster to screen
  dev.hold()
  grid.raster(nr, interpolate = FALSE)
  dev.flush()

  # Update the position and velocity of each dino
  # Dinos move at constant velocity and bounce off the sides of the image
  x  <- x + vx
  y  <- y + vy
  vx <- ifelse(x > (w - 25)| x < 1, -vx, vx)
  vy <- ifelse(y > (h - 25)| y < 1, -vy, vy)
  
  # slight pause to slow things down 
  Sys.sleep(0.03)
}

Live screen recording

Coordinate System

The coordinate system for nara nativeRaster objects has its origins at the bottom left corner of the image with coordinates (1,1).

Benchmark `raster` vs `nativeRaster`

A pretty naive benchmark showing that drawing a nativeRaster

is approx 5x faster than drawing a raster
allocates only one quarter of the memory compared to raster

nr  <- nr_new(800, 600)
ras <- nr_to_raster(nr)

x11(type = 'dbcairo')
dev.control('inhibit')

draw_nr <- function() {
  dev.hold()
  grid.raster(nr, interpolate = FALSE)
  dev.flush()
}


draw_raster <- function() {
  dev.hold()
  grid.raster(ras, interpolate = FALSE)
  dev.flush()
}

bench::mark(
  draw_nr(),
  draw_raster()
)

expression	itr/sec	mem_alloc
draw_nr()	269.8799	1.83MB
draw_raster()	46.6820	7.32MB

Future possibilities

More efficient polygon drawing with active edge lists.

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

World's simplest R music system. Part 3 - Non-sinusoidal Waveforms

Tue, 12 Jul 2022 15:45:00 +1000

Introduction

A note doesn’t have to be a sine wave.

Square, Triangle and sawtooth waves are also common and have different sound characteristics.

Utilities developed in prior posts

Click to reveal ADSR profiling and other utilities

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create an ADSR profile of the given length - using only linear segments
#' 
#' @param N length of profile (integer)
#' @param a,d,r fractions of the profile devoted to attack, decay and release
#'        respectively
#' @param s the level of sustain in range [0,1].  The duration of the sustain
#'        will be the remaining fraction after attack, decay and release
#'        are accounted for
#'
#' @return numeric vector in range [0,1] of length N which defines a 
#'         volumn envelope for the note.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_adsr_profile <- function(N, a, d, s, r) {
   
  dur <- 1 - a - d - r
  stopifnot(dur >= 0)
  
  profile <- c(
    seq(0, 1, length.out = a * N),
    seq(1, s, length.out = d * N),
    rep(s, length.out = dur * N),
    seq(s, 0, length.out = r * N)
  )
  
  # Ensure we have the right number of elements in case of weird rounding
  length(profile) <- N
  profile[is.na(profile)] <- 0
  
  profile
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Play a note
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
play_note <- function(samples) {
  audio::play(samples, rate = 44100)
}

Create simple note with different waveforms

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a note - sine wave
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_sine_wave <- function(freq, duration) {
  t <- seq(duration * 44100)
  samples <- sin((t) * 2*pi/ (44100/freq))
  samples
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a note - square wave
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_square_wave <- function(freq, duration) {
  samples <- create_sine_wave(freq, duration)
  samples <- ifelse(samples >=0, 1, -1)
  samples
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a note - triangular wave. 
# Create as a cumsum() of a square wave.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_triangle_wave <- function(freq, duration) {
  period <- 44100/freq
  wave <- c(
    seq( 0,  1, length.out = (period/4 - 1)),
    seq( 1, -1, length.out = (period/2 - 1)),
    seq(-1,  0, length.out = (period/4 - 1))
  )
  
  rep(wave, length.out = 44100 * duration)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a note - sawtooth wave
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_sawtooth_wave <- function(freq, duration) {
  period <- 44100/freq
  wave <- seq(-1,  1, length.out = period - 1)
  rep(wave, length.out = 44100 * duration)
}



note_sine <- create_sine_wave(440, 1)
plot(note_sine[1:300], type = 'l')
title('Sine')



note_square <- create_square_wave(440, 1)
plot(note_square[1:300], type = 'l')
title('Square')


note_tri <- create_triangle_wave(440, 1) 
plot(note_tri[1:300], type = 'l')
title('Triangle')


note_saw <- create_sawtooth_wave(440, 1)
plot(note_saw[1:300], type = 'l')
title('Sawtooth')

profile <- create_adsr_profile(44100, 0.2, 0.3, 0.8, 0.5)

play_note(note_sine   * profile)
play_note(note_square * profile)
play_note(note_tri    * profile)
play_note(note_saw    * profile)

Sine

Your browser does not support the audio element.

Square

Your browser does not support the audio element.

Triangle

Your browser does not support the audio element.

Sawtooth

Your browser does not support the audio element.

World’s simplest R music system - with linear ADSR profile shaping + sawtooth waveform

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Octaves/Notes/Frequencies in an equal tempered scale
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ets <- tibble(
  freq   = 440 * (2 ^ ((-57:50)/12)),
  note   = rep(c('C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B'), 9),
  octave = rep(0:8, each = 12),
  mnote  = ifelse(nchar(note) == 1, paste(note, octave, sep = "-"), paste(note, octave, sep = ""))
)

head(ets)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Note-to-Freq lookup
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
freq <- setNames(ets$freq, ets$mnote)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Function: Play a note of the given frequency for the given duration
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
profile <- create_adsr_profile(0.4 * 44100, 0.1, 0.25, 0.2, 0.6)
  
play_note <- function(freq, duration) {
  samples <- create_sawtooth_wave(freq, duration)
  samples <- samples * profile
  
  
  audio::play(samples , rate = 44100)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Mary had a little lamb.
# Format is "[Note]-[Octave]"
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mhall <- c(
  'A-4', 'G-4', 'F-4', 'G-4', 'A-4', 'A-4', 'A-4',
  'G-4', 'G-4', 'G-4', 'A-4', 'C-5', 'C-5',
  'A-4', 'G-4', 'F-4', 'G-4', 'A-4', 'A-4', 'A-4',
  'A-4', 'G-4', 'G-4', 'A-4', 'G-4', 'F-4'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Play it
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (note in mhall) {
  play_note(freq[[note]], 0.4)
  Sys.sleep(0.4)
}

Different waveforms sound different

The following two live captures of the same song at the same pitch with the same ADSR note shaping - only the note waveform is different.

Live capture of “Mary had a little lamb” - with ADSR note shaping + sawtooth waveform

Your browser does not support the video tag.

Live capture of “Mary had a little lamb” - with ADSR note shaping + sine waveform

Your browser does not support the video tag.

World's simplest R music system. Part 2 - linear ADSR note shaping

Mon, 11 Jul 2022 15:45:00 +1000

Introduction

Using a raw sine curve as a note will lead to clipping artefacts as the note immediately starts with maximum amplitude and terminates abruptly.

To make the note sound anything like an actual note from an instrument the profile of the note must be shaped to emulate the actual characteristics of a note produced by an actual physical object e.g. the note will ramp up to its playing volume, and then ramp down again.

So by shaping the profile of the raw note (raw sine curve) we can make something that sounds more plausibly like an instrument.

Create naive note

If we create a note of the correct frequency, but with a constant amplitude, then the note will sound harsh.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a note
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_note <- function(freq, duration) {
  t <- seq(duration * 44100)
  samples <- sin((t) * 2*pi/ (44100/freq))
  samples
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Play a note
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
play_note <- function(samples) {
  audio::play(samples, rate = 44100)
}

note <- create_note(440, 1)

play_note(note)

Raw note

Your browser does not support the audio element.

Shape of a naive note

Looking at the profile of the note we are playing, this immediately starts at the maximum volume i.e. amplitude = 1

plot(note[1:300], type = 'l')

Attack Decay Sustain Release (linear)

Instead of a note staying at the same loudness/amplitude for its duration, we instead shape the note using an envelope.

A common way of shaping the profile of a note is via ADSR - Attack, Decay, Sustain and Release.

Note this code is only creating a piecewise-linear profile. Better sounding envelopes are possible using exponentials.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create an ADSR profile of the given length - using only linear segments
#' 
#' @param N length of profile (integer)
#' @param a,d,r fractions of the profile devoted to attack, decay and release
#'        respectively
#' @param s the level of sustain in range [0,1].  The duration of the sustain
#'        will be the remaining fraction after attack, decay and release
#'        are accounted for
#'
#' @return numeric vector in range [0,1] of length N which defines a 
#'         volumn envelope for the note.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_adsr_profile <- function(N, a, d, s, r) {
   
  dur <- 1 - a - d - r
  stopifnot(dur >= 0)
  
  profile <- c(
    seq(0, 1, length.out = a * N),
    seq(1, s, length.out = d * N),
    rep(s, length.out = dur * N),
    seq(s, 0, length.out = r * N)
  )
  
  # Ensure we have the right number of elements in case of weird rounding
  length(profile) <- N
  profile[is.na(profile)] <- 0
  
  profile
}


profile <- create_adsr_profile(500, 0.25, 0.25, 0.8, 0.25)
plot(profile, type = 'l')

Compare the sounds of a raw note, and a note profiled with ADSR

note1 <- create_note(440, 0.5)
plot(note1, type = 'l')


profile <- create_adsr_profile(length(note1), 0.1, 0.25, 0.2, 0.6)
note2 <- note1 * profile
plot(note2, type = 'l')

play_note(note1)
play_note(note2)

Raw note

Your browser does not support the audio element.

Note adjusted with ADSR profile

Your browser does not support the audio element.

The profiled note should sound less “harsh” than the raw note - possibly more like a real note from a hypothetical instrument!

World’s simplest R mustic system - with linear ADSR profile shaping

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Octaves/Notes/Frequencies in an equal tempered scale
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ets <- tibble(
  freq   = 440 * (2 ^ ((-57:50)/12)),
  note   = rep(c('C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B'), 9),
  octave = rep(0:8, each = 12),
  mnote  = ifelse(nchar(note) == 1, paste(note, octave, sep = "-"), paste(note, octave, sep = ""))
)

head(ets)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Note-to-Freq lookup
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
freq <- setNames(ets$freq, ets$mnote)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Function: Play a note of the given frequency for the given duration
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
play_note <- function(freq, duration) {
  t <- seq(duration * 44100)
  samples <- sin((t) * 2*pi/ (44100/freq))
  
  profile <- create_adsr_profile(length(samples), 0.1, 0.25, 0.2, 0.6)
  samples <- samples * profile

  audio::play(samples, rate = 44100)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Mary had a little lamb.
# Format is "[Note]-[Octave]"
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mhall <- c(
  'A-4', 'G-4', 'F-4', 'G-4',  'A-4',  'A-4',  'A-4',
  'G-4', 'G-4', 'G-4', 'A-4', 'C-5', 'C-5',
  'A-4', 'G-4', 'F-4', 'G-4', 'A-4', 'A-4', 'A-4',
  'A-4', 'G-4', 'G-4', 'A-4', 'G-4', 'F-4'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Play it
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (note in mhall) {
  play_note(freq[[note]], 0.4)
  Sys.sleep(0.4)
}

Live capture of “Mary had a little lamb” - with ADSR note shaping

This will sound as if someone is playing this on a toy piano or similar low quality instrument. But at least it doesn’t sound too harsh.

Your browser does not support the video tag.

Live capture of “Mary had a little lamb” - raw note (unmodified sine curve)

This sounds harsh and clipped. Not as pleasant as the notes shaped with ADSR.

Your browser does not support the video tag.

World's simplest R music system

Sun, 10 Jul 2022 20:55:00 +1000

World’s simplest R mustic system

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Octaves/Notes/Frequencies in an equal tempered scale
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ets <- tibble(
  freq   = 440 * (2 ^ ((-57:50)/12)),
  note   = rep(c('C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B'), 9),
  octave = rep(0:8, each = 12),
  mnote  = ifelse(nchar(note) == 1, paste(note, octave, sep = "-"), paste(note, octave, sep = ""))
)

head(ets)
#> # A tibble: 6 × 4
#>    freq note  octave mnote
#>   <dbl> <chr>  <int> <chr>
#> 1  16.4 C          0 C-0  
#> 2  17.3 C#         0 C#0  
#> 3  18.4 D          0 D-0  
#> 4  19.4 D#         0 D#0  
#> 5  20.6 E          0 E-0  
#> 6  21.8 F          0 F-0

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Note-to-Freq lookup
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
freq <- setNames(ets$freq, ets$mnote)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Function: Play a note of the given frequency for the given duration
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
play_note <- function(freq, duration) {
  t <- seq(duration * 44100)
  audio::play(sin((t) * 2*pi/ (44100/freq)), rate = 44100)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Mary had a little lamb.
# Format is "[Note]-[Octave]"
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mhall <- c(
  'A-4', 'G-4', 'F-4', 'G-4',  'A-4',  'A-4',  'A-4',
  'G-4', 'G-4', 'G-4', 'A-4', 'C-5', 'C-5',
  'A-4', 'G-4', 'F-4', 'G-4', 'A-4', 'A-4', 'A-4',
  'A-4', 'G-4', 'G-4', 'A-4', 'G-4', 'F-4'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Play it
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (note in mhall) {
  play_note(freq[[note]], 0.4)
  Sys.sleep(0.4)
}

Live capture of “Mary had a little lamb”

Your browser does not support the video tag.

{isocubes} v0.1.2 update with Signed Distance Fields

Fri, 01 Jul 2022 15:10:00 +1000

isocubes

The purpose of this package is to provide a 3D rendering backend for a very particular visual aesthetic.

That is, {isocubes} is an isometric rendering canvas with cubes as the only graphics primitive.

Some tools are included for creating particular scenes, but in general, if you can provide a list of (x,y,z) integer coorindates of what to render, then isocumes will create a 3d render.

What’s new in v0.1.2

Signed distance fields for creating objects

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/isocubes')

Fake Terrain with `ambient`

library(grid)
library(ggplot2)
library(dplyr)
library(ambient)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create some perline noise on an NxN grid
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
set.seed(3)
N <- 60

dat <- long_grid(x = seq(0, 10, length.out = N), y = seq(0, 10, length.out = N)) %>% 
  mutate(
    noise = 
      gen_perlin(x, y, frequency = 0.3) + 
      gen_perlin(x, y, frequency = 2) / 10
  ) 

hm <- dat %>%
  mutate(
    x = x * 4,
    z = y * 4,
    y = noise * 4
  )

pal  <- topo.colors(11)
sy   <- as.integer(10 * (hm$y - min(hm$y)) / diff(range(hm$y))) + 1
cols <- pal[sy]

cubes  <- isocubesGrob(hm, ysize = 1/45, xo = 0.7, fill = cols, col = NA)

grid.newpage(); grid.draw(cubes)

Bitmap font rendering

library(grid)
library(isocubes)
library(bdftools)


bdf <- bdftools::read_bdf_builtin("spleen-32x64.bdf")
single_word <- bdftools::bdf_create_df(bdf, "#RStats!")

N    <- 10
cols <- rainbow(N)

multiple_words <- purrr::map_dfr(seq(N), function(i) {
  single_word$z <- i
  single_word$col <- cols[i]
  single_word
}) 

cubes  <- isocubesGrob(multiple_words, ysize = 1/170, xo = 0.1, fill = multiple_words$col)
grid.newpage(); grid.draw(cubes)

Signed Distance Fields - Simple

library(grid)
library(dplyr)
library(isocubes)

# Create a scene that consists of a scaled torus
scene <- sdf_torus(3, 1) %>% 
  sdf_scale(5)

# Render the scene into a list of coordinates of voxels inside objects
coords <- sdf_render(scene, N = 30)

# Create cubes, and draw
cubes  <- isocubesGrob(coords, ysize = 1/50, xo = 0.5, yo = 0.5, fill = 'lightblue')
grid.newpage(); grid.draw(cubes)

Signed Distance Fields - More Complex

library(dplyr)
library(grid)
library(isocubes)


sphere <- sdf_sphere() %>%
  sdf_scale(40)

box <- sdf_box() %>%
  sdf_scale(32)

cyl <- sdf_cyl() %>%
  sdf_scale(16)

scene <- sdf_subtract_smooth(
  sdf_intersect(box, sphere),
  sdf_union(
    cyl,
    sdf_rotatey(cyl, pi/2),
    sdf_rotatex(cyl, pi/2)
  )
)

coords <- sdf_render(scene, 50)
cubes  <- isocubesGrob(coords, ysize = 1/100, xo = 0.5, yo = 0.5, fill = 'lightseagreen')
grid.newpage(); grid.draw(cubes)

Signed Distance Fields - Animated

Unfortunately this isn’t fast enough to animate in realtime, so I’ve stitched together individuall saved frames to create an animation.

thetas <- seq(0, pi, length.out = 45)

for (i in seq_along(thetas)) {
  cat('.')
  theta <- thetas[i]
  
  rot_scene <- scene %>% 
    sdf_rotatey(theta) %>%
    sdf_rotatex(theta * 2) %>%
    sdf_rotatez(theta / 2)
  
  coords <- sdf_render(rot_scene, 50)
  cubes  <- isocubesGrob(coords, ysize = 1/110, xo = 0.5, yo = 0.5)
  
  png_filename <- sprintf("working/anim/%03i.png", i)
  png(png_filename, width = 800, height = 800)
  grid.draw(cubes)
  dev.off()
}

# ffmpeg -y -framerate 20 -pattern_type glob -i 'anim/*.png' -c:v libx264 -pix_fmt yuv420p -s 800x800 'anim.mp4'

Technical Bits

Cube occlusion

In an isometric view, a cube at position (x, y, z) will block the view of any cube at (x + n, y - n, z + n).

Since cube positions must be integer values, hashes of cube positions are calculated as x + (y * 256) + (z * 256^2).

For each initial cube position, calculate the hash or coordinates of several occluded cubes. Then remove any initial cubes which match the occluded cube hashes.

Cube sort

Arrange cubes by -x, -z then y to ensure cubes are drawn in the correct ordering such that cubes in front are drawn over the top of cubes which are behind.

grob

All the faces of all the cubes are then calculated as polygons - each with 4 vertices.

The data for all polygons is then concatenated into a single polygonGrob() call with an appropiate vector for id.lengths to split the data.

Prototyping

Most of the prototyping for this package was done with {ingrid} - a package I wrote which I find makes working iteratively/at-the-console with base grid graphics a bit easier.

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing isocubes - an isometric rendering backend

Tue, 21 Jun 2022 16:10:00 +1000

isocubes

{isocubes} is an isometric rendering canvas with cubes as the only graphics primitive.

What’s in the box

isocubesGrob() to convert 3d integer coordinates into a grob for plotting
coord_heightmap() to create coordinates for a heightmap from a matrix and (optional) colour information
coord_sphere() to create coordinates for all isocubes within a sphere

Coordinate system

The size and positioning of the isometric coordinate system is controlled by arguments isocubesGrob(coords, max_y, xo, yo)
xo and yo give the positition of the origin of the isometric view within the graphics window. These are fractional values which will be interpreted as snpc units i.e. fractional width and height of the graphics devices.
max_y is the main control for cube sizing. This value is the number of cubes that can be stacked to fill the vertical extents of the window. Higher values of max_y means smaller cubes.
The isometric view is a left-handed coordinate system with y vertical.
The (x, y, z) coordinates given to position the cubes will be rounded to the nearest integer. There is no fractional positioning of cubes.

Why isometric?

Isometric cubes have advantages over other axonometric and perspective coordinate systems:

No perspective correction needed.
No foreshortening along different dimensions.
The cube is just a hexagon with each third shaded differently, and the polygons for each face are trivial to calculate and draw.
The rules for occlusion are simple i.e. it’s easy to cull cubes from the drawing process if they’re hidden behind other cubes and won’t be seen. Fewer cubes mean a faster rendering time.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/isocubes')

‘R’ in isocubes

library(grid)
library(purrr)
library(isocubes)

x <- c(9, 8, 7, 6, 5, 4, 3, 2, 10, 9, 3, 2, 11, 10, 3, 2, 11, 10, 
3, 2, 11, 10, 3, 2, 11, 10, 3, 2, 10, 9, 3, 2, 9, 8, 7, 6, 5, 
4, 3, 2, 10, 9, 3, 2, 11, 10, 3, 2, 11, 10, 3, 2, 11, 10, 3, 
2, 11, 10, 3, 2, 11, 10, 3, 2, 11, 10, 3, 2)

y <- c(15, 15, 15, 15, 15, 15, 15, 15, 14, 14, 14, 14, 13, 13, 13, 
13, 12, 12, 12, 12, 11, 11, 11, 11, 10, 10, 10, 10, 9, 9, 9, 
9, 8, 8, 8, 8, 8, 8, 8, 8, 7, 7, 7, 7, 6, 6, 6, 6, 5, 5, 5, 5, 
4, 4, 4, 4, 3, 3, 3, 3, 2, 2, 2, 2, 1, 1, 1, 1)

coords <- data.frame(x = x, y = y, z = 0)
cubes  <- isocubesGrob(coords, max_y = 25)
grid.newpage(); grid.draw(cubes)

# Colour the cubes with rainbow
cubes <- isocubesGrob(coords, fill = rainbow(nrow(coords)), max_y = 25)
grid.newpage(); grid.draw(cubes)

# VaporWave palette
cubes <- isocubesGrob(coords, fill = '#ff71ce', fill_left = '#01cdfe',
                      fill_right = '#05ffa1', max_y = 25)
grid.newpage(); grid.draw(cubes)

# Nightmare palette
cubes <- isocubesGrob(coords, 
                      fill = rainbow(nrow(coords)), 
                      fill_left = 'hotpink',
                      fill_right = viridisLite::inferno(nrow(coords)), 
                      max_y = 25, col = NA)
grid.newpage(); grid.draw(cubes)

Calculate isocubes within a sphere

library(grid)
library(isocubes)

N      <- 13
coords <- expand.grid(x=seq(-N, N), y = seq(-N, N), z = seq(-N, N))
keep   <- with(coords, sqrt(x * x + y * y + z * z)) < N
coords <- coords[keep,]

cubes <- isocubesGrob(coords, max_y = 35, xo = 0.5, yo = 0.5)
grid.newpage()
grid.draw(cubes)

Random rainbow volume of isocubes

library(isocubes)

N      <- 15
coords <- expand.grid(x=0:N, y=0:N, z=0:N)
coords <- coords[sample(nrow(coords), 0.66 * nrow(coords)),]
fill   <- rgb(red = 1 - coords$x / N, coords$y /N, 1 - coords$z/N, maxColorValue = 1)

cubes <- isocubesGrob(coords, fill, max_y = 40, occlusion_depth = 4)
grid.newpage()
grid.draw(cubes)

Heightmap as isocubes

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Prepare a matrix of values
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mat <- volcano

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# An optional matrix of colours
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
val <- as.vector(mat)
val <- round(255 * (val - min(val)) / diff(range(val)))
col <- viridisLite::viridis(256)[val + 1L]
dim(col) <- dim(mat) 

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Find the (integer) coordiinates of the cubes in the heightmap
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
coords <- coords_heightmap(mat - min(mat), col = col, scale = 0.3)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Convert the coordinates into a grob
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cubes  <- isocubesGrob(coords, max_y = 100, fill = coords$col, xo = 0.8)
grid.newpage(); grid.draw(cubes)

Image as isocubes

Treat image to a heightmap

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Load image and convert to a matrix of heights
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
img <- png::readPNG("../../static/img/isocubes/Rlogo-small-blur.png")
ht        <- round( 10 * (1 - img[,,2]) ) # Use Green channel intensity as height
ht[,1]    <- 0 # image editing to remove some artefacts

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# A matrix of colours extracted from the image
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
col       <- rgb(img[,,1], img[,,2], img[,,3])
dim(col)  <- dim(ht) 

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# convert to cubes and draw
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
coords <- coords_heightmap(ht, col = col, ground = 'xy')
cubes  <- isocubesGrob(coords, max_y = 130, fill = coords$col, col = NA)
grid.newpage(); grid.draw(cubes)

Technical Bits

Cube occlusion

In an isometric view, a cube at position (x, y, z) will block the view of any cube at (x + n, y - n, z + n).

Since cube positions must be integer values, hashes of cube positions are calculated as x + (y * 256) + (z * 256^2).

For each initial cube position, calculate the hash or coordinates of several occluded cubes. Then remove any initial cubes which match the occluded cube hashes.

Cube sort

Arrange cubes by -x, -z then y to ensure cubes are drawn in the correct ordering such that cubes in front are drawn over the top of cubes which are behind.

grob

All the faces of all the cubes are then calculated as polygons - each with 4 vertices.

The data for all polygons is then concatenated into a single polygonGrob() call with an appropiate vector for id.lengths to split the data.

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Nesting Functions

Wed, 15 Jun 2022 09:00:00 +1000

Introduction

Many structured formats for documents and data have a natural nested hierarchy.

That is, there are lower-level elements nested within higher level structures

A great xample of a nested document creation using nested function calls is HTML creation with {htmltools}. In the code below, the call to create the body() is nested within the function call to create the top-level html() document.

The structure of the nested function calls in R match the structure of the created HTML document. This is both aesthetically pleasing, and low friction e.g. it’s easy to work out the structure of the input if you know what you want as the output (and vice versa).

library(htmltools) 

tags$html(
  tags$body(
    tags$p('...'), 
    tags$p('...')
  )
)

<html>
  <body>
    <p> ... </p>
    <p> ... </p>
  </body>
</html>

However there are many document formats where the current tools do not support this idea of nested creation. This may be because the underlying C library or API doesn’t really support the concept.

A (contrived) example of this is the creation of {grid} graphics with nested viewports.

The following code creates two nestedviewport and then draw squares within them.
I’m calling this style of document creation linear (in contrast to nested).

library(grid)
grid.newpage()
vp1 <- viewport(x = 0.5, y = 0.5, angle = 22.5)
pushViewport(vp1)
grid.rect(width=20, height=20, default.units = 'mm', gp = gpar(fill='hotpink'))
vp2 <- viewport(x = 0.5, y = 0.5, angle = 22.5)
pushViewport(vp2)
grid.rect(width=10, height=10, default.units = 'mm', gp = gpar(fill='blue'))

A hypothetical alterative nested syntax for grid graphics creation could look like the following code.

viewport(
  angle = 22.5,
  grid.rect(...),
  viewport(
    angle = 22.5,
    grid.rect(...)
  )
)

In the above code, the nested makes clearer the relationship between the viewports and the rectangles.

My use-case: document creation

I am working through a situation where the tools available are linear (because of the underlying C library), but I want a nested structure exposed to the user.

In its simplest form, my use case is for the creation of a document consisting of multiple paragraphs. Each paragraph in turn consisting of multiple sentences.

document
    paragraph
        sentence
        sentence
    paragraph
        sentence
        sentence
        sentence

The constraints on this problem are:

The creation of the document, paragraph and sentence should each be separate functions.
There is a document object which all the functions manipulate.
The final document is returned to the user

The following post details:

The current linear structure for document creation
A nested structure for document creation

Current linear function structure

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Document is stored in a list
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
new_doc <- function() {
  list(par = 0, words = list())
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Creating a new paragraph increases the 'par' counts and prepares some
# space for the words in this paragraph
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
new_par <- function(doc) {
  doc$par <- doc$par + 1
  doc$words[[doc$par]] <- list()
  doc
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add a sentence to the current paragraph
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
new_sentence <- function(doc, words) {
  doc$words[[doc$par]] <- append(doc$words[[doc$par]], words)
  doc
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Simple print method
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
print_doc <- function(doc) {
  for (i in seq_along(doc$words)) {
    cat(strwrap(paste(doc$words[[i]], collapse = " "), width = 20), sep = "\n")
    if (i != length(doc$words)) cat("\n")
  }
}

Linear function calls

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Modify the `document` with every call
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
my_doc <- new_doc()
my_doc <- new_par(my_doc)
my_doc <- new_sentence(my_doc, "Hello there.")
my_doc <- new_sentence(my_doc, "My name is greg.")
my_doc <- new_par(my_doc)
my_doc <- new_sentence(my_doc, "Start of second par.")

print_doc(my_doc)
#> Hello there. My
#> name is greg.
#> 
#> Start of second
#> par.

Notes

the document object must be passed in to each function
document object is modified and returned by each function
There is no auto indentation in R which would indicate which sentences go with which paragraphs i.e. the linear structure of the functions don’t reveal the nested structure of the document when coding.

Nested function structure

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Nested evaluation 
# @param ... child elements are evaluated after the parent is created
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
doc <- function(...) {
  # Create document
  document <- as.environment(list(par = 0, words = c()))
  
  # Evaluate child 'par' elements within this document
  # Adapt the call for child elements to include a 'document' as argument
  for (elem in rlang::enquos(...)) {
    elem <- rlang::call_modify(elem, document = document)
    rlang::eval_tidy(elem)
  }
  
  as.list(document)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add a paragraph to the current document
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
par <- function(document, ...) {
  document$par <- document$par + 1
  document$words[[document$par]] <- list()
  for (elem in rlang::enquos(...)) {
    elem <- rlang::call_modify(elem, document = document)
    rlang::eval_tidy(elem, env = sys.frame())
  }
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add words to the current paragraph
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sentence <- function(document, words) {
  document$words[[document$par]] <- append(document$words[[document$par]], words)
}

Nested function calls

my_doc <- doc(
  par(
    sentence("Hello there."),
    sentence("My name is Greg.")
  ),
  par(
    sentence("Start of second par.")
  )
)

print_doc(my_doc)
#> Hello there. My
#> name is Greg.
#> 
#> Start of second
#> par.

Notes

Code structure now mimics document structure
Internally adapting the function calls so that the user does not need to specify the passing of the document to each call. This simplifies the users code at the cost of complicating the functions a little.

Introducing `{tickle}` quickly build UIs in base R

Fri, 03 Jun 2022 15:00:00 +1000

tickle

{tickle} is a package for creating UIs in base R.

This is an opinionated abstraction over the base R package {tcltk}.

This package aims to provide:

a simplified UI creation process similar to shiny.
a modern-looking visual default.
more documentation to help create common UI elements without resorting to the online tcl/tk documentation.
a way to still access the low-level tcl/tk structures in order to achieve complex effects and customisation.

What’s in the box

An array of tic_*() functions for nested creation of a UI specification.
render_ui() to render a UI specification into a window onscreen.
reactive_*() to create reactive values used to transfer values between the UI and R
canvas_*() functions to do some simple drawing an manipulation on canvas widgets.

Overview

Create reactive variables (with reactive_*()) in order to pass values between R and the UI. e.g. the value of the slider, or the text in a text entry box.
Define callback functions that are called, say, when a button is pressed.
Create a UI specification by nesting containers and widgets with tic_*() calls. This specification can include
- binding callback functions to particular events like mouse buttons or key presses (bind argument)
- controlling how widgets are packed within their parent container (pack argument)
Render the UI to an actual object on the screen with render_ui()
The object returned by render_ui() can be ignored by beginners. For intermediate/advanced users, this object is a nested list of tclObj objects representing the UI components, and these can be further manipulated with {tcltk} to finesse and configure the UI.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/tickle')

Hello World

Things to note:

Define a reactive variable for the slider before defining the UI
UI specificaiton created with nested tic_*() calls.
Some commands (e.g. tic_button()) have an explicit command function which is run when they are activated.
After defining the UI specificaiton, it is rendered to screen with render_ui()

library(tickle)

value <- reactive_dbl(40)

ui_spec <- tic_window(
  title = "Hello World", 
  tic_row(
    tic_col(
      tic_button("Hello", command = function() {message("Hello")}, style = 'primary'),
      tic_button("World", command = function() {message("World")})
    ),
    tic_col(
      tic_slider(value),
      tic_label(textvariable = value)
    )
  )
)

win <- render_ui(ui_spec)

Gallery

Examples/Vignettes

Please view the online vignettes for more details on how to use {tickle}

Containers

Containers are ways of grouping multiple widgets.

Containers can be nested within other containers to achieve complex layouts.

Container	Code/Description
	`tic_window(…)` Create a top level window
	`tic_col(A, B, C)` Layout objects in column
	`tic_row(A, B, C)` Layout objects rowwise
	`tic_frame(…)` Invisible container. Useful for advanced users who want to customize layout
	`tic_labelframe(…)` Frame with a a label and usually visible outline
	`tic_notebook(A, B, C)` Tabbed display
	`tic_panedwindow(A, B, C)` Layout multiple elements which can be resized as panes

Widgets

Widget	Code/Description
	`tic_label(…)` Display text. If you need headings rather than body text, Use `style = 'h1'` to `style = 'h5'` for different sized text
	`tic_button(…)` Clickable button. Available `style` options: ‘primary’, ‘seconary’, ‘info’, ‘success’, ‘warning’, ‘danger’, ‘light’, ‘dark’
	`tic_checkbutton(…)` On/off button (default styling)
	`tic_checkbutton(…)` On/off button with `style = 'toggle'`
	`tic_checkbutton(…)` On/off button with `style = 'switch'`
	`tic_radiobutton(…)` Groups of mutually exclusion options
	`tic_menubutton(…)` Button which displays a drop-down menu
	`tic_canvas(…)` General drawing canvas
	`tic_spinbox(…)` Choose options
	`tic_combobox(…)` Choose options
	`tic_textentry(…)` Single line text entry
	`tic_textbox(…)` Multipe line text entry
	`tic_progressbar(…)` Progress bar
	`tic_slider(…)` Slider

Popups

Popups are windows which are initiated separate from the main UI.

Popup	Code/Description
	`popup_color_picker()`
	`popup_messagebox()`
	`popup_open_file()`
	`popup_save_file()`

Canvas

After creating a canvas with tic_canvas(), it can be manipulated with the following commands:

Draw on the canvas
- canvas_line()
- canvas_text()
- canvas_rect()
- canvas_polygon()
- canvas_oval()
- canvas_arc()
canvas_plot() render a plot to the canvas
canvas_clear() clear all objects from the canvas
canvas_image() render an image from a file to the canvas
canvas_save() save the contents of the canvas to an image file.

The actual canvas in tcl/tk renders structured graphics and it is much more like SVG or PDF than just a simple array of pixels.

The canvas implementation in this package treats the canvas as just a raster object i.e. a rectangular collection of pixels. This made it easier to write this package and keep the API/syntax simple, but it doesn’t unleash the full power of the canvas.

The effort to write a more complete abstraction over the canvas is not currently warranted. Please get in contact if such a facility is important to you.

Theme

The theme for this package is an adaptaton of the sun-valley-light theme available from rdbende on github.

The sun-valley-light theme is MIT licensed (see “LICENSE-sun-valley”) and has been adapted into the theme r-sun-valley-light included in this package which has the following extra features:

Styles ‘h1’ through ‘h5’ for different sized heading text to use with tic_label() widgets.
- To use: tic_label(..., style = 'h1')
Standard buttons colours from Bootstrap to use with tic_button() widgets.
- To use: tic_button(..., style = 'primary')
- Available styles: primary, secondary, success, danger, warning, info, light, dark

Possible Future Features

The following items are not yet implemented, or incomplete:

Popup menus when a user right-clicks in the window.
No access yet to the “grid” geometry layout.
treeview, listbox and some other widgets

Package Name

tcl is the scripting language
tk is the graphics toolkit for tcl
tcl/tk is often how the langauge and toolkit are talked about as a single entity
{tcltk} is the R package interfacing to tcl/tk
tcl is often pronounced as “tickle” i.e. tcl/tk = “tickle-tee-kay”

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing `{tr808r}` a TR-808 Drum Machine in R

Sat, 14 May 2022 07:50:00 +1000

A TR-808 Drum machine in R using {eventloop}.

Check it out on github!

Playback

Your browser does not support the video tag.

Realtime Interactive Pattern Editing

Your browser does not support the video tag.

Fetching patterns from tweets

Your browser does not support the video tag.

A naive implementation of Visvalingam's line simplification in R

Sat, 07 May 2022 18:50:00 +1000

Visvalingham’s Line Simplification Algorithm

Given a number of points defining a line
Find the areas of the triangles defined by each set of 3 continuous points
Remove the point which is the centre of the triangle with the minimum area
Recalculate areas (as two will have changed when removing the point)

Naive R implementation

Full set of all triangle areas is calculated prior to the remove of each point
- A priority queue would help here


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Visvalingham Line Simplification
#'
#' @param x,y coordinates
#' @param n number of points to keep
#'
#' @importFrom utils head tail
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
visvalingam <- function(x, y, n) {

  # Sanity Check
  stopifnot(length(x) == length(y))
  stopifnot (n <= length(x) && n >= 2)
  if (length(x) == 2) {
    return(list(x=x, y=y))
  }

  # Remove points
  for (i in seq_len(length(x) - n)) {
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Find areas
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    x1 <- head(x, -2)
    x2 <- head(x[-1], -1)
    x3 <- tail(x, -2)

    y1 <- head(y, -2)
    y2 <- head(y[-1], -1)
    y3 <- tail(y, -2)

    a0 <- x1 - x2
    a1 <- x3 - x2

    b0 <- y1 - y2
    b1 <- y3 - y2

    tri_areas <- abs(a0 * b1 - a1 * b0)  # / 2

    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Find minimim area triangle and remove its centre vertex from all pts
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    min_tri <- which.min(tri_areas)
    
    x <- x[-(min_tri + 1)]
    y <- y[-(min_tri + 1)]
  }

  list(x = x, y = y)
}

Demo

This demo shows how visvalingam can be used to tidy up a noisy drawing of a square

library(grid)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a messy square
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
set.seed(2)
N <- 20
x <- c(seq(0, 1, length.out = N), rep(1, N), seq(1, 0, length.out = N), rep(0, N)) / 2 + 0.25
y <- c(rep(0, N), seq(0, 1, length.out = N), rep(1, N), seq(1, 0, length.out = N)) / 2 + 0.25

x <- x + runif(length(x), -0.02, 0.02)
y <- y + runif(length(x), -0.02, 0.02)

x[1] <- y[1] <- x[N*4] <- y[N*4] <- 0.25

grid::grid.newpage()
grid::grid.lines(x, y)



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Capture the simplification step by step.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
xs <- list()
ys <- list()

for (n in (4*N):5) {
  res <- visvalingam(x, y, n)
  xs <- c(xs, list(res$x))
  ys <- c(ys, list(res$y))
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Save frames 
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (i in seq_along(xs)) {
  filename <- sprintf("jnk/%03i.png", i)
  png(filename)
    grid.lines(xs[[i]], ys[[i]], gp = gpar(lwd= 4))
  dev.off()
}
# ffmpeg -y -framerate 15 -pattern_type glob -i '*.png' -c:v libx264 -pix_fmt yuv420p -s 800x800 anim.mp4

Your browser does not support the video tag.

Introducing {eventloop} - Realtime interactive rendering in R

Fri, 06 May 2022 20:00:00 +1000

eventloop

The {eventloop} package provides a framework for rendering interactive graphics and handling mouse+keyboard events from the user at speeds fast enough to be considered interesting for games and other realtime applications.

{eventloop} is a wrapper around the built-in event handling available in base R as part of {grDevices}, but presents it in a more palatable format with some enhanced features.

The {eventloop} package will:

Initiate an x11() window with monitoring for keyboard & mouse events.
Capture events as they happen such that they will be available to the user-supplied function.
Coordinate the setup of the user-defined callback function to be run continually with access to the latest event information presented as the function arguments.
Optionally limit the frequency of screen updates by maintaining a frame-rate specified by the user.

At each call, the user’s function processes events and updates the display.

What’s in the box

run_loop() takes a user-specified function and calls it continuously within an event-driven loop.

Supported Platforms

System	x11() device has ‘onIdle()’ event callback	System supported in {eventloop}
macOS	✅Yes	✅Yes
*nix	✅Yes	✅Yes
Windows	❌ No	❌ No

Notes:

windows x11() device does not support onIdle callback and hence this package does not work on windows
macOS x11() support is via Xquartz. Xquartz may slow to a crawl after running for a while. You will need to logout-and-log-back in, or restart your machine to regain full speed. This bug may be in Xquartz or how x11() support is implemented in macOS - I’m really not sure.

Installation

Pre-requisites

Unix-like systems
- R compiled with X11() support
macOS
- Xquartz installed
windows
- Sorry, but R on windows does not support features needed for this package

# install.package('remotes')
remotes::install_github('coolbutuseless/eventloop')

Example - Basic Drawing app

This is a basic application which lets the user draw in a window using the mouse.

library(grid)
library(eventloop)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Set up the global variables which store the state of the world
#  'drawing'      = Is the mouse button currently pressed?
#  last_x/last_y  = the last mouse position is manually saved every time
#                 the callback function runs.
#
# These values will be updated manually by the user in the `draw()` function
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
drawing <- FALSE
last_x  <- NA
last_y  <- NA

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Callback function - 'draw()' 
#'
#' If 'event' is not NULL, then it means that the user interacted with the
#' display.  
#' 
#' The following events are handled by this callback:
#'  - hold mouse to set drawing mode
#'  - releasing the mouse button stops drawing mode
#'  - pressing SPACE clears the canvas
#'  
#' Press ESC to quit.
#' 
#' @param event The event from the graphics device. Is NULL when no event
#'        occurred.  Otherwise has `type` element set to:
#'        `event$type = 'mouse_down'` 
#'               - an event in which a mouse button was pressed
#'               - `event$button` gives the index of the button
#'        `event$type = 'mouse_up'`   
#'               - a mouse button was released
#'        `event$type = 'mouse_move'`   
#'               - mouse was moved 
#'        `event$type = 'key_press'`  
#'               - a key was pressed
#'               - `event$str` String describing which key was pressed. See \code{grDevices::setGraphicsEventHandlers} for more information.
#' @param mouse_x,mouse_y current location of mouse within window in normalised coordinates in the range [0, 1]. If mouse is 
#'        not within window, this will be set to the last available coordinates
#' @param frame_num Current frame number (integer)
#' @param fps_actual,fps_target the curent framerate and the framerate specified
#'        by the user
#' @param dev_width,dev_height the width and height of the output device. Note:
#'        this does not cope well if you resize the window
#' @param ... any extra arguments ignored
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
draw <- function(event, mouse_x, mouse_y, ...) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Process events
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (!is.null(event)) {
    if (event$type == 'mouse_down') {
      drawing <<- TRUE
    } else if (event$type == 'mouse_up') {
      drawing <<- FALSE
      last_x  <<- NA
      last_y  <<- NA
    } else if (event$type == 'key_press' && event$str == ' ') {
      grid::grid.rect(gp = gpar(col=NA, fill='white')) # clear screen
    }
  }
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # If 'drawing' is currently TRUE, then draw a line from last known 
  # coordinates to current mouse coordinates
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (drawing) {
    if (!is.na(last_x)) {
      grid::grid.lines(
        x = c(last_x, mouse_x),
        y = c(last_y, mouse_y),
        gp = gpar(col = 'black')
      )
    }
    
    # Keep track of where the mouse was for the next time we draw
    last_x <<- mouse_x
    last_y <<- mouse_y
  }
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Start the event loop. Press ESC to quit.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
eventloop::run_loop(draw, fps_target = NA, double_buffer = TRUE)

Notes:

Every time the callback function draw() is executed from within the event loop, it draws a line from the last mouse position to the current mouse position.
The position of the mouse during the previous call is saved manually using global variables.
A boolean variable (drawing) is used to note whether the mouse button is currently pressed or not. Changes to the screen only happend if drawing == TRUE.

Gallery of Puzzles, Games + Applications implemented in the vignettes

Click an image to view the code/vignette

The linked pages contain videos of realtime screen captures which illustrate how the interactive nature of these applications work.

All examples are written in plain R using the {eventloop} package.

Grid-based drawing	Line-based drawing
Streaming plot data	Game of Life
Asteroids	Raycast ‘Wolfenstein’ 3d engine
Wordle	Interactive Mystery Curves
	Verbose example

FAQ

Why is Windows not supported?

No graphics device on windows supports the onIdle callback, which is essential to the workings of this package.

The Windows operating system supports the concept of an onIdle callback, but no one has yet written this into the R graphics device on this platform.

Why does this run so slow on macOS sometimes?

Through some unknown combination of factors, after running x11() windows on macOS for some number of times or duration, the system will slowdown from hundreds-of-frames-per-second to just ten-frames-per-second.

This feels like a bug in either the XQuartz() x11 framework, or it could be a bug within R in how it interfaces with XQuartz()

Note that I have not seen any slowdowns when using x11() devices on Linux machines.

Tech bits: What is an event loop?

gameprogrammingpatterns.com defines an event loop (also known as a game loop) as follows:

A game loop runs continuously during gameplay. Each turn of the loop, it 
processes user input without blocking, updates the game state, and renders 
the game. It tracks the passage of time to control the rate of gameplay.

Tech bits: How is the event loop implemented in R?

Graphics windows in R can have event handlers attached which instruct the device to run a function when a certain event occurs.

When a mouse or keyboard event occurs, {eventloop} stores the event in an environment for later access.

When there is no event occuring, another function is called continuously. This function is the ‘onIdle’ event callback and is only available in the x11() device on macOS and *nix.

The {eventloop} package orchestrates the events and window information into arguments to the user-supplied ‘onIdle’ function - calling this function over and over while the event loop is running.

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing {cstructr} - a demonstration package showing how C structs may be exposed to R

Tue, 26 Apr 2022 17:20:10 +1000

cstructr

{cstructr} is a demonstration package illustrating how a C struct may be wrapped and manipulated from within R as an external pointer.

This is a “full-service” implementation which makes the internal values of the struct accessible from R via getters and setters.

For bespoke solutions, a lot of the code could be excised to just keep some core functions.

Note: The code in this package was auto-generated by parsing the C struct definition and the C library function declaration.

C Struct Definition

typedef struct {
  int N;
  double strength;
} MyCStruct;

C Library Function Declaration

double multiply(MyCStruct *mycstruct);

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/cstructr')

Create and Manipulate

library(cstructr)
mycstruct <- MyCStruct(N = 1, strength = 13)
mycstruct
#> MyCStruct(N = 1, strength = 13)

class(mycstruct)
#> [1] "MyCstruct_extptr"
typeof(mycstruct)
#> [1] "externalptr"

mycstruct$N
#> [1] 1
mycstruct$strength
#> [1] 13

mycstruct$N <- 3
mycstruct
#> MyCStruct(N = 3, strength = 13)

rm(mycstruct)
gc()
#> MyCStruct finalizer called to free the C pointer memory
#>           used (Mb) gc trigger (Mb) limit (Mb) max used (Mb)
#> Ncells  568772 30.4    1291230   69         NA   667665 35.7
#> Vcells 1036286  8.0    8388608   64      16384  1824267 14.0

Create multiple structs at once

lots <- MyCStructs(n = 3)
class(lots)
#> [1] "list"
lots
#> [[1]]
#> MyCStruct(N = 0, strength = 0)
#> [[2]]
#> MyCStruct(N = 0, strength = 0)
#> [[3]]
#> MyCStruct(N = 0, strength = 0)

Call a C library function

Write a “bridge function” wrapper (in C) that maps from R objects to C objects
Call the C library function from this wrapper
Return the result to R in an appropriate container

An example of a C function in a library is as follows. C libraries know nothing about R or SEXP objects.

double multiply(MyCStruct *mycstruct) {
  return mycstruct->N * mycstruct->strength;
}

The “bridge” function between R and the C library call is written in C as follows.

This function unpacks the externalptr to a real MyCStruct pointer, calls the C library function, and then returns the results as an R real numeric value.

SEXP multiply_(SEXP mycstruct_ptr_) {
  MyCStruct *mycstruct = external_ptr_to_MyCStruct_ptr(mycstruct_ptr_);
  double res = multiply(mycstruct);
  return ScalarReal(res);
}

The call from R is:

multiply <- function(mycstruct) {
  .Call(multiply_, mycstruct)
}

All these functions combine such that we can create a pointer to a C struct in R, and then call the C library function as follows

library(cstructr)
mycstruct <- MyCStruct(N=2, strength = 4.5)
multiply(mycstruct)
#> [1] 9

Auto-generation of bridge function

A lot of the code to wrap a C function and make it callable from R is standard boilerplate.

For simple library functions, you could auto-generate a lot of this R + C code from the C function declaration.

Find sets of five words in the wordle dictionary that contain 25 unique letters

Mon, 17 Jan 2022 17:25:50 +1000

Find five words in the wordle dictionary that contain 25 unique letters

While thinking about wordle I wondered if there existed any sets of five words in the wordle dictionary that would cover 25 unique letters of the alphabet.

Given there are twelve thousand words in the wordle dictionary, there are 12000^5 five-word sets. This is approx 2.5x10^20 - which means that if I could test a million five-word sets every second it would take well over a million years.

So I thought about how I might practically do this with recurstion and vicious pruning of candidates in the search tree.

All in base R!

General solution process

Develop data structures which are easy for R to compute on and help with pruning candidate words
At each step of choosing anew word, prune quickly all the words that could no longer be part of a possible 5-word set
- e.g. if abers is the first word, then the pool of remaining words to choose should immediately discard any word with an a, b, e, r or s.

Overivew of solution technique

Remove all words with repeated letters.
Build list of letters in each word. letters_in_word.
Build letter membership indices. The words_with_letter data structure.
Recursive searching (with early termination) with vicious pruning of the remaining candidate words at each stage.

Start with the wordle dictionary

The wordle dictionary contains 12972 five-letter words.

words <- wordle::wordle_dict
length(words)

#> [1] 12972

head(words)

#> [1] "aahed" "aalii" "aargh" "aarti" "abaca" "abaci"

Remove words with repeated letters

If I need five words covering 25 letters, then no word should have two of the same letter.

Once these are filteredd out 8322 words remain.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Determine if a word has any repeated letters
#' @param words character vector of words
#' @return logical vector
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
has_doubles <- function(words) {
  vapply(strsplit(words, ''), function(lets) {
    any(table(lets) > 1)
  }, logical(1))
}

words <- words[!has_doubles(words)]
length(words)

#> [1] 8322

Pre-calc strsplit

Pre-calculate a data structure with the letters in each word.

Letters are represented by their index within the alphabet

letters_in_word <- lapply(words, function(word) {
  utf8ToInt(word) - 96L
})

test_idx <- which(words == 'panic')
letters_in_word[[test_idx]]

#> [1] 16  1 14  9  3

letters[letters_in_word[[test_idx]]]

#> [1] "p" "a" "n" "i" "c"

Build letter membership indices

Build a data structure mapping each letter of the alphabet to which words contain that letter.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Membership indices
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
words_with_letter <- list()
for (let in letters) {
  words_with_letter[[let]] <- grep(let, words)
}

For instance, can now lookup all the letters which contain ‘q’

words_with_letter[['q']]

#>  [1]  984 1268 1437 2196 2197 2198 2289 2418 2419 3099 4370 4870 5391 5723 5724
#> [16] 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739
#> [31] 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754
#> [46] 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769
#> [61] 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784
#> [76] 5785 5786 5787 6079 6798 6799 6800 6801 6802 6803 6804 6805 6806 7307 7359
#> [91] 7545 7896

words[words_with_letter[['q']]]

#>  [1] "burqa" "cinqs" "coqui" "equal" "equid" "equip" "faqir" "fiqhs" "fique"
#> [10] "guqin" "maqui" "niqab" "pique" "qadis" "qaids" "qapik" "qibla" "qophs"
#> [19] "qorma" "quack" "quads" "quags" "quail" "quair" "quais" "quake" "quaky"
#> [28] "quale" "qualm" "quant" "quare" "quark" "quart" "quash" "quasi" "quate"
#> [37] "quats" "quayd" "quays" "qubit" "quean" "quena" "quern" "query" "quest"
#> [46] "queyn" "queys" "quich" "quick" "quids" "quiet" "quilt" "quims" "quina"
#> [55] "quine" "quino" "quins" "quint" "quipo" "quips" "quire" "quirk" "quirt"
#> [64] "quist" "quite" "quits" "quoad" "quods" "quoif" "quoin" "quoit" "quonk"
#> [73] "quops" "quota" "quote" "quoth" "qursh" "quyte" "roque" "squab" "squad"
#> [82] "squat" "squaw" "squeg" "squib" "squid" "squit" "squiz" "toque" "tranq"
#> [91] "umiaq" "waqfs"

Pick a word and recursively build word sets

This function bails early if the set of ramining candidate words in any search drops to zero.

If a five-word sequence is found then print it.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Recursively filter a set of words
#'
#' @param word_idx an index in [1, length(words)]
#' @param remaining_idx all other word indexes remaining at this stage
#' @param word_seq integer vector of the word indices up to this point
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
filter_words <- function(word_idx,
                         remaining_idx,
                         word_seq   = c()) {

  # In the remaining list of words, filter out any words that contain
  # any of the letters of the current word
  for (letter_idx in letters_in_word[[word_idx]]) {
    remaining_idx <- setdiff(remaining_idx, words_with_letter[[letter_idx]])
  }

  # Bail early if no words available after exclusion
  if (length(remaining_idx) == 0L) return()

  # Update the word sequence 
  word_seq <- c(word_seq, word_idx)

  if (length(word_seq) == 4) {
    # terminal condition
    for (j in remaining_idx) {
      cat(words[c(word_seq, j)], "\n")
    }
  } else {
    for (jj in seq_along(remaining_idx)) {
      filter_words(
        word_idx      = remaining_idx[[jj]],
        remaining_idx = remaining_idx[-seq(jj)],
        word_seq      = word_seq
      )
    }
  }

}

Example starting at `jumby`

Picking jumby as the first word and trying all word sets which start with this word takes about a minute on my old laptop.

However, different starting words will take different times because:

candidate words are only those which come alphabetically after the starting word, so words later in the dictionary will be faster because only words which are after this one are posibble candidate words in the search tree.
different starting words can more rapidly prune the search space, meaning that there are fewer possible candidate words in the search tree

i <- 3666  # 'jumby'
filter_words(
  word_idx = i,
  remaining_idx = seq.int(i+1L, length(words))
)

#> jumby pling treck vozhd waqfs

Search the entire space of five-word sets

I’ve run this sequentially in a for loop and it took about 8 hours to find the word sets.

for (i in seq_along(words)) {
  filter_words(
    word_idx = i,
    remaining_idx = seq.int(i+1L, length(words))
  )
}

bemix clunk grypt vozhd waqfs
bling jumpy treck vozhd waqfs
blunk cimex grypt vozhd waqfs
brick glent jumpy vozhd waqfs
brung cylix kempt vozhd waqfs
brung kempt vozhd waqfs xylic
chunk fjord gymps vibex waltz
clipt jumby kreng vozhd waqfs
fjord gucks nymph vibex waltz
glent jumby prick vozhd waqfs
jumby pling treck vozhd waqfs

{wordle} v0.1.5 - a package for playing (and helping solve) Wordle puzzles

Tue, 04 Jan 2022 20:35:50 +1000

wordle

The {wordle} package contains code to assist in finding good candidate words for Wordle.

“Wordle” itself is a guess-a-word puzzle playable online.

The game plays like the old ‘mastermind’ board game, but with letters instead of coloured pins. The gameplay is as follows:

Enter a word as a guess for the hidden target word.
Any letters which are within the hidden target word are coloured in yellow.
Any letters which match exactly the letter in the hidden target word are coloured green
Figure out a new candidate word as a guess for the hidden target word, and go back to Step 1.

In the following game of Wordle, the first guess was eaten, the second was arise, and then the third guess really only has one good option given the constraints revealed so far: aside. This was the hidden target word, which means the puzzle is solved!

The process of finding good candidate words given letters which have been seen so far is a good match for regular expressions. This package aims to help you find these good candidate words.

What’s in the box

play_wordle() Simple way to play a game of wordle in the R console
wordle_dict an ‘official’ list of words scraped from the Wordle website
WordleHelper R6 Class is the primary way of finding candidate words. It has the following methods:
- $new() to start a new object to help with a new puzzle.
- $words to get a list of all the remaining possible valid words given the words and responses that have been seen so far
- $update() to notify the object of what the latest word was, and the colour responses received back from the game for each letter.
- The WordleHelper class is a stateful wrapper around filter_words()

Advanced:

filter_words() is a stateless function for filtering a list of words by various constraints on letter position.
WordleGame R6 class represnting a wordle game engine
- $new() to create a new game and internally choose a target word for this game
- $try(word) to try a word and see what the respnse is in relation to the hidden target word
- $share() create a block of unicode representing the evolution of the solution process.
- play_wordle() is a simple helper function wrapping this class.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/wordle')

Play a game of Wordle in your R console

wordle::play_wordle()

Help solve a puzzle with `wordle::WordleHelper`

In this example, after picking my favourite starting word, at each step I will just pick the first word in the alphabetical list of remaining possible words.

helper <- WordleHelper$new(nchar = 5)
length(helper$words)

#> [1] 12972

head(helper$words)

#> [1] "aahed" "aalii" "aargh" "aarti" "abaca" "abaci"

Initial word choice: `arose`

There are many opinions on a good starting word - I like: arose

Update puzzle state with the word played and the response:

helper$update("arose", c('grey', 'grey', 'grey', 'yellow', 'green'))
helper$words

#>  [1] "besee" "disme" "ensue" "esile" "fusee" "geste" "gusle" "issue" "istle"
#> [10] "lisle" "mesne" "piste" "pusle" "scene" "scute" "sedge" "segue" "seine"
#> [19] "seize" "selle" "semee" "semie" "sente" "shine" "shite" "shive" "shule"
#> [28] "shute" "sidhe" "sidle" "siege" "sieve" "since" "singe" "sithe" "sixte"
#> [37] "skene" "skite" "skive" "skyte" "slice" "slide" "slime" "slipe" "slive"
#> [46] "slype" "smeke" "smile" "smite" "snide" "snipe" "spice" "spide" "spike"
#> [55] "spile" "spine" "spite" "spule" "spume" "stede" "stele" "steme" "stile"
#> [64] "stime" "stipe" "stive" "stude" "stupe" "style" "styme" "styte" "suede"
#> [73] "suete" "suite" "sujee" "swede" "swile" "swine" "swipe" "swive" "sybbe"
#> [82] "sycee" "sythe" "teste" "unsee" "upsee" "usque" "visie" "visne"

Choose the first word: `besee`

Update puzzle state with the word played and the response:

helper$update("besee", c('grey', 'yellow', 'yellow', 'grey', 'green'))
helper$words

#>  [1] "esile" "scene" "siege" "sieve" "skene" "smeke" "stede" "stele" "steme"
#> [10] "suede" "suete" "sujee" "swede" "sycee"

Choose the first word: `esile`

Update puzzle state with the word played and the response:

helper$update("esile", c('yellow', 'yellow', 'yellow', 'grey', 'green'))
helper$words

#> [1] "siege" "sieve"

Choose the first word: `siege`

Success!

Optimizing word selection

In the above worked example no effort was made to optimize the word choice - instead the first word in the alphabetical list of remaining words was chosen.

There may be opportunities to pick the “best” word that helps to solve the puzzle faster, but no such code is included in this package - yet!

For example, it may be possible to pick the word that when played results in the most other words in the remaining list of words to be eliminated.

Tweetable Wordle Game Engine

A playable game of Wordle in a tweet.

This was an exercise to see if I could simplify the WordleGame into just 280 characters. It’s mostly unreadable, and lacks safety checks, but it works!

#RStats #wordle in a tweet
s=\(x)el(strsplit(x,''))
t=s(sample(grep("^[a-z]{5}$",readLines('/usr/share/dict/words'),v=T),1))
while(1){g=s(readline("? "))
M=t==g
r=which(!M)
for(i in r)for(j in r)if(g[i]==t[j]){M[i]=2;r=r[r!=j]}
cat(paste0('\033[48;5;',c(249,46,226)[M+1],'m ',g))}

Expert Function: `filter_words()`

The WordleHelper R6 class is just a stateful wrapper around a core function called filter_words().

In general you wouldn’t need to call this function for solving a Wordle puzzle but it might come in handy for other word puzzles.

In this example, I’m searching for a word:

with 9 letters
starting with p
containing v and z somewhere, but not as the first letter
containing only one z
without an a or an o in it

words <- readLines("/usr/share/dict/words")

filter_words(
  words            = words,
  exact            = "p........",
  wrong_spot       = c("vz", "", "", "", "", "", "", "", ""),
  min_count        = c(v = 1),
  known_count      = c(z = 1, a = 0, o = 0)
)

#> [1] "pulverize"

Introducing {wordle} - a package for helping solve Wordle puzzles

Fri, 31 Dec 2021 06:35:50 +1000

wordle

The {wordle} package contains code to assist in finding good candidate words for Wordle.

“Wordle” itself is a guess-a-word puzzle playable online.

The game plays like the old ‘mastermind’ board game, but with letters instead of coloured pins. The gameplay is as follows:

Enter a word as a guess for the hidden target word.
Any letters which are within the hidden target word are coloured in yellow.
Any letters which match exactly the letter in the hidden target word are coloured green
Figure out a new candidate word as a guess for the hidden target word, and go back to Step 1.

The process of finding good candidate words given letters which have been seen so far is a good match for regular expressions. This package aims to help you find these good candidate words.

What’s in the box

Wordle R6 Class is the primary way of finding candidate words. It has the following methods:
- $new() to start a new object to help with a new puzzle. Use the word_file argument to set the location of a list of words to start with. This defaults to /usr/share/dict/words (which should work on macOS and many unix-ish systems).
- $words to get a list of candidate words given the words and responses that have been seen so far
- $update() to notify the object of what the latest word was, and the colour responses received back from the game for each letter.
filter_words() is a stateless function for filtering a list of words by various constraints on letter position.
- The Wordle class is a stateful wrapper around filter_words()

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/wordle')

Solving a puzzle with `Wordle`

puzzle <- wordle::WordleHelper$new(nchar = 5)
head(puzzle$words, 20)

#>  [1] "aahed" "aalii" "aargh" "aarti" "abaca" "abaci" "aback" "abacs" "abaft"
#> [10] "abaka" "abamp" "aband" "abase" "abash" "abask" "abate" "abaya" "abbas"
#> [19] "abbed" "abbes"

Guess `eaten`

There are a lot of uncommon words in the word list, and the online puzzle doesn’t accept some of them, so you’ll need to pick out a likely word - in this case I picked: eaten

Update puzzle state with the word played and the response:

puzzle$update("eaten", c('yellow', 'grey', 'grey', 'grey', 'grey'))
head(puzzle$words, 20)

#>  [1] "bebop" "becks" "bedim" "befog" "begum" "beigy" "belch" "bells" "belly"
#> [10] "below" "bemix" "bemud" "bergs" "berko" "berks" "berms" "berob" "berry"
#> [19] "beryl" "besom"

Guess `rodeo`

Update puzzle state with the word played and the response:

puzzle$update("rodeo", c('yellow', 'grey', 'grey', 'yellow', 'grey'))
puzzle$words

#>   [1] "bergs" "berks" "berms" "berry" "beryl" "biers" "birle" "birse" "breis"
#>  [10] "brers" "brews" "breys" "bribe" "brise" "brize" "brule" "brume" "burke"
#>  [19] "burse" "cerci" "ceric" "clerk" "crems" "creps" "crepy" "cress" "crews"
#>  [28] "crime" "cripe" "crise" "cruse" "cruve" "curie" "curse" "curve" "femur"
#>  [37] "ferly" "fermi" "ferms" "ferry" "fibre" "fiers" "fiery" "firie" "fleur"
#>  [46] "fresh" "frise" "frize" "furze" "gebur" "germs" "germy" "grews" "greys"
#>  [55] "grice" "grike" "grime" "gripe" "grise" "grize" "grufe" "grume" "gryce"
#>  [64] "gryke" "grype" "gurge" "heirs" "herbs" "herby" "herls" "herms" "herry"
#>  [73] "huers" "icers" "jerks" "jerky" "jerry" "jirre" "kefir" "keirs" "kerbs"
#>  [82] "kerfs" "kerky" "kerry" "kiers" "kurre" "kyrie" "lehrs" "leirs" "lemur"
#>  [91] "lerps" "liers" "livre" "lucre" "lurve" "merch" "mercs" "mercy" "meril"
#> [100] "meris" "merks" "merls" "merry" "murre" "perch" "percs" "peril" "peris"
#> [109] "perks" "perky" "perms" "perps" "perry" "pervs" "pervy" "piers" "preif"
#> [118] "prems" "premy" "preps" "press" "prexy" "preys" "price" "prime" "prise"
#> [127] "prize" "pryse" "puers" "purge" "purse" "query" "quire" "sehri" "seirs"
#> [136] "serfs" "seric" "serif" "serks" "serrs" "serry" "serum" "shire" "sieur"
#> [145] "skers" "skyre" "smerk" "speir" "sperm" "spire" "sprue" "spyre" "sucre"
#> [154] "suers" "surge" "sweir" "swerf" "swire" "umbre" "ureic" "users" "usure"
#> [163] "verbs" "verry" "vezir" "viers" "virge" "weirs" "wersh" "wreck" "xeric"
#> [172] "xerus" "yerks" "zerks"

Guess `shire`

Update puzzle state with the word played and the response:

puzzle$update("shire", c('grey', 'grey', 'grey', 'green', 'yellow'))
puzzle$words

#> [1] "berry" "clerk" "ferry" "jerry" "kerry" "merry" "perry" "query" "verry"

Guess `merry`

Update puzzle state with the word played and the response:

puzzle$update("merry", c('grey', 'green', 'green', 'green', 'green'))
puzzle$words

#> [1] "berry" "ferry" "jerry" "kerry" "perry" "verry"

Guess `ferry`

Success!

Expert Users: `filter_words()`

The Wordle R6 class is just a stateful wrapper around a core function called filter_words().

In general you wouldn’t need to call this function for solving a Wordle puzzle but it might come in handy for other word puzzles.

In this example, I’m searching for a word:

with 9 letters
starting with p
containing v and z somewhere, but not as the first letter
containing only one z
without an a or an o in it

words <- readLines("/usr/share/dict/words")

filter_words(
  words            = words,
  exact            = "p........",
  wrong_spot       = c("vz", "", "", "", "", "", "", "", ""),
  min_count        = c(v = 1),
  known_count      = c(z = 1, a = 0, o = 0)
)

#> [1] "pulverize"

Solving a Wordle with assistance from R

Tue, 28 Dec 2021 04:35:50 +1000

Wordles!

Wordles are a word guessing puzzle playable online.

There’s a small write-up in a recent article in The Guardian

The game plays like the old ‘mastermind’ board game, but with letters instead of coloured pins.

Enter a word as a guess
Any letters which are within the hidden target word are coloured in yellow.
Any letters which match exactly the letter in the hidden target word are coloured green
Figure out a new candidate word as a guess for the hidden target word, and go back to Step 1.

This process of finding strong and weak matches for characters in a word seems quite suited for regular expressions.

The code below is a first rough attempt at generating good candidate guesses to solve Wordle puzzles.

Establish a scoring system for words

At any stage of the game there will be a number of candidate words which match the letters which have been guessed so far. I’ll use an trivial scoring system to determine a priority list of possible next words.

As a rough rule-of-thumb, I’ll score each word by scoring the letters within the word.

Common letters like e and t score low, while q and z score high.

Tally the scores of all letters in a word to determine a score for a word.

This score will then be used to sort words in order to choose a candidate for the next attempt.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a scoring vector c(e=1, t=2, a=3 ... z=26)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
letter_freqs  <- strsplit('etaoinshrdlcumwfgypbvkjxqz', '')[[1]]
letter_scores <- setNames(1:26, letter_freqs)
score_letters <- function(letters) sum(letter_scores[tolower(letters)])

score_letters(c('h', 'e', 'l', 'l', 'o'))

#> [1] 35

score_letters(c('z', 'y', 'x', 'x', 'y'))

#> [1] 110

Glorified regular expressions in a function

The regular expression to find candidate words from a larger list of words evolves with each guess as new letters are discovered or excluded.

To help out with this regex evolution, I wrote a function to wrap a number of common operations starting from a candidate list of words:

keep only words which have known letters in their exact position.
Discard words which have letters we know are excluded.
Discard words which have letter counts are in excess of requirments
Carefully filter out words where we know particular letters are not correct

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Filter words based upon "Wordle" game state
#'
#' @param words character vector of candidate words
#' @param exact single string representing known characters in the word, with
#'        '.' used to indicate the letter at this position is unknown.
#'        E.g. For a 5 letter word if the 3rd and 4th letters are known to be 'a' and 'c', but
#'        all other letters are unknown, then \code{exact = "..ac."}
#' @param excluded_letters string containing letters known to not be in the word
#' @param wrong_spot a character vector the same length as the number of letters 
#'        in the target word.  Each string in this vector represents all letters
#'        which are known to be part of the word, but in the wrong spot.
#'        E.g. if 'a' has been attempted as the first character, and it exists
#'        in the word, but worlde claims it is not yet in the correct position,
#'        then \code{wrong_spot = c('a', '', '', '', '')}
#' @param known_count name character vector giving letters and their known counts.
#'        E.g. This can be used if it is known definitively that there is only 
#'        one letter 'e' in the target word, in which case
#'        \code{known_count = c(e = 1)}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
filter_words <- function(words, exact = ".....", excluded_letters = "", wrong_spot = c('', '', '', '', ''), known_count = c()) {

  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Build a regex to match the exact case, but exclude any words which 
  # contain excluded letters, or letters in the wrong spot
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  excluded_letters <- rep(excluded_letters, nchar(exact))

  stopifnot(length(wrong_spot) == nchar(exact))
  excluded_letters <- paste(excluded_letters, wrong_spot, sep = "")
  excluded_letters <- ifelse(nchar(excluded_letters) == 0, '.', paste0("[^", excluded_letters, "]"))

  regex <- strsplit(exact, '')[[1]]
  regex <- ifelse(regex == '.', excluded_letters, regex)
  regex <- paste(regex, collapse = "")
  regex <- paste0('^', regex, '$')


  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Keep only words which match the exact case, and do not contain excluded
  # letters, or letters in the wrong spot
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  words <- grep(regex, words, value = TRUE, ignore.case = TRUE)

  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Built a vector of all included letters regardless of whether they're in
  # the wrong spot or not.
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  included_letters1 <- strsplit(exact, '')[[1]]
  included_letters2 <- unlist(strsplit(wrong_spot, ''))
  included_letters  <- c(included_letters1, included_letters2)
  included_letters  <- included_letters[included_letters != '.']
  included_letters  <- sort(unique(included_letters))
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Check that we have all included letters required
  # Do this by comparing the sorted letters within each word vs a sorted regex
  # e.g. to check for letters 'r' and 'e' in 'rebel'
  #  grepl('e.*r', 'beerl')
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (length(included_letters) > 0) {

    sorted_included_letters <- paste(sort(included_letters), collapse = ".*")

    split_words <- strsplit(words, '')
    sorted_letters <- vapply(split_words, function(letters) {
      paste0(sort(letters), collapse = "")
    }, character(1))

    matching_included_letters <- which(grepl(sorted_included_letters, sorted_letters))
    words <- words[matching_included_letters]
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # enforce a known count e.g. if it is known that there is only a single
  # 'e' then drop words like "rebel" from the list of candidate words
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  split_words <- strsplit(words, '')
  for (i in seq_along(known_count)) {
    letter <- names(known_count)[1]
    count  <- known_count[[1]]
    match_counts <- vapply(split_words, function(x) {
      sum(x == letter) == count
    }, logical(1))
    words <- words[match_counts]
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Re-order words by their score. lowest first.
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  split_words <- strsplit(words, '')
  word_scores <- vapply(split_words, score_letters, numeric(1))
  words[order(word_scores)]
}

Puzzle - What’s my first guess?

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Read a bit list of words that is available on many MacOS/Linux systems
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
words <- readLines("/usr/share/dict/words")

words <- filter_words(words, exact = ".....")
head(words, 20)

#>  [1] "otate" "tatta" "tenet" "Aotea" "eaten" "enate" "tatie" "teest" "teste"
#> [10] "setae" "tease" "teeth" "theet" "State" "state" "taste" "Tates" "testa"
#> [19] "Teton" "arete"

Guess `eaten`

There’s a lot of sillier words in the word list, so I picked out something a bit more common: eaten

For the next guess:

a, t and n are definitely excluded letters
- excluded_letters = "atn"
the first e was correct but in the wrong spot
- wrong_spot = c('e', '', '', '', '')
the second e is not part of the word at all, which means there can be only 1 e in this word
- known_count = c(e = 1)

words <- filter_words(words, exact = ".....", excluded_letters = "atn", 
                      wrong_spot = c('e', '', '', '', ''), known_count = c(e=1))
head(words, 20)

#>  [1] "hoose" "hoise" "issei" "osier" "Rhoeo" "serio" "diose" "idose" "loose"
#> [10] "oside" "ohelo" "rodeo" "shies" "Heidi" "helio" "horse" "roleo" "shoer"
#> [19] "shore" "cooer"

Guess `rodeo`

For the next guess:

o and d should be added to excluded_letters
e is still not in the correct spot, and we now know that r is part of the word but it should not be in the first position.

words <- filter_words(words, exact = ".....", excluded_letters = "atnod", 
                      wrong_spot = c('er', '', '', 'e', ''), known_count = c(e=1))
head(words, 20)

#>  [1] "hirse" "shire" "Seric" "cheir" "cress" "swire" "crile" "serif" "shure"
#> [10] "cerci" "ceric" "Circe" "girse" "curie" "ferri" "freir" "Iberi" "meril"
#> [19] "ureic" "crime"

Guess `shire`

For the next guess:

I now know that r is the 4th letter in the word
- exact = "...r."
s, h and i are all excluded from this word.
I now know that e should not be the last letter in this word

words <- filter_words(words, exact = "...r.", excluded_letters = "atnodshi", 
                      wrong_spot = c('er', '', '', 'e', 'e'), known_count = c(e=1))
head(words, 20)

#>  [1] "merry" "ferry" "clerk" "Perry" "perry" "berry" "lyery" "Kerry" "kerry"
#> [10] "querl" "becry" "Jerry" "jerry" "Jewry" "query"

Guess `merry`

words <- filter_words(words, exact = ".erry", excluded_letters = "atnodshim", 
                      wrong_spot = c('er', '', '', 'e', 'e'), known_count = c(e=1))
head(words, 20)

#> [1] "ferry" "Perry" "perry" "berry" "Kerry" "kerry" "Jerry" "jerry"

Guess `ferry`

Solved! Now what?

This might be a nifty Shiny app if anyone felt so inclined.
Streamline/optimise code - but it runs fast enough for now for it not to be an issue
Nicer interface - maybe an R6 wrapper to retain state

Introducing {ggsvg} - use SVG as ggplot points

Thu, 23 Dec 2021 21:35:50 +1000

ggsvg - Use SVG as points in ggplot

ggsvg is an extension to ggplot to use arbitrary SVG as points.

This SVG can be customised to respond to aesthetics e.g. element colours can changes in response to fill and/or colour scales.

However, aesthetics are not limited to colour - any other SVG parameter can be linked to any aesthetic which makes sense e.g. an aesthethic may be used to control the corner radius on a rounded rectangle.

What’s in the box

geom_point_svg() is equivalent to geom_point() except it also requires SVG text to be set (via the svg argument)
scale_svg_* a full(?) set of compatible scale functions for controlling the mapping of values to arbitrary named aesthetics.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/cssparser')
remotes::install_github('coolbutuseless/svgparser')
remotes::install_github('coolbutuseless/ggsvg')

Debugging

Set options(GGSVG_DEBUG = TRUE) for some verbose debugging.

This will cause {ggsvg} to output the final SVG for each and every element it wants to put on the plot.

Simple SVG Image

An SVG Christmas Tree with a hex star on top!

library(ggplot2)
library(ggsvg)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define simple SVG
#   - Square with rounded corners and a circle inside it.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
svg_text <- '
  <svg viewBox="0 0 100 100 ">
    <polygon points = "20,80 80,80 50,20" fill="darkgreen" />
    <polygon points = "40,83 60,83 60,95 40,95" fill="darkred" />
    <polygon points = "58.66 25.00 50.00 30.00 41.34 25.00 41.34 15.00 50.00 10.00 58.66 15.00 58.66 25.00" 
       fill="yellow3" />
  </svg>
  '


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Render SVG with `{svgparser}`
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grob <- svgparser::read_svg(svg_text)
grid::grid.newpage()
grid::grid.draw(grob)

Simple SVG drawn for each point

Here, the simple SVG will be used as a plotting character.

The point locations are given by the capital “R” in the Hershey script font.

# remotes::install_github('coolbutuseless/hershey')
library(hershey)
letter <- hershey[hershey$char == 'R' & hershey$font == 'scriptc',]

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use 'geom_point_svg' to plot SVG image at each point
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(letter) +
  geom_path(aes(x, y, group = stroke), alpha = 0.5) +
  geom_point_svg(
    mapping  = aes(x, y),
    svg      = svg_text,
    size     = 10
  ) +
  theme_bw() + 
  coord_equal() + 
  labs(
    title    = "Merry Christmas #RStats",
    subtitle = "{ggsvg} Using SVG as points"
  )

Simple aesthetics

This is a basic example showing how ggplot aesthetics may be used to control SVG image properties.

Some key things to note:

Locations for ggplot to insert aesthetics via the glue package are marked with double curly braces i.e. {{...}}.
One such variables has been added to the SVG - {{fill_tree}} is used in place of the static colour that was defined in the original SVG
fill_tree must now appear as an aesthetic in the call to geom_point_svg()
Need to inform ggplot2 of the default value for each new aesthetic by setting the defaults argument
For each aesthetic, you will need to add a scale with scale_svg_*() to let ggplot know how it should turn the mapped variable into a value to insert in the SVG.
In this case, the variables is a fill variable, so use one of scale_svg_fill_*() family to ensure that the value is mapped to a colour.
The new scale_svg_*() scales are mostly identical to their ggplot counterparts except:
- The aesthetics argument no longer has a default value
- colourbar guides have been tweaked to allow for non-standard aesthetics.

library(ggplot2)
library(ggsvg)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define some SVG
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
svg_text <- '
  <svg viewBox="0 0 100 100 ">
    <polygon points = "20,80 80,80 50,20" fill="{{fill_tree}}" />
    <polygon points = "40,83 60,83 60,95 40,95" fill="darkred" />
    <polygon points = "58.66 25.00 50.00 30.00 41.34 25.00 41.34 15.00 50.00 10.00 58.66 15.00 58.66 25.00" 
       fill="yellow3" />
  </svg>
  '

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use 'geom_svg' to plot with this symbol
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(mtcars) +
  geom_point_svg(
    mapping     = aes(
      x           = mpg, 
      y           = wt, 
      size        = cyl, 
      fill_tree   = as.factor(cyl)
    ),
    svg         = svg_text,
    defaults    = list(fill_tree = 'darkgreen')
  ) +
  labs(
    title    = "{ggsvg} Simple SVG with fill aesthetic",
    subtitle = "`cyl` mapped to tree colour and size"
  ) + 
  theme_bw() +
  scale_size(range = c(5, 12), guide = 'none') + 
  scale_svg_fill_viridis_d('fill_tree', guide = guide_legend(override.aes = list(size = 7)))

More complex example - Virus with multiple aesthetics

This is an SVG image of something virus-like from wikimedia - it is public domain.

svg_file <- system.file("Virus_black_white.svg", package = "ggsvg")
grob <- svgparser::read_svg(svg_file)
grid::grid.draw(grob)

I have hand-edited the SVG to add two locations for {glue} to insert text:

fill = "{{fill_inner}}" has been added to all elements in the central body of the virus.
fill = "{{fill_outer}}" has been added to the “arms” of the virus

library(ggplot2)
library(ggsvg)

fake_data <- readr::read_csv(
'county, month, count, majority
A, 1, 1.00, delta
A, 2, 1.40, delta
A, 3, 1.96, delta
A, 4, 2.74, delta
A, 5, 3.85, omicron
A, 6, 5.38, omicron
B, 1, 1.00, delta
B, 2, 1.10, delta
B, 3, 1.21, omicron
B, 4, 1.33, omicron
B, 5, 1.46, omicron
B, 6, 1.61, omicron
', show_col_types = FALSE)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Read in the SVG as text.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
svg_file <- system.file("virus.svg", package = "ggsvg")
svg_text <- paste(readLines(svg_file), collapse = "\n")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use 'geom_svg' to plot with this symbol
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(fake_data) +
  geom_line(aes(month, count, group = county)) +
  geom_point_svg(
    mapping = aes(month, count, 
                  size = count, 
                  fill_inner = county, 
                  fill_outer = majority),
    svg         = svg_text,
    defaults    = list(fill_inner = '#aaaaaa80', fill_outer = '#aaaaaa80')
  ) +
  theme_bw() +
  scale_size_continuous(range = c(6, 20), guide = 'none') +
  scale_svg_fill_brewer(
    aesthetics = 'fill_inner', 
    palette = 'Dark2',
    guide = guide_legend(override.aes = list(size = 9))
  ) +
  scale_svg_fill_manual(
    aesthetics = 'fill_outer',
    values = c(delta = 'grey50', omicron = 'darkred'),
    guide = guide_legend(override.aes = list(size = 9))
  ) + 
  labs(
    title    = "{ggsvg} - Complex SVG with multiple fill aesthetics",
    subtitle = "Virus body coloured by county\nVirus tendrils coloured by delta/omicron majority status"
  )

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Lex, Parse and Evaluate a Simple S-Expression with {flexo}

Thu, 09 Dec 2021 04:10:50 +1000

library(flexo)

`{flexo}`

flexo is a package containing a simple lexer (to split text into named tokens) and a TokenStream R6 class for manipulating the stream (in order to iterate through the stream to parse it).

LISPy S-Expression

The following code is an S-Expression which evaluates to 21

sexp <- "(+ (* 2 3) (* 3 5))"

Lex the S-Expression into tokens

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define the regex for each token
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sexp_regexes <- c(
  open       = "\\(",
  close      = "\\)",
  num        = "\\d+",
  whitespace = "\\s+",
  op         = ".+?"
)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Split the expression into tokens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tokens <- lex(sexp, sexp_regexes)
tokens <- tokens[names(tokens) != 'whitespace']

tokens

#>  open    op  open    op   num   num close  open    op   num   num close close 
#>   "("   "+"   "("   "*"   "2"   "3"   ")"   "("   "*"   "3"   "5"   ")"   ")"

Evaluate the expression by interpreting the tokens

Recurisve evaulation of the S-Expression by calculating on the stream of tokens.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise a token stream
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
stream <- TokenStream$new(tokens)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Recursive function to evaluate a TokenStream full of sexp tokens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
eval_sexp <- function(stream) {
  name  <- stream$read_names(1)
  
  if (name == 'op') {
    
    # Get the 'op'
    op <- stream$consume(1)
    
    # Gather the args
    args <- list()
    while (stream$read_names(1) != 'close') {
      this_arg <- eval_sexp(stream)
      args     <- c(args, this_arg)
    }
    stream$consume(1)           # Consume the "close" bracket
    result <- do.call(op, args) # Eval the "op"
  } else if (name == "open") {
    stream$consume(1)           # Consume the "open" bracket
    result <- eval_sexp(stream) # Recursive eval
  } else if (name == 'num') {
    result <- as.numeric( stream$consume(1) ) 
  } 
  
  result
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Calculate the result
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
eval_sexp(stream)

#> [1] 21

Evaluate the expression by translating to R

Translate the S-Expression into a string of R code and then evaluate it.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise a token stream
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
stream <- TokenStream$new(tokens)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Evaluate a TokenStream full of sexp tokens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
convert_sexp <- function(stream) {
  name  <- stream$read_names(1)
  
  if (name == 'op') {
    
    # Get the 'op'
    op <- stream$consume(1)
    
    # Gather the args
    args <- list()
    while (stream$read_names(1) != 'close') {
      this_arg <- convert_sexp(stream)
      args     <- c(args, this_arg)
    }
    stream$consume(1)           # Consume the "close" bracket
    
    # Create some R code
    result <- paste0("`", op, "`(", paste(args, collapse = ", "), ")")
  } else if (name == "open") {
    stream$consume(1)           # Consume the "open" bracket
    result <- convert_sexp(stream) # Recursive eval
  } else if (name == 'num') {
    result <- as.numeric( stream$consume(1) ) 
  } 
  
  result
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Calculate the result
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
r_string <- convert_sexp(stream)
r_string

#> [1] "`+`(`*`(2, 3), `*`(3, 5))"

eval(parse(text = r_string))

#> [1] 21

Base64 encoding/decoding in plain R

Sat, 04 Dec 2021 05:30:50 +1000

Introduction

As part of working on {svgparser} I am adding support for the <image> tag in SVGs.

<image> tags can reference an image as a URL, or they can also contain an inline copy of the image encoded in an “ASCII-safe” format.

Base64 encoding is one commonly supported method for converting raw bytes into ASCII character strings.

The following code is a mini-exploration into how Base64 encoding/decoding could be done quickly(?) in base R.

TL;DR - base64 encoding/decoding can be done easily in base R, but not quickly.
I’ll be better off using one of the packages with C code for this task.

Not really a surprising result, but this was a fun diversion.

Base64 Encoding/Decoding

A high level description of Base64 encoding:

View the sequence of raw bytes as a sequence of raw bits
Group the bits six-at-a-time.
Interpret each 6-bit grouping as an integer (0-63)
Use this integer as index to choose from safe ASCII character set
- 26 uppercase letters
- 26 lowercase letters
- 10 digits
- ‘+’ and ‘\’ make up the last to characters
Combine all these characters in a single string

Decoding is then just the reverse of this process.

Note that there is some messy stuff to do with padding that I’m not doing to describe here, but the code below mostly(?) deals with this.

Base64 encoding/decoding support in existing R packages

The {openssl} package and the {base64enc} package both support fast encoding/decoding of Base64 values

# input data should be raw bytes
data <- as.raw(sample(1:10))
data

#>  [1] 09 04 07 01 02 05 03 0a 06 08

# Encode to a single Base64 encoded string
b64 <- openssl::base64_encode(data)
b64

#> [1] "CQQHAQIFAwoGCA=="

# Decode the string back into raw data
openssl::base64_decode(b64)

#>  [1] 09 04 07 01 02 05 03 0a 06 08

Vanilla R code for Base64 Encoding/Decoding

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create lookup table to convert characters to their 6-bit-integer values
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
char_to_int <- function(vec) {
  unname(vapply(as.character(vec), utf8ToInt, integer(1)))
}


lookup_names <- c(LETTERS, letters, 0:9, '+', '/', '=')
lookup_values <- c(
  char_to_int(LETTERS) - char_to_int('A'),
  char_to_int(letters) - char_to_int('a') + 26L,
  char_to_int(0:9)     - char_to_int('0') + 52L,
  62L,
  63L,
  0L
)

lookup <- setNames(lookup_values, lookup_names)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Decode a base64 string to a vector of raw bytes
#'
#' @param b64 Single character string containing base64 encoded values
#'
#' @return raw vector
#'
#' @example
#' b64 <- 'iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAQAAAC1HAwCAAAAC0lEQVR42mNk+A8AAQUBAScY42YAAAAASUVORK5CYII='
#' decode_base64(b64)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
decode_base64 <- function(b64) {
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Get a, integer 6-bit value for each of the characters in the string
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  chars    <- strsplit(b64, '')[[1]]
  six_bits <- lookup[chars]

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Explode these integers into their individual bit values (32 bits per int)
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  bits <- intToBits(six_bits)

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Convert to 32 row matrix
  # Truncate to 6-row matrix (ignoring bits 7-32).
  # Then reshape to 8-row matrix.
  # Note that 'intToBits()' output is little-endian, so switch it here to
  # big endian for easier logic
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  mat <- matrix(as.integer(bits), nrow = 32)[6:1,]
  N <- length(mat)
  stopifnot(N %% 8 == 0)
  dim(mat) <- c(8, N/8)

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Convert bits to bytes by multiplying out rows by 2^N and summing
  # along columns (i.e. each column is a bit-pattern for an 8-bit number)
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  raw_vec <- as.raw(colSums(mat * c(128L, 64L, 32L, 16L, 8L, 4L, 2L, 1L)))

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Trim padded characters
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (endsWith(b64, "==")) {
    length(raw_vec) <- length(raw_vec) - 2L
  } else if (endsWith(b64, "=")) {
    length(raw_vec) <- length(raw_vec) - 1L
  }

  raw_vec
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Encode a raw vector to a base64 encoded character string
#'
#' @param raw_vec raw vector
#'
#' @return single character string containing base64 encoded values
#'
#' @example
#' encode_base64(as.raw(1:20))
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
encode_base64 <- function(raw_vec) {
  stopifnot(is.raw(raw_vec))

  # work out if we need to pad the result to an 8-bit boundary
  npad <- 3L - (length(raw_vec) %% 3L)
  if (npad %in% 1:2) {
    length(raw_vec) <- length(raw_vec) + npad
  }

  # Create an 8 row matrix.  Each column is the bit-vector for an 8-bit number
  int <- as.integer(raw_vec)
  res <- as.integer(bitwAnd(rep(int, each = 8),  c(128L, 64L, 32L, 16L, 8L, 4L, 2L, 1L)) > 0)
  mat <- matrix(res, nrow = 8)

  # Reshape to a 6-row matrix (i.e. 6-bit numbers)
  N <- length(mat)
  stopifnot(N %% 6 == 0)
  dim(mat) <- c(6, N/6)

  # Calcualte the 6-bit numbers
  mat <- mat * c(32L, 16L, 8L, 4L, 2L, 1L)
  values <- colSums(mat)

  # Find the letter which is associated with each 6-bit number
  # and paste together into a string
  chars <- lookup_names[values + 1L]
  b64 <- paste(chars, collapse = "")

  # Replace padding bits with '=' signs
  if (npad == 1) {
    b64 <- gsub(".$", "=", b64)
  } else if (npad == 2) {
    b64 <- gsub("..$", "==", b64)
  }

  b64
}

Check results agree with `{openssl}`

for (i in seq(100)) {
  data    <- as.raw(sample(i))
  b64_me  <- encode_base64(data)
  b64_ref <- openssl::base64_encode(data)
  
  # Does my base64 string agree with `openssl`?
  stopifnot(identical(b64_me, b64_ref))
  
  # Does the decoded value match the original data?
  decoded <- decode_base64(b64_ref)
  stopifnot(identical(data, decoded))
}

print("All good!")

#> [1] "All good!"

Rough encoding speed comparison

Simple timing shows that the R code is 2x to 100x slower than the C code. Base R code is only competitive at really small sizes.

No real suprises.

res <- bench::press(
  N = c(10, 100, 10000),
  {
    data <- as.raw(sample(N) %% 256)
    bench::mark(
      openssl::base64_encode(data),
      encode_base64(data)
    )
  }
)

Table 1: Speed timing
expression	N	min	median	itr/sec	mem_alloc
openssl::base64_encode(data)	10	22.31µs	28.02µs	27978.7464	0B
encode_base64(data)	10	48.68µs	59.7µs	14708.8449	2.53KB
openssl::base64_encode(data)	100	22.6µs	29.17µs	28753.0286	192B
encode_base64(data)	100	91.39µs	122.42µs	6996.1620	25.05KB
openssl::base64_encode(data)	10000	57.08µs	74.45µs	11249.6782	13.08KB
encode_base64(data)	10000	5.17ms	6.22ms	160.5602	2.36MB

Introducing {svgparser} - an SVG renderer in plain R

Thu, 02 Dec 2021 05:30:50 +1000

svgparser

Load SVG files as R vector objects (grobs) or data.frames

svgparser loads vector-based SVG images as R vector objects.

The vector objects which are created in R are the standard graphics object (‘grob’) in the base R {grid} graphics system.

SVG images can also be imported as data.frames. Each shape, line and point is represented in the data.frame with copious helpings of metadata to relate individual coordinates to the original SVG structure.

Example: Load SVG as vector image

This example loads an SVG image into a base R grid graphics object, and then draws the object using grid.draw.

Note that this is not a fixed size raster image! This is a vector image which can be resized without loss of precision.

tiger_filename <- system.file("tiger.svg", package = "svgparser")
tiger_grob <- svgparser::read_svg(tiger_filename)
grid::grid.draw(tiger_grob)

Example: Load SVG as a data.frame

This example loads an SVG as a data.frame and then plots the coordinates using ggplot. The element type from the original SVG is used as the aesthetic for colouring the lines in the plot.

tiger_df <- svgparser::read_svg(tiger_filename, obj_type = 'data.frame')

nrow(tiger_df)

#> [1] 57117

knitr::kable(head(tiger_df, 3))

x	y	name	idx	path_idx	inst_idx	path	col	fill	alpha	lwd	lineend	linejoin	linemitre	fontsize	cex	fontface	fontfamily	font	xpath	tag	elem_idx
-122.3000	84.2850	move	1	1	1	m -122.3 84.285	#000000FF	#FFFFFFFF	1	0.172	butt	mitre	4	12	1	plain	serif	1	/svg/g/g[1]/path	path	1
-122.3000	84.2850	bezier3_reflect	1	2	2	s 0.1 1.894 -0.73 1.875	#000000FF	#FFFFFFFF	1	0.172	butt	mitre	4	12	1	plain	serif	1	/svg/g/g[1]/path	path	1
-122.2997	84.2916	bezier3_reflect	1	2	2	s 0.1 1.894 -0.73 1.875	#000000FF	#FFFFFFFF	1	0.172	butt	mitre	4	12	1	plain	serif	1	/svg/g/g[1]/path	path	1

There’s enough information in the data.frame to manually recreate most of the SVG using whatever drawing mechanism you’d like. Here, I’ve used ggplot2 to draw the outlines from the data.

ggplot(tiger_df) + 
  geom_path(aes(x, y, colour = name, group = interaction(elem_idx, path_idx))) +
  scale_y_reverse()

What’s in the box

read_svg() read SVG into R as a {grid} graphics object (grob) or data.frame
load_supertinyicon() to load an SVG icon from the Super Tiny Icons icon pack included with this package. See LICENSE-supertinycons.txt (MIT License)

Installation

This package is available on GitHub.

# install.package('remotes')
remotes::install_github('coolbutuseless/cssparser') # Handles CSS styling
remotes::install_github('coolbutuseless/svgparser')

With R > v4.1.0:

gradients and clipping paths are rendered as correctly as possible.

With R < v4.1.0:

solid colours will be used in place of gradients, and
any elements which use a clipping path in the SVG will not be properly clipped in R.

Vignettes

Description
SVG in ggplot using gggrid
Creating tileable patterns for R graphics
Add SVG to ggplot2 plots
Debugging Issues by Using False Colouring
Customising SVG with CSS

SVG Feature Support

(#tab:features_svg)SVG Feature Support
Feature	Support	Notes
<path> elements	yes	Working well!
<rect> <circle> etc	yes	Working
<ellipse>	yes	No rotation yet
<text>	meh	Works at a basic level. Don’t expect anything using fancy text effects to work
style cascading	yes	Using `{cssparser}`
<linearGradient> <radialGradient>	yes	converted to R4.1 gradient objects. ‘userSpaceOnUse’ coordinate space only. Send examples!
transform presentation attribute	yes	.
<defs> <use>	yes	.
<pattern>	no	Impossible?
<filter>	no	Impossible?
animation	no	Impossible?
linetypes	no	Planned feature - but R is much more limited compared to SVGs linetype features.
masks	no	need example SVG
clipping paths	yes	works on the few examples tested

SVG icon pack `SuperTinyIcons` is included with the package

SuperTinyIcons is a set of icons focussed on small representations of logos of some internet companies and other images.

These icons can be accessed from this package using:

supertinyicons (for the names of all the icons), and
load_supertinyicon() to load an icon as an R object.

See LICENSE-supertinycons.txt for MIT license information for this icon set.

supertinyicon_names[1:10]
load_supertinyicon('twitter', obj_type = 'svg')

 [1] "acast"          "access"         "adobe"          "airbnb"        
 [5] "amazon_alexa"   "amazon_s3"      "amazon"         "amberframework"
 [9] "andotp"         "android"

<?xml version="1.0" encoding="UTF-8"?>
<svg xmlns="http://www.w3.org/2000/svg" aria-label="Twitter" role="img" viewBox="0 0 512 512">
  <rect width="512" height="512" rx="15%" fill="#1da1f2"/>
  <path fill="#fff" d="M437 152a72 72 0 01-40 12a72 72 0 0032-40a72 72 0 01-45 17a72 72 0 00-122 65a200 200 0 01-145-74a72 72 0 0022 94a72 72 0 01-32-7a72 72 0 0056 69a72 72 0 01-32 1a72 72 0 0067 50a200 200 0 01-105 29a200 200 0 00309-179a200 200 0 0035-37"/>
</svg>

grid.draw(load_supertinyicon('twitter'))

Technical bits

svgparser is vanilla R code which walks the XML tree and converts elements (and nested sub-elements) into a nested set of grid::grobTree() objects.

Circles, lines and points are translated to their corresponding grid object i.e. grid::circleGrob(), grid::linesGrob(), grid::pointsGrob().

Radial and linear gradients are captured as the new objects available in R4.1: grid::radialGradient() and grid::linearGradient()

For <use> tags, {svgparser} extracts xpath information to retrieve relevant referenced section of the SVG, parse it into R objects and then insert it at the given location.

There are only a few dependencies:

{xml2} is used as to parse the SVG into R
{cssparser} is used to cascade stylesheets within the XML representation. This was initially built-in to svgparser, but was moved to a separate package as things got complicated. (Who could have known that parsing and cascading style sheets could be so complicated!)
{stringi} is used as part of the lexer which breaks some of the SVG structures into smaller objects for parsing e.g. transform strings like translate(10, 10) rotate(50)

Related Software

{rsvg} renders SVG files into bitmaps, and some other file representations.
- This package is wraps the C library librsvg
{grImport2} reads SVG files into R
- grImport2 only seems to load SVG created by the Cairo graphics library

Comparison to related R packages

	svgparser	rsvg	grImport2
Loads as Vector Object	Yes (grob)	No (bitmap)	Yes (grob)
Loads as Standard Grob	Yes (grobTree)	No (bitmap)	No (custom PictureGrob)
Exposes coordinates	Yes (as a data.frame) along with SVG meta-information	No	Yes (via grid::grobPoints), but lacks meta-information
Note		Backed by fast + well tested C library	Will only load SVG created by Cairo

Acknowledgements

Thanks to early alpha testers:
R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

A simple 2048 game engine in R

Sun, 14 Nov 2021 19:30:50 +1000

2048 in R

A simple/naive implementation of 2048 in plain R - with {ggplot2} output for a little bit of zing.
Interactive keypress response seems basically impossible from R, so this uses readline() and you have to press return to register each action.
Code in a gist
Motivation:
- Looking at some game stuff in R and this was the simplest thing I could think to write
There’s an existing package on CRAN: twenty48
- But I wanted to re-invent the wheel so I could think about the process of game creation.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#
#    #####    ###   #        #####
#   #     #  #   #  #    #  #     #
#         # #     # #    #  #     #
#    #####  #     # #    #   #####
#   #       #     # ####### #     #
#   #        #   #       #  #     #
#   #######   ###        #   #####
#
#
#
# Board Size: Default = 4
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
library(ggplot2)
N <- 4L

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Collapse a vector in the style of 2048
#
# Collapse vector by removing zeros, then summing pairs of adjacent values
#
# Result is padded with zeros to length of input
#
# @param x vector of integers
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
collapse_vec <- function(x) {
  new  <- x[x > 0]

  i <- 1L
  while (i < length(new)) {
    if (new[i] == new[i + 1L]) {
      new[i] <- new[i] * 2L
      new    <- new[-(i + 1L)]
    }

    i <- i + 1L
  }

  c(new, integer(N - length(new)))
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise game board
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
m       <- matrix(0L, N, N)
init    <- sample(N*N, 2)
m[init] <- 2L
m_prior <- m


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot game board
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
plot_m <- function(m) {
  grid <- expand.grid(1:N, 1:N)
  idx  <- arrayInd(which(m > 0), .dim = c(N, N))
  df   <- cbind(as.data.frame(idx), V3 = factor(m[m > 0], levels = 2^(1:11)))
  ggplot(df, aes(V2, N + 1L - V1)) +
    geom_tile(data = grid, aes(Var1, Var2), fill = 'grey90', width = 0.9, height = 0.9) +
    geom_tile(aes(fill = V3), width = 0.9, height = 0.9) +
    geom_text(aes(label = V3), colour = 'white', size = 10) +
    theme_void() +
    xlim(0, N+1L) + ylim(0, N+1L) +
    coord_equal() +
    theme(legend.position = 'none') +
    scale_fill_viridis_d(option = 'D', drop = FALSE, end = 0.9)
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Game loop
#    Use WASD to collapse the board in up/left/down/right directions
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
print(plot_m(m))

while (max(m) < 2048 && any(m == 0)) {
  if (!identical(m, m_prior)) {
    # if the board has changed, then add a new '2' tile
    m[sample(which(m == 0), 1)] <- 2L

    print(m)
    print(plot_m(m))
  }

  m_prior <- m
  # cmd <- readline(prompt = "move?: ")
  m <- switch(
    readline(prompt = "move?: "),
    'q' = break,
    'w' = apply(m, 2, collapse_vec),                            # up
    'a' = t(apply(m, 1, collapse_vec)),                         # left
    's' = apply(m[nrow(m):1,], 2, collapse_vec)[nrow(m):1,]   , # down
    'd' = t(apply(m[,nrow(m):1], 1, collapse_vec))[,nrow(m):1], # right
    m
  )
}

if (max(m) >= 2048) {
  message("You won!")
}

Custom {ggplot2} point shapes with {gggrid}

Thu, 04 Nov 2021 19:30:50 +1000

library(ggplot2)
library(grid)
library(gggrid)

Use grobs as points in `{ggplot}` using `{gggrid}`

I highly recommend reading Paul Murrel’s Report on {gggrid} and other techniques for getting grobs into ggplots.

# remotes::install_github('https://github.com/pmur002/gggrid')
library(grid)
library(gggrid)

hex <- FALSE
if (hex) {
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Create the template grob - a hex!
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  r     <- 0.5
  theta <- seq(30, 360, 60) * pi/180
  x     <- r * cos(theta)
  y     <- r * sin(theta)
  g     <- grid::polygonGrob(x = x, y = y, vp = viewport(), gp = gpar())
} else {
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Create the template grob - a 5 pointed star
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  r     <- 0.5
  theta <- seq(36, 360, 72) * pi/180
  x     <- r * cos(theta)
  y     <- r * sin(theta)
  g     <- grid::polygonGrob(x = x[c(1,3,5,2,4)], y = y[c(1,3,5,2,4)], vp = viewport(), gp = gpar())
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define the callback function to use within each panel.
# See https://www.stat.auckland.ac.nz/~paul/Reports/gggrid/gggrid.html
#
# @param data data.frame of original data
# @param coords data.frame of values scaled to fit into the desired output units
#               as well as any aesthetic values. 
#               One row per point.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
panel_func <- function(data, coords) {
  
  # Function which will be called for each row in 'coords'
  position_grob <- function(point) {
    gnew           <- g
    gnew$gp$fill   <- point$fill
    gnew$gp$col    <- NA  #point$colour
    gnew$gp$alpha  <- point$alpha
    gnew$vp$x      <- unit(point[['x']], 'npc')
    gnew$vp$y      <- unit(point[['y']], 'npc')
    gnew$vp$width  <- unit(point[['size']]/4, 'cm')
    gnew$vp$height <- unit(point[['size']]/4, 'cm')
    gnew$name <- strftime(Sys.time(), "%H%M%OS6") # Enforce unique name per grob. 
    gnew
  }
  
  # For each point, generate a grob
  grobs <- lapply(
    seq(nrow(coords)), 
    function(idx) {
      position_grob(coords[idx, ])
    })
  
  # group all the point grobs into a single grobTree object
  do.call(grid::grobTree, grobs)
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot wih a `gggrid::grid_panel()`
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(
  data = mtcars, 
  mapping = aes(
    x      = mpg, 
    y      = wt, 
    size   = cyl, 
    fill   = as.factor(cyl)
  )
) + 
  gggrid::grid_panel(panel_func) + 
  theme_bw() +
  labs(title = "{gggrid}: Custom ggplot points")

Introducing {cssparser} - parse CSS into R lists and apply CSS to html within R

Wed, 29 Sep 2021 21:40:50 +1000

cssparser

cssparser is a CSS parser (written in vanilla R) which can:

Parse CSS into R lists
Combine CSS
Apply CSS to determine final computed styles of elements in an HTML document

What’s in the box

read_css() read a cascading style sheet consisting of multiple selectors into an R list
read_inline_style() read a single inline style string into an R list
css_apply() determine the calculated style for each element in an html document
css_apply_inline() add the calculated style an inline <style> tag to every element in an HTML document
css_merge(), style_merge() recursively merge multiple style sheets or styles
css_pretty_print(), style_pretty_print() helpers to view the R list structures in a way that may be more meaningful if you are comparing the information to its original CSS form.

Vignettes

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/cssparser')

Limitations

Shorthand properties. There are many shorthand properties in CSS which are compact representations of multiple other CSS properties. E.g. border is is a way of combining border-width, border-style and border-color in a single property. These shorthand properties have particular inheritance rules, and currently only the font shorthand property is the only one which is expanded and inhertied correctly.
The all selector is not implemented yet.
The CSS values like inherit and unset are not yet handled.
The @-prefixed selectors (e.g. @media) aren’t really handled well. They exist in the parsed data, but have not been tested
pseudo-elements and pseudo-classes do not take part in the cascading of styles
there is no concept of page size, and it is expected that if you want to calculate the final width of any particular element, you’ll have to do your own device-specific shenanigans.

Example: Parse CSS

library(cssparser)

stylesheet <- '
#main {
  background-color: red !important;
  color: blue;
}

.footer {
  border-color: rgb(50 100 255);
  font-weight: lighter;
  margin-left: 1cm;
}

.footer > p {
  background-color: green;
}
'

css <- cssparser::read_css(stylesheet)
css

#> $`#main`
#> $`#main`$`background-color`
#> [1] "red"
#> attr(,"important")
#> [1] TRUE
#> 
#> $`#main`$color
#> [1] "blue"
#> 
#> 
#> $.footer
#> $.footer$`border-color`
#> [1] "rgb(50 100 255)"
#> 
#> $.footer$`font-weight`
#> [1] "lighter"
#> 
#> $.footer$`margin-left`
#> [1] "1cm"
#> 
#> 
#> $`.footer > p`
#> $`.footer > p`$`background-color`
#> [1] "green"

cssparser::css_pretty_print(css)

#> #main {
#>   background-color: red !important;
#>   color: blue;
#> }
#> 
#> .footer {
#>   border-color: rgb(50 100 255);
#>   font-weight: lighter;
#>   margin-left: 1cm;
#> }
#> 
#> .footer > p {
#>   background-color: green;
#> }

Example: Extract values from CSS in R

The object returned by read_css() is a nested list of name/value pairs.

The top-level name is the CSS Selector (e.g. #main). The value it points to is another named list - property/value pairs e.g. color = blue

To extract a single style from the CSS object, just subset it as you would for any R list

css[['.footer']][['font-weight']]

#> [1] "lighter"

css[['#main']][['background-color']]  # Note the 'important' attribute on this CSS declaration

#> [1] "red"
#> attr(,"important")
#> [1] TRUE

Example: Extract/Convert values

Some tools are included for extracting parsing CSS values into R values e.g.

css_colour_to_hex() will convert rgb() and hsl() strings to R colours. As well as CSS colour names and 3 letter hex colours (e.g. #fab -> #ffaabb)
css_string_as_pixels() has a (naive) go at converting length values to a number of pixels (assuming 96dpi display). This is a wrapper around two other functions:
- css_string_as_css_length() to convert a string to a numeric value, and include the unit as an attribute.
- css_length_as_pixels() to convert a value with a unit attribute to a length in pixels

colour <- css[['.footer']][['border-color']]
colour

#> [1] "rgb(50 100 255)"

cssparser::css_colour_to_hex( colour )

#> [1] "#3264FFFF"

value <- css[['.footer']][['margin-left']]
value

#> [1] "1cm"

cssparser::css_string_as_css_length(value)

#> [1] 1
#> attr(,"unit")
#> [1] "cm"

cssparser::css_string_as_pixels(value)

#> [1] 37.79528

Example: Apply CSS to html

Given css and an html/xml document, cssparser can produce a named list containing the computed style for every element.

The names in this list are the xpaths for each element, and the values are the named list of property/value declarations on this element.

The calculation of the style for each element takes into account:

<tag>, #id and .class selectors
selector combinators like #main > div
CSS inheritance from parent elements

In the computed_styles for the following HTML document, note the following:

The first <div> (with id="main") has xpath = "/html/body/div[1]" has a background-color of red as the !important flag was set in the stylesheet and this overrides the inline style background-color: yellow
The CSS selector .footer > p has correctly applied background-color = "green" to only the second <p> in the document (with xpath = "/html/body/div[2]/p")
The border-related properties on the <div> elements are not evident on the child <p> elements as border properties are not inherited.

html <- xml2::read_html('
<html>
<div id="main" class="thin" style="border: 2px; background-color: yellow;">
  <p>Lorem Ipsum</p>
</div>
<div class="footer">
  <p>Goodbye</p>
</div>

</html>')


computed_styles <- cssparser::css_apply(html, css)
cssparser::css_pretty_print(computed_styles)

#> /html/body/div[2] {
#>   border-color: rgb(50 100 255);
#>   font-weight: lighter;
#>   margin-left: 1cm;
#> }
#> 
#> /html/body/div[2]/p {
#>   font-weight: lighter;
#>   background-color: green;
#> }
#> 
#> /html/body/div[1] {
#>   background-color: red !important;
#>   color: blue;
#>   border: 2px;
#> }
#> 
#> /html {
#> }
#> 
#> /html/body {
#> }
#> 
#> /html/body/div[1]/p {
#>   color: blue;
#> }

Example: Manually merging CSS styles

The following code shows a manual way of combining styles from a number of different sources using style_merge()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# StyleSheet
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
stylesheet <- '
#greg {
  fill: red !important;
  color: blue;
}

.thin {
  border: 1px;
  border-color: hsl(30 50% 40%);
  font-weight: lighter;
}'

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Example HTML
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
html <- xml2::read_html('
<div id="greg" class="thin" style="border: 2px; fill: yellow;">
  Lorem Ipsum
</div>')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Convert stylesheet into rulesets (i.e. R lists indexed by selector)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
css <- read_css(stylesheet)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Manually calculate style for this element by merging the various styles
# which apply to this element based upon the CSS selectors
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
greg_final <- style_merge(
  css[['div']],
  css[[".thin"]],
  css[['#greg']], 
  read_inline_style("border: 2px; fill: yellow;")
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Note: "!important" property carried through.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cssparser::style_pretty_print(greg_final)

#> border: 2px;
#> border-color: hsl(30 50% 40%);
#> font-weight: lighter;
#> fill: red !important;
#> color: blue;

cssparser::css_colour_to_hex(greg_final$`border-color`)

#> [1] "#996633FF"

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing {gozer} add destruction artefacts to R objects

Tue, 28 Sep 2021 23:10:50 +1000

gozer - choose the form of the destructor

gozer allows you to attach a ‘destructor’ artefact (either a string or a function) to an R object.

When the R object is destroyed (i.e. garbage collected) the ‘destructor’ artefact is printed or called.

What’s in the box

gozer() to attach a destructor artefact to an object.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/gozer')

Printing a string as a ‘destructor’ artefact.

library(gozer)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define an object and add a string destruction artefact
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
a <- 'hello'
a <- gozer(a, "I was garbage collected! Goodbye ...")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Destructor is added as object attribute as a NULL external pointer on t
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
a

#> [1] "hello"
#> attr(,"destructor")
#> <pointer: 0x0>
#> attr(,"class")
#> [1] "gozer"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Destroy the object and get the destruction artefact
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rm(a)
invisible(gc())

#> I was garbage collected! Goodbye ...

Calling a function as a ‘destructor’ artefact.

library(gozer)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Funciton to call when object is destroyed. 
# Argument will be an external pointer object which is unusable
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ff <- function(ext_ptr) {
  print("There was definitely a garbage collection event")
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define an object and add a function as a destruction artefact
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
a <- 'hello'
a <- gozer(a, ff)
a

#> [1] "hello"
#> attr(,"destructor")
#> <pointer: 0x0>
#> attr(,"class")
#> [1] "gozer"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Destroy the object and get the destruction artefact
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rm(a)
invisible(gc())

#> [1] "There was definitely a garbage collection event"

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Gozer the Gozerian

New {flexo} vignette - parsing subtitles in srt format

Thu, 16 Sep 2021 23:30:50 +1000

library(flexo)

`flexo`: Simple Lex/Parse Tools in R

{flexo} is a small package containing a lexer (for splitting text into tokens).

The v0.2.6 update of flexo added support for stringi regex options like multiline support, and this vignette is a quick test of this new functionality.

Parsing subtitles in srt format with flexo

The srt subtitle format is a simple representation of subtitles for video which consists of timestamped lines of text.

SRT format example

The first 10 lines of dialogue from “It’s a Wonderful Life” in srt format

srt <- "
1
00:01:25,210 --> 00:01:28,004
I owe everything to George Bailey.

2
00:01:28,422 --> 00:01:30,298
Help him, dear Father.

3
00:01:30,674 --> 00:01:33,718
Joseph, Jesus and Mary,

4
00:01:33,802 --> 00:01:36,429
help my friend Mr. Bailey.

5
00:01:36,889 --> 00:01:39,515
Help my son George tonight.

6
00:01:40,350 --> 00:01:42,226
He never thinks about himself, God.

7
00:01:42,311 --> 00:01:44,061
That's why he's in trouble.

8
00:01:44,146 --> 00:01:45,313
George is a good guy.

9
00:01:46,482 --> 00:01:47,732
Give him a break, God.

10
00:01:47,816 --> 00:01:49,942
I love him, dear Lord.
"

Lex the srt file into tokens

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define the regex for each token
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
srt_regexes <- c(
  time  = "\\d+:\\d+:\\d+,\\d+",
  link  = "\\s*-->\\s*",
  index = "^\\d+$",
  text  = "^.+?$"
)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Collapse the file into a single string
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
srt <- paste(enc2utf8(srt), collapse = "\n")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Split the file by regex, and drop the 'link' between times
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tokens <- lex(srt, multiline = TRUE, srt_regexes)
tokens <- tokens[names(tokens) != 'link']

tokens

#>                                 index                                  time 
#>                                   "1"                        "00:01:25,210" 
#>                                  time                                  text 
#>                        "00:01:28,004"  "I owe everything to George Bailey." 
#>                                 index                                  time 
#>                                   "2"                        "00:01:28,422" 
#>                                  time                                  text 
#>                        "00:01:30,298"              "Help him, dear Father." 
#>                                 index                                  time 
#>                                   "3"                        "00:01:30,674" 
#>                                  time                                  text 
#>                        "00:01:33,718"             "Joseph, Jesus and Mary," 
#>                                 index                                  time 
#>                                   "4"                        "00:01:33,802" 
#>                                  time                                  text 
#>                        "00:01:36,429"          "help my friend Mr. Bailey." 
#>                                 index                                  time 
#>                                   "5"                        "00:01:36,889" 
#>                                  time                                  text 
#>                        "00:01:39,515"         "Help my son George tonight." 
#>                                 index                                  time 
#>                                   "6"                        "00:01:40,350" 
#>                                  time                                  text 
#>                        "00:01:42,226" "He never thinks about himself, God." 
#>                                 index                                  time 
#>                                   "7"                        "00:01:42,311" 
#>                                  time                                  text 
#>                        "00:01:44,061"         "That's why he's in trouble." 
#>                                 index                                  time 
#>                                   "8"                        "00:01:44,146" 
#>                                  time                                  text 
#>                        "00:01:45,313"               "George is a good guy." 
#>                                 index                                  time 
#>                                   "9"                        "00:01:46,482" 
#>                                  time                                  text 
#>                        "00:01:47,732"              "Give him a break, God." 
#>                                 index                                  time 
#>                                  "10"                        "00:01:47,816" 
#>                                  time                                  text 
#>                        "00:01:49,942"              "I love him, dear Lord."

Parse raw tokens into a data.frame

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Merge together runs of text
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rl    <- unclass(rle(names(tokens)))
end   <- cumsum(rl$lengths)[rl$values == 'text']
len   <- rl$lengths[rl$values == 'text']
start <- end - len + 1

text <- mapply(function(start, end) {
  paste(tokens[start:end], collapse = "\n")
}, start, end)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Extract index and time vectors
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
indices <- as.integer(tokens[names(tokens) == 'index'])
times   <- tokens[names(tokens) == 'time']

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Munge into data.frame
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
data.frame(
  index  = indices,
  start  = times[c(T, F)],
  end    = times[c(F, T)],
  text   = text,
  stringsAsFactors = FALSE
)

#>    index        start          end                                text
#> 1      1 00:01:25,210 00:01:28,004  I owe everything to George Bailey.
#> 2      2 00:01:28,422 00:01:30,298              Help him, dear Father.
#> 3      3 00:01:30,674 00:01:33,718             Joseph, Jesus and Mary,
#> 4      4 00:01:33,802 00:01:36,429          help my friend Mr. Bailey.
#> 5      5 00:01:36,889 00:01:39,515         Help my son George tonight.
#> 6      6 00:01:40,350 00:01:42,226 He never thinks about himself, God.
#> 7      7 00:01:42,311 00:01:44,061         That's why he's in trouble.
#> 8      8 00:01:44,146 00:01:45,313               George is a good guy.
#> 9      9 00:01:46,482 00:01:47,732              Give him a break, God.
#> 10    10 00:01:47,816 00:01:49,942              I love him, dear Lord.

Introducing {priorityqueue} - two simple priority queues. One written in R, the other in C

Tue, 14 Sep 2021 20:13:50 +1000

priorityqueue

priorityqueue is a package with two priority queue implementations for R: one written in C, and the other written in plain R.

Both of these are max-priority-queues i.e. “popping” from the queue returns the value with highest priority.

These priority queues support any R object. The priority can be any finite double() value.

What’s in the box

Two priority queue implementations with identical call APIs.

Pure R priority queue:
- rpq_create(), rpq_insert(rpq, obj, priority), rpq_pop(rpq)
C-based priority queue:
- cpq_create(), cpq_insert(cpq, obj, priority), cpq_pop(cpq)

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/priorityqueue')

Example

Priority queues are a data-structure to store objects along with a priority with each object.

When popping a value off the queue, the object with the largest priority is returned.

library(priorityqueue)

rpq <- rpq_create()
rpq_is_empty(rpq)

#> [1] TRUE

rpq_insert(rpq, obj = "#RStats", priority = 2)
rpq_insert(rpq, obj = "hello"  , priority = 3)
rpq_insert(rpq, obj = 2 * 2    , priority = 1)

rpq_length(rpq)

#> [1] 3

# Retrieve the objects from largest priority to smallest
rpq_pop(rpq)

#> [1] "hello"

rpq_pop(rpq)

#> [1] "#RStats"

rpq_pop(rpq)

#> [1] 4

Rationale

I needed a data structure in R which would allow me to insert/pop items based upon a priority value - what is known as a priority queue.

I wrote a quick solution in R that met my basic needs i.e. an environment containing a list of objects and a vector of values, plus some standard functions to manipulate. This code is the basis of the rpq_* functions in this package.

I then wondered how this could be done with C, and as a learning exercise I wrote a minimal priority queue in C which supported R objects. This was tidied to be the C prioirty queue (cpq_*) in this package.

Timing

In general the C implementation is faster and uses less memory than the R implementation (no surprises there).

For larger queues, the C implementation can be ~10x faster and use 1/30th the memory.

This implementation of a priority queue compares favourably with the priority queue included in the {collections} package on CRAN.

Click to show/hide the timing code

r_priority_queue <- function(N) {
  set.seed(1)
  rpq <- rpq_create()
  
  for (i in 1:(N*2)) {
    rpq_insert(rpq, 1, runif(1))
    rpq_insert(rpq, 1, runif(1))
  }
  
  for (i in 1:N) {
    rpq_insert(rpq, 1, runif(1))
    rpq_insert(rpq, 1, runif(1))
    rpq_pop(rpq)
    rpq_pop(rpq)
    rpq_pop(rpq)
  }
}


cpq_priority_queue <- function(N) {
  set.seed(1)
  cpq <- cpq_create()
  
  for (i in 1:(N*2)) {
    cpq_insert(cpq, 1, runif(1))
    cpq_insert(cpq, 1, runif(1))
  }
  
  for (i in 1:N) {
    cpq_insert(cpq, 1, runif(1))
    cpq_insert(cpq, 1, runif(1))
    cpq_pop(cpq)
    cpq_pop(cpq)
    cpq_pop(cpq)
  }
}



collections_priority_queue <- function(N) {
  set.seed(1)
  colq <- collections::priority_queue()
  
  for (i in 1:(N*2)) {
    colq$push(1, runif(1))
    colq$push(1, runif(1))
  }
  
  for (i in 1:N) {
    colq$push(1, runif(1))
    colq$push(1, runif(1))
    colq$pop()
    colq$pop()
    colq$pop()
  }
}


res <- bench::press(
  N = c(10, 100, 1000),
  bench::mark(
    `Plain R priority queue` = r_priority_queue(N), 
    `C priority queue` = cpq_priority_queue(N),
    `collections::priority_queue()` = collections_priority_queue(N)
  )
)

#> Warning: Some expressions had a GC in every iteration; so filtering is disabled.

expression	N	itr/sec	mem_alloc
Plain R priority queue	10	774.412196	408.02KB
C priority queue	10	3443.282577	226.52KB
collections::priority_queue()	10	3271.967561	278.96KB
Plain R priority queue	100	61.281542	7.94MB
C priority queue	100	370.743903	1.48MB
collections::priority_queue()	100	317.896057	1.47MB
Plain R priority queue	1000	1.463592	645.93MB
C priority queue	1000	36.510057	14.73MB
collections::priority_queue()	1000	29.865650	14.71MB

Technical Bits

Plain R priority queue

Implemented as an environment with storage for a list of objects and a vector of priorities.
New objects and their priorities are appended to the list/vector in the environment.
When a value is popped, the maximum priority is found (using whichmax()) and the matching object is returned

C priority queue

A heap-based priority queue.
Creating a cpq creates an ExternalPointer to a cpq_t object which contains the queue and other information all entirely within C.
An R list is attached to this ExternalPointer in C (as a protected item on the pointer). When new R objects are added to the priority queue, they are also added to this list to prevent them from being garbage collected.

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing {typhoid} uint16, fixedpt & numberwang implemented in vctrs

Thu, 09 Sep 2021 19:57:50 +1000

typhoid - non-standard numeric datatypes

typhoid provides implementations of some non-standard datatypes using {vctrs}

What’s in the box

numberwang(x) for creating numeric values which present themselves as words.
uint16(x) for creating 16-bit unsigned integers, where each value is stored as a pair of raw bytes.
fixedpt(x, decimals = 3) for creating 32-bit fixed point numeric values.

Each of the types supports as_<type>() and is_<type>(), as well as standard arithmetic operations (+, * etc) and mathematical functions e.g. abs()

Limitations

These types were created in order to explore the {vctrs} package, and its capabilities for easily creating new types, with minimal effort, along with broad support for standard R features.

These are all pretty naive implementations with ill-defined overflow, and incomplete implementations.

They could be the core of properly useful, robust datatypes - but for now they merely stand as small tutorials on how new types can be defined with the {vctrs} package.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/numberwang')
remotes::install_github('coolbutuseless/typhoid')

The numberwang type is backed by the {numberwang} package which provides functions for converting from numbers to words, and vice versa.

num <- numberwang(42.123)
num

  <typ_numberwang[1]>
  [1] "forty-two point one two three"

num + 5

  <typ_numberwang[1]>
  [1] "forty-seven point one two three"

numberwang(1:3) * 10

  <typ_numberwang[3]>
  [1] "ten"    "twenty" "thirty"

numberwang(1:3) * as_numberwang("twenty seven")

  <typ_numberwang[3]>
  [1] "twenty-seven" "fifty-four"   "eighty-one"

uint16 values are represented internally as a pair of bytes.

Since a uint16 takes up only 16bits, it can only hold integers in the range 0-65535.

This offers space savings compared with R’s standard integer (four bytes), as long as your numbers fit in the given range.

Arithmetic operations are performed modulo 65536.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# uint16 doesn't really behave differently from a small integer
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
uint16(42)

#> <typ_uint16[1]>
#> [1] 42

uint16(c(100, 150)) * 2

#> <typ_uint16[2]>
#> [1] 200 300

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# uint16 uses only half the memory of a regular integer, but has
# a much reduced range as well
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ints <- sample(65535)
lobstr::obj_size(ints)

#> 262,192 B

lobstr::obj_size(uint16(ints))

#> 131,904 B

Fixed point numbers are implemented as integer values and a divisor which is a power of 10. For instance 12.34 is represented as the integer 1234 with a divisor of 100.

Fixed point numbers show as many decimal places as set during initialisation with the fixedpt(x, decimals = 3) call.

When numeric operations are performed on a fixedpt, the result is also a fixed point, with the number of decimals set to the be the maximum of decimal places of the two arguments.

Numbers are only representable as a fixedpt if the unscaled number fits into a normal R integer.

n1 <- fixedpt(1:5, decimals = 3)
n1

#> <typ_fixedpt[5]>
#> [1] 1.000 2.000 3.000 4.000 5.000

n2 <- fixedpt(101:105, decimals = 5)
n2

#> <typ_fixedpt[5]>
#> [1] 101.00000 102.00000 103.00000 104.00000 105.00000

n1 * n2

#> <typ_fixedpt[5]>
#> [1] 101.00000 204.00000 309.00000 416.00000 525.00000

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

{smallfactor} update - store factors in bytes and bits rather than integers

Mon, 06 Sep 2021 19:30:50 +1000

smallfactor - store factors in bytes and bits rather than an `integer`

smallfactor is an experiment to see what trade-offs there might be for storing a factor in bytes or bits instead of an integer.

An R integer is 4-bytes, meaning it could hold a factor with two billion levels, which seems like overkill.

bytefactor targets factors with up to 256 levels.

bitfactor will choose the fewest bits to store a factor for factors with 2 up to 32768 (2^15) levels.

What’s in the box

bytefactor() store factor values in raw bytes rather than an integer.
bitfactor() store factor values as bits within integers - with multiple factors stored in a single integer value. E.g. a factor with 4 levels could be stored as just 2 bits of information, meaning 16 values could be stored in a single R integer (16 * 2 bits = 32 bits = 4 bytes)

Limitations

It seems possible that you could write more methods to make these smaller factors behave similar to regular R factor objects, but this package is not attempting this (yet).

Internally, there’s currently a lot of transferring back-and-forth between these small factors and the standard R factor in order to make use of the printing and subsetting capabilities of the R factor implementation. Much of this back-and-forth could be avoided if effort was expended to do so.

Note: bitfactor uses only 31 bits of a 32-bit integer in order to avoid issues around NA_integer_ representation. This means, for example, that an integer can only hold 15 x 2-bit values. In practice the user is never expected to notice this or care about it.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/smallfactor')

`bytefactor`

small <- bytefactor(c('a', 'b', 'c', 'a', 'd'))
small

#> [bytefactor]
#> [1] a b c a d
#> Levels: a b c d

small[1:3]

#> [bytefactor]
#> [1] a b c
#> Levels: a b c d

`bitfactor`

bitfactor() will choose an appropriate number of bits to store the given number of levels.

In the following example, there are 4 levels, so bitfactor() chooses to store each value in the factor in 2 bits.

tiny <- bitfactor(c('a', 'b', 'c', 'a', 'd'))
tiny

#> [bitfactor] 5 values @ ~2 bits/value = 1 integer(s)
#> [1] a b c a d
#> Levels: a b c d

tiny[1:3]

#> [bitfactor] 3 values @ ~2 bits/value = 1 integer(s)
#> [1] a b c
#> Levels: a b c d

In this next example, there are 100 levels in the factor, so 7 bits are needed to fully store all the levels

tiny <- bitfactor(sample(100, 10), levels=1:100)
tiny

#> [bitfactor] 10 values @ ~7 bits/value = 3 integer(s)
#>  [1] 24 77 87 57 33 21 18 2  11 62
#> 100 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 ... 100

tiny[4:6]

#> [bitfactor] 3 values @ ~7 bits/value = 1 integer(s)
#> [1] 57 33 21
#> 100 Levels: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 ... 100

Storing some DNA in `bytefactor` and `bitfactor` objects.

	character	factor	bytefactor	bitfactor
bits/value	64	32	8	2
total size	8 MB	4 MB	1 MB	270 kB
size reduction		2x	8x	30x

library(smallfactor)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Generate some random DNA
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
character_vector_dna <- sample(c('A', 'T', 'G', 'C'), 1e6, replace = TRUE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a `factor` and a `smallfactor` using the same basic syntax
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
integer_factor <- factor    (character_vector_dna, levels = c('A', 'T', 'G', 'C'))
byte_factor    <- bytefactor(character_vector_dna, levels = c('A', 'T', 'G', 'C'))
bit_factor     <- bitfactor (character_vector_dna, levels = c('A', 'T', 'G', 'C'))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# `smallfactor` is approx 1/4 the size of the regular factor
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
lobstr::obj_size(character_vector_dna)

#> 8,000,272 B

lobstr::obj_size(integer_factor)

#> 4,000,688 B

lobstr::obj_size(byte_factor)

#> 1,000,696 B

lobstr::obj_size(bit_factor)

#> 267,704 B

Similar projects

{lofi}

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing {numberwang} - numbers to words and vice versa)

Mon, 30 Aug 2021 20:09:50 +1000

numberwang

numberwang will convert floating point numbers (and integers) to their word representations, and vice versa.

The key differentiator of this package, compared to {nombre}, is that it supports decimal representations by listing individual decimal digits.

See below for a comparison with {nombre}, {english}, {spanish} and {xfun}.

What’s in the box

num_to_words(num, decimals = 3) converts numeric vectors to character vectors
words_to_num(words) converts character vectors to numeric vectors

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/numberwang')

That’s `numberwang`

library(numberwang)

c(12, pi, exp(10))

#> [1]    12.000000     3.141593 22026.465795

num_to_words(c(12, pi, exp(10)))

#> [1] "twelve"                                               
#> [2] "three point one four two"                             
#> [3] "twenty-two thousand and twenty-six point four six six"

words_to_num(c(
  'negative fifteen point seven',
  "twenty-three point seven zero one",
  "ten million, two thousand and forty two"
))

#> [1]      -15.700       23.701 10002042.000

Limitations

Floating point representation isn’t exact, which means that for very large numbers or very small numbers, and for lots of numbers inbetween, all the digits after the first few must often be taken with a grain of salt.
E.g. formatC(0.3-0.2, format = 'f', digits = 20) = 0.09999999999999997780
E.g. 1e25 should just be a 1 followed by zeros, but in floating point representation we get: formatC(1e25, format = 'f', digits = 0) = 10000000000000000905969664
The {english} and {nombre} packages will warn you about precision loss like this, but {numberwang} won’t.

Feature comparison

	numberwang	nombre	english	spanish	xfun
function	num_to_words	nom_card	english	to_words	n2w
working range	double()	double()	+/- 2^90	[0,999]	+/- 1e15
decimals	Yes	as fractions	No	No	No
spanish	No	No	No	Yes	No
words-to-numbers	words_to_num	nom_uncard (ints only)	No	No	No

Just for fun - Let’s rotate the board!

exp(300)

#> [1] 1.942426e+130

formatC(
  exp(300), format = 'f', digits = 0
)

#> [1] "19424263952412558251527551342607068708348876681949259689720520473778975990853476787505520791207218561168735878224980403355291484160"

num_to_words(exp(300))

  nineteen duoquadragintillion, four hundred and twenty-four
  unquadragintillion, two hundred and sixty-three quadragintillion, nine
  hundred and fifty-two novemtrigintillion, four hundred and twelve
  octatrigintillion, five hundred and fifty-eight septentrigintillion,
  two hundred and fifty-one sextrigintillion, five hundred and
  twenty-seven quintrigintillion, five hundred and fifty-one
  quattuortrigintillion, three hundred and forty-two tretrigintillion,
  six hundred and seven duotrigintillion, sixty-eight untrigintillion,
  seven hundred and eight trigintillion, three hundred and forty-eight
  novemvigintillion, eight hundred and seventy-six octavigintillion, six
  hundred and eighty-one septenvigintillion, nine hundred and forty-nine
  sexvigintillion, two hundred and fifty-nine quinvigintillion, six
  hundred and eighty-nine quattuorvigintillion, seven hundred and twenty
  trevigintillion, five hundred and twenty duovigintillion, four hundred
  and seventy-three unvigintillion, seven hundred and seventy-eight
  vigintillion, nine hundred and seventy-five novemdecillion, nine
  hundred and ninety octadecillion, eight hundred and fifty-three
  septendecillion, four hundred and seventy-six sexdecillion, seven
  hundred and eighty-seven quindecillion, five hundred and five
  quattuordecillion, five hundred and twenty tredecillion, seven hundred
  and ninety-one duodecillion, two hundred and seven undecillion, two
  hundred and eighteen decillion, five hundred and sixty-one nonillion,
  one hundred and sixty-eight octillion, seven hundred and thirty-five
  septillion, eight hundred and seventy-eight sextillion, two hundred and
  twenty-four quintillion, nine hundred and eighty quadrillion, four
  hundred and three trillion, three hundred and fifty-five billion, two
  hundred and ninety-one million, four hundred and eighty-four thousand,
  one hundred and sixty

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing {smallfactor} - a space-saving factor backed by a raw vector (instead of integers)

Fri, 27 Aug 2021 15:09:50 +1000

smallfactor - store factors in `raw` rather than `integer`

smallfactor is an experiment to see what tradeoffs there might be for storing a factor in a raw byte instead of an integer.

Since an R raw value is only a single byte, but an integer is 4 bytes, there are space saving for large factors if stored in raw vector - as long as the number of levels is less than 256.

What’s in the box

smallfactor() - similar to factor(), but creates an object backed by raw bytes rather than an integer.

Limitations

This package includes creating an object of the smallfactor class, and includes a few expected methods for common usage e.g. as.character.smallfactor(), as.data.frame.smallfactor().

It seems possible that you could write more methods to make smallfactor behaviour almost identical to regular factor behaviour, but this package is not attempting this (yet).

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/smallfactor')

Example simple usage

small <- smallfactor(c('a', 'b', 'c', 'a', 'd'))
small

#> [smallfactor]
#> [1] a b c a d
#> Levels: a b c d

small[1:3]

#> [smallfactor]
#> [1] a b c
#> Levels: a b c d

df <- data.frame(value = small, y = 1:5)
df

#>   value y
#> 1     a 1
#> 2     b 2
#> 3     c 3
#> 4     a 4
#> 5     d 5

library(dplyr)
df %>%
  filter(value < 3)

#>   value y
#> 1     a 1
#> 2     b 2
#> 3     a 4

Example - storing some DNA in 1/4 the space of a regular factor

library(smallfactor)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Generate some random DNA
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dna <- sample(c('A', 'T', 'G', 'C'), 1e6, replace = TRUE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a `factor` and a `smallfactor` using the same basic syntax
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small   <- smallfactor(dna, levels = c('A', 'T', 'G', 'C'))
regular <- factor     (dna, levels = c('A', 'T', 'G', 'C'))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# `smallfactor` is approx 1/4 the size of the regular factor
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
lobstr::obj_size(dna)

#> 8,000,272 B

lobstr::obj_size(regular)

#> 4,000,688 B

lobstr::obj_size(small)

#> 1,000,696 B

Fast(?) cubic beziers at variable resolution

Wed, 11 Aug 2021 22:09:50 +1000

I wanted to calculate some points along cubic bezier curves
Current R grid bezier implementation is not a real bezier! According to docs for grid::bezierGrob(): “The curve is currently drawn using an approximation based on X-splines.”
Code below is the fastest thing I could come up with (I’m only 80% sure it’s correct)
It vectorized implemntation of the explicit form of the curve as explained on Wikipedia
I need something that can quickly change between low-complexity and high-complexity approximations to the curve by changing the number of line segments generated
Speed-ups welcomed

Code

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Pre-calculate sets of control-point weights for each for a range of 
# different desired points in the output
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
bf3s <- lapply(1:100, function(N) {
  t  <- seq.int(0, 1, length.out = N)

  matrix(c(
    1 * t^0 * (1 - t)^3,
    3 * t^1 * (1 - t)^2,
    3 * t^2 * (1 - t)^1,
    1 * t^3 * (1 - t)^0
  ), ncol = 4
  )
})


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Convert cubic  beziers to data.frame of coordinates along curve
#'
#' @param x,y coords of control points
#' @param N Number of output points
#'
#' @return list of coords
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
bezier3 <- function(x, y, N = 5) {
  stopifnot(length(x)== 4, length(y) == 4)
  list(
    x = rowSums(bf3s[[N]] * matrix(x, nrow = N, ncol = 4, byrow = TRUE)),
    y = rowSums(bf3s[[N]] * matrix(y, nrow = N, ncol = 4, byrow = TRUE))
  )
}

Demo

library(grid)

# Random control points
set.seed(1)
xcp <- runif(4)
ycp <- runif(4)

# Generate low and high complexity approximations
pt_lo <- bezier3(xcp, ycp,  4)
pt_hi <- bezier3(xcp, ycp, 40)

# Draw my approximations
grid.lines(pt_lo$x, pt_lo$y, gp = gpar(col = 'red' ))
grid.lines(pt_hi$x, pt_hi$y, gp = gpar(col = 'blue'))

Comparison to `grid::grid.bezier()`

# Overlay the grid version of this bezier 
grid.lines(pt_lo$x, pt_lo$y, gp = gpar(col = 'red' ))
grid.lines(pt_hi$x, pt_hi$y, gp = gpar(col = 'blue'))
grid.bezier(xcp, ycp)

Benchmark

About 30,000 beziers/second

expression	N	min	median	itr/sec
bezier3(xcp, ycp, N)	5	22.4µs	26.9µs	35103.10
bezier3(xcp, ycp, N)	10	22.3µs	27.5µs	31933.63
bezier3(xcp, ycp, N)	20	22.7µs	27.8µs	33358.24
bezier3(xcp, ycp, N)	50	24µs	30.5µs	30847.32
bezier3(xcp, ycp, N)	100	27µs	33µs	27591.29

Introducing {colourmebad} - find pronounceable colours close to reference colours

Fri, 30 Jul 2021 21:09:50 +1000

colourmebad

colourmebad provides some tools for finding pronounceable approximations to hex colours.

These tools will be handy if you ever have to memorise a set of hex colours, or would like to impress people with your recall of a good colour palette as a party trick. In summary - no one needs these tools.

This package was inspired by mdsumner’s hexwords package.

What’s in the box

find_best_colour_match() For each of the reference colours supplied, this function will find the best match amongst a list of candidate colours. Where ‘best match’ is defined as the shortest euclidean distance in Lab colourspace.
colours_to_words() and words_to_colours() to use some digit/letter substitutions and convert a 6-letter word into a hex colour and vice versa
show_palette() to display a single set of colours
compare_palettes() to show 2 palettes side-by-side
Included colour lists
- colour_words hex colours which are directly readable as dictionary words
- colour_words_with_substitutions hex colours which can be converted to dictionary words if certain digit/letter substitutions are performed e.g. replay all letter-o with number-0 etc.
- nonsense_words hex colours which could almost be read as a pronounceable word but with a very high probability of being nonsense/gibberish. e.g. #elesta

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/colourmebad')

Hex colours which are dictionary words

library(colourmebad)

colour_words

#>  [1] "#accede" "#afaced" "#bacaba" "#baccae" "#baffed" "#beaded" "#bedaff"
#>  [8] "#bedded" "#bedead" "#bedeaf" "#beebee" "#beefed" "#cabbed" "#cadded"
#> [15] "#dabbed" "#daffed" "#decade" "#decede" "#deeded" "#deface" "#defade"
#> [22] "#efface" "#facade" "#feeded"

colourmebad::colours_to_words(colour_words)

#>  [1] "accede" "afaced" "bacaba" "baccae" "baffed" "beaded" "bedaff" "bedded"
#>  [9] "bedead" "bedeaf" "beebee" "beefed" "cabbed" "cadded" "dabbed" "daffed"
#> [17] "decade" "decede" "deeded" "deface" "defade" "efface" "facade" "feeded"

colourmebad::show_palette(colour_words)

Hex colours which are dictionary words if you allow for some digit-letter subsitutions

In the great tradition of “hacker speak” and customised number plates for cars, digits can be used in place of letters if they look similar enough.

The default substitutions this package employs:

0 = o
1 = l (lower case L)
2 = z
5 = s
7 = t
9 = g

cols <- sample(colour_words_with_substitutions, 25)
cols

#>  [1] "#7ea51e" "#9e0da1" "#ba1a7a" "#5099ed" "#de17a5" "#cac7a1" "#b017e1"
#>  [8] "#fe0da1" "#ca77ed" "#add1e5" "#9051e7" "#5ca775" "#d0d1e7" "#5ca1e5"
#> [15] "#c0991e" "#5701e5" "#0b1a7a" "#5add1e" "#501ace" "#ca57e5" "#2abe7a"
#> [22] "#e570c5" "#bab005" "#effe7e" "#e771ed"

colourmebad::colours_to_words(cols)

#>  [1] "teasle" "geodal" "balata" "sogged" "deltas" "cactal" "boltel" "feodal"
#>  [9] "catted" "addles" "goslet" "scatts" "dodlet" "scales" "coggle" "stoles"
#> [17] "oblata" "saddle" "solace" "castes" "zabeta" "estocs" "baboos" "effete"
#> [25] "ettled"

colourmebad::show_palette(cols)

Hex colours which are probably nonsense words but may be pronounceable

cols <- sample(nonsense_words, 25)
cols

#>  [1] "#9e1ae7" "#fa15e5" "#5e7a75" "#91e052" "#b1009b" "#ce7e77" "#09090a"
#>  [8] "#a91e17" "#ede91a" "#75a570" "#77e75e" "#17e7ca" "#0021a7" "#d00d1e"
#> [15] "#1a091a" "#1ee755" "#cac1a7" "#57a7ed" "#05707a" "#07ae15" "#027ee2"
#> [22] "#05c1a5" "#7e0d01" "#51eac1" "#7ee570"

colourmebad::colours_to_words(cols)

#>  [1] "gelaet" "falses" "setats" "gleosz" "bloogb" "cetett" "ogogoa" "aglelt"
#>  [9] "edegla" "tsasto" "ttetse" "ltetca" "oozlat" "doodle" "laogla" "leetss"
#> [17] "caclat" "stated" "ostota" "otaels" "ozteez" "osclas" "teodol" "sleacl"
#> [25] "teesto"

colourmebad::show_palette(cols)

Creating a pronounceable palette similar to a reference palette

ref <- RColorBrewer::brewer.pal(8, 'Dark2')

colourmebad::show_palette(ref, labels = ref, title = "Reference Palette")

pronounceable <- colourmebad::find_best_colour_match(ref, colour_words_with_substitutions)
colourmebad::compare_palettes(ref, pronounceable, "ColorBrewer Dark2", "Words with digit/letter substitutions")

Creating a pronounceable nonsense palette similar to a reference palette

pronounceable <- colourmebad::find_best_colour_match(ref, nonsense_words)
colourmebad::compare_palettes(ref, pronounceable, "ColorBrewer Dark2", "Nonsense words")

Creating a pronounceable Spanish palette similar to a reference palette

# http://ftp.icm.edu.pl/packages/wordlists/spanish/
spanish_words_with_substitutions <- system('grep -i -E "^[abcdeflsotgz]{6}$" ./working/spanish.txt', intern = TRUE)
cols <- colourmebad::words_to_colours(spanish_words_with_substitutions)
pronounceable_spanish <- colourmebad::find_best_colour_match(ref, cols)
colourmebad::compare_palettes(ref, pronounceable_spanish, "ColorBrewer Dark2", "Spanish words")

Introducing {ggqr} - A geom for QR codes in ggplot2

Tue, 27 Jul 2021 21:22:50 +1000

ggqr

ggqr provides geom_qr() for inserting QR Codes into a plot.

The core QR functionality is provided by Bob Rudis’s qrencoder package.

What’s in the box

geom_qr() to add QR codes to a plot
grGrob() to create a QR grob

Future Possibilities?

Add automatic label positioning to avoid overlap of codes

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/ggqr')

Example

library(ggplot2)
library(ggqr)

plot_df       <- head(mtcars)
plot_df$car   <- paste0("https://duckduckgo.com/?q=", rownames(plot_df))
plot_df$hjust <- c(-0.1, 1.1, 1.1, -0.1,   0,   0)
plot_df$vjust <- c( 1.1, 0.0, 0.0, -0.1, 1.1, 1.1)

ggplot(plot_df) +
  geom_qr(
    aes(
      x     = mpg, 
      y     = wt, 
      label = car, 
      hjust = I(hjust), 
      vjust = I(vjust), 
      col   = as.factor(cyl)
    ), 
    size = 0.8
  ) +
  geom_point(aes(mpg, wt), size = 3) +
  theme_bw() + 
  theme(legend.position = 'bottom') +
  labs(title = "ggqr::geom_qr() - QR codes with search links to car names")

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing {bdftools} - tools for bitmap fonts in R

Mon, 26 Jul 2021 21:02:50 +1000

bdftools

bdftools provides some tools for reading, manipulating and outputting BDF bitmap fonts.

ToDo

Todo: print header info when printing font
- Number of characters, width, height, bbox etc

What’s in the box

read_bdf(filename) reads a BDF pixel font file into an R representation i.e. an object of class bdf
print.bdf() prints meta information and a font sample.
bdf_create_df(bdf, text) Create a data.frame of points for the given string
bdf_create_mat(bdf, text) Create a matrix representation for the given string
bdfGrob(bdf, text, ...) create a simple grob representation of the given string using squares for pixels
geom_text_bdf() renders text in a bitmap font - simlar interface to ggplot2::geom_text()
as.data.frame.bdf(bdf) converts the full bdf font into a rectangular data.frame of all characters and their (x, y) coordinates.
read_bdf_builtin() to read in a font included with this package:
- Cozette License: MIT. See LICENSE-cozette
- Creep2 License: MIT. See LICENSE-creep2
- Spleen License: BSD 2-clause. See LICENSE-spleen

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/bdftools')

Example: Loading and displaying a BDF bitmap font.

library(grid)
library(ggplot2)
library(bdftools)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Load a BDF font
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fontfile <- system.file("spleen-5x8.bdf", package = "bdftools", mustWork = TRUE)
myfont <- read_bdf(fontfile)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# By default, printing a font will print some header info, and a text 
# sample rendered in that font in the console
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
myfont

size=8, bbox=5, pixel_size=8, font_descent=0, font_ascent=-1, default_char=8, line_height=1, bitmap=7, size=32, bbox=8, pixel_size= 

                  #       #                      
#  #              #       #                      
#  #  ##  ###   ###  ###  #    ##  #  #  ###  ###
####    # #  # #  # #  #  #   #  # #  # #  # #   
#  #  ### #  # #  # #  #  #   #  # #  # ####  ## 
#  # #  # #  # #  #  ##   #   #  #  ##  #       #
#  #  ### #  #  ###    #   ##  ##   ##   ### ### 
                    ###

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Generate some sample text in the console
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
bdf_print_sample(myfont, "Hello RStats", wrap = FALSE)

           #    #                        #         #       
#  #       #    #             ###   ###  #         #       
#  #  ###  #    #    ##       #  # #    ###   ##  ###   ###
#### #  #  #    #   #  #      #  #  ##   #      #  #   #   
#  # ####  #    #   #  #      ###     #  #    ###  #    ## 
#  # #     #    #   #  #      #  #    #  #   #  #  #      #
#  #  ###   ##   ##  ##       #  # ###    ##  ###   ## ###

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Generate a graphics grob and draw it
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grob <- bdfGrob(myfont, "Hello\nRStats", size = 10, shrink = 0.8, fill = 'lightblue', col = 'blue')
grid.newpage(); grid.draw(grob)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# View the entire font as a data.frame of coordiantes
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
as.data.frame(myfont)

# A tibble: 2,385 x 10
   encoding desc    dwidth     x     y  size pixel_size font_ascent font_descent
 *    <int> <chr>    <int> <dbl> <dbl> <int>      <int>       <int>        <int>
 1       32 SPACE        5    NA    NA     8          8           7            1
 2       33 EXCLAM…      5     3     7     8          8           7            1
 3       33 EXCLAM…      5     3     6     8          8           7            1
 4       33 EXCLAM…      5     3     5     8          8           7            1
 5       33 EXCLAM…      5     3     4     8          8           7            1
 6       33 EXCLAM…      5     3     3     8          8           7            1
 7       33 EXCLAM…      5     3     1     8          8           7            1
 8       34 QUOTAT…      5     4     7     8          8           7            1
 9       34 QUOTAT…      5     2     7     8          8           7            1
10       34 QUOTAT…      5     4     6     8          8           7            1
# … with 2,375 more rows, and 1 more variable: line_height <int>

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# View the coordinates of a string rendered in this font
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
bdf_create_df(myfont, "abc")

# A tibble: 34 x 3
       x     y   idx
   <dbl> <dbl> <int>
 1     3     5     1
 2     2     5     1
 3     4     4     1
 4     4     3     1
 5     3     3     1
 6     2     3     1
 7     4     2     1
 8     1     2     1
 9     4     1     1
10     3     1     1
# … with 24 more rows

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# View the coordinates of a string rendered in this font
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
bdf_create_mat(myfont, "abc")

     [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12] [,13] [,14]
[1,]    0    0    0    0    0    1    0    0    0     0     0     0     0     0
[2,]    0    0    0    0    0    1    0    0    0     0     0     0     0     0
[3,]    0    1    1    0    0    1    1    1    0     0     0     1     1     1
[4,]    0    0    0    1    0    1    0    0    1     0     1     0     0     0
[5,]    0    1    1    1    0    1    0    0    1     0     1     0     0     0
[6,]    1    0    0    1    0    1    0    0    1     0     1     0     0     0
[7,]    0    1    1    1    0    1    1    1    0     0     0     1     1     1

An example of a larger font

myfont <- bdftools::read_bdf_builtin("spleen-16x32.bdf")
bdf_print_sample(myfont, "Frak")

    ##########                                     ##         
   ###########                                     ##         
  ###                                              ##         
  ##                                               ##         
  ##                                               ##         
  ##                                               ##         
  ##                ##########     #########       ##     ##  
  ##               ###########     ##########      ##    ###  
  ##              ###       ##             ###     ##   ###   
  #########       ##        ##              ##     ##  ###    
  #########       ##                        ##     ## ###     
  ##              ##                ##########     #####      
  ##              ##               ###########     #####      
  ##              ##              ###       ##     ## ###     
  ##              ##              ##        ##     ##  ###    
  ##              ##              ##        ##     ##   ###   
  ##              ##              ##        ##     ##    ###  
  ##              ##              ###       ##     ##     ### 
  ##              ##               ###########     ##      ###
  ##              ##                ##########     ##       ##

ggplot2 example with `geom_text_bdf()`

geom_text_bdf() works very similar to geom_text() but text is rendered from a bitmap font as a collection of large square pixels. Key things to note:

Can set both an outline colour and a fill
shrink argument determines the size of the square pixel. shrink = 1 is the default. shrink = 0.9 will make the square pixels smaller and not touching each other.

library(ggplot2)
library(bdftools)

fontfile <- system.file("spleen-5x8.bdf", package = "bdftools", mustWork = TRUE)

plot_df <- head(mtcars)
plot_df$car <- rownames(plot_df)
plot_df$cyl <- as.factor(plot_df$cyl)

ggplot(plot_df, aes(mpg, wt)) + 
  geom_point(col = 'red') + 
  geom_text_bdf(
    aes(mpg, wt, label=car, fill = cyl), 
    col          = NA, 
    linewidth    = 0.5,
    bdf_filename = fontfile, 
    shrink       = 1,
    size         = 9,
    hjust        = -0.1
  ) + 
  theme_bw() + 
  scale_fill_brewer(palette = 'Dark2') + 
  labs(title = "geom_text_bdf() - bitmap font rendering in ggplot2")

Font sample sheet

An example of how the data.frame representation of the font can be plotted in ggplot2.

library(ggplot2)
library(bdftools)

myfont <- read_bdf_builtin("cozette.bdf")

plot_df <- as.data.frame(myfont)
plot_df <- plot_df[plot_df$encoding >= 65 & plot_df$encoding <= 124,]

ggplot(plot_df) +
  geom_tile(aes(x, y), width=0.9, height = 0.9, na.rm = TRUE) +
  facet_wrap(~encoding + desc, ncol = 12)+
  theme_void(10) +
  coord_equal()

Package Header

How the header for this page was created.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Choose some fonts
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
font1 <- bdftools::read_bdf_builtin("spleen-16x32.bdf")
font2 <- bdftools::read_bdf_builtin("spleen-5x8.bdf")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Main header
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
txt1 <- bdfGrob(
  font1, "bdftools", 
  lwd    = 0.5,
  fill   = '#3D428B',
  col    = 'darkblue',
  size   = 8, 
  shrink = 0.8
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Subtitle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
txt2 <- bdfGrob(
  font2, "bitmap fonts in R", 
  lwd    = 0.5,
  col    = 'darkblue',
  size   = 11, 
  shrink = 0.8,
  fill   = viridisLite::inferno(151),
  y      = unit(0.5, 'npc') - unit(50, 'mm')
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot it
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage(); 
grid.draw(txt1)
grid.draw(txt2)

BDF Bitmap Font Resources

Fonts
- Tom Thumb tiny font (License: Dual licensed CC0 or CC-BY 3.0 license.)
- github repo of lots of fonts (License: Various/unknown)
- unifont a BDF font with glyphs for every printable codepoint from U+0000 to U+FFFF. (License: Dual licensed SIL Open Font License (OFL) version 1.1 and the GNU GPL 2+ with the GNU font embedding exception)
- X11 fonts (License: Public Domain)
BDF Font Specification
- BDF on Wikipedia
- BDF Specification Document (Adobe)

Introducing {facetious} - alternate facets for ggplot2

Tue, 20 Jul 2021 19:52:50 +1000

facetious

facetious is home to some alternate facetting options for ggplot2.

What’s in the box

facet_wrap_strict()
- respects nrow, ncol and inserts empty grobs to keep the resultant plot at the given size
- Otherwise works like ggplot2::facet_wrap()
facet_grid_blank()
- When a factor level doesn’t exist, this facetting approach will insert a totally empty object, instead of just an empty plot
- Otherwise works like ggplot2::facet_grid()

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/facetious')

`facet_wrap_strict`

library(ggplot2)
library(patchwork)
library(facetious)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Standard ggplot2 facet_wrap()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot_facet_wrap <- ggplot(mtcars) +
  geom_point(aes(mpg, wt)) + 
  facet_wrap(~cyl, nrow = 3, ncol = 2) + 
  labs(title = "facet_wrap(... nrow=3, ncol=2)")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# facetious::facet_wrap_strict
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
facetious_facet_wrap_strict <- ggplot(mtcars) +
  geom_point(aes(mpg, wt)) + 
  facet_wrap_strict(~cyl, nrow = 3, ncol = 2) + 
  labs(title = "facet_wrap_strict(... nrow=3, ncol=2)")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use 'patchwork' to stitch plots side-by-side
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot_facet_wrap + facetious_facet_wrap_strict

`facet_grid_blank`

library(dplyr)
library(ggplot2)
library(patchwork)
library(facetious)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Make some data with some empty factors
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
plot_df <- mtcars %>%
  mutate(
    cyl = as.factor(cyl),
    am = as.factor(am)
  ) %>%
  filter(!(cyl == 4 & am == 1)) %>%
  filter(!(cyl == 8 & am == 0))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Standard ggplot facet_grid()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot_facet_grid <- ggplot(plot_df) +
  geom_point(aes(mpg, wt)) +
  facet_grid(rows = vars(cyl), cols = vars(am), drop = FALSE,
             labeller = label_both) +
  labs(title = "ggplot2::facet_grid()")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# facetious::facet_grid_blank()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
facetious_facet_grid_blank <- ggplot(plot_df) +
  geom_point(aes(mpg, wt)) +
  facet_grid_blank(rows = vars(cyl), cols = vars(am), drop = FALSE, 
                   labeller = label_both) +
  labs(title = "facetious::facet_grid_blank()")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use 'patchwork' to stitch plots side-by-side
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot_facet_grid + facetious_facet_grid_blank

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing {ingrid} - alternate tools for grab creation, manipulation and output

Thu, 15 Jul 2021 19:21:50 +1000

ingrid

ingrid provides some tools that I find useful for creating/manipulating grid/grob objects interactively in the console.

The name ingrid stands for INteractive GRID

The key benefits I get from ingrid:

verbose output of grobs, gTrees and polyclipgrobs, with much more output than their default print methods from {grid}
a suite of grob creation functions with inline gpar parameter specification.
default.units can be set globally to whatever the user wants, but default to ‘mm’
a consistent set of grob combination functions (e.g. intersection, minus) that work across single grobs, gTrees and polyclipgrobs

Vignettes

What’s in the box (Details, details, details)

	grid	ingrid
grob creation	circleGrob(), rectGrob(), etc	circle_grob(), rect_grob(), etc
default.units	‘npc’	getOption(‘ingrid.default.units’, ‘mm’)
unit creation	unit(10, ‘mm’)	.mm(10), .npc(), .points() etc
gpar creation	gpar(fill = ‘red’)	gp(fill = ‘red’) Has named arguments to support autocompletion.
pattern creation	pattern() default extend = ‘pad’	pattern_creation() default extend = ‘repeat’
grob combination	gridGeometry::polyclipgrob()	grob_stack(), grob_intersect(), grob_union(), grob_minus(), grob_xor() supporting grobs, gTrees, polyclipgrobs
print()	print.grob() is terse	verbose printing print.grob(), print.gTree(), print.polyclipgrob()
enable verbose printing		register_verbose_printing(), deregister_verbose_printing()
grob coord transforms		grob_translate(), grob_rotate()
viewport updates		vp_translate(), vp_rotate(), vp_setmask(), vp_setclip()

Click here to reveal more details on what’s included

grob_circle() etc. Analoges for the the grob creation functions in the grid package, but with a slight change in the argument defaults:
- default.units are now ‘mm’ instead of ‘npc’
- the gp and vp objects are both created as fully realised structures, and no longer left as NULL if no values are given. This makes manipulation of grob objects a bit easier after they’ve been created.
- location coordinates (e.g. x, y) are offset from the centre of the viewport by default. Set centred = FALSE to disable this behaviour.
Set of functions for combining vanilla grobs, polyclipgrobs and gTree objects. These functions are mostly extensions of gridGeometry::polyclipgrob() which extends the operations to recurse into gTree and polyclipgrob structures to affect all child objects:
- grob_stack() for simple combination of shapes
- grob_intersect() for shape intersection
- grob_union() for shape union
- grob_minus() for shape subtraction
- grob_xor() for shape combination thruogh use of ‘exclusive or’
Functions for creating units quickly e.g .mm(x) instead of units(x, 'mm')
Verbose printing of vanilla grob, gTree and polyclipgrob objects
Structured printing of the grid pattern objects available in R4.1.0
Simple grob coordinate transformations:
- grob_translate()
- grob_rotate()
Simple viewport transformations:
- vp_translate()
- vp_rotate()
gp() is a wrapper around grid::gpar() which is more friendly for IDEs which support auto-complete.
Some helpers for patterns:
- S3 print methods with more structured output than grid’s default
- pattern_create() is a wrapper around grid::pattern() where:
  - extend = 'repeat' is the default (instead of ‘pad’)
  - default.units are in ‘mm’ (instead of ‘npc’)
  - location coordinates (x, y) are offset from the centre of the viewport by default. Set centred = FALSE to disable this behaviour.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/ingrid')

Example - verbose grob output

In the code below, circle is created with {grid} and circle2 is created with {ingrid}.

There aren’t any major differences in how this creation works, but look for:

default units for ingrid::circle_grob are ‘mm’
gpar parameters are given inline with the grob call (although it is also possible to pass in a gp argument)
by calling ingrid::register_verbose_printing() the output for circle2 gives much more detail than the default printing.

library(grid)
library(ingrid)

Creating a blue circle in `{grid}`

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Using 'grid'
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
circle1 <- circleGrob(r = unit(20, 'mm'), gp = gpar(fill = 'lightblue'))
circle1

#> circle[GRID.circle.1]

grid.newpage()
grid.draw(circle1)

Creating a blue circle in `{ingrid}`

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Using 'ingrid' where default units are 'mm'
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
circle2 <- circle_grob(20, fill = 'lightblue')
circle2

#> circle[GRID.circle.2]

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Enable verbose printing of grobs 
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ingrid::register_verbose_printing()
circle2

#> circle [GRID.circle.2]
#>   x=c(sum(0mm, 0.5npc)), y=c(sum(0mm, 0.5npc)), r=c(20mm)
#>   gp: 
#>     fill: lightblue
#>   vp: [GRID.VP.1] default

grid.newpage()
grid.draw(circle2)

Creating and combining grobs

library(grid)
library(ingrid)
register_verbose_printing()


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create 4 circles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c1 <- circle_grob(r = 20, fill = 'red', alpha = 0.3)
grid.newpage(); grid.draw(c1);

c2 <- circle_grob(r = 33, x = 25, fill = 'blue', alpha = 0.3)
grid.newpage(); grid.draw(c2);

c3 <- circle_grob(r = 28, x = -19, y = -20, fill = 'lightblue', col = 'transparent', alpha = 0.3)
grid.newpage(); grid.draw(c3);

c4 <- circle_grob(r = 2, x = -13, y= 4, fill='black', col='white')
grid.newpage(); grid.draw(c4);

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Stack some of the circles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
i1 <- grob_stack(c1, c2, c4)
grid.newpage(); grid.draw(i1);

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Visualise how the 4th circle overlaps
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage();
grid.draw(i1)
grid.draw(c3)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Keep just the intersection of the stack of 3 circls and the 4th circle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
wug <- ingrid::grob_intersect(i1, c3)
grid.newpage(); grid.draw(wug);

logo for `ingrid`

library(grid)
library(ingrid)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Parameters for a hex
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
r     <- 100
theta <- seq(30, 360, 60) * pi/180 
x     <- r * cos(theta)
y     <- r * sin(theta)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# a hex polygon
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
hex <- polygon_grob(x, y, fill = 'black')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create an image maskeed by the hex
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
jpg <- jpeg::readJPEG("./man/figures/ingrid.jpg")
image <- raster_grob(
  image  = jpg, 
  x      = .mm(-5),
  y      = .mm(-25),
  width  = .mm(2 * 1.0 * r), 
  height = .mm(3 * 1.0 * r),
  mask   = hex
)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Position text
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
text <- text_grob(
  label      = 'ingrid',
  x          =  0.25 * r,
  y          = -0.75 * r, 
  rot        = 30,
  just       = 0,
  col        = 'white', 
  fontfamily = 'courier',
  cex        = 4
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw the objects
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid::grid.newpage()
grid::grid.draw(image)
grid::grid.draw(text)

Future

Include grobs from other sources:
- ellipseGrob, ngonGrob from gridExtra

Introducing 'sars' - proof-of-concept for running 'SAS' DATA and PROC SQL statements in R

Wed, 14 Jul 2021 19:21:50 +1000

sars

sars is an totally useless, very experimental, proof-of-concept, oh-my-god-why package for executing sas DATA and PROC SQL statements in R.

What’s in the box

sars::run(code) to run some code
- as long as it is only DATA and PROC SQL statements
- and even then, not much of either of those statements is really supported either.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/sars')

Example

library(sars)

sars::run("
  data mytable;
    set 'mtcars';
  run;
  
  
  proc sql;
    SELECT cyl, sum(mpg) as total  FROM mytable
    WHERE am = 1
    GROUP BY cyl
    ORDER BY cyl;
  quit;"
)

##   cyl total
## 1   4 224.6
## 2   6  61.7
## 3   8  30.8

R v4.1.0 - {grid} graphics new feature - patterns (part 3)

Sat, 03 Jul 2021 19:20:10 +1000

Introduciton

As of R 4.1.0 there is built-in support for patterns in grid graphics. There are 3 types of pattern:

grid::linearGradient() for linear colour gradients
grid::radialGradient() for radial colour gradients
grid::pattern() repetition of any combination of graphic objects (grobs)

This quick post summarises a few more things which can be done with patterns:

A mask with an alpha channel can be applied to the pattern to create some softer effects
Patterns can be defined using:
- absolute units (like ‘mm’), in which case their rendered size does not change
- relative units (like ‘npc’) mean that the size and shape of the pattern renders differently depending on the viewport

Reading list:

14 July 2020 Catching up with R Graphics Gradients, Patterns, Clipping Paths, and Masks
15 July 2020 New Features in the R Graphics Engine Paul Murrell

library(grid)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Ensure that images are rendered using a device which understands patterns
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
knitr::opts_chunk$set(dev.args = list(png = list(type = "cairo")))

A simple mask

Create a circle
use the circl as the mask when drawing a rectangle

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 1. Create a circle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mask <- circleGrob(
  r = unit(23, 'mm'),
  gp = gpar(fill='black')
)

grid.newpage()
grid.draw(mask)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 4. Create a rectangle using the patterned circle as a mask
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect <- rectGrob(
  width  = unit(40, 'mm'),
  height = unit(40, 'mm'),
  gp = gpar(
    fill = 'lightblue', 
    col  = 'darkblue'
  ),
  vp = viewport(
    mask = mask
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(small_rect)

A mask can have a pattern

Rather than a mask being just a solid shape or something with an alpha channel, it is also possible to create a mask which itself contains a pattern.

Create a tiny rectangle
Make a pattern out of the tiny rectangle
Fill a circle with this tiny rectangle pattern
Create a rectangle using the patterned circle as a mask

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 1. Create a tiny rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tiny_rect <- rectGrob(
  width  = unit(4, 'mm'),
  height = unit(4, 'mm'),
  gp = gpar(fill = 'pink')
)

grid.newpage()
grid.draw(tiny_rect)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 2. Make a pattern out of the tiny rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tiny_rect_pattern <- grid::pattern(
  tiny_rect,
  width  = unit(10, 'mm'),
  height = unit(10, 'mm'),
  extend = 'repeat'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 3. Fill a circle with this tiny rectangle pattern 
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mask <- circleGrob(
  r = unit(23, 'mm'),
  gp = gpar(fill=tiny_rect_pattern)
)

grid.newpage()
grid.draw(mask)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 4. Create a rectangle using the patterned circle as a mask
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect <- rectGrob(
  width  = unit(40, 'mm'),
  height = unit(40, 'mm'),
  gp = gpar(
    fill = 'lightblue', 
    col  = 'darkblue'
  ),
  vp = viewport(
    mask = mask
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(small_rect)

R v4.1.0 - {grid} graphics new feature - patterns (part 2)

Fri, 02 Jul 2021 19:20:10 +1000

Introduciton

As of R 4.1.0 there is built-in support for patterns in grid graphics. There are 3 types of pattern:

grid::linearGradient() for linear colour gradients
grid::radialGradient() for radial colour gradients
grid::pattern() repetition of any combination of graphic objects (grobs)

This quick post summarises a few things which can be done with patterns:

creating a pattern
a repeating element within a pattern can be masked (another new feature of grid in R v4.1.0)
a pattern can itself have a pattern
a pattern can consist of any objects you can put in a grid::grobTree()

Reading list:

14 July 2020 Catching up with R Graphics Gradients, Patterns, Clipping Paths, and Masks
15 July 2020 New Features in the R Graphics Engine Paul Murrell

library(grid)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Ensure that images are rendered using a device which understands patterns
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
knitr::opts_chunk$set(dev.args = list(png = list(type = "cairo")))

Patterns can have masks with an alpha channel

In this example, a simple square is the basis of the repeating pattern.

The square is then masked with a circle containing a radial gradient which is transparent at the edges - this has the effect of softening the edges of the square

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a mask
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mask <- circleGrob(
  x = unit(0.5, 'npc') + unit(2.5, 'mm'),
  y = unit(0.5, 'npc') + unit(2.5, 'mm'),
  r = unit(8, 'mm'),
  gp = gpar(fill = radialGradient(c('black', 'transparent')), col = 'transparent')
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define a small rectangle with some masking
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect_with_mask <- rectGrob(
  width  = unit(10, 'mm'), 
  height = unit(10, 'mm'),
  gp     = gpar(
    fill = 'lightblue', 
    col  = 'blue'
  ),
  vp = viewport(mask = mask)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Wrap the core element (small_rect_with_mask) inside a pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect_with_mask_pattern <- grid::pattern(
  small_rect_with_mask,
  width  = unit(15, 'mm'),
  height = unit(15, 'mm'), 
  extend = 'repeat'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use the pattern as a 'fill' on another shape
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
large_rect <- rectGrob(
  width  = 0.5, 
  height = 0.5,
  gp = gpar(fill = small_rect_with_mask_pattern)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(large_rect)

Patterns can be defined with concrete units

When patterns are defined using concrete/absolute units (such as ‘mm’), then their size is constant regardless of the viewport

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define a small rectangle with size in concrete/absolute units
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect <- rectGrob(
  width  = unit(10, 'mm'), 
  height = unit(10, 'mm'),
  gp     = gpar(
    fill = 'lightblue', 
    col  = 'blue'
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Wrap the core element (small_rect) inside a pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect_pattern <- grid::pattern(
  small_rect,
  width  = unit(15, 'mm'),
  height = unit(15, 'mm'), 
  extend = 'repeat'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use the pattern as a 'fill' on another shape
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
large_rect <- rectGrob(
  width  = 0.3, 
  height = 0.3,
  gp = gpar(fill = small_rect_pattern),
  vp = viewport(
    x = unit(0.33, 'npc'),
    y = unit(0.5 , 'npc')
  )
)

large_rect2 <- rectGrob(
  width  = 0.3, 
  height = 0.6,
  gp = gpar(fill = small_rect_pattern),
  vp = viewport(
    x = unit(0.67, 'npc'),
    y = unit(0.5 , 'npc')
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(large_rect)
grid.draw(large_rect2)

Patterns can be defined with relative units

When patterns are defined using relatives units (such as ‘npc’), then their apparent size depends on the viewport they’re rendered into.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define a small rectangle with size in relative units 'npc'
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect <- rectGrob(
  width  = unit(0.1, 'npc'), 
  height = unit(0.1, 'npc'),
  gp     = gpar(
    fill = 'lightblue', 
    col  = 'blue'
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Wrap the core element (small_rect) inside a pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect_pattern <- grid::pattern(
  small_rect,
  width  = unit(15, 'mm'),
  height = unit(15, 'mm'), 
  extend = 'repeat'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use the pattern as a 'fill' on another shape
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
large_rect <- rectGrob(
  width  = 0.3, 
  height = 0.3,
  gp = gpar(fill = small_rect_pattern),
  vp = viewport(
    x = unit(0.33, 'npc'),
    y = unit(0.5 , 'npc')
  )
)

large_rect2 <- rectGrob(
  width  = 0.3, 
  height = 0.6,
  gp = gpar(fill = small_rect_pattern),
  vp = viewport(
    x = unit(0.67, 'npc'),
    y = unit(0.5 , 'npc')
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(large_rect)
grid.draw(large_rect2)

R v4.1.0 - {grid} graphics new feature - patterns

Thu, 01 Jul 2021 21:20:10 +1000

Introduciton

As of R 4.1.0 there is built-in support for patterns in grid graphics. There are 3 types of pattern:

grid::linearGradient() for linear colour gradients
grid::radialGradient() for radial colour gradients
grid::pattern() repetition of any combination of graphic objects (grobs)

This quick post summarises a few things which can be done with patterns:

creating a pattern
a repeating element within a pattern can be masked (another new feature of grid in R v4.1.0)
a pattern can itself have a pattern
a pattern can consist of any objects you can put in a grid::grobTree()

Reading list:

14 July 2020 Catching up with R Graphics Gradients, Patterns, Clipping Paths, and Masks
15 July 2020 New Features in the R Graphics Engine Paul Murrell

library(grid)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Ensure that images are rendered using a device which understands patterns
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
knitr::opts_chunk$set(dev.args = list(png = list(type = "cairo")))

Define the core element of the pattern

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define a small rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect <- rectGrob(
  width  = unit(10, 'mm'), 
  height = unit(10, 'mm'),
  gp     = gpar(
    fill = 'lightblue', 
    col  = 'blue'
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(small_rect)

Create a pattern by wrapping the core element in `grid::pattern()`

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Wrap the core element (small_rect) inside a pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect_pattern <- grid::pattern(
  small_rect,
  width  = unit(15, 'mm'),
  height = unit(15, 'mm'), 
  extend = 'repeat'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use the pattern as a 'fill' on another shape
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
large_rect <- rectGrob(
  width  = 0.5, 
  height = 0.5,
  gp = gpar(fill = small_rect_pattern)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(large_rect)

Patterns can have masks

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a mask
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mask <- circleGrob(
  x = unit(0.5, 'npc') + unit(2.5, 'mm'),
  y = unit(0.5, 'npc') + unit(2.5, 'mm'),
  r = unit(4, 'mm'),
  gp = gpar(fill = 'black')
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define a small rectangle with some masking
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect_with_mask <- rectGrob(
  width  = unit(10, 'mm'), 
  height = unit(10, 'mm'),
  gp     = gpar(
    fill = 'lightblue', 
    col  = 'blue'
  ),
  vp = viewport(mask = mask)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Wrap the core element (small_rect_with_mask) inside a pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect_with_mask_pattern <- grid::pattern(
  small_rect_with_mask,
  width  = unit(15, 'mm'),
  height = unit(15, 'mm'), 
  extend = 'repeat'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use the pattern as a 'fill' on another shape
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
large_rect <- rectGrob(
  width  = 0.5, 
  height = 0.5,
  gp = gpar(fill = small_rect_with_mask_pattern)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(large_rect)

Pattern - Patterns can have patterns

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define an inner pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
inner_pattern_element <- circleGrob(
  r  = unit(5, 'mm'), 
  gp     = gpar(
    fill = 'pink', 
    col  = 'red'
  )
)

inner_pattern <- grid::pattern(
  inner_pattern_element,
  width  = unit(12, 'mm'),
  height = unit(12, 'mm'), 
  extend = 'repeat'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define an outer pattern which is filled with the inner pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
outer_pattern_element <- polygonGrob(
  x = unit(0.5, 'npc') + unit(c(0, 20, 20) - 10, 'mm'),
  y = unit(0.5, 'npc') + unit(c(0,  0, 20) - 10, 'mm'),
  gp = gpar(fill = inner_pattern, col = 'blue')
)

outer_pattern <- grid::pattern(
  outer_pattern_element,
  width  = unit(30, 'mm'),
  height = unit(30, 'mm'), 
  extend = 'reflect'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fill a 'rect' with the outer pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
large_rect <- rectGrob(
  width  = 0.5, 
  height = 0.5,
  gp = gpar(fill = outer_pattern)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(large_rect)

Pattern - Patterns can contain multiple objects

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define a small rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_rect <- rectGrob(
  width  = unit(10, 'mm'), 
  height = unit(10, 'mm'),
  gp     = gpar(
    fill = 'lightblue', 
    col  = 'blue'
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define a small circle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
small_circle <- circleGrob(
  x = unit(0.5, 'npc') + unit(3, 'mm'),
  y = unit(0.5, 'npc') + unit(3, 'mm'),
  r  = unit(4, 'mm'),
  gp     = gpar(
    fill = 'pink', 
    col  = 'red'
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Creat a compound pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compound_pattern <- pattern(
  grobTree(small_rect, small_circle),
  width  = unit(15, 'mm'),
  height = unit(15, 'mm'),
  extend = 'repeat'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fill a 'rect' with the compound pattern
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
large_rect <- rectGrob(
  width  = 0.5, 
  height = 0.5,
  gp = gpar(fill = compound_pattern)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the rectangle
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
grid.newpage()
grid.draw(large_rect)

Introducing {gluestick} - a simple, base R, single function, glue-like string interpolator

Fri, 04 Jun 2021 21:22:20 +1000

gluestick

The goal of the gluestick package is to provide a home for a single, simple function (also named gluestick).

This gluestick() function is meant to be an almost drop-in replacement for 99.9% of the reasons I use the amazing glue package.

The idea is that you would just steal the function out of this package and use it in your own package in order to avoid having glue as a dependency.

Benefits

Single function
No dependencies
No C code
Vanilla base R code (easy to hack upon)

Limitations

There is no special handling when delimiters are repeated. This differs from glue where doubling the delimiter escpaes it.
No support for glue’s idea of data transformers
Far fewer sanity checks than glue

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/gluestick')

In reality, I can’t see anyone actually wanting to install/use this package in preference to the glue package.

What I envisage is that if you want something “glue-like” to include in your own work, you can just steal the gluestick() function out of this package and include it in your own package.

Basic Usage

library(gluestick)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# By default, `src` data is the calling environment
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
name <- 'Mike'
gluestick("Hello {name}")

## [1] "Hello Mike"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# R code will be evaluated
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
gluestick("Hello {name}. Score = {1 + 2}")

## [1] "Hello Mike. Score = 3"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Can pass in a list, data.frame, environment etc as the data source to 
# override the default
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
gluestick("Hello {name}", src = list(name = '#RStats'))

## [1] "Hello #RStats"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Delimiters are user-definable
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
gluestick("Hello ~~!name]]?", open = "~~!", close = "]]?")

## [1] "Hello Mike"

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Package Development Update

Thu, 01 Apr 2021 21:20:02 +1000

Package Development Update

plot(x=c(1.8, 4.2), y=c(0, 1), type = 'n', xlab = 'Time', ylab = 'Ideas', axes = F)

N <- 1000
x <- numeric(N)
x[1] <- 0.5

for (r in seq(2.4, 4, length.out = 3000)) {
  for (i in seq(N-1)) {
    x[i+1] <- r * x[i] * (1 - x[i])
  }

  y <- unique(x[900:1000])
  points(rep(r, length(y)), y, pch = '.', col = '#00000030')

}

title("Current Package Project in #RStats")
text(1.8, 0.58, pos = 4, "How it started", col = 'navy')
text(4.1, 0.1, pos = 4, srt = 90, "How it's going", col = 'tomato', cex = 2)

Introducing 'fugly' - fast regular expression substring extraction with named capture groups

Fri, 19 Mar 2021 22:50:02 +1000

fugly

This package provides a single function (str_capture) for using named capture groups to extract values from strings. This function is just a wrapper around stringr.

fugly::str_capture() is very similar to both unglue and utils::strcapture().

This package was written because stringr doesn’t yet do named capture groups (See issues for stringr and stringi), and I needed something faster than unglue

	fugly::str_capture	unglue:::unglue	utils::strcapture
Speed	fastest	slow	faster
Naming Groups	inline capture group naming	inline capture group naming	use of prototype to define names
Safe + Robust?	dodgy	quite safe	quite safe

What do I mean when I say `fugly::str_capture()` is unsafe/dodgy/non-robust?

It doesn’t adhere to standard regular expression syntax for named capture groups as used in perl, python etc.
It doesn’t really adhere to glue syntax (although it looks similar at a surface level).
If you specify delimiters which appear in your string input, then you’re going to have a bad time.
It’s generally only been tested on data which is:
- highly structured
- only ASCII
- non-pathological

What’s in the box?

fugly::str_capture(string, pattern, delim)
- capture named groups with regular expressions
- returns a data.frame with all columns containing character strings
- can mix-and-match with non-capturing regular expressions
- if no regular expression specified for a named group then .*? is used.
- does not do any type guessing/conversion.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/fugly')

Example 1

In the following example:

Input consists of multiple strings
capture groups are delimited by {} by default.
the regex for the capture group for name is unspecified, so .*? will be used
the regex for the capture group for age is \d+ i.e. match must consist of 1-or-more digits

library(fugly)

string <- c(
  "information: Name:greg Age:27 ",
  "information: Name:mary Age:34 "
)

str_capture(string, pattern = "Name:{name} Age:{age=\\d+}")

##   name age
## 1 greg  27
## 2 mary  34

Example 2

A more complicated example:

Note the mixture of capturing groups and a bare .*? in the pattern which is not returned as a result

string <- c(
'{"type":"Feature","properties":{"hash":"1348778913c0224a","number":"27","street":"BANAMBILA STREET","unit":"","city":"ARANDA","district":"","region":"ACT","postcode":"2614","id":"GAACT714851647"},"geometry":{"type":"Point","coordinates":[149.0826143,-35.2545558]}}',
'{"type":"Feature","properties":{"hash":"dc776871c868bc7e","number":"139","street":"BOUVERIE STREET","unit":"UNIT 711","city":"CARLTON","district":"","region":"VIC","postcode":"3053","id":"GAVIC423944917"},"geometry":{"type":"Point","coordinates":[144.9617149,-37.8032551]}}',
'{"type":"Feature","properties":{"hash":"8197f34a40ccad47","number":"6","street":"MOGRIDGE STREET","unit":"","city":"WARWICK","district":"","region":"QLD","postcode":"4370","id":"GAQLD155949502"},"geometry":{"type":"Point","coordinates":[152.0230999,-28.2230133]}}',
'{"type":"Feature","properties":{"hash":"18edc96308fc1a8e","number":"22","street":"ORR STREET","unit":"UNIT 507","city":"CARLTON","district":"","region":"VIC","postcode":"3053","id":"GAVIC424282716"},"geometry":{"type":"Point","coordinates":[144.9653484,-37.8063371]}}'
)


str_capture(string, pattern = '"number":"{number}","street":"{street}".*?"coordinates":\\[{coords}\\]')

##   number           street                  coords
## 1     27 BANAMBILA STREET 149.0826143,-35.2545558
## 2    139  BOUVERIE STREET 144.9617149,-37.8032551
## 3      6  MOGRIDGE STREET 152.0230999,-28.2230133
## 4     22       ORR STREET 144.9653484,-37.8063371

Simple Benchmark

I acknowledge that this isn’t the greatest benchmark, but it is relevant to my current use-case.

For large inputs (1000+ input strings), fugly is the fastest
For small inputs, fugly and utils::strcapture are about equivalent
unglue is the slowest of the methods.
ore lies somewhere between unglue and utils::strcapture

# remotes::install_github("jonclayden/ore")
library(ore)
library(unglue)
library(ggplot2)

# meaningless strings for benchmarking
string <- paste0("Information name:greg age:", 1:1000)

res <- bench::mark(
  `fugly::str_capture()` = fugly::str_capture(string, "name:{name} age:{age=\\d+}"),
  `unglue::unglue()` = unglue::unglue_data(string, "Information name:{name} age:{age=\\d+}"),
  `utils::strcapture()` = utils::strcapture("Information name:(.*?) age:(\\d+)", string, 
                    proto = data.frame(name=character(), age=character())),
  `ore::ore_search()` = do.call(rbind.data.frame, lapply(ore_search(ore('name:(?<name>.*?) age:(?<age>\\d+)', encoding='utf8'), string, all=TRUE), function(x) {x$groups$matches}))
)

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

On 'on.exit()' - Part 2

Fri, 12 Mar 2021 08:22:02 +1000

Introduction

on.exit() is a base R function which records expressions to evaluate when the current function exits.

I was wanting to use on.exit() in a function that was allocating some resources, and I explicitly wanted these resources freed in the reverse order.

Working out how to do what I wanted was easy (discussed below), but it lead me down a path of discovery as I tried to figure out just exactly where and when the on.exit() expressions were being executed.

Yesterday I posted some code snippets from this exploration.

This is a follow-up post with some more notes

Capture variable values at time of `on.exit()` creation

The following code shows that, by default, values in the on.exit() expression are evaluated as the function exits.

f <- function(a, b) {
  on.exit(cat("a =", a, " b =", b, "\n"))
  a <- a + 1
  b <- b + 1
  a + b
}

f(1, 2)

## a = 2  b = 3

## [1] 5

However sometimes you might like the on.exit() expression to capture the current values of the variables at the time the on.exit() expression was captured.

The docs suggest using substitute() to do this. I’m not sure if the following is exactly what the docs are suggesting, but this works:

f <- function(a, b) {
  eval(substitute(on.exit(cat("a =", a, " b =", b, "\n"))))
  a <- a + 1
  b <- b + 1
  a + b
}

f(1, 2)

## a = 1  b = 2

## [1] 5

Make a function callable only once by removing the function from the calling environment

Antoine Fabri in his {once} package uses on.exit() to remove some functions from the calling environment after they are run for the first (and only!) time.

The following code is a small recreation of this functionality i.e. the function can be called once, and is then removed from the calling environment.

f <- function() {
  on.exit(rm('f', envir = parent.frame()))
  print("In the function")
}

f()

## [1] "In the function"

f()

## Error in f(): could not find function "f"

`on.exit()` in nested functions - abnormal exit with `stop()`

Nested functions - each with their own on.exit() - will trigger the evaluation of the captured exit expressions when a stop() is called in the innermost function. The on.exit() expressions are evaluated from most deeply nested function out to the initial outer function call.

fa <- function() {on.exit(print("Exit fa()")); stop("Bang!")}
fb <- function() {on.exit(print("Exit fb()")); fa()}
fc <- function() {on.exit(print("Exit fc()")); fb()}

fc()

## Error in fa(): Bang!

## [1] "Exit fa()"
## [1] "Exit fb()"
## [1] "Exit fc()"

`on.exit()` in nested functions - abnormal exit with `kill` signals.

For those familiar with sending signals to processes, on.exit() code may or may not be run when signals are sent.

A common way to send a signal on Unix or MacOS is with the kill command.

My tests on MacOS with some common signals, show that R only executes the captured on.exit() expressions when sent a SIGINT (equivalent to hitting CTRL-C).

Many other signals caused R to terminate completely without the on.exit() registered expressions being evaluated.

Other signals had zero noticeable effect.

On 'on.exit()'

Fri, 12 Mar 2021 08:21:10 +1000

Introduction

on.exit() is a base R function which records expressions to evaluate when the current function exits.

I was wanting to use on.exit() in a function that was allocating some resources, and I explicitly wanted these resources freed in the reverse order.

Below are some of my code snippets from this exploration.

Simple usage

The following simple code shows:

The on.exit() call can appear anywhere in the function
The on.exit() expression is evaluated after the function budy is complete i.e. after the return statement.

f <- function(a, b) {
  on.exit(print("on.exit() called"))
  print("Function finished, returning value")
  return(a + b)
}

f(1, 2)

## [1] "Function finished, returning value"
## [1] "on.exit() called"

## [1] 3

Multiple `on.exit()` statements

The following code shows:

The on.exit() call can appear multiple times in the function
by using add = TRUE, the expression is added to any prior expressions

f <- function(a, b) {
  on.exit(print("on.exit() called 1"))
  result <- a + b
  on.exit(print("on.exit() called 2"), add = TRUE)
  print("Function finished, returning value")
  return(result)
}

f(1, 2)

## [1] "Function finished, returning value"
## [1] "on.exit() called 1"
## [1] "on.exit() called 2"

## [1] 3

Multiple `on.exit()` statements

The following code shows:

The on.exit() call can appear multiple times in the function
by using add = TRUE, the expression is added to any prior expressions
by using after = FALSE, the expression is added before any any prior expressions

f <- function(a, b) {
  on.exit(print("on.exit() called 1"))
  result <- a + b
  on.exit(print("on.exit() called 2"), add = TRUE, after = FALSE)
  print("Function finished, returning value")
  return(result)
}

f(1, 2)

## [1] "Function finished, returning value"
## [1] "on.exit() called 2"
## [1] "on.exit() called 1"

## [1] 3

The evaluation environment for `on.exit()` has access to function variables

The evaulation environment where the on.exit() expressions are a run has access to variables within the function.

f <- function(a, b) {
  on.exit(cat("The numbers were ", a, " and ", b, "\n"))
  return(a + b)
}

f(1, 2)

## The numbers were  1  and  2

## [1] 3

The variables aren’t explicitly captured when then on.exit() expression is registered, so the variable values will be those at the end of the function evaluation.

f <- function(a, b) {
  on.exit(cat("The numbers were ", a, " and ", b, "\n"))
  a <- a + 1
  b <- b + 1
  return(a + b)
}

f(1, 2)

## The numbers were  2  and  3

## [1] 5

Viewing the expressions registered via `on.exit()`

It is possible to view the expressions that have been registered with on.exit() during a function call by calling sys.on.exit()

f <- function(a, b) {
  on.exit(print("on.exit() called 1"))
  result <- a + b
  on.exit(print("on.exit() called 2"), add = TRUE, after = FALSE)
  print(sys.on.exit())
  print("Function finished, returning value")
  return(result)
}

f(1, 2)

## {
##     print("on.exit() called 2")
##     print("on.exit() called 1")
## }
## [1] "Function finished, returning value"
## [1] "on.exit() called 2"
## [1] "on.exit() called 1"

## [1] 3

It is even possible to return the on.exit() expressions for later evaluation in a different context.

f <- function(a, b) {
  on.exit(print("on.exit() called 1"))
  result <- a + b
  on.exit(print("on.exit() called 2"), add = TRUE, after = FALSE)
  return(sys.on.exit())
}

# capture the returned on.exit() expressions
exp <- f(1, 2)

## [1] "on.exit() called 2"
## [1] "on.exit() called 1"

exp

## {
##     print("on.exit() called 2")
##     print("on.exit() called 1")
## }

# Evaluate the returned on.exit() expressions
eval(exp)

## [1] "on.exit() called 2"
## [1] "on.exit() called 1"

Can you use `on.exit()` within an `on.exit()`? Attempt 1

In the following code, I attempt to ask on.exit() to try and execute another on.exit() during the evaluation of the on.exit() expressions.

This does not work. Only the first on.exit() expression is evaluated.

f <- function() {
  on.exit({print("hello 1")})
  on.exit(on.exit(print('hello 2')), add = TRUE)
}

f()

## [1] "hello 1"

Can you use `on.exit()` within an `on.exit()`? Attempt 2

You can sort of make this work by setting up another function context in the on.exit() expression, but nesting on.exit() calls this way doesn’t really do anything that regular usage doesn’t already do.

f <- function() {
  on.exit(print("hello 1"))
  on.exit((function() {on.exit(print("hello 2"))})(), add = TRUE)
}

f()

## [1] "hello 1"
## [1] "hello 2"

Can you use `on.exit()` within an `on.exit()`? Attempt 3

It’s interesting to note that on.exit() expressions are evaluated at the end of code created via an eval(parse(...)) statement. i.e.

eval(parse(text="on.exit(print('hello'))"))

## [1] "hello"

So it is possible to get an on.exit() to evaluate within the context of a different on.exit() - but I can’t see an application for this behaviour.

f <- function() {
  on.exit(print("hello 1"))
  on.exit(eval(parse(text="on.exit(print('hello 2'))")), add = TRUE)
}

f()

## [1] "hello 1"
## [1] "hello 2"

What happens if you call `stop()` within an `on.exit()`?

If an error occurs during the evaluation of the on.exit() expressions, then the return value is never assigned to the variable in the calling environment.

a <- NULL

f <- function() {
  on.exit(stop("error during on.exit()"))
  return(1)
}

a <- f()

## Error in f(): error during on.exit()

print(a)

## NULL

What happens if you call `return()` within an `on.exit()`?

If return() is called within on.exit() then this will actually override any return value in the function itself.

f <- function() {
  on.exit(return(2))
  return(1)
}

f()

## [1] 2

Manipulating the return value with `on.exit()`

The on.exit() evaluation environment has access to the return value of the function using the returnValue() function.

This can then be used to post-process any return value before it actual gets to the function calling environment.

In the following code, the return value of the function is doubled during the exit process.

f <- function()  {
  on.exit(return(returnValue() * 2))
  return(1)
}

result <- f()
print(result)

## [1] 2

Using `Recall()` within an `on.exit()`

In the following code, the return value is evaluated within the on.exit() context, and if it does not meet the specified criteria, the function is called again (via Recall()) until it passes.

set.seed(1)

f <- function() {
  
  on.exit({
    if (returnValue() < 0.9) {
      return(Recall())
    }
    return(x)
  })
  
  x <- runif(1)
  cat("Returning: ", x, "\n")
  return(x)
}


result <- f()

## Returning:  0.2655087 
## Returning:  0.3721239 
## Returning:  0.5728534 
## Returning:  0.9082078

print(result)

## [1] 0.9082078

Shift the entire function body to be evaluated `on.exit()`

In this code, the entire function body and return statement for this simpl addition function are within the on.exit() statement.

f <- function(a, b) {
  on.exit({
    result <- a + b
    return(result)
  })
  
  
  return(-999)
}



result <- f(1, 2)
print(result)

## [1] 3

Modifying R6 objects after creation - Part 2

Sat, 20 Feb 2021 08:17:00 +1000

R6 classes

The {R6} package is an implementation of encapsulated object-oriented programming for R, and is a simpler, faster, lighter-weight alternative to R’s built-in reference classes. This style of programming is also sometimes referred to as classical object-oriented programming.

In this post I’ll be using the word class to refer to the original class definition using R6::R6Class() and object to refer to an instantiation of that class e.g. my_object = ClassName$new().

In this post, I’m experimenting with overriding the $ operator to automatically add variables rather than return NULL when trying to access variables which do not exist in the class defintion.

Current R6 Behaviour when Reading Missing Member Variables

If you attempt to read a variable which does not exist, then R6 will return NULL.

MyClass <- R6::R6Class(
  "MyClass",
  lock_object = FALSE,
  public = list(height = 100)
)
 
# Create an instance of the class 
myobj <- MyClass$new()

# Call a method on this object
myobj$height

## [1] 100

# Try and call a non-existant method and get a NULL
myobj$name

## NULL

Override the `$` operator to add missing variables rather than return NULL

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# OVerride $ to check for existance of element. If not, then add to object
# with a default value of 999
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`$.MyClass` <- function(x, y) {
  if (!y %in% names(x)) {
    x[[y]] <- 999
  }
  NextMethod()
}

myobj$name

## [1] 999

Automatically, Dynamicalliy creating nested/linked objects

This is an experimental node/tree class that automatically creates new node objects when one doesn’t exist at the named location in an R6 object.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# A node class
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Node <- R6::R6Class(
  "Node",
  lock_object = FALSE,
  public = list(
    index      = NULL,
    initialize = function(index = 1L) {self$index = index; self},
    print      = function() {cat("I am a node at depth:", self$index, "\n")}
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# OVerride $ to check for existance of element. If not, then add a new 
# node object at this location
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`$.Node` <- function(x, y) {
  if (!y %in% names(x)) {
    message("Creating new node at depth: ", x[['index']] + 1L)
    x[[y]] <- Node$new(x[['index']] + 1L)
  }
  NextMethod()
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a single new object
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
node <- Node$new(1)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Every reference to an unknown variable in that object creates a new 
# 'Node' object at that location
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
node$node2

## Creating new node at depth: 2

## I am a node at depth: 2

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Node creation can be chained together!
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
node$node2$node3$node4$node5$node6

## Creating new node at depth: 3

## Creating new node at depth: 4

## Creating new node at depth: 5

## Creating new node at depth: 6

## I am a node at depth: 6

What’s next?

This means I can establish a base class with a certain set of methods, but I can now dynamically create a menagerie of slightly different objects which each have different sets of methods and variables.

I guess this is sort of similar to perhaps defining a class inheritance hierarchy except what I want to do is regularly, and dynamically, modify the methods available on existing objects during runtime.

Modifying R6 objects after creation

Fri, 19 Feb 2021 21:17:00 +1000

R6 classes

It is possible to add a method to an existing R6 class after it has been defined, but I want to add a new method to an object (i.e. just an instance of this class).

R6 classes simple example

MyClass <- R6::R6Class(
  "MyClass",
  public = list(
    hello = function(name) { cat("Hello", name, "\n")}
  )
)
 
# Create an instance of the class 
myobj <- MyClass$new()

# Call a method on this object
myobj$hello("#RStats")

## Hello #RStats

Modifying a Class

It is possible to create a class and then modify the definition of that class afterwards. lock_class must be set to FALSE to do this.

# Create an empty class
MyClass <- R6::R6Class(
  "MyClass",
  lock_class = FALSE
)
 
# Create a new method within the class after it was defined
MyClass$set("public", "hello", function(name) { cat("Hello", name, "\n")})

# Create an instance of the class 
myobj <- MyClass$new()

# Call a method on this object
myobj$hello("#RStats")

## Hello #RStats

Adding a new method to an Object (withouth modifying the class)

It is possible to create a class, instantiate an object of that class, and then modify the contents of that object to add a new method not in the original class definition, but only to this object.

Requires:

lock_object = FALSE
In order for a new method to behave correctly, is must have the same environment as other methods in the class. This is so it can look-up public and private variables in the class. e.g. using self$

# Create an empty class
MyClass <- R6::R6Class(
  "MyClass",
  lock_object = FALSE,
  public = list(
    line_end = "!!",
    hello = function(name) { cat("Hello", name, self$line_end, "\n")}
  )
)

# Create an instance of the class 
myobj <- MyClass$new()

# Call a method on this object
myobj$hello("#RStats")

## Hello #RStats !!

# Create a method Ensure it has the right environment
myobj$goodbye <- function(name) { cat("Goodbye", name, self$line_end, "\n")}
environment(myobj$goodbye) <- myobj$.__enclos_env__

myobj$goodbye("Mike")

## Goodbye Mike !!

What’s next?

This means I can establish a base class with a certain set of methods, but I can now dynamically create a menagerie of slightly different objects which each have
different sets of methods.

A Simple Ray-Tracer Written in Base R

Mon, 15 Feb 2021 20:17:00 +1000

Introduction

This code was a personal challenge to write a simple ray-tracer in pure R.

Ray tracing is an example of something which is really silly to do in base R, and I’d be interested to see how others would approach this problem.

Code is shared in a public gist. Please share and enjoy.

Design

Has to be base R only. No other packages allowed
Supports sphereical objects only. This simplifies object handling.
Tracing a single eye-ray per pixel only
Single light probe rays for shadow testing
Objects represented by signed distance fields.
Ray-marching/Sphere-tracing is used to move rays through space

Setting expectations

This is what Blender can do

This is what this code does

Data representation

rays - a bundle of rays stored as a list of matrices. Stores ray origin, direction, distance travelled so far, closest object index, distance to closest object
sphere - a list of information about a spherical object i.e. coordinates of centre, radius and colour

Helper functions

Normalise vectors `normalise()`

#-----------------------------------------------------------------------------
#' Normalise vectors to unit length
#' @param mat a matrix storing multiple vectors i.e. one vector per row
#' @return modified matrix with all vectors normalised to length=1
#-----------------------------------------------------------------------------
normalise <- function(mat) {
  mat / sqrt(rowSums(mat ^ 2))
}

Plot values associated with a bundle of rays - `draw()`

#-----------------------------------------------------------------------------
#' Draw a ray parameter shading with viridis
#' @param rays list of ray information
#' @param paramter valid ray parameter e.g. 't', 'obj_index', 'dist2obj'
#' @param ... other parameters passed to `viridisLit::viridis()`
#-----------------------------------------------------------------------------
draw <- function(rays, parameter, option = 'A', ...) {
  values <- rays[[parameter]]

  if (length(unique(values)) == 1) {
    values[] <- 0
  } else {
    values <- as.integer(255 * (values - min(values)) / (max(values) - min(values)))
  }

  colours <- viridisLite::viridis(256, option = option, ...)[values + 1L]
  mat <- matrix(colours, N, N)
  mat <- mat[rev(seq(N)),]

  plot(as.raster(mat), interpolate = FALSE)
}

Create rays through image plane - `create_eye_rays()`

Eye rays are the rays which are cast from the eye through each pixel in the screen.

The colour of the object at the end of this ray is the colour of the pixel in the final image representation.

An illustration of these rays is included below:

#-----------------------------------------------------------------------------
#' Create the initial set of eye rays
#' Image plane is in the x,y plane centered at c(0, 0, 0)
#' @param N pixel width and height of the resulting image
#' @param eye_to_image_plane default: 2
#-----------------------------------------------------------------------------
create_eye_rays <- function(N=5, eye_to_image_plane = 2) {
  eye <- c(0, 0, -eye_to_image_plane)
  mid <- as.integer((N+1)/2)

  col <- rep(1:N, each=N)
  row <- rep(1:N,      N)

  x <- (col - mid) / (mid - 1)
  y <- (row - mid) / (mid - 1)

  ray_origin  <- cbind(x=x, y=y, z=0)

  ray_dir <- ray_origin
  ray_dir[,1] <- ray_origin[,1] - eye[1]
  ray_dir[,2] <- ray_origin[,2] - eye[2]
  ray_dir[,3] <- ray_origin[,3] - eye[3]

  ray_dir <- normalise(ray_dir)

  rays <- list(
    origin    = ray_origin,
    dir       = ray_dir,
    t         = numeric(N*N),
    obj_index = NA,
    steps     = rep(-1L, N*N)
  )

  rays$ray_end <- rays$origin + rays$dir * rays$t

  rays
}

Signed distance function - `calc_distances_to_sphere()`

This renderer uses signed distance functions to determine the distance from the position of any point in space to a given object.

Each ray is tested against each object. The distance to the closet object determines how far the ray will advance at the next time step (and be guaranteed to not hit anything else). This is ray-marching with sphere-tracing.

#-----------------------------------------------------------------------------
#' Core function to calculate distance from sphere and a bundle of rays
#-----------------------------------------------------------------------------
calc_distances_to_sphere <- function(sphere, rays) {
  sqrt(colSums( (t(rays$ray_end) - sphere$centre) ^ 2 )) - sphere$radius
}

Ray marching - `raymarch()`

This function orchestrates the marching of a bundle of rays within a scene containing a set of objects.

It proceeds as follows:

For each ray, find the distance to the nearest object
Advance the ray that distance
Repeat.

The sphere-tracing/ray-marching step is illustrated in the figure below (from hasmcole.com)

Note: There is no convergence criteria used here to determine if a ray has actually hit an object. Instead, all rays are marched through the scene a fixed number of times. This is pretty naive, and there would be speed gains by stopping the marching of rays which have already intersected an object.

#-----------------------------------------------------------------------------
#' march the rays
#-----------------------------------------------------------------------------
raymarch <- function(rays, objects) {

  #---------------------------------------------------------------------------
  # Naive marching. Just goint to a fixed number of iterations
  #  1. Calc distance from end of each ray to the nearest object
  #  2. Ray march (sphere tracing) to advance the ray this minimum distance
  #  3. Repeat
  #---------------------------------------------------------------------------
  for (step in seq_len(100)) {
    distances      <- lapply(objects, calc_distances_to_sphere, rays)
    rays$dist2obj  <- do.call(pmin.int, distances)
    rays$t         <- rays$t + rays$dist2obj
    rays$ray_end   <- rays$origin + rays$dir * rays$t
    
    # Keep a rough notion of the step number at which the ray converged 
    # on an object
    just_converged <- rays$dist2obj < 0.001 & rays$step < 0
    rays$step[just_converged] <- step
  }

  #---------------------------------------------------------------------------
  # Ray cleanup
  #  - find closest object
  #  - mark objects within a given idstance as 'converged'
  #---------------------------------------------------------------------------
  rays$obj_index <- max.col(-do.call(cbind, distances))
  rays$converged <- rays$dist2obj < 0.01
  rays$step[rays$step < 0] <- step

  rays
}

Define the objects in the scene

Only spheres are supported, with each object represented as a list of centre, radius and colour.

The back wall and floor are just very large spheres.

The specifications for the spheres is also stored as matrices to ease the creation of light probe rays and colour calculations.

#-----------------------------------------------------------------------------
#' Place some random spheres
#-----------------------------------------------------------------------------
set.seed(1)
random_spheres <- lapply(1:35, function(x) {
  radius <- runif(1, 0.2, 0.8)
  x      <- runif(1,  -3, 3)
  y      <- runif(1,  -3, 3)
  z      <- runif(1, 3, 6) #- radius
  list(centre = c(x, y, z), radius = radius, colour = runif(3))
})

walls <- list(
  list(centre = c(0  ,    0  , 900), radius = 895  , colour = c(1, 1, 0.9)),  # back wall,
  list(centre = c(0  , -900  ,   0), radius = 897  , colour = c(1, 1, 1  ))   # floor
)

regular_objects <- c(random_spheres, walls)


#-----------------------------------------------------------------------------
# Extract summary representations across all objects of:
#  - colours
#  - centres
#  - radii
#-----------------------------------------------------------------------------
object_colours <- lapply(regular_objects, `[[`, 'colour')
object_colours <- do.call(rbind, object_colours)

object_radii <- vapply(regular_objects, `[[`, numeric(1), 'radius')

object_centres <- lapply(regular_objects, `[[`, 'centre')
object_centres <- do.call(rbind, object_centres)

Render the scene

Create rays from the eye through each pixel in the output image
March these rays through the scene, using the sphere objects to define how far to advance at each step

#-----------------------------------------------------------------------------
#' Create a bundle of NxN rays and march them into the scene
#-----------------------------------------------------------------------------
N <- 400
eye_rays <- create_eye_rays(N)

print(system.time({
  rays <- raymarch(eye_rays, regular_objects)
}))

##    user  system elapsed 
##  20.802   4.282  25.126

Information about the render

Each ray retains some information about how it travelled through the scene:

The index of the closest object - obj_index
The number of steps to converge on an object - step
The distance travelled - t

draw(rays, 'obj_index'); title("Index of object closest to end of eye ray")

draw(rays, 't')        ; title("Distance ray has travelled")

draw(rays, 'step')     ; title("Number of steps to converge")

This last image is interesting as it shows that rays which pass near to the edge of an object takes more steps to converge.

As illustrated below, this is because as a ray grazes an object it takes a large number of very small steps.

Shadows

To determine which objects are in light and which are in shadow:

Define a light source object
At the end of each ray, determine the local surface normal and direction to this light source
Ray march these new light probe rays
If they hit the light, then it means there are no objects in the way and it is fully lit. Otherwise it is in shadow

#-----------------------------------------------------------------------------
# Define the position of the light within the scene
#-----------------------------------------------------------------------------
light <- list(centre=c(-1.5, 2.5, 0.2), radius=0.1)


#-----------------------------------------------------------------------------
# Calculate probes from the end of each camera ray to the light source.
#  (1) find object each ray intersects
#  (2) Find the centre of this object and the local normal
#  (3) Calculate the direction from this intersection to the light source
#  (4) Construct set of rays to probe for visibilit of light source
#-----------------------------------------------------------------------------
centres <- object_centres[rays$obj_index,]

normal <- rays$ray_end - centres
normal <- normalise(normal)

radii <- object_radii[rays$obj_index]

# Start light ray from just above surface
intersect <- centres + (radii + 0.001) * normal

# Direction to lightsource (normalised to unit length)
dir <- intersect
dir[,1] <- light$centre[1] - intersect[,1]
dir[,2] <- light$centre[2] - intersect[,2]
dir[,3] <- light$centre[3] - intersect[,3]
dir <- normalise(dir)

# Dot product of local normal with direction to lightsource.
# Clamp negative values (where normal points away from light) to zero
facing_light <- (dir[,1]*normal[,1] + dir[,2]*normal[,2] + dir[,3]*normal[,3])
facing_light <- ifelse(facing_light > 0, facing_light, 0)

# Construct light probes
light_probes <- list(
  origin = intersect,
  dir    = dir,
  t      = numeric(length(radii))
)

light_probes$ray_end <- light_probes$origin + light_probes$dir * light_probes$t


#-----------------------------------------------------------------------------
#' raymarch the light probes
#' If a lightprobe hits the light, then the object can see the light source,
#' otherwise it is in shadow
#-----------------------------------------------------------------------------
objects_with_light <- c(list(light), regular_objects)
light_probes       <- raymarch(light_probes, objects_with_light)

Determine colour and shading of each pixel

#-----------------------------------------------------------------------------
# Find the colour of each object at the end of each eye ray
# If ray is not close to any object, set colour to black
#-----------------------------------------------------------------------------
intersect_colour <- object_colours[rays$obj_index,]
intersect_colour[rays$dist2obj > 0.1, ] <- 0

#-----------------------------------------------------------------------------
# If a light probe from this intersection intersects with any object other
# than the light source, then it is in shadow, so darken this colour
#-----------------------------------------------------------------------------
in_shadow <- light_probes$obj_index != 1
intersect_colour[in_shadow] <- 0.3 * intersect_colour[in_shadow]

#-----------------------------------------------------------------------------
# Shade the colour from light-to-dark depending on how close the local normal
# aligns with the direction of the light source.
#-----------------------------------------------------------------------------
final_colour <- intersect_colour * facing_light


#-----------------------------------------------------------------------------
# Convert final colours to a raster for plotting
#-----------------------------------------------------------------------------
colours <- rgb(final_colour[,1], final_colour[,2], final_colour[,3])
image   <- matrix(colours, nrow = N, ncol = N)
image   <- image[rev(seq(nrow(image))),] # flip top-to-bottom
image   <- as.raster(image)

plot(image, interpolate = FALSE)

From the time before Tetris - 'Beat the Computer' puzzles

Wed, 27 Jan 2021 20:59:00 +1000

In the time before ‘Tetris’

Before ‘Tetris’, if you wanted to stack smaller pieces into bigger areas, you could play with the Tenyo puzzles called “Beat the Computer”.

These puzzles were pocket-sized containers with a bestiary of pre-cut pieces - you tipped them out and then tried to fit them back in.

They were really difficult!

Below are puzzle numbers 783 and 6 in this series.

Finding all 9356 solutions to Puzzle No 5

This puzzle challenges you to fit the complete set of 12 pentominos into a 6x10 space.

According to the instructions for Puzzle No. 5, there are 2339 unique solutions to this puzzle. If reflections along both axes are considered then there are 2339 * 4 = 9356 solutions.

The code which follows finds all solutions by:

modelling each piece as a set of indices defining its shape
using recursive backtracking to try and place each piece in turn

It takes about 15 minutes to find all solutions - about 10 solutions/second.

The following 50 minute video shows all the solutions (at a rate of 3 solutions per second)

suppressPackageStartupMessages({
  library(dplyr)
  library(purrr)
  library(tidyr)
})


# Reference and naming scheme from:
#  https://en.wikipedia.org/wiki/Pentomino

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
w   <- 10    # width  of space to place pentominos
h   <- 6     # height of space to place pentominos
buf <- 5 - 1 # maximum safety buffer around placement area


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a board to contain the placement area.
# The buffer arund the outside is to ensure that any piece that starts within
# the placement area, will not be out of bounds of the board.
# Use '1' to indicate that the space is occupied.
# Use '0' to indicate an empty space into which a pentomino may be placed
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
board <- matrix(1L, nrow = h + 2 * buf, ncol = w + 2 * buf)

for (i in seq(h)) {
  board[buf + i, buf + seq(w)] <- 0L
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Pentominoes as matrices
# Naming scheme follows wikipedia: https://en.wikipedia.org/wiki/Pentomino
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pent_mats <- list(
  I = matrix(c(
    1, 1, 1, 1, 1
  ), nrow = 1, ncol = 5, byrow = TRUE),

  F = matrix(c(1, 0, 0,
               1, 1, 1,
               0, 1, 0), nrow=3, byrow = TRUE),

  L = matrix(c(1, 1, 1, 1,
               1, 0, 0, 0), nrow = 2, byrow = TRUE),

  P = matrix(c(1, 1, 0,
               1, 1, 1), nrow = 2, byrow = TRUE),

  N = matrix(c(0, 1, 1, 1,
               1, 1, 0, 0), nrow = 2, byrow = TRUE),

  T = matrix(c(1, 1, 1,
               0, 1, 0,
               0, 1, 0), nrow = 3, byrow = TRUE),

  U = matrix(c(1, 0, 1,
               1, 1, 1), nrow =  2, byrow = TRUE),

  V = matrix(c(0, 0, 1,
               0, 0, 1,
               1, 1, 1), nrow = 3, byrow = TRUE),

  W = matrix(c(1, 0, 0,
               1, 1, 0,
               0, 1, 1), nrow = 3, byrow = TRUE),

  X = matrix(c(0, 1, 0,
               1, 1, 1,
               0, 1, 0), nrow = 3, byrow = TRUE),

  Y = matrix(c(0, 0, 1, 0,
               1, 1, 1, 1), nrow = 2, byrow = TRUE),

  Z = matrix(c(1, 0, 0,
               1, 1, 1,
               0, 0, 1), nrow = 3, byrow = TRUE)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Check that they're all pentominoes
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
stopifnot(all(map_dbl(pent_mats, sum) == 5))


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot the board
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
plot_board <- function(x) {
  # trim the board
  x <- x[buf + seq(h), buf + seq(w)]

  image(t(x), asp=6/10, col = RColorBrewer::brewer.pal(12, 'Paired'), axes = F, ann = F)
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Convert a piece matrix to a vector of indices
#'
#' @param piece_mat integer matrix with values 0/1 to represent piece layout
#' @param rows how many rows are in the matrix this will be superimposed upon?
#' @return integer vetor of offsets of the locations in this piece
#'
#' @examples
#' piece_to_idx(pent_mats[[1]], rows = nrow(board))
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
piece_to_idx <- function(piece_mat, rows) {

  # Find all the locations in the matrix as (row, col) coords
  coords <- arrayInd(which(piece_mat > 0), dim(piece_mat))

  # Offset set to first part of piece
  offset <- which(piece_mat >= 1)[1]

  coords[, 1] <- coords[,1] - offset

  idx <- (coords[,2] - 1L) * rows + coords[,1]
  idx
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Matrix manipulation functions. Nothing fancy - only called during setup.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rot90 <- function(x) {
  x <- t(x)
  x <- x[rev(seq(nrow(x))),,drop=FALSE]
  x
}

rot180 <- function(x) rot90(rot90(x))
rot270 <- function(x) rot90(rot90(rot90(x)))

mirror <- function(x) {
  x[rev(seq(nrow(x))), , drop=FALSE]
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Convert the pentomino matrices into lists of indices
#
# Add all rotated versions of all pieces as well.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
all_pents <- map(pent_mats, function(x) {
  list(
    piece_to_idx(x        , rows = nrow(board)),
    piece_to_idx(rot90(x) , rows = nrow(board)),
    piece_to_idx(rot180(x), rows = nrow(board)),
    piece_to_idx(rot270(x), rows = nrow(board))
  )
})


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Pieces which need to also have mirrored counterparts
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mirror_pieces <- c('F', "L", 'P', 'N', 'Y', 'Z')

for (letter in mirror_pieces) {
  x <- mirror(pent_mats[[letter]])
  all_pents[[letter]][[5]] <- piece_to_idx(  x        , rows = nrow(board))
  all_pents[[letter]][[6]] <- piece_to_idx(  rot90(x) , rows = nrow(board))
  all_pents[[letter]][[7]] <- piece_to_idx(  rot180(x), rows = nrow(board))
  all_pents[[letter]][[8]] <- piece_to_idx(  rot270(x), rows = nrow(board))
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Remove duplicates.
#  *  'I' piece only exists as horizontal and vertical. Rotated versions are dupes.
#  * 'X' only needs a single piece as all rotations are identical
#  * 'Z' some rotations are duplicates of existing
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
all_pents[['I']][[4]] <- NULL
all_pents[['I']][[3]] <- NULL

all_pents[['X']][[4]] <- NULL
all_pents[['X']][[3]] <- NULL
all_pents[['X']][[2]] <- NULL


all_pents[['Z']][[8]] <- NULL
all_pents[['Z']][[7]] <- NULL
all_pents[['Z']][[4]] <- NULL
all_pents[['Z']][[3]] <- NULL


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Assign a number ('val') to use for each piece. This is the number that will be
# written to the 'board' matrix for this piece.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
all_pents <- map(1:12, function(x) {
  list(
    val = x,
    piece_indices = all_pents[[x]]
  )
})


#=============================================================================
#=============================================================================
#
# Everything above this comment is just prepping the data structures
#
# Everything below this comment is the recursive backtracking
#
#=============================================================================
#=============================================================================



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Place a piece on the board
#'
#' @param board integer matrix of an appropriate size
#' @param idx location on board to place piece
#' @param piece_indices integer vector of offsets which define the piece
#' @param val integer value to write into the board
#'
#' @return copy of 'board' with piece if placement is valid. Otherwise 'NULL'
#' @example
#' place_piece(board, 106, all_pents[[12]]$piece_indices[[1]], 99)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
place_piece <- function(board, idx, piece_indices, val) {

  current_vals <- board[idx + piece_indices]
  if (any(current_vals > 0)) {
    return(NULL)
  }

  board[idx + piece_indices] <- val

  board
}


count <- 0L
zz <- NULL

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Fill a board with the given set of pentominos
#'
#' Recursive placement of pentominos with backtracking
#'
#' @param board integer matrix
#' @param pents list of pentoninos i.e. `all_pents`
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fill_board <- function(board, pents) {

  # Ran out of pentominos => must be a solution!
  if (length(pents) == 0L) {
    count <<- count + 1L

    # Save image
    if (FALSE) {
      filename <- sprintf("images/%04i.png", count)
      png(filename, width = 480, height = 320)
      par(mar=c(0, 0, 0, 0))
      plot_board(board)
      dev.off()
    }

    # be verbose about number of solutions found so far
    if (count %% 100 == 0) cat(count, "")

    return()
  }

  # Where's the next location in the board that we can place a pentomino?
  idx <- which(board == 0)[1]

  # Try and place each pentomino at the current position.
  # If the placement is valid, recursively call 'fill_board' with the
  # latest version of the board, and the updated list of pentominos
  for (i in seq_along(pents)) {
    val <- pents[[i]]$val
    all_piece_indices <- pents[[i]]$piece_indices
    for (piece_indices in all_piece_indices) {
      new_board <- place_piece(board, idx, piece_indices, val = val)
      if (!is.null(new_board)) {
        fill_board(new_board, pents[-i])
      }
    }
  }

}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# It takes about 15 minutes to generate all 9356 solutions - about 10 solns/second
# Note: Mirrored and flipped solutions are included.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fill_board(board, all_pents)

Introducing {wingspan} - data about the cards in the Wingspan boardgame

Mon, 18 Jan 2021 20:10:00 +1000

Wingspan

The R {wingspan} package makes available information about the birds and bonus cards in the boardgame wingspan

Wingspan (the boardgame) was designed by Elizabeth Hargrave, with art by Natalia Rojas, Ana Maria Martinez Jaramillo, and Beth Sobel

The boardgame is a competitive, medium-weight, card-driven, engine-building board game, and is absolutely delightful!

This package just provides stats and data on the cards in the box - it won’t really help you to play the game, and doesn’t include any of the amazing artwork; it’s just the facts about all birds and bonus cards as collected by TawnyFrogmouth at BoardGameGeek (original data).

What’s in the box

birds a data.frame of information about each of the cards in the base game and the expansions (europe and oceania)
bonus_cards information about the cards used to give you a bonus at the end of the game (based upon the numbers of birds of different types you accumulate during the game)

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/wingspan')

Example Bird Data

Some of the stats for the 2 birds at the bottom of this image are shown below.

library(dplyr)
library(wingspan)

wingspan::birds %>% 
  filter(common_name %in% c('Barn Swallow', 'Peregrine Falcon')) %>%
  select(common_name, scientific_name, points = victory_points, predator, 
         egg_capacity, nest_type, total_food_cost) %>%
  knitr::kable()

common_name	scientific_name	points	predator	egg_capacity	nest_type	total_food_cost
Barn Swallow	Hirundo rustica	1	FALSE	3	Wild	1
Peregrine Falcon	Falco peregrinus	5	TRUE	2	Platform	2

Example Summary Plot

library(ggplot2)

ggplot(birds, aes(as.factor(total_food_cost), victory_points)) + 
  geom_boxplot() + 
  theme_bw() + 
  labs(
    x = "Total food cost to play bird card",
    y = "Bird value (Victory points at end of game)",
    title = "Birds with higher total food cost score more victory points"
  ) + 
  scale_y_continuous(breaks = 0:10)

Acknowledgements

TawnyFrogmouth at BoardGameGeek for collating and sharing the data
Stonemeier games for releasing such a delicious game
R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing flexo - simple lex/parse tools in R

Mon, 07 Dec 2020 20:20:00 +1000

flexo: Simple Lex/Parse Tools in R

flexo provides tools for simple tokenising/lexing/parsing of text files.

flexo aims to be useful in getting otherwise unsupported text data formats into R.

For complicated parsing (e.g. programming languages) you’ll want to use the more formally correct lexing/parsing provided by the rly package or the dparser package.

flexo is a replacement for minilexer (which should now be considered abandoned).

What’s in the box

lex(text, regexes) break a text string into tokens using the supplied regular expressions
TokenStream is an R6 class for manipulating a stream of tokens - a first step for parsing the data into a more useful format

Installation

You can install flexo from github coolbutuseless/flexo with

# install.packages('remotes')
remotes::install_github('coolbutuseless/flexo', ref='main')

Usage Overview

Define a set of regular expressions (regexes) that define the tokens in the data
Call lex() to use these regexes to split data into tokens i.e. lex(text, regexes)
lex() returns a named character vector of tokens. The names of the tokens correspond to the respective regex which captured it.
Optionally use the TokenStream R6 class to aid in the manipulation of the raw tokens into more structured data.

Vignettes

Example: Using `lex()` to split sentence into tokens

sentence_regexes <- c(
  word        = "\\w+", 
  whitespace  = "\\s+",
  fullstop    = "\\.",
  comma       = ","
)

sentence = "Hello there, Rstats."

flexo::lex(sentence, sentence_regexes)

      word whitespace       word      comma whitespace       word   fullstop 
   "Hello"        " "    "there"        ","        " "   "Rstats"        "."

Example: Using `lex()` to split some simplified R code into tokens

R_regexes <- c(
  number      = "-?\\d*\\.?\\d+",
  name        = "\\w+",
  equals      = "==",
  assign      = "<-|=",
  plus        = "\\+",
  lbracket    = "\\(",
  rbracket    = "\\)",
  newline     = "\n",
  whitespace  = "\\s+"
)

R_code <- "x <- 3 + 4.2 + rnorm(1)"

R_tokens <- flexo::lex(R_code, R_regexes)
R_tokens

      name whitespace     assign whitespace     number whitespace       plus 
       "x"        " "       "<-"        " "        "3"        " "        "+" 
whitespace     number whitespace       plus whitespace       name   lbracket 
       " "      "4.2"        " "        "+"        " "    "rnorm"        "(" 
    number   rbracket 
       "1"        ")"

Example: Using `lex()` with `TokenStream`

Once lex() is used to create the separate tokens, the next step is to intepret the token sequence into something much more structured e.g. a data.frame or matrix.

The example below shows flexo being used to to parse a hypothetical tic-tac-toe game format into a matrix.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# A tough game between myself and Kasparov (my pet rock)
# The comment line denotes who the game was between
# Each square is marked with an 'X' or 'O'
# After each X and O is a number indicating the order in which the mark
# appeared on the board.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
game <- "
# Kasparov(X) vs Coolbutuseless(O)
  X2 | O1 | O5 
  O3 | X4 | X6
  X7 | O8 | X9
"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define all the regexes to split the game into tokens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
game_regexes <- c(
  comment     = "(#.*?)\n", 
  whitespace  = "\\s+",
  sep         = "\\|",
  mark        = "X|O",
  order       = flexo::regex$number
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use flexo::lex() to break game into tokens with these regexes
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tokens <- flexo::lex(game, game_regexes)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Remove some tokens that don't contain actual information
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tokens <- tokens[!names(tokens) %in% c('whitespace', 'comment', 'sep')]

tokens

 mark order  mark order  mark order  mark order  mark order  mark order  mark 
  "X"   "2"   "O"   "1"   "O"   "5"   "O"   "3"   "X"   "4"   "X"   "6"   "X" 
order  mark order  mark order 
  "7"   "O"   "8"   "X"   "9"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a TokenStream object for help in manipulating the tokens
# Obviously there are easier ways to do this on such a simple example, but 
# the below example is hopefully illustrative of the technique
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
stream <- TokenStream$new(tokens)

mark  <- c()
order <- c()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Keep processing all the tokens until done.  
# The tokens should exist in pairs of 'mark' and 'order', so assert that pairing
# Consume and store the values from the stream into 'mark' and 'order' vectors
# Bind all the information into a matrix
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
while (!stream$end_of_stream()) {
  stream$assert_name_seq(c('mark', 'order'))
  mark  <- c(mark , stream$consume(1))
  order <- c(order, stream$consume(1))
}

cbind(mark, order)

     mark order
mark "X"  "2"  
mark "O"  "1"  
mark "O"  "5"  
mark "O"  "3"  
mark "X"  "4"  
mark "X"  "6"  
mark "X"  "7"  
mark "O"  "8"  
mark "X"  "9"

Introducing ggrgl - a 3d extension to ggplot

Wed, 02 Dec 2020 21:20:00 +1000

ggrgl

ggrgl extends ggplot2 into the third dimension.

ggrgl does this by adding a new z aesthetic which is respected when a plot is rendered to the {devoutrgl} device which renders to OpenGL via {rgl}.

Because {devoutrgl} is an interactive device, the view of the plot may be manipulated by the user - zoom, rotate, change field-of-view etc.

Slideshow

Note: interactive 3d plots cannot be displayed in a github README file, and static images or animated gifs are used here instead.

Visit the pkgdown online documentation to view plots which can be manipulated in the browser.

Installation

A lot of support packages are needed for ggrgl - most of which should already be installed if you have ggplot.

Custom packages which are needed (and not currently on CRAN):

devout - The core package for writing graphics devices using R (rather than C).
devoutrgl - a graphics device which renders to {rgl}
triangular - decompaose polygons into triangles for 3d rendering. Much faster than rgl::triangulate()
snowcrash - a package for encoding objects as images - needed to circumvent limitations in the device system provided by R
cryogenic - a package for capturing a call to be evaluated later. Calls to generate 3d geometry are generated when plot object is created, but not executed until later when the plot is actually rendered to screen.

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/devout')
remotes::install_github('coolbutuseless/devoutrgl')
remotes::install_github('coolbutuseless/triangular')
remotes::install_github('coolbutuseless/snowcrash')
remotes::install_github('coolbutuseless/cryogenic')
remotes::install_github('coolbutuseless/ggrgl', ref='main')

New `z` Aesthetic

The new z aesthetic works the same as the x and y aesthetics in ggplot2.

z may be mapped to a data variable or set to a constant.

New Extrusion Aesthetics

When graphical elements have a z value they are raised above the ground.

By setting extrude = TRUE (on geoms which support it), then the raised element is connected to the ground as if it were extruded from it.

New aesthetics control the appearance of the extruded faces and edges:

aesthetic	Description	default
extrude_z	Lower limit of extrusion	0.05
extrude_face_fill	Extruded face colour	grey20
extrude_face_alpha	Extruded face alpha	1
extrude_edge_colour	Edge colour for extrusion	NA
extrude_edge_alpha	Edge alpha for extrusion	1
extrude_edge_size	Width of line for extruded edges	1

3-dimensional Geometry Types: `z` and `3d`

ggrgl defines 2 classes of geoms: z and 3d

z geoms are identical to their ggplot2 counterparts, except the entire shape may be raised (as a unit) in the z direction. The resulting geometry will still be planar, and parallel to the original plotting surface.
3d geoms allow for full specification of (x, y, z) locations. Their orientation is not constrained to be planar, or parallel to the original plotting surface.

Click on a geom in the following table to view its vignette

ggplot2	Planar Z offset	3d
geom_bar	geom_bar_z
geom_contour	geom_contour_z
geom_contour_filled	geom_contour_filled_z
geom_density	geom_density_z
geom_line		geom_line_3d
geom_path		geom_path_3d
geom_point	geom_point_z	geom_sphere_3d
geom_polygon	geom_polygon_z
geom_rect	geom_rect_z
geom_ribbon	geom_ribbon_z
geom_segment		geom_segment_3d
geom_text	geom_text_z
geom_tile	geom_tile_z

Vignettes

There are vignettes on all the new geoms in this package, see links in the table above or click on an image below

Some vignettes with some details of the implementation and usage are:

Technical Overview gives some details on how the 3d geometry is communicated internally
Z Scaling shows examples how the scaling of the Z coordinate may be controlled.
Keep 2d ‘shadows’ demonstrates how the 2d shadow of 3d geometry may be kept for some supported geoms.

To see all vignettes see the online documentation

Example - A Basic 3d Bar Plot with `geom_bar_z()`

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use `geom_bar_z` and set `z` to 200 and use extrusion
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
p <- ggplot(mpg) +
  geom_bar_z(aes(x=class, fill=class), colour='black', z=200, extrude=TRUE)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Render Plot in 3d with {devoutrgl}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
devoutrgl::rgldev()
p
invisible(dev.off())

Acknowledgements

Hadley Wickham, Thomas Lin Pedersen and others for developing and maintaining ggplot2
Michael Sumner + Tyler Morgan-Wall on twitter for their in-depth technical advice on graphics and 3d in R
R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Demo: Rendering Images in Polygons with {ggplot2} and {ggpattern}

Wed, 18 Nov 2020 08:00:00 +1000

After seeing a wonderful plot by darwinanddavis on twitter, I was reminded that I need to address some bugs in {ggpattern}.

Instead I made a plot with kittens as the texture for a map of Australia.

A worthwhile diversion!

library(dplyr)
library(ggplot2)
# remotes::install_github("coolbutuseless/ggpattern")
library(ggpattern)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fetch the map data as a data.frame
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
oz_df <- ggplot2::map_data('world', 'australia') 
mainland_df <- oz_df %>% filter(
  is.na(subregion)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Render the whole of australia (including islands) as a polygon 
# Render mainland australia with kittens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot() + 
  geom_polygon(data = oz_df, mapping = aes(long, lat, group = group)) + 
  geom_polygon_pattern(data = mainland_df, mapping = aes(long, lat, group = group), 
                       pattern = 'placeholder', pattern_type = 'kitten') + 
  coord_equal() + 
  theme_bw() + 
  labs(
    title = "ggpattern::geom_polygon_pattern(..., pattern = 'placeholder')",
    subtitle = "pattern_type = 'kitten'"
  )

Play Zork in RStats

Sun, 15 Nov 2020 10:00:00 +1000

Frotz is an Infocom Z-Machine interpreter for playing text adventure games (also known as interactive fiction) such as Zork and Hitchhiker’s Guide to the Galaxy.

Here I’m using {processx} to read/write to frotz on the command line.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Play Zork in the R console with 'frotz' + {processx}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
play_zork <- function(game = "../infocom/zork.z3") {

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Initialise Game
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  sf  <- process$new('dfrotz', args = c(game),
                     stdin = '|', stdout = '|', stderr = '|')
  Sys.sleep(0.1)
  cat(sf$read_output())

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Game Loop
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  while(TRUE && sf$is_alive()) {
    cmd <- readline(">>> ")
    if (cmd == 'Q')  {sf$kill(); break }
    sf$write_input(paste(cmd, "\n"))
    Sys.sleep(0.1)
    cat(gsub("\\s+>$", "", trimws(sf$read_output())), "\n")
  }
}

play_zork()

{emphatic} v0.1.3 - highlight data.frame output with ANSI - Added legends & support for vectors

Wed, 11 Nov 2020 07:00:00 +1000

emphatic

`{emphatic}` augments the output of data.frames, matrices and vectors in R by adding user-defined ANSI highlighting.

{emphatic} v0.1.3 Update

This update adds:

support for simple atomic vectors
option to add legends when colour is applied using ggplot2 colour scales

Support for Vectors (1)

A simple random vector

v <- sample(letters[1:5], 50, TRUE, (1:5)^2)
v

 [1] "d" "e" "e" "e" "c" "e" "d" "c" "b" "e" "c" "e" "e" "b" "e" "d" "b" "d" "b"
[20] "c" "d" "a" "d" "d" "d" "c" "d" "c" "d" "d" "d" "e" "c" "d" "d" "b" "d" "d"
[39] "e" "e" "b" "e" "d" "e" "c" "e" "c" "c" "d" "d"

Highlight vector where a value is the third-identical-value-in-a-row

v %>%
  hl_vec('red', .x == lag(.x) & .x == lag(lag(.x)))

[ 1] "d" "e" "e" "e" "c" "e" "d" "c" "b" "e" "c" "e" "e" "b" "e" "d" "b" "d" "b"
[20] "c" "d" "a" "d" "d" "d" "c" "d" "c" "d" "d" "d" "e" "c" "d" "d" "b" "d" "d"
[39] "e" "e" "b" "e" "d" "e" "c" "e" "c" "c" "d" "d"

Support for Vectors (2)

A simple random vector

v <- sample(5, 50, TRUE, (1:5)^2)
v

 [1] 4 5 5 5 3 5 4 3 2 5 3 5 5 2 5 4 2 4 2 3 4 1 4 4 4 3 4 3 4 4 4 5 3 4 4 2 4 4
[39] 5 5 2 5 4 5 3 5 3 3 4 4

Highlight vector with a colour scale

v %>%
  hl_vec(scale_colour_viridis_c())

[ 1] 4 5 5 5 3 5 4 3 2 5 3 5 5 2 5 4 2 4 2 3 4 1 4 4 4 3 4 3 4 4 4 5 3 4 4 2 4 4
[39] 5 5 2 5 4 5 3 5 3 3 4 4

Highlight vector with a colour scale. Include legend

v %>%
  hl_vec(scale_colour_viridis_c(), show_legend = TRUE)

[ 1] 4 5 5 5 3 5 4 3 2 5 3 5 5 2 5 4 2 4 2 3 4 1 4 4 4 3 4 3 4 4 4 5 3 4 4 2 4 4
[39] 5 5 2 5 4 5 3 5 3 3 4 4

legend:  1.0 1.5 2.0 2.5 3.0 3.5 4.0 4.5 5.0

Legends

Legends can be added whenever a ggplot2 colour scale is used to highlight an object.

mtcars %>%
  head() %>%
  hl(scale_colour_viridis_c(), cols = mpg, dest_cols = .all, show_legend = TRUE)

                     mpg cyl disp  hp drat    wt  qsec vs am gear carb
Mazda RX4           21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
Mazda RX4 Wag       21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
Datsun 710          22.8   4  108  93 3.85 2.320 18.61  1  1    4    1
Hornet 4 Drive      21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
Hornet Sportabout   18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
Valiant             18.1   6  225 105 2.76 3.460 20.22  1  0    3    1

mpg:  18.5 19.0 19.5 20.0 20.5 21.0 21.5 22.0 22.5

Multiple Legends

Multiple legends are possible, but there’s definitely diminishing returns in interpretability.

mtcars %>%
  head() %>%
  mutate(cyl = as.factor(cyl)) %>%
  hl(scale_colour_viridis_c(), cols = mpg, show_legend = TRUE) %>%
  hl(scale_colour_discrete(), cols = cyl, show_legend = TRUE)

     mpg cyl disp  hp drat    wt  qsec vs am gear carb
1   21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
2   21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
3   22.8   4  108  93 3.85 2.320 18.61  1  1    4    1
4   21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
5   18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
6   18.1   6  225 105 2.76 3.460 20.22  1  0    3    1

mpg:  18.5 19.0 19.5 20.0 20.5 21.0 21.5 22.0 22.5
cyl:  4 6 8

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/emphatic')

See the online documentation for vignettes and more examples.

Slideshow

A Chess Engine in RStats (Proof-of-Concept using Stockfish)

Thu, 05 Nov 2020 20:10:00 +1000

The Queen’s Gambit - Post 5

Inspired by The Queen’s Gambit on Netflix, I’m doing a few posts on Chess in R.

This screenshot from the show explains everything:

Stockfish

stockfish is a free, open source chess engine which implements the UCI (Universal Chess Interface)

Installation of Stockfish

On MacOS (with homebrew installed): brew install stockfish

See the stockfish website for more details on installation on your system

`{processx}`

To interface with Stockfish (a command line/terminal program) I’m using processx.

processx is a package for executing and controlling subprocesses (like a command like program) from R. You can write to the program’s stdin and then read what it outputs (stdout).

Simple interfacing with Stockfish using `{processx}`

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Run 'stockfish' on the command line and set up pipes so we can send and 
# receive messages from stdin and stdou
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sf  <- process$new('stockfish', stdin = '|', stdout = '|', stderr = '|')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# UCI standard says that you should always request 'uci' from whatever ches
# ending you're using.  This outputs the configuration in stockfish
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sf$write_input('uci\n')
cat(sf$read_output_lines())

## Stockfish 12 by the Stockfish developers (see AUTHORS file)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise the board to the opening state and a couple of basic moves.
# There's no "opening book" in stockfish
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sf$write_input('position startpos moves e2e4 e7e5\n')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Ask stockfish to think about this move for 0.1 second (100 ms)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sf$write_input('go movetime 100\n')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# wait for Stockfish to think 
# Need to be certain that it finishes and prints out its move
# Note: probably nicer ways to wait via processx, but haven't dug deep enough yet
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sys.sleep(1)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Get all the output that stockfish produces.
# There's a lot of lines that start with 'info' which are steps along its
# thinking process.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sf_response <- sf$read_output_lines()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# The only line that i'm interested in is the last one which is the 
# description of the 'bestmove'
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
best_move_line <- tail(sf_response, 1)
best_move      <- strsplit(best_move_line, " ")[[1]][2]
best_move_line

## [1] "bestmove g1f3 ponder g8f6"

best_move

## [1] "g1f3"

Stockfish-based Chess game in RStats

The following code is a very rough chess engine in R using Stockfish to make the computer’s moves.

Instructions:

Enter Your Move: in Long Algebraic Notation (LAN)
- e.g. e2e4 is a valid opening move
- The first 2 symbols are the starting location e2 i.e. White King’s Pawn
- The second 2 symbols are the destination e4 i.e. the fourth row in column e
The computer will make a move (after thinking for 0.1 seconds)
Enter q to quit when it’s your turn to move.

Limitiations:

no move validation, so there’s no prevention of impossible moves.
- What stockfish does with impossible moves is undefined as far as I know.
No detection of ‘end-of-game’
no castling
I’ve given Stockfish very little thinking time by default (0.1s) - feel free to make this longer if you need a challenge.

Click to reveal/hide support functions

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Convert a FEN string to a char matrix representing the chess board.
#' 
#' @param fen fen string
#' 
#' @return 8x8 character matrix representing the chess board
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fen_to_matrix <- function(fen) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Currently only interested in 1st field in fen i.e. piece placement
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  pieces <- strsplit(fen, ' ')[[1]][1]
  rows   <- strsplit(pieces, "/")[[1]]
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Replaces digits with the number of spaces they represent
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (i in 1:8) {
    rows <- gsub(i, paste(rep(' ', i), collapse=''), rows)
  }
  
  matrix(unlist(strsplit(rows, '')), 8, 8, byrow = TRUE, list(c(8:1), letters[1:8]))
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create a plot of the state of a chess board from a FEN string
#'
#' @param fen FEN string
#'
#' @return ggplot2 object
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
plot_board <- function(mat) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Unicode chars for chess pieces
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  unicode <- c(
    ` ` = '',
    P='\u2659', R='\u2656', N='\u2658', B='\u2657', Q='\u2655', K='\u2654', # White
    p='\u265F', r='\u265C', n='\u265E', b='\u265D', q='\u265B', k='\u265A'  # Black
  )
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Convert the matrix chess board to a data.frame
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  board <- expand.grid(x=1:8, y=1:8) %>%
    mutate(
      tilecol = (x+y)%%2 == 1,
      piece  = as.vector(t(mat[8:1,])),
      colour = piece %in% letters,
      unicode = unicode[piece]
    )
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Create plot
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  p <- ggplot(board, aes(x, y)) + 
    geom_tile(aes(fill = tilecol), colour = 'black', show.legend = FALSE) + 
    geom_text(aes(label = unicode), family="Arial Unicode MS", size = 8) + 
    coord_equal() + 
    scale_fill_manual(values = c('grey50', 'grey95')) +
    scale_y_continuous(breaks = 1:8) + 
    scale_x_continuous(breaks = 1:8, labels = letters[1:8]) +
    theme_bw() +
    theme(
      axis.title      = element_blank(),
      plot.background = element_blank(),
      panel.grid      = element_blank(),
      panel.border    = element_blank(),
      axis.ticks      = element_blank()
    )
  
  plot(p)
  
  invisible()
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Super basic Long Annoation to matrix coordinates
# 
# @param lan e.g. e2e5
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
lan_to_coords <- function(lan) {
  stopifnot(nchar(lan) == 4)
  lan <- tolower(lan)
  
  bits <- strsplit(lan, '')[[1]]
  bits[1] <- match(bits[1], letters[1:8])
  bits[3] <- match(bits[3], letters[1:8])
  bits <- as.integer(bits)
  
  list(
    start = matrix(c(9 - bits[2], bits[1]), nrow = 1),
    end   = matrix(c(9 - bits[4], bits[3]), nrow = 1)
  )
  
}

library(ggplot2)
library(processx)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Start the Stockfish proces
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sf  <- process$new('stockfish', stdin = '|', stdout = '|', stderr = '|')
sf$write_input('uci\n')
jnk <- sf$read_output_lines()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise board (i.e. matrix) to opening position
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fen <- 'rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1'
board <- fen_to_matrix(fen)
plot_board(board)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Keep track of all the moves played. This list of moves is fed to Stockfish
# every time, and then it decides what the next move should be
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
all_moves <- c()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#
# Game Loop
#
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
while(TRUE) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Ask user for a move and add it to the list of all moves
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  move_lan <- readline("Your move?   : ")
  if (move_lan %in% c('', 'q', 'Q', 'quit')) {
    message("Done")
    break
  }
  
  all_moves <- c(all_moves, move_lan)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Validate move
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Not done yet
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Move the piece on the local board
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  move_coords <- lan_to_coords(move_lan)
  if (board[move_coords$start] %in% c(NA, ' ', '')) {
    stop("Bad move given current board state: ", best_move)
  }
  board[move_coords$end  ] <- board[move_coords$start]
  board[move_coords$start] <- ' '
  plot_board(board)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Tell stockfish about the move
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  moves <- paste(all_moves, collapse = " ")
  cmd   <- paste('position startpos moves', moves, '\n')
  # print(cmd)
  sf$write_input(cmd)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Ask stockfish to consider the next move for 0.1 seconds
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  sf$write_input('go movetime 100\n')
  Sys.sleep(0.2)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Extract the best move from output from Stockfish
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  sf_response    <- sf$read_output_lines()
  best_move_line <- tail(sf_response, 1)
  best_move      <- strsplit(best_move_line, " ")[[1]][2]
  cat("Computer move:", best_move, "\n")
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Add the computers move
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  all_moves <- c(all_moves, best_move)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Move the piece on the local board
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  move_coords <- lan_to_coords(best_move)
  if (board[move_coords$start] %in% c(NA, ' ', '')) {
    stop("Bad move given current board state: ", best_move)
  }
  board[move_coords$end  ] <- board[move_coords$start]
  board[move_coords$start] <- ' '
  plot_board(board)
}

Parsing Forsyth Edwards Notation for Chess in RStats

Thu, 05 Nov 2020 06:10:00 +1000

The Queen’s Gambit - Post 4

Inspired by The Queen’s Gambit on Netflix, I’m doing a few posts on Chess in R.

This screenshot from the show explains everything:

Forsyth-Edwards Notation (FEN)

Forsyth-Edwards Notation (FEN) is a short ascii description of the state of play of a game of chess.

See the article on wikipedia for a more complete description.

Examples of FEN

Initial state of a chess game

rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1

This is an actual board state when opening with the queen’s gambit.

rnbqkbnr/ppp1pppp/8/3p4/2PP4/8/PP2PPPP/RNBQKBNR b KQkq c3 0 2

FEN format

A FEN record contains six fields. The separator between fields is a space. The fields are:[5]

Piece placement (from White’s perspective). Each rank is described, starting with rank 8 and ending with rank 1; within each rank, the contents of each square are described from file “a” through file “h”. Following the Standard Algebraic Notation (SAN), each piece is identified by a single letter taken from the standard English names (pawn = “P”, knight = “N”, bishop = “B”, rook = “R”, queen = “Q” and king = “K”). White pieces are designated using upper-case letters (“PNBRQK”) while black pieces use lowercase (“pnbrqk”). Empty squares are noted using digits 1 through 8 (the number of empty squares), and “/” separates ranks.
Active color. “w” means White moves next, “b” means Black moves next.
Castling availability. If neither side can castle, this is “-”. Otherwise, this has one or more letters: “K” (White can castle kingside), “Q” (White can castle queenside), “k” (Black can castle kingside), and/or “q” (Black can castle queenside). A move that temporarily prevents castling does not negate this notation.
En passant target square in algebraic notation. If there’s no en passant target square, this is “-”. If a pawn has just made a two-square move, this is the position “behind” the pawn. This is recorded regardless of whether there is a pawn in position to make an en passant capture.[6]
Halfmove clock: This is the number of halfmoves since the last capture or pawn advance. The reason for this field is that the value is used in the fifty-move rule.[7]
Fullmove number: The number of the full move. It starts at 1, and is incremented after Black’s move.

Parsing Piece Placement from a FEN record

The following code is only determining the placement of pieces on the board. All other information is ignored.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Convert a FEN string to a char matrix representing the chess board.
#' 
#' @param fen fen string
#' 
#' @return 8x8 character matrix representing the chess board
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fen_to_matrix <- function(fen) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Currently only interested in 1st field in fen i.e. piece placement
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  pieces <- strsplit(fen, ' ')[[1]][1]
  rows   <- strsplit(pieces, "/")[[1]]
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Replaces digits with the number of spaces they represent
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (i in 1:8) {
    rows <- gsub(i, paste(rep(' ', i), collapse=''), rows)
  }
  
  matrix(unlist(strsplit(rows, '')), 8, 8, byrow = TRUE, list(c(8:1), letters[1:8]))
}


fen <- 'rnbqkbnr/ppp1pppp/8/3p4/2PP4/8/PP2PPPP/RNBQKBNR b KQkq c3 0 2'
fen_to_matrix(fen)

##   a   b   c   d   e   f   g   h  
## 8 "r" "n" "b" "q" "k" "b" "n" "r"
## 7 "p" "p" "p" " " "p" "p" "p" "p"
## 6 " " " " " " " " " " " " " " " "
## 5 " " " " " " "p" " " " " " " " "
## 4 " " " " "P" "P" " " " " " " " "
## 3 " " " " " " " " " " " " " " " "
## 2 "P" "P" " " " " "P" "P" "P" "P"
## 1 "R" "N" "B" "Q" "K" "B" "N" "R"

Tighter matrix output

mat <- fen_to_matrix(fen)
mat[mat ==' '] <- '.'
cat(apply(mat, 1, paste, collapse=''), sep="\n")

## rnbqkbnr
## ppp.pppp
## ........
## ...p....
## ..PP....
## ........
## PP..PPPP
## RNBQKBNR

Add a splash of colour with `{emphatic}`

# remotes::install_github('coolbutuseless/emphatic')
library(emphatic)
library(dplyr)
hl_opt_global(dark_mode = FALSE)

mat <- fen_to_matrix(fen) 
mat[] <- paste0(mat, ' ')

mat %>% 
  hl_matrix('grey90') %>% 
  hl_matrix('grey10', selection = (row(.x) + col(.x)) %% 2 == 1)

     a  b  c  d  e  f  g  h
8   r  n  b  q  k  b  n  r 
7   p  p  p     p  p  p  p 
6                          
5            p             
4         P  P             
3                          
2   P  P        P  P  P  P 
1   R  N  B  Q  K  B  N  R

ggplot of the board state from a FEN

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create a plot of the state of a chess board from a FEN string
#'
#' @param fen FEN string
#'
#' @return ggplot2 object
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_fen_plot <- function(fen) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Convert fen to matrix
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  mat <- fen_to_matrix(fen)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Unicode chars for chess pieces
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  unicode <- c(
    ` ` = '',
    P='\u2659', R='\u2656', N='\u2658', B='\u2657', Q='\u2655', K='\u2654', # White
    p='\u265F', r='\u265C', n='\u265E', b='\u265D', q='\u265B', k='\u265A'  # Black
  )
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Convert the matrix chess board to a data.frame
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  board <- expand.grid(x=1:8, y=1:8) %>%
    mutate(
      tilecol = (x+y)%%2 == 1,
      piece  = as.vector(t(mat[8:1,])),
      colour = piece %in% letters,
      unicode = unicode[piece]
    )
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Create plot
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ggplot(board, aes(x, y)) + 
    geom_tile(aes(fill = tilecol), colour = 'black', show.legend = FALSE) + 
    geom_text(aes(label = unicode), family="Arial Unicode MS", size = 8) + 
    coord_equal() + 
    theme_void() +
    scale_fill_manual(values = c('grey50', 'grey95'))  +
    labs(
      title = "Forsyth-Edwards Notation of the Queen's Gambit in #RStats",
      subtitle = fen
    )
  
}


create_fen_plot(fen)

Convert a matrix of chess locations into FEN

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Matrix to Forsyth-Edwards Notation notation
#'
#' This function only considers piece positions. All other information is
#' filled in with dummy values e.g. next move is always set to white (0)
#'
#' @param mat 8x8 character matrix of chess locations. 
#'
#' @return Single character string containing board status in Forsyth-Edwards Notation
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
matrix_to_fen <- function(mat) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Sanity check board
  # Empty board spaces must be a single blank character
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  stopifnot(is.character(mat))
  stopifnot(nrow(mat) == 8, ncol(mat) == 8)
  mat[is.na(mat) | mat == ''] <- ' '
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Collapse each row
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  rows <- apply(mat, 1, paste, collapse='')
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Replace runs of spaces with the integer count of spaces
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (i in 8:1) {
    rows <- gsub(paste(rep(' ', i), collapse=''), i, rows)
  }
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # piece position is rows concatentated with "/" as dividing character
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  pieces <- paste(rows, collapse="/")

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  
  # Remaining information filled out with dummy values
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  
  move      <- 'w'
  castling  <- 'KQkq'
  enpassant <- '-'
  halfmove  <- 0
  fullmove  <- 1

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Concatenate all the information together - separated by spaces
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  
  paste(pieces, move, castling, enpassant, halfmove, fullmove)
}


fen

## [1] "rnbqkbnr/ppp1pppp/8/3p4/2PP4/8/PP2PPPP/RNBQKBNR b KQkq c3 0 2"

mat <- fen_to_matrix(fen) 
mat

##   a   b   c   d   e   f   g   h  
## 8 "r" "n" "b" "q" "k" "b" "n" "r"
## 7 "p" "p" "p" " " "p" "p" "p" "p"
## 6 " " " " " " " " " " " " " " " "
## 5 " " " " " " "p" " " " " " " " "
## 4 " " " " "P" "P" " " " " " " " "
## 3 " " " " " " " " " " " " " " " "
## 2 "P" "P" " " " " "P" "P" "P" "P"
## 1 "R" "N" "B" "Q" "K" "B" "N" "R"

matrix_to_fen(mat)

## [1] "rnbqkbnr/ppp1pppp/8/3p4/2PP4/8/PP2PPPP/RNBQKBNR w KQkq - 0 1"

Parsing Chess PGN files in RStats

Wed, 04 Nov 2020 20:10:00 +1000

The Queen’s Gambit - Post 3

Inspired by The Queen’s Gambit on Netflix, I’m doing a few posts on Chess in R.

This screenshot from the show explains everything:

Chess game format: pgn

The pgn file format is a human readable representation of a chess game.

In its most basic form, it consists of

a sequence of tags (i.e. comments) surrounded by []
a sequence of numbers and events representing the moves taken by the players i.e.
- A number indicating which move this is within the game.
- Moves the for the white and black player represented in Standard Algebraic Notation (SAN).
Comments can be interspersed between/within the moves and are surrounded by “{}”

An example pgn file is show below:

alekhine_pgn <- r'{[Event "Vilnius All-Russian Masters"]
[Site "Vilna (Vilnius) RUE"]
[Date "1912.08.23"]
[EventDate "1912.08.19"]
[Round "5"]
[Result "0-1"]
[White "Alexander Alekhine"]
[Black "Akiba Rubinstein"]
[ECO "C83"]
[WhiteElo "?"]
[BlackElo "?"]
[PlyCount "54"]

1. e4 {Notes by Dr. Savielly Tartakower.} 1... e5 2. Nf3 Nc6 3. Bb5 a6 4. Ba4
Nf6 5. O-O Nxe4 6. d4 b5 7. Bb3 d5 8. dxe5 Be6 9. c3 Be7 10. Nbd2 Nc5 11. Bc2
Bg4 12. h3 {The most reasonable course here is 12.Re1, guarding the e-pawn.}
12... Bh5 13. Qe1 $6 {Here again 13. Re1 ensured a very good game for White.}
13... Ne6 14. Nh2 $6 Bg6 $1 15. Bxg6 fxg6 {! Far seeing strategy! Black
recognizes that the f-file and not the e-file will be needed as a base for
action.} 16. Nb3 {Or 16.f4 d4!.} 16... g5 $1 17. Be3 O-O 18. Nf3 Qd7 19. Qd2
{White pays insufficient attention to the scope of his opponent's threats. A
better course is 19.Nfd4 (19...Nxe5 20.Bxg5) seeking to establish equality.}
19... Rxf3 $1 20. gxf3 Nxe5 21. Qe2 Rf8 22. Nd2 Ng6 23. Rfe1 Bd6 24. f4 Nexf4
25. Qf1 Nxh3+ 26. Kh1 g4 27. Qe2 Qf5 0-1}'

Use `lex()` to turn the text into tokens

Start by defining the regular expression patterns for each element in the pgn file.
Use minilexer::lex() to turn the pgn text into tokens
Throw away whitespace, newlines and tags, since I’m not interested in them.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use the mini-lexer to break text into labelled tokens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# remotes::install_github('coolbutuseless/minilexer')
library(minilexer)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define all the patterns to match as regular expressions.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pgn_patterns <- c(
  tag           = '\\[.*?\\]',     # Capture tags as a unit
  comment       = "\\{.*?\\}",     # Capture comments as a unit
  resumption    = "\\d+\\.\\.\\.", # Resume moves after comment
  move_number   = "\\d+\\.",
  end_of_game   = '0-1|1-0|0-0|1/2-1/2',
  nag           = '\\$\\d+',      # Numeric annotation glyph
  move          = '[-+\\w\\./]+', # Anything else is a move
  newline       = '\n',
  whitespace    = '\\s+'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define some different sets of tokens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
chaff     <- c('whitespace', 'newline', 'tag')
non_moves <- c('comment', 'resumption', 'nag', 'end_of_game')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Parse a PGN file to tokens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pgn_text <- alekhine_pgn
pgn_text <- gsub("\n", ' ', pgn_text)
tokens   <- minilexer::lex(pgn_text, pgn_patterns)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Tidy the tokens
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tags   <- tokens[names(tokens) == 'tag']
tokens <- tokens[!(names(tokens) %in% chaff)]

head(tokens, 20)

##                           move_number                                  move 
##                                  "1."                                  "e4" 
##                               comment                            resumption 
## "{Notes by Dr. Savielly Tartakower.}"                                "1..." 
##                                  move                           move_number 
##                                  "e5"                                  "2." 
##                                  move                                  move 
##                                 "Nf3"                                 "Nc6" 
##                           move_number                                  move 
##                                  "3."                                 "Bb5" 
##                                  move                           move_number 
##                                  "a6"                                  "4." 
##                                  move                                  move 
##                                 "Ba4"                                 "Nf6" 
##                           move_number                                  move 
##                                  "5."                                 "O-O" 
##                                  move                           move_number 
##                                "Nxe4"                                  "6." 
##                                  move                                  move 
##                                  "d4"                                  "b5"

Final Game Record (after some manual tidying)

Tag	Value
Event	Vilnius All-Russian Masters
Site	Vilna (Vilnius) RUE
Date	1912.08.23
EventDate	1912.08.19
Round	5
Result	0-1
White	Alexander Alekhine
Black	Akiba Rubinstein
ECO	C83
WhiteElo	?
BlackElo	?
PlyCount	54

N	White	Black	Comment
1.	e4	e5	Notes by Dr. Savielly Tartakower.
2.	Nf3	Nc6
3.	Bb5	a6
4.	Ba4	Nf6
5.	O-O	Nxe4
6.	d4	b5
7.	Bb3	d5
8.	dxe5	Be6
9.	c3	Be7
10.	Nbd2	Nc5
11.	Bc2	Bg4
12.	h3	Bh5	The most reasonable course here is 12.Re1, guarding the e-pawn.
13.	Qe1	Ne6	Here again 13. Re1 ensured a very good game for White.
14.	Nh2	Bg6
15.	Bxg6	fxg6	! Far seeing strategy! Black recognizes that the f-file and not the e-file will be needed as a base for action.
16.	Nb3	g5	Or 16.f4 d4!.
17.	Be3	O-O
18.	Nf3	Qd7
19.	Qd2	Rxf3	White pays insufficient attention to the scope of his opponent’s threats. A better course is 19.Nfd4 (19…Nxe5 20.Bxg5) seeking to establish equality.
20.	gxf3	Nxe5
21.	Qe2	Rf8
22.	Nd2	Ng6
23.	Rfe1	Bd6
24.	f4	Nexf4
25.	Qf1	Nxh3+
26.	Kh1	g4
27.	Qe2	Qf5

Knight's Tour Problem

Tue, 03 Nov 2020 20:50:00 +1000

The Queen’s Gambit - Post 2

Inspired by The Queen’s Gambit on Netflix, I’m doing a few posts on Chess in R.

This screenshot from the show explains everything:

Introduction to the Knight’s Tour problem

The knight’s tour is a sequence of moves of a single knight such that it visits every square on the board once only.

The wikipedia page is a good starting resource.

This post contains:

A recursive function for finding a solution given a starting move: move_knight()
A solution to the knight’s tour that fits in a tweet

Recursive solution in R for the Knight’s Tour Problem

The following code finds an 8x8 knight’s tour in less than a second.

library(purrr)
library(dplyr)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Knight offsets i.e. the possible movements of a knight from the current location
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
knight_offsets <- matrix(c(
    1,    2,
    2,    1,
   -2,    1,
   -1,    2,
    2,   -1,
    1,   -2,
   -1,   -2,
   -2,   -1
), ncol = 2, byrow = TRUE)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Recurisvely calculate moves for a knight to complete a tour
#'
#' @param this_move proposed next move. 2 element numeric vector of (row, col)
#'        position at which to place the knight next
#' @param moves list of vectors. Each vector is length=2 and indicates the 
#'        row/column locations of the knight's tour so far
#' @param visited 8x8 logical matrix which indicates whether or not a square has been
#'        visited by the knight already. When called by the user, this matrix
#'        must only contain FALSE
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
move_knight <- function(this_move, moves, visited) {

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Mark the move as visited
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  moves <- append(moves, list(this_move))
  visited[this_move[1] + (this_move[2] - 1)*8] <- TRUE

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # termination if all visited
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (all(visited)) {
    return(moves)
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Find all possible moves from this position
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  next_move <- cbind(knight_offsets[,1] + this_move[1], knight_offsets[,2] + this_move[2])
  

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # keep only moves that remain on the board
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  on_board  <- next_move[,1] %in% 1:8 & next_move[,2] %in% 1:8
  next_move <- next_move[on_board,,drop=FALSE]

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Keep only moves that target a location that has not yet been visited
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  not_yet_visited <- !visited[next_move]
  next_move <- next_move[not_yet_visited,, drop = FALSE]

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Recurse over every possible next move
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (i in seq_len(nrow(next_move))) {
    res <- move_knight(next_move[i,, drop = FALSE], moves, visited)
    if (!is.null(res)) {
      return(res)
    }
  }

  NULL
}

Find a knight’s tour and plot it

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Find a tour from the given starting position
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
system.time({
  moves <- move_knight(c(4, 8), moves = list(), visited = matrix(FALSE, 8, 8))
})

##    user  system elapsed 
##   0.192   0.012   0.204

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Convert results to a data.frame for ggplot
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
moves_df <- as.data.frame(do.call(rbind, moves))
moves_df <- set_names(moves_df, c('x', 'y'))
moves_df$idx <- 1:nrow(moves_df)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot the knight's tour
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(moves_df, aes(x, y)) + 
  geom_tile(aes(fill=as.logical((x+y)%%2)), colour = 'black') +
  geom_path(alpha = 0.7, linetype = 1, size = 0.25) +
  geom_text(aes(label = idx)) + 
  scale_fill_manual(values = c('grey70', 'white')) + 
  theme_void() + 
  theme(legend.position = 'none') + 
  coord_equal() + 
  labs(
    title = "A knight's tour in #RStats"
  )

An animation of the Knight’s Tour

Tweet-length Knight’s Tour

The following tweet-able code generates a knight’s tour on an 8x8 chess board.

The list of values returned is a list of

#RStats
s=1:2;t=2:1;A=matrix;R=return
f=function(m,M,v){M=rbind(M,m)
v[m]=T
if(all(v))R(M)
N=cbind(c(s,-t,t,-s)+m[1],c(t,s,-s,-t)+m[2])
N=N[N[,1]%in%1:8&N[,2]%in%1:8,,drop=F]
N=N[!v[N],,drop=F]
for(i in row(N)[,1])if(length((r=f(N[i,,drop=F],M,v))))R(r)}
f(A(s*4,1),c(),A(F,8,8))

Running this code produces a set of 64 locations which are a knight’s tour of an 8x8 chess board.

Click to reveal/hide the solution matrix of knight locations

      [,1] [,2]
 [1,]    4    8
 [2,]    6    7
 [3,]    8    8
 [4,]    7    6
 [5,]    5    7
 [6,]    7    8
 [7,]    8    6
 [8,]    7    4
 [9,]    5    5
[10,]    3    6
[11,]    1    7
[12,]    3    8
[13,]    4    6
[14,]    5    8
[15,]    7    7
[16,]    8    5
[17,]    6    6
[18,]    8    7
[19,]    6    8
[20,]    5    6
[21,]    3    7
[22,]    1    8
[23,]    2    6
[24,]    4    7
[25,]    2    8
[26,]    1    6
[27,]    3    5
[28,]    2    7
[29,]    1    5
[30,]    3    4
[31,]    5    3
[32,]    6    5
[33,]    8    4
[34,]    7    2
[35,]    6    4
[36,]    4    5
[37,]    3    3
[38,]    5    4
[39,]    7    5
[40,]    8    3
[41,]    7    1
[42,]    5    2
[43,]    4    4
[44,]    2    5
[45,]    1    3
[46,]    2    1
[47,]    4    2
[48,]    2    3
[49,]    1    1
[50,]    3    2
[51,]    2    4
[52,]    1    2
[53,]    3    1
[54,]    4    3
[55,]    5    1
[56,]    6    3
[57,]    8    2
[58,]    6    1
[59,]    7    3
[60,]    8    1
[61,]    6    2
[62,]    4    1
[63,]    2    2
[64,]    1    4

8 Queens Chess Problem

Mon, 02 Nov 2020 17:00:00 +1000

The Queen’s Gambit - Post 1

Inspired by The Queen’s Gambit on Netflix, I’m doing a few posts on Chess in R.

This screenshot from the show explains everything:

Introduction to the 8 queens puzzle

The eight queens puzzle is the problem of placing eight chess queens on an 8×8 chessboard so that no two queens threaten each other.

The wikipedia page is a good starting resource.

This post contains:

A recursive function for finding all solutions: place_queen()
A manually minified version that fits in a tweet - this code also generates a plot of all solutions.

Recursive solution in R

library(tidyverse)

#-----------------------------------------------------------------------------
#' Try and place a Queen given a vector of positions of the current Queens
#'
#' This function calls itself recursively for every valid placement of the
#' next queen. 
#'
#' @param queens A vector of integers representing the column placement 
#'               of queens so far. The index within this list
#'               is the row, and the value is the column.  
#'               To generate all solutions, pass in an empty vector (the default)
#'
#'  e.g. queens = c(1, 4, 7) corresponds to queens placed at c(1, 1), c(2, 4) and
#'  c(3, 7)
#'                  
#'
#'  ---------------------------------
#'  |   |   |   |   |   |   |   |   |
#'  ---------------------------------
#'  |   |   |   |   |   |   |   |   |
#'  ---------------------------------
#'  |   |   |   |   |   |   |   |   |
#'  ---------------------------------
#'  |   |   |   |   |   |   |   |   |
#'  ---------------------------------
#'  |   |   |   |   |   |   | Q |   |    3rd row, 7th column
#'  --------------------------------- 
#'  |   |   |   | Q |   |   |   |   |    2nd row, 4th column
#'  ---------------------------------
#'  | Q |   |   |   |   |   |   |   |    1st row, 1st column
#'  ---------------------------------
#'
#'
#'
#'
#' @return a list where each element is a vector of 8 integers 
#'         i.e. a solution to the 8 queens problem
#-----------------------------------------------------------------------------
place_queen <- function(queens=c()) {
  
  #---------------------------------------------------------------------------
  # If there are 8 queens placed, then this must be a solution.
  #---------------------------------------------------------------------------
  if (length(queens) == 8) {
    return(list(queens))
  }
  
  #---------------------------------------------------------------------------
  # Figure out where a queen can be placed in the next row.
  # Drop all columns that have already been taken - since we 
  # can't place a queen below an existing queen
  #---------------------------------------------------------------------------
  possible_placements <- setdiff(1:8, queens)
  
  #---------------------------------------------------------------------------
  # For each queen already on the board, find the diagonal 
  # positions that it can see in this row.
  #---------------------------------------------------------------------------
  diag_offsets <- seq.int(length(queens), 1)
  diags <- c(queens + diag_offsets, queens - diag_offsets)
  diags <- diags[diags > 0 & diags < 9]
  
  #---------------------------------------------------------------------------
  # Drop these diagonal columns from possible placements
  #---------------------------------------------------------------------------
  possible_placements <- setdiff(possible_placements, diags)
  
  #---------------------------------------------------------------------------
  # For each possible placement, try and place a queen
  #---------------------------------------------------------------------------
  possible_placements %>% 
    map(~place_queen(c(queens, .x))) %>%
    keep(~length(.x) > 0) %>%
    flatten()
}


#-----------------------------------------------------------------------------
#' Plot a single solution
#' @param queens a vector of 8 integers giving the column positions of 8 queens
#-----------------------------------------------------------------------------
plot_single_8queens <- function(queens, title = NULL) {
  queens_df <- tibble(cols = queens, rows=1:8)
  board_df <- expand.grid(cols = 1:8, rows = 1:8) %>% 
    mutate(check = (cols + rows) %%2 == 1)
  
  p <- ggplot(queens_df, aes(rows, cols)) + 
    geom_tile(data=board_df, aes(fill=check), colour='black') +
    geom_text(label='\u2655', family="Arial Unicode MS", size = 8) + 
    theme_void() + 
    coord_equal() + 
    scale_fill_manual(values = c('TRUE'='white', 'FALSE'='grey70')) + 
    theme(
      legend.position = 'none'
    ) 
  
  if (is.null(title)) {
    p <- p + labs(title = paste("Queens:", deparse(as.numeric(queens)))) 
  } else {
    p <- p + labs(title = title)
  }
}


#-----------------------------------------------------------------------------
# Start with no queens placed and generate all solutions.
#-----------------------------------------------------------------------------
solutions <- place_queen()

Table 1: First 10 solutions. Each row of this table is a solution i.e. a vector of 8 numbers where the values are the row position on the chessboard. The table column indicates which column on the chess board.
V1	V2	V3	V4	V5	V6	V7	V8
1	5	8	6	3	7	2	4
1	6	8	3	7	4	2	5
1	7	4	6	8	2	5	3
1	7	5	8	2	4	6	3
2	4	6	8	3	1	7	5
2	5	7	1	3	8	6	4
2	5	7	4	1	8	6	3
2	6	1	7	4	8	3	5
2	6	8	3	1	4	7	5
2	7	3	6	8	5	1	4

#-----------------------------------------------------------------------------
#  Plot the first 2 solutions
#-----------------------------------------------------------------------------
plot_single_8queens(solutions[[1]])
plot_single_8queens(solutions[[2]])

Animation showing all solutions

8Queens solution in Rstats Compacted into a tweet

This tweet calculates all 92 solutions and plots them on a checkered board - the bright blue squares on the board represent the locations of the queens.

This solution fits in a tweet!

library(tidyverse)
v=1:8
f=function(q){L=length(q)
if(L==8){q}else{flatten(map(setdiff(v,c(q,q+L:1,q-L:1)),~f(c(q,.))))}}
s=data.frame(c=unlist(f(c())),r=v,x=rep(1:92,e=8),z=3)
b=mutate(crossing(c=v,r=v),z=(c+r)%%2)
g=geom_tile
ggplot(s,aes(r,c,fill=z))+g(d=b)+g()+facet_wrap(~x)

Extension

Nothing else I want to do :)

Introducing 'emphatic' - highlight data.frames in the R console

Fri, 30 Oct 2020 07:00:00 +1000

emphatic

`{emphatic}` augments the output of data.frames and matrices in R by adding user-defined ANSI highlighting.

See the online documentation for vignettes and more examples.

What’s in the box

There are separate high-level functions for highlighting data.frames and matrices, and a low-level function which can be used on both.

The hl_ prefix can be read as highlight.

hl() for highlighting data.frames
hl_matrix() for highlighting matrices
hl_loc() for low-level control of highlighting of both data.frames and matrices
hl_opt() to set some local options on the current emphatic object e.g. full_colour option sets 24-bit colour mode.
hl_opt_global() sets global options for highlighting. These values will be the default unless overridden with a call to hl_opt() for the given emphatic object.

	data.frame	matrix
High Level	`hl()`	`hl_matrix()`
Low Level	`hl_loc()`	`hl_loc()`

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/emphatic')

Warning

This package calls eval() on user-supplied code and extreme caution should be taken before exposing functions in this package to the internet (e.g. via shiny)

Vignettes

Intro

Guided Example

Speicifying rows, columns and colours

Test cases on Real data

Advanced:

Low level highlighting with hl_loc()

Example - set alternating colours on a data.frame

library(emphatic)
emphatic::hl_opt_global(dark_mode = FALSE)

mtcars %>%
  hl(c('red', 'white'))

Example 2 - using row and column specification

Use {emphatic} to highlight the mtcars dataset where:

6 and 8 cylinder cars only
colour each row to indicate the miles-per-gallon rating
do not colour the gear or carb columns
highlight the car with the maximum miles per gallon in hotpink
de-emphasise the numeric values to focus on the colour highlighting

mtcars %>%
  hl(ggplot2::scale_colour_viridis_c(), rows = cyl %in% c(6, 8), 
     cols = mpg, dest_cols = mpg:am) %>%
  hl('hotpink', rows = mpg == max(mpg)) %>%
  hl_opt(text_contrast = 0.25)

Example 3 - Rainbows!

mtcars %>% 
  hl(rainbow(32)) %>%
  hl_opt(text_contrast = 0.5)

Example 4: Correlation matrix

Create a correlation matrix of some of the variables in mtcars.

Colour the values using red for negative correlations and blue for positive correlations. Values in-between are coloured using a gradient between red and blue. This colouring is applied using ggplot2::scale_colour_gradient2().

mtcars %>%
  select(cyl, mpg, hp, disp, vs) %>%
  cor() %>%
  hl_matrix(scale_colour_gradient2(), selection = abs(.x) > 0.7 & row(.x) != col(.x))

Introducing 'purler' - fast run-length encoding with data.frame output

Wed, 14 Oct 2020 21:10:00 +1000

purler

purler contains tools for run-length encoding vector data.

Key features:

NA values are considered identical (unlike base::rle())
Results returned as a data.frame (rather than a list), but still compatible with base::inverse.rle()
Faster! Includes a C implementation for regular atomic vectors, and an R version compatible with every input base::rle() accepts.

What’s in the box

rlenc() is C code for run-length encoding of raw, logical, integer, numeric and character vectors.
- Groups NA values into a run (unlike base::rle())
- Returns a data.frame rather than a list
- Returned object is compatible with base::inverse.rle()
- Can be 10x faster than base::rle()
rlenc_compat()
- A pure R version of rlenc() which is compatible with all inputs that base::rle() accepts
rleid() returns an integer vector numbering the runs of identical values within a vector of numeric or character data. This is very similar to data.table::rleid(), execpt the data.table() version is much more configurable and flexible. This version is probably only useful if you wanted to avoid pulling in data.table as a dependency.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/purler')

ToDo

Long vector support in rlenc()

`rlenc()` - run-length encoding output as a data.frame

input <- c(1, 1, 1, 2, 2, 8, 8, 8, 8, 8, NA, NA, NA, NA)

(result <- purler::rlenc(input))

  lengths values start
1       3      1     1
2       2      2     4
3       5      8     6
4       4     NA    11

inverse.rle(result)

 [1]  1  1  1  2  2  8  8  8  8  8 NA NA NA NA

`rlenc()` benchmark

library(tidyr)
library(bench)
library(dplyr)
library(ggplot2)

N <- 1000
M <- 10

zz <- sample(seq_len(M), N, replace = TRUE)

res <- bench::mark(
  rle(zz),
  rlenc(zz),
  rlenc_compat(zz),
  check = FALSE
)

plot(res) + theme_bw()

Run-length encoding with NAs

In base::rle(), runs of NA values are not treated as a group.

All functions in purler do treat NAs as identical for the purpose of creating groups

input <- c(1, 1, 2, NA, NA, NA, NA, 4, 4, 4)

base::rle(input)

Run Length Encoding
  lengths: int [1:7] 2 1 1 1 1 1 3
  values : num [1:7] 1 2 NA NA NA NA 4

purler::rlenc_compat(input)

  lengths values start
1       2      1     1
2       1      2     3
3       4     NA     4
4       3      4     8

purler::rlenc(input)

  lengths values start
1       2      1     1
2       1      2     3
3       4     NA     4
4       3      4     8

purler::rlenc_id(input)

 [1] 1 1 2 3 3 3 3 4 4 4

Run-length encoded group ids

rlenc_id() numbers the runs of identical values in a numeric or character vector.

For a more complete approach to this problem, see data.table::rleid()

input <- c(11, 11, 12, 12, 12, NA, NA, NA, NA)

rlenc_id(input)

[1] 1 1 2 2 2 3 3 3 3

Introducing geomlime

Tue, 13 Oct 2020 20:38:00 +1000

geomlime

geomlime provides a bloody geom_lime() function for ggplot because of all the zarking times I frakking type geom_lime() instead of geom_line()

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/geomlime')

Example Usage

library(ggplot2)
library(geomlime)

ggplot(mtcars) +
  geom_lime(aes(mpg, wt, size = cyl)) + 
  theme_bw() + 
  theme(legend.position = 'none')

Introducing devoutrgl - a 3d graphics device targetting rgl

Tue, 06 Oct 2020 20:45:00 +1000

devoutrgl

devoutrgl::rgldev() is a graphics device - like pdf() or png(). This device will render a plot as an interactive 3d opengl document using {rgl}.

NOTE: Since Github does not allow webgl rendering in README files, all plots on GitHub have been rendered as PNGs or animated gifs. Please visit the package website to interact with the generated output in the vignettes

What’s in the box:

rgldev() is the rgl device. Use it like you would use the pdf() device or the png() device.

Installation

You can install from GitHub with:

# install.packages("remotes")
remotes::install_github("coolbutuseless/snowcrash")  # Store R objects as images
remotes::install_github("coolbutuseless/cryogenic")  # Freeze R calls + replay
remotes::install_github("coolbutuseless/triangular") # Polygon Triangulation
remotes::install_github("coolbutuseless/devout")     # R device framework
remotes::install_github("coolbutuseless/devoutrgl")  # This device

Limitations

No font selection. Everything will be in the default sans serif!
Multi-line text in a single string with “” characters does not render well.
No support for clipping paths.

Examples

Bar Plot

library(ggplot2)
library(devoutrgl)

plot_df <- data.frame(x=c('a', 'b', 'c'), y=4:6)
p <- ggplot(plot_df) +
  geom_bar(aes(x, y, fill=x), colour = NA, stat='identity') +
  labs(title = "{devoutrgl}") +
  scale_fill_brewer(type = 'seq', palette = 'Blues') + 
  theme_minimal() + theme_rgl()


devoutrgl::rgldev(fov = 30, view_angle = -30)
p
invisible(dev.off())

Use your mouse, mouse buttons and scrollwheel to manipulate the 3d plot

Base plot

devoutrgl::rgldev(fov = 30, view = 'flat', view_angle = 30, zoom = 0.6) 
pie(c(cool=1, but = 2, use=3, less = 4))
dev.off()

quartz_off_screen 
                2

Use your mouse, mouse buttons and scrollwheel to manipulate the 3d plot

Polygon with a hole

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# polygons_df - data.frame of polygon vertices with group/subgroups
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
polygons_df <- df <- data.frame(
  x        = c(4, 8, 8, 4,   6, 7, 7, 6),
  y        = c(4, 4, 8, 8,   6, 6, 7, 7),
  group    = c(1, 1, 1, 1,   1, 1, 1, 1),
  subgroup = c(1, 1, 1, 1,   2, 2, 2, 2)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
p <- ggplot(polygons_df) +
  geom_polygon(aes(x, y, group=group, subgroup=subgroup)) +
  geom_path(aes(x, y, group = interaction(group, subgroup)), colour = 'red') +
  theme_bw() + 
  coord_equal() + 
  labs(title = "{devoutrgl} polygon with a hole")

rgldev(fov = 30, view_angle = -30, zoom = 0.8)
p
invisible(dev.off())

Use your mouse, mouse buttons and scrollwheel to manipulate the 3d plot

Density Plot

library(ggplot2)
library(devoutrgl)

p <- ggplot(mtcars) +
  geom_density(aes(mpg, fill=as.factor(cyl)), colour = '#ffffff00') +
  theme(legend.position = 'none') +
  scale_fill_brewer(palette = 'Set1') + 
  theme_bw() +
  labs(title = "{devoutrgl} geom_density()")


rgldev(fov = 30, view_angle = 30)
p
invisible(dev.off())

Use your mouse, mouse buttons and scrollwheel to manipulate the 3d plot

Generating the logo for this package

library(ggplot2)
library(dplyr)

hex_df <- tibble(
  rad = seq(0, 2*pi, pi/3),
  x   = sin(rad),
  y   = cos(rad)
)

p <- ggplot(hex_df) +
  geom_polygon(aes(x, y), fill = '#002366', colour = '#436B9530') +
  annotate('text', x = 0, y = 0, label = "/dev/out/\nrgl", size = 20, color = 'grey90') +
  coord_fixed() +
  theme_minimal(25) + 
  theme(panel.grid = element_blank())

devoutrgl::rgldev(
  width       = 5.5,
  fov         = 30,
  view3d_args = list(-45, 0, zoom = 0.8)
)

p
invisible(dev.off())

Use your mouse, mouse buttons and scrollwheel to manipulate the 3d plot

A level 3 menger sponge in R

Sun, 27 Sep 2020 18:27:00 +1000

Level 3 menger sponge in `{rgl}`

library(rgl)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# The base cube
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sl  <- shapelist3d(cube3d(alpha = 1, color = 'grey90', specular = 'black', lit = TRUE), plot = FALSE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Given a shapelist, calculate the next level of the sponge
#' @param sl shapelist3d() object
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
create_next_level <- function(sl, level) {

  scale <- 1/2
  sla <- scale3d(sl, scale, scale, scale)

  x <- 1.5^(level-1)
  shapelist3d(
    list(
      translate3d(sla, -x, -x, -x),
      translate3d(sla,  0, -x, -x),
      translate3d(sla,  x, -x, -x),

      translate3d(sla, -x,  0, -x),
      translate3d(sla,  x,  0, -x),

      translate3d(sla, -x,  x, -x),
      translate3d(sla,  0,  x, -x),
      translate3d(sla,  x,  x, -x),

      translate3d(sla, -x, -x,  0),
      translate3d(sla,  x, -x,  0),

      translate3d(sla, -x,  x,  0),
      translate3d(sla,  x,  x,  0),

      translate3d(sla, -x, -x,  x),
      translate3d(sla,  0, -x,  x),
      translate3d(sla,  x, -x,  x),

      translate3d(sla, -x,  0,  x),
      translate3d(sla,  x,  0,  x),

      translate3d(sla, -x,  x,  x),
      translate3d(sla,  0,  x,  x),
      translate3d(sla,  x,  x,  x)
    ),
    plot = FALSE
  )
}

rgl::clear3d()
sl <- create_next_level(sl, level = 1)
sl <- create_next_level(sl, level = 2)
sl <- create_next_level(sl, level = 3)

shade3d(sl)

Introducing the {triangular} package for decomposing complex polygons to triangles

Sat, 26 Sep 2020 20:27:00 +1000

triangular

triangular decomposes complex polygons into sets of triangles and works with:

polygons with holes
self-intersecting polygons

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/triangular')

Example

This is a basic example which shows you how to solve a common problem:

library(triangular)

Polygon with a Hole in it

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# polygons_df - data.frame of polygon vertices with group/subgroups
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
polygons_df <- df <- data.frame(
  x        = c(4, 8, 8, 4,   6, 7, 7, 6),
  y        = c(4, 4, 8, 8,   6, 6, 7, 7),
  group    = c(1, 1, 1, 1,   1, 1, 1, 1),
  subgroup = c(1, 1, 1, 1,   2, 2, 2, 2)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# How 'ggplot2' handles this case
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(polygons_df) +
  geom_polygon(aes(x, y, group=group, subgroup=subgroup)) +
  geom_path(aes(x, y, group = interaction(group, subgroup)), colour = 'red') +
  theme_bw() + 
  coord_equal() + 
  labs(title = "ggplot2 rendering of original polygon(s)")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Turn the polygon data.frame into individual triangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
res <- triangular::decompose(polygons_df)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Remove the triangles which are 'interior' according to the even-odd rule
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tri_df <- res$plot_df %>%
  filter(interior)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot the triangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(tri_df) +
  geom_polygon(aes(x, y, group = idx), alpha = 0.3, colour = 'blue') +
  theme_bw() + 
  coord_equal() + 
  labs(title = "Decomposition into simple tris with {triangular}")

Polygon with Two Holes

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
poly <- df <- data.frame(
  x        = c(4, 8, 8, 4,   6, 7, 7, 6,  4.5,   5, 5, 4.5),
  y        = c(4, 4, 8, 8,   6, 6, 7, 7,  4.5, 4.5, 5, 5),
  group    = c(1, 1, 1, 1,   1, 1, 1, 1,    1,   1, 1, 1),
  subgroup = c(1, 1, 1, 1,   2, 2, 2, 2,    3,   3, 3, 3)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# "Native" ggplot2 rendering
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(df) +
  geom_polygon(aes(x, y, subgroup = subgroup), colour = 'red') + 
  theme_bw() + 
  coord_equal() + 
  labs(title = "ggplot2 rendering of original polygon(s)")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Decompose into triangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
res <- triangular::decompose(poly)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Remove the triangles which are 'interior' according to the even-odd rule
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tri_df <- res$plot_df %>%
  filter(interior)

ggplot(tri_df) +
  geom_polygon(aes(x, y, group = idx), alpha = 0.3, colour = 'blue') +
  theme_bw() + 
  coord_equal() + 
  labs(title = "Decomposition into simple tris with {triangular}")

Two Polygons with One Hole Each

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Two polygons with one hole each
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
poly <- df <- data.frame(
  x        = c(1, 4, 4, 1,  2, 3, 3, 2,      5, 8, 8, 5,  6, 7, 7, 6),
  y        = c(1, 1, 4, 4,  2, 2, 3, 3,      5, 5, 8, 8,  6, 6, 7, 7),
  group    = c(1, 1, 1, 1,  1, 1, 1, 1,      1, 1, 1, 1,  1, 1, 1, 1),
  subgroup = c(1, 1, 1, 1,  2, 2, 2, 2,      3, 3, 3, 3,  4, 4, 4, 4)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# "Native" ggplot2 rendering
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(df) +
  geom_polygon(aes(x, y, subgroup = subgroup), colour = 'red') + 
  theme_bw() + 
  coord_equal() + 
  labs(title = "ggplot2 rendering of original polygon(s)")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Decompose into triangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
res <- triangular::decompose(poly)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Remove the triangles which are 'interior' according to the even-odd rule
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tri_df <- res$plot_df %>%
  filter(interior)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Manual rendering of triangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(tri_df) +
  geom_polygon(aes(x, y, group = idx), alpha = 0.3, colour = 'blue') +
  theme_bw() +
  coord_equal() + 
  labs(title = "Decomposition into simple tris with {triangular}")

Polygon from Random Points

set.seed(1)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 10 random points
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
poly <- df <- data.frame(
  x        = runif(10),
  y        = runif(10),
  group    = 1,
  subgroup = 1
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# "Native" ggplot2 rendering
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(df) +
  geom_polygon(aes(x, y)) +
  geom_path(aes(x, y, group = interaction(group, subgroup)), colour = 'red') +
  theme_bw() + 
  coord_equal() + 
  labs(title = "ggplot2 rendering of original polygon(s)")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Decompose into triangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
res <- triangular::decompose(poly)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Remove the triangles which are 'interior' according to the even-odd rule
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tri_df <- res$plot_df %>%
  filter(interior)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Manual rendering of triangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(tri_df) +
  geom_polygon(aes(x, y, group = idx), alpha = 0.3, colour = 'blue') +
  theme_bw() + 
  coord_equal() + 
  labs(title = "Decomposition into simple tris with {triangular}")

What's the upper limit on serialization speed in R?

Tue, 22 Sep 2020 17:20:00 +1000

`{serializer}`

serializer is a package which demonstrates how to use R’s internal serialization interface from C. The code is the minimum amount of code required to do this, and I’ve inserted plenty of comments for guidance.

This package was developed to help me figure out the serialization process in R. It is perhaps only really interesting if you want to look at and/or steal the C code. It’s under the MIT license, so please feel free to re-use in your own projects.

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/serializer')

Simple Example

library(serializer)

robj <- sample(10)
v1 <- serializer::marshall(robj)
v1

 [1] 42 0a 03 00 00 00 02 00 04 00 00 05 03 00 05 00 00 00 55 54 46 2d 38 0d 00
[26] 00 00 0a 00 00 00 09 00 00 00 04 00 00 00 07 00 00 00 01 00 00 00 02 00 00
[51] 00 05 00 00 00 03 00 00 00 0a 00 00 00 06 00 00 00 08 00 00 00

serializer::unmarshall(v1)

 [1]  9  4  7  1  2  5  3 10  6  8

What’s the upper bound on serialization speed?

calc_marshalled_size() can be used to calculate the size of a serialized object, but does not actually try and create the serialized object.

Because this does not do any memory allocation, or copying of bytes, the speed of calc_marshalled_size() should give an approximation of the maximum throughput of the serialization process when using R’s internal serialization mechanism.

The speeds below seem ridiculous, because at its core, serialization is just passing pointers + lengths to an output stream, and doing very very little actual memory allocation or copying.

N <- 1e7
obj1 <- data.frame(
  x = sample(N),
  y = runif(N)
)

obj2 <- do.call(rbind, replicate(1000, iris, simplify = FALSE))
obj3 <- sample(N)
obj4 <- sample(10)

n1 <- lobstr::obj_size(obj1)
n2 <- lobstr::obj_size(obj2)
n3 <- lobstr::obj_size(obj3)
n4 <- lobstr::obj_size(obj4)

res <- bench::mark(
  calc_marshalled_size(obj1),
  calc_marshalled_size(obj2),
  calc_marshalled_size(obj3),
  calc_marshalled_size(obj4),
  check = FALSE
)


res %>% 
  mutate(MB = round(c(n1, n2, n3, n4)/1024/1024)) %>%
  mutate(`GB/s` = round(MB/1024 / as.numeric(median), 1)) %>%
  mutate(`itr/sec` = round(`itr/sec`)) %>%
  select(expression, median, `itr/sec`, MB, `GB/s`) %>%
  knitr::kable(caption = "Maximum possible throughput of serialization")

Table 1: Maximum possible throughput of serialization
expression	median	itr/sec	MB	GB/s
calc_marshalled_size(obj1)	11.42µs	84786	114	9746.8
calc_marshalled_size(obj2)	6.23µs	163324	5	783.3
calc_marshalled_size(obj3)	7.36µs	137883	38	5043.4
calc_marshalled_size(obj4)	2.52µs	298593	0	0.0

Summary

R’s process of chopping up an object for serialization is fast.

The limiting factor in the speed of serialization is whatever the actual output stream does with the description of the bytes.

xxhashlite - hash arbitrary R objects as fast as possible

Tue, 22 Sep 2020 06:20:00 +1000

xxhashlite

xxhashlite provides simple access to the extremely fast hashing functions in xxHash for in-memory hashing of R objects.

This new version of xxhashlite (v0.2.0) is a major update which now offers fast hashing of any R object by internally leveraging R’s serialization capabilities.

This package is a wrapper around xxHash v0.8.0.
See LICENSE-xxHash for the copyright and licensing information for that code. With this latest version of xxHash, the new (even faster) hash functions, xxh3_64bits and xxhash128, are considered stable.

What’s in the box

xxhash(robj, algo) calculates the hash of any R object understood by base::serialize().

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/xxhashlite)

Installation - set CFLAGs for optimised executable

To get the most out of what xxHash offers, it will be important to set some optimization flags for your machine. The important compiler flags to set are -O3 and -march=native.

Here are 2 possible ways to do this:

Copy src/Makevars.custom to src/Makevars re-build package.
Edit your ~/.R/Makevars to include CFLAGS = -O3 -march=native (this will change flags for all future compilation, and should probably be used with caution)

Why use a hash?

A hash is a way of succinctly summarising the contents of an object in a compact format.

If there are changes to the object (no matter how small) then the hash should change as well.

library(xxhashlite)
xxhash(mtcars)

[1] "2c8a35b061878544"

# Small changes results in a different hash
mtcars$cyl[1] <- 0
xxhash(mtcars)

[1] "06a3bba3891cfe7e"

Timing for hashing arbitrary R objects

xxhashlite uses the xxHash family of hash functions to provide very fast hashing of R objects.

For the test case shown below, xxhashlite is faster at calculating a hash than all other methods I could find, with a maximum hashing speed in this specific case of 20 GB/s.

Note: actual hashing speed will still depend on R’s serialization functions e.g. small complex data.frames might have a lot of serialization overhead compared to long numeric vectors.

Click to show/hide the benchmarking code

library(xxhashlite)
library(digest)
library(fastdigest)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Simple data.frame
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N   <- 1e5
df  <- data.frame(
  x = runif(N),
  y = sample(N)
)

size <- pryr::object_size(df)

Registered S3 method overwritten by 'pryr':
  method      from
  print.bytes Rcpp

size

1.2 MB

res <- bench::mark(
  # {xxhashlite}
  xxhash(df, 'xxhash32'),
  xxhash(df, 'xxhash64'),
  xxhash(df, 'xxhash128'),
  xxhash(df, 'xxh3_64bits'),
  
  # {digest}
  digest(df, algo = 'xxhash32'),
  digest(df, algo = 'xxhash64'),
  digest(df, algo = 'murmur32'),
  digest(df, algo = 'spookyhash'),
  
  # {fastdigest}
  fastdigest(df),
  
  check = FALSE
)

Table 1: Hashing a simple data.frame
package	expression	median	itr/sec	MB/s
xxhashlite	xxhash(df, “xxhash32”)	193.4µs	4966	5921.5
xxhashlite	xxhash(df, “xxhash64”)	198.13µs	4856	5780.0
xxhashlite	xxhash(df, “xxhash128”)	52.68µs	18247	21737.3
xxhashlite	xxhash(df, “xxh3_64bits”)	51.24µs	18628	22348.8
digest	digest(df, algo = “xxhash32”)	4.38ms	227	261.4
digest	digest(df, algo = “xxhash64”)	4.04ms	242	283.1
digest	digest(df, algo = “murmur32”)	4.58ms	216	250.2
digest	digest(df, algo = “spookyhash”)	168.88µs	5643	6781.1
fastdigest	fastdigest(df)	201.69µs	4741	5678.2

Acknowledgements

Yann Collett for releasing, maintaining and advancing xxHash
R Core for developing and maintaining such a great language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing serializer - a demonstration pkg illustrating how to use R's serialiation from C

Fri, 18 Sep 2020 08:20:00 +1000

serializer

If you want a rock solid version of this package that already exists, use RApiSerialize.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/serializer')

Notes

Using R’s serialization infrastructure from C involves 2 main parts:
- a buffer (which could be memory, a file, a pipe, etc) with accompanying functions for reading and writing bytes to/from the buffer
- input/output stream wrappers around this buffer initialised and created using R internals
  - Input stream: R_inpstream_st, R_InitInPStream()
  - Output stream: R_outpstream_st, R_InitOutPStream()

Example

library(serializer)

v1 <- serializer::pack(mtcars)
v2 <- base::serialize(mtcars, NULL, xdr = FALSE)

identical(v1, v2)

[1] FALSE

Code for serializing R object within C

Click to show/hide for serialization

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Serialize an R object
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SEXP pack_(SEXP robj) {

  // Create the buffer for the serialized representation
  // See also: `expand_buffer()` which re-allocates the memory buffer if
  // it runs out of space
  buffer *buf = init_buffer(16384);

  // Create the output stream structure
  struct R_outpstream_st output_stream;

  // Initialise the output stream structure
  R_InitOutPStream(
    &output_stream,          // The stream object which wraps everything
    (R_pstream_data_t) buf,  // The actual data
    R_pstream_binary_format, // Store as binary
    3,                       // Version = 3 for R >3.5.0 See `?base::serialize`
    write_byte,              // Function to write single byte to buffer
    write_bytes,             // Function for writing multiple bytes to buffer
    NULL,                    // Func for special handling of reference data.
    R_NilValue               // Data related to reference data handling
  );

  // Serialize the object into the output_stream
  R_Serialize(robj, &output_stream);

  // Copy just the valid bytes to return to the user
  SEXP res_ = PROTECT(allocVector(RAWSXP, buf->pos));
  memcpy(RAW(res_), buf->data, buf->pos);

  // Free all the memory
  free(buf->data);
  free(buf);
  UNPROTECT(1);
  return res_;
}

Click to show/hide for unserialization

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Unpack a raw vector to an R object
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SEXP unpack_(SEXP vec_) {

  if (TYPEOF(vec_) != RAWSXP) {
    error("unpack(): Only raw vectors can be unserialized");
  }

  // Unpack the raw vector into a C void *
  void *vec = RAW(vec_);
  R_xlen_t len = XLENGTH(vec_);

  // Create a buffer object which points to the raw data
  buffer *buf = malloc(sizeof(buffer));
  if (buf == NULL) {
    error("'buf' malloc failed!");
  }
  buf->length = len;
  buf->pos    = 0;
  buf->data   = vec;

  // Treat the data buffer as an input stream
  struct R_inpstream_st input_stream;

  R_InitInPStream(
    &input_stream,           // Stream object wrapping data buffer
    (R_pstream_data_t) buf,  // Actual data buffer
    R_pstream_any_format,    // Unpack all serialized types
    read_byte,               // Function to read single byte from buffer
    read_bytes,              // Function for reading multiple bytes from buffer
    NULL,                    // Func for special handling of reference data.
    NULL                     // Data related to reference data handling
  );

  // Unserialize the input_stream into an R object
  SEXP res_  = PROTECT(R_Unserialize(&input_stream));

  free(buf);
  UNPROTECT(1);
  return res_;
}

Click to show/hide code for the memory buffer

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// The data buffer.
// Needs total length and pos to keep track of how much data it contains
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
typedef struct {
  R_xlen_t length;
  R_xlen_t pos;
  unsigned char *data;
} buffer;



//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Initialise an empty buffer to hold 'nbytes'
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
buffer *init_buffer(int nbytes) {
  buffer *buf = (buffer *)malloc(sizeof(buffer));
  if (buf == NULL) {
    error("init_buffer(): cannot malloc buffer");
  }

  buf->data = (unsigned char *)malloc(nbytes * sizeof(unsigned char));
  if (buf->data == NULL) {
    error("init_buffer(): cannot malloc buffer data");
  }

  buf->length = nbytes;
  buf->pos = 0;

  return buf;
}


//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Naive buffer expansion - double it every time space runs out
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
void expand_buffer(buffer *buf) {

  double factor = 2;
  buf->length = (R_xlen_t)(factor * buf->length);

  if (buf->length > R_XLEN_T_MAX) {
    error("Requested buffer expandsion too large: %td\n", buf->length);
  }

  unsigned char *new_data = (unsigned char *)realloc((void *)buf->data, buf->length);

  if (new_data == NULL) {
    free(buf->data);
    free(buf);
    error("Couldn't expand buffer to reallocate: %td\n", buf->length);
  }

  buf->data = new_data;

}


//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Write a byte into the buffer at the current location.
// The actual buffer is encapsulated as part of the stream structure, so you
// have to extract it first
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
void write_byte(R_outpstream_t stream, int c) {
  buffer *buf = (buffer *)stream->data;

  // Expand the buffer if it's out space
  while (buf->pos >= buf->length) {
    expand_buffer(buf);
  }

  buf->data[buf->pos++] = (unsigned char)c;
}



//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Write multiple bytes into the buffer at the current location.
// The actual buffer is encapsulated as part of the stream structure, so you
// have to extract it first
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
void write_bytes(R_outpstream_t stream, void *src, int length) {
  buffer *buf = (buffer *)stream->data;

  // Expand the buffer if it's out space
  while (buf->pos + length > buf->length) {
    expand_buffer(buf);
  }

  memcpy(buf->data + buf->pos, src, length);

  buf->pos += length;
}



//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Read a byte from the serialized stream
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
int read_byte(R_inpstream_t stream) {
  buffer *buf = (buffer *)stream->data;

  if (buf->pos >= buf->length) {
    error("read_byte(): overflow");
  }

  return buf->data[buf->pos++];
}



//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Read multiple bytes from the serialized stream
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
void read_bytes(R_inpstream_t stream, void *dst, int length) {
  buffer *buf = (buffer *)stream->data;

  if (buf->pos + length > buf->length) {
    error("read_bytes(): overflow");
  }

  memcpy(dst, buf->data + buf->pos, length);

  buf->pos += length;
}

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Creating a data.frame in C

Wed, 16 Sep 2020 19:55:00 +1000

simplecall - demo package for calling C code with `.Call()`

simplecall is a small demo package showing how C code could be included in a package and called with .Call().

This package now includes demo code for:

creating a list in C
creating a data.frame in C

There are probably more succinct ways of doing this, and if you know such a way, please hit me up on twitter

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/simplecall)

Creating a R List within C

Example code is included to create a list completely within C and return it to R

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Creating a list within C and returning it to R
//
//  1. Create individual integer/real/whatever vectors
//  2. allocate a VECSXP of the correct size
//  3. assign each member into the list
//  4. create names and assign them to the list
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SEXP create_list_in_c_() {


  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Each member of the list gets allocated separately
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  int n = 10;

  SEXP idx_ = PROTECT(allocVector(INTSXP , n));
  SEXP x_   = PROTECT(allocVector(REALSXP, n));
  SEXP y_   = PROTECT(allocVector(REALSXP, n));


  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Assign some dummy values into the members
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (int i = 0; i < n; i++) {
    INTEGER(idx_)[i] = i + 1;
    REAL(x_)[i] = i + 10;
    REAL(y_)[i] = i + 100;
  }

  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Allocate a list with 3 members
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SEXP list_ = PROTECT(allocVector(VECSXP, 3));

  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Add members to the list
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SET_VECTOR_ELT(list_,  0, idx_);
  SET_VECTOR_ELT(list_,  1, x_);
  SET_VECTOR_ELT(list_,  2, y_);

  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Set the names on the list.
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SEXP names = PROTECT(allocVector(STRSXP, 3));
  SET_STRING_ELT(names,  0, mkChar("idx"));
  SET_STRING_ELT(names,  1, mkChar("x"));
  SET_STRING_ELT(names,  2, mkChar("y"));
  setAttrib(list_, R_NamesSymbol, names);

  UNPROTECT(5);
  return list_;
}

simplecall::create_list_in_c()

$idx
 [1]  1  2  3  4  5  6  7  8  9 10

$x
 [1] 10 11 12 13 14 15 16 17 18 19

$y
 [1] 100 101 102 103 104 105 106 107 108 109

Creating a R data.frame within C

Example code is included to create a data.frame completely within C and return it to R

//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
// Creating a data.frame within C and returning it to R
//
//  1. Create individual integer/real/whatever vectors
//  2. allocate a VECSXP of the correct size
//  3. assign each member into the data.frame
//  4. create names and assign them to the data.frame
//  5. set the class to "data.frame"
//  6. set rownames on the data.frame
//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SEXP create_data_frame_in_c_() {


  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Each member of the list gets allocated separately
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  int n = 10;

  SEXP idx_ = PROTECT(allocVector(INTSXP , n));
  SEXP x_   = PROTECT(allocVector(REALSXP, n));
  SEXP y_   = PROTECT(allocVector(REALSXP, n));


  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Assign some dummy values into the members
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (int i = 0; i < n; i++) {
    INTEGER(idx_)[i] = i + 1;
    REAL(x_)[i] = i + 10;
    REAL(y_)[i] = i + 100;
  }

  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Allocate a data.frame
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SEXP df_ = PROTECT(allocVector(VECSXP, 3));

  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Add columns to the data.frame
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SET_VECTOR_ELT(df_,  0, idx_);
  SET_VECTOR_ELT(df_,  1, x_);
  SET_VECTOR_ELT(df_,  2, y_);

  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Treat the VECSXP as a data.frame rather than a list
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SET_CLASS(df_, mkString("data.frame"));

  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Set the names on the list.
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SEXP names = PROTECT(allocVector(STRSXP, 3));
  SET_STRING_ELT(names,  0, mkChar("idx"));
  SET_STRING_ELT(names,  1, mkChar("x"));
  SET_STRING_ELT(names,  2, mkChar("y"));
  setAttrib(df_, R_NamesSymbol, names);

  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  // Set the row.names on the list.
  // Use the shortcut as used in .set_row_names() in R
  // i.e. set rownames to c(NA_integer, -len) and it will
  // take care of the rest. This is equivalent to rownames(x) <- NULL
  //~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SEXP rownames = PROTECT(allocVector(INTSXP, 2));
  SET_INTEGER_ELT(rownames, 0, NA_INTEGER);
  SET_INTEGER_ELT(rownames, 1, -n);
  setAttrib(df_, R_RowNamesSymbol, rownames);

  UNPROTECT(6);
  return df_;
}

simplecall::create_data_frame_in_c()

   idx  x   y
1    1 10 100
2    2 11 101
3    3 12 102
4    4 13 103
5    5 14 104
6    6 15 105
7    7 16 106
8    8 17 107
9    9 18 108
10  10 19 109

Similar packages

This is one of a series of small demo packages for
calling other languages from R:

{simplec} - calling C with .C()
{simplecall} - calling C with .Call()
{simplercpp} - calling C++ with {Rcpp}
{simplefortran} - calling Fortran with .Fortran()

Installation

Resources

David Vaughan’s post - Now you C me
Peter Dalgaard’s Keynote from UseR 2004 discusses R’s language interfaces
Using R — Calling C Code ‘Hello World’
Hadley’s Advanced R book chapter - ‘Rs C interface’
Rcpp

Acknowledgements

R Core for developing and maintaining such a wonderful language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'snowcrash' - a package to encode arbitrary R objects into image representations

Fri, 11 Sep 2020 06:20:00 +1000

snowcrash

snowcrash is a package for encoding arbitrary R objects as rasters, PNGs and rasterGrobs.

Why?

Although this may seem like a frivolous package, encoding data as images is one way to transmit information to a graphics device through an otherwise impenetrable barrier. This package is needed to enable extra data to pass to a graphics device when using devices based upon devout.

What’s in the box

encode_robj_to_bytes()/decode_bytes_to_robj encode an arbitrary R object to bytes using base::serialize(). This will also compress the data if zstdlite is installed.
encode_robj_to_png()/decode_png_to_robj encode an arbitrary R object as a png
encode_robj_to_raster()/decode_raster_to_robj encode as a raster image
encode_robj_to_rasterGrob()/decode_rasterGrob_to_robj() encode as a grid::rasterGrob() object

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/zstdlite') # suggested. but not mandatory.
remotes::install_github('coolbutuseless/snowcrash')

Encoding a small vector as bytes

bytes <- encode_robj_to_bytes(c(1, 2, 3))
bytes

 [1] 5a 53 54 18 28 b5 2f fd 20 37 a5 01 00 74 02 58 0a 00 00 00 03 00 04 00 02
[26] 00 03 05 00 00 00 00 05 55 54 46 2d 38 00 00 00 0e 3f f0 00 00 40 08 00 00
[51] 00 00 00 00 04 04 01 2b 00 65 dc c4 f3 1c 03

decode_bytes_to_robj(bytes)

[1] 1 2 3

Encoding a `data.frame` as an Image Raster

This example encodes the head of the mtcars data.frame into a raster image.

ras <- encode_robj_to_raster(head(mtcars), alpha = 1)
head(ras)

     [,1]        [,2]        [,3]        [,4]        [,5]        [,6]       
[1,] "#5A550CFF" "#0064BDFF" "#5260D0FF" "#104EE6FF" "#5EE176FF" "#9D371CFF"
[2,] "#53C640FF" "#364065FF" "#5AD887FF" "#4BE71CFF" "#8C98EBFF" "#9A32C1FF"
[3,] "#543F18FF" "#1341E5FF" "#68CB46FF" "#C1EDF4FF" "#5E92DDFF" "#6C4279FF"
[4,] "#18834BFF" "#4B1695FF" "#B801FFFF" "#304003FF" "#96D4E9FF" "#6C28A9FF"
[5,] "#28392FFF" "#3E0CE2FF" "#A042E3FF" "#62B7B9FF" "#C7939FFF" "#014293FF"
[6,] "#B54CE0FF" "#207639FF" "#C0F068FF" "#8AC390FF" "#16DA0DFF" "#FD4B12FF"
     [,7]        [,8]        [,9]        [,10]       [,11]       [,12]      
[1,] "#24FF9CFF" "#32FEC7FF" "#B8A9D0FF" "#7F886CFF" "#FB2A00FF" "#904700FF"
[2,] "#3CEEF6FF" "#598FA3FF" "#306627FF" "#C7187CFF" "#7F1600FF" "#508100FF"
[3,] "#36DBAEFF" "#D465DBFF" "#688F62FF" "#FF4D3FFF" "#4E0100FF" "#906D00FF"
[4,] "#001585FF" "#23DFA5FF" "#E1C85BFF" "#EFA33BFF" "#7BD600FF" "#3F1100FF"
[5,] "#40FF8EFF" "#8A10A0FF" "#C276E1FF" "#BFBBE6FF" "#F62C00FF" "#131500FF"
[6,] "#00B355FF" "#F6A58AFF" "#A1C042FF" "#84B1DEFF" "#EDA500FF" "#2E5400FF"
     [,13]      
[1,] "#7DA000FF"
[2,] "#DCC800FF"
[3,] "#922500FF"
[4,] "#A8F000FF"
[5,] "#340200FF"
[6,] "#242900FF"

plot(ras, interpolate = FALSE)

decode_raster_to_robj(ras)

                   mpg cyl disp  hp drat    wt  qsec vs am gear carb
Mazda RX4         21.0   6  160 110 3.90 2.620 16.46  0  1    4    4
Mazda RX4 Wag     21.0   6  160 110 3.90 2.875 17.02  0  1    4    4
Datsun 710        22.8   4  108  93 3.85 2.320 18.61  1  1    4    1
Hornet 4 Drive    21.4   6  258 110 3.08 3.215 19.44  1  0    3    1
Hornet Sportabout 18.7   8  360 175 3.15 3.440 17.02  0  0    3    2
Valiant           18.1   6  225 105 2.76 3.460 20.22  1  0    3    1

Encoding a Function as a `grid::rasterGrob()`

This example encodes the rle() function into a rasterGrob() object.

raster_grob <- encode_robj_to_rasterGrob(rle, alpha = 1)
grid::grid.draw(raster_grob)

decode_rasterGrob_to_robj(raster_grob)

function (x) 
{
    if (!is.vector(x) && !is.list(x)) 
        stop("'x' must be a vector of an atomic type")
    n <- length(x)
    if (n == 0L) 
        return(structure(list(lengths = integer(), values = x), 
            class = "rle"))
    y <- x[-1L] != x[-n]
    i <- c(which(y | is.na(y)), n)
    structure(list(lengths = diff(c(0L, i)), values = x[i]), 
        class = "rle")
}
<bytecode: 0x7fe06c1e3bf0>
<environment: namespace:base>

Encoding a `ggplot2` Object as a PNG image

This example encodes a full ggplot code object in a PNG image file.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a plot ojbect
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
library(ggplot2)
p <- ggplot(mtcars) + 
  geom_point(aes(mpg, wt))


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Save the ggplot2 object as a PNG image
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
png_file <- "/tmp/test.png"
encode_robj_to_png(p, filename = png_file, alpha = 1)

p <- decode_png_to_robj("/tmp/test.png") 

p + 
  theme_bw() + 
  labs(title = "Decoded plot object")

`snowcrash` - by Neal Stephenson

This package is named after Snow Crash, a sci-fi book by Neal Stephenson where events are set in motion by someone viewing an image of encoded information.

“You saw the whole thing,” Da5id says. “A fixed pattern of black-and-white pixels, fairly high-resolution. Just a few hundred thousand ones and zeroes for me to look at.”

“So in other words, someone just exposed your optic nerve to what, maybe a hundred thousand bytes of information,” Hiro says.

“Noise, is more like it.”

“Well, all information looks like noise until you break the code,” Hiro says.

“Why would anyone show me information in binary code? I’m not a computer. I can’t read a bitmap.”

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'cryogenic' - a package to freeze function calls to modify and evaluate later

Wed, 09 Sep 2020 21:30:00 +1000

cryogenic

cryogenic is a package for freezing a function call, modifying its arguments and then evaluating later.

This package is written for a particular use case I have in mind, and may not be generally applicable. The functions are all in base R and quite small, and the reasoning for having this in a package is consistency of the interface.

See rlang for a much more comprehensive and generalisable approach.

My Use Case

Both the calling environment and evaluation environment are under my control.
- I am not executing captured calls based on user input.
Need an R package for this as I need to use this code across multiple packages
Need eager evaluation of arguments when call is captured
Need to be able to update any arguments
- Need to be able to update an argument to have a value of NULL
Need to be able to set arguments to a default value if they aren’t already present
Nearly everything is in lists
Need to be able to consistently add arbitrary meta information as an attribute on the call
There are probably other constraints which I’ll add as I think of them

What’s in the box

capture_call() to capture a call without evaluating it
modify_call() to modify call arguments
evaluate_call() to evaluate a call - and optionally modify the call arguments just prior to the evaluation.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/cryogenic')

Simple example 1

capture a call
modify the call
evaluate the call

library(cryogenic)

cc <- capture_call(runif(n = 10, min=-3))
cc

runif(n = 10, min = -3)

cc <- modify_call(cc, defaults = list(min=0, max=5), update = list(n = 5))
cc

runif(n = 5, min = -3, max = 5)

evaluate_call(cc)

[1] -0.8759307 -0.0230088  1.5828269  4.2656623 -1.3865446

Simple example 2

capture a call
simultaneously update a call and evalute it

library(cryogenic)

cc <- capture_call(runif(n = 10, min=-3))
cc

runif(n = 10, min = -3)

evaluate_call(cc, defaults = list(min=0, max=5), update = list(n = 15))

 [1]  4.18711748  4.55740215  2.28638234  2.03291235 -2.50570984 -1.35220340
 [7] -1.58754598  2.49618277  0.07282975  3.15873136  0.98159394  2.74094807
[13]  4.93524876  0.04028144  3.21956177

Simple example 3

library(cryogenic)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Capture a call as-is.
#
# * the function does not have to exist in the capturing environment
# * By default, all arguments are eagerly evaluated in the environment in which
#   the call was captured
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cc <- capture_call(farnarkle(6, x = 2, y = 3, z = 2+9, error = TRUE))
cc

farnarkle(6, x = 2, y = 3, z = 11, error = TRUE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Update the arguments to the call
#
# * 'defaults' are only added to the arguments if the named argument does 
#    not already exist there.
# * 'update' values are added to the arguments unconditionally
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cc <- modify_call(
  cc, 
  defaults = list(x = NULL, y = 7), 
  update   = list(z = NULL, na.rm = TRUE),
  delete   = c('error')
)

cc

farnarkle(6, x = 2, y = 3, z = NULL, na.rm = TRUE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 'farnarkle' is not yet defined, so evaluation should fail
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
evaluate_call(cc)

Error in farnarkle(6, x = 2, y = 3, z = NULL, na.rm = TRUE): could not find function "farnarkle"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# define farnarkle and it should work
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
farnarkle <- function(...) {print("Hello #Rstats")}
evaluate_call(cc)

[1] "Hello #Rstats"

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Inserting rgl as webgl in an Rmarkdown document - Part 2

Mon, 07 Sep 2020 20:00:00 +1000

How to insert `rgl` as webgl in an Rmarkdown document - Part 2

This post is really a mini-reminder to myself on how to insert an rgl render as webgl within an Rmarkdown document.

library(rgl)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw a 3D cube! Woo!
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
shade3d(cube3d(color = rep(rainbow(6), rep(4, 6))))

Use your mouse, mouse buttons and scrollwheel to manipulate the 3d plot

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Display the last render 
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
if (!interactive()) rgl::rglwidget()

Inserting rgl as webgl in an Rmarkdown document

Mon, 07 Sep 2020 16:00:00 +1000

How to insert `rgl` as webgl in an Rmarkdown document

This post is really a mini-reminder to myself on how to insert an rgl render as webgl within an Rmarkdown document.

library(rgl)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# The setupKnitr() function needs to be called once at the start of the 
# document to install the knitr hooks and to initialize hook_webgl
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rgl::setupKnitr()

# ^^^^^^ You can't see it, but you have to set `webgl=TRUE` on the chunk
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw a 3D cube! Woo!
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
shade3d(cube3d(color = rep(rainbow(6), rep(4, 6))))

# Use your mouse to manipulate the object!

You must enable Javascript to view this page properly.

Introducing 'insitu' - functions for in-place modification

Thu, 03 Sep 2020 07:00:00 +1000

insitu

insitu provides some functions for modifying vectors in-situ (in place) without allocating a new vector.

This is an experimental package I wrote to try and figure out just how fast things could be in R.

Warning: Modifying vectors in-situ can be fast, but doing so violates some very strong norms within R internals.

Warning: Unless you are very confident on who has references to your data, do not use this package for in-place modification.

Modifying vectors in-place

Pros of modifying in-situ

Often faster as there is reduced memory allocation (and also reduced pressure on the garbage collector)
Often faster as there is no copying from the original vector into a new vector
By using C, we can override the copy-on-modify semantics usually used in R (regardless of how many references exist to the given object)

Cons of modifying in-situ

Normal R copy-on-modify behaviour is not followed - this will be a point of confusion as essentially everything in R uses copy-on-modify and not modification in-place.
Copying and allocating vectors is already very fast. It only takes a few microseconds to allocate memory for a vector of 1000 elements and assign new values into it. The speed saved by switching to in-situ modification will only possibly be useful if this operations is performed many, many times.

In the words of Luke Tierney in his User2020 keynote:

You should never modify something without duplicating it.

This package ignores this advice. Beware.

What’s in the box

insitu	description	integer	real	character
insitu_fill(x, value)	Fill vector with the given value	Yes	Yes	Yes
insitu_fill_runif(x, lower, upper)	Fill vector with uniform random numbers	Yes	Yes
insitu_fill_runif_fast(x, lower, upper)	Fill vector with uniform random numbers	Yes	Yes
insitu_replace(x, pos, values)	Replace values in x with given values starting from the given position	Yes	Yes	Yes
insitu_reverse(x)	Reverse vector	Yes	Yes	Yes
insitu_shuffle(x)	Shuffle the elements of a vector	Yes	Yes	Yes
insitu_shuffle_fast(x)	Shuffle the elements of a vector	Yes	Yes	Yes
insitu_sort(x)	Sort the elements of a vector	Yes	Yes

Fast Variants

The _fast versions of some functions use their own random-number generator rather than the one supplied in R. This generator is lehmer64. It is very fast, but has different properties from R’s built in random number generator. Use with caution.

ALTREP utils

is_altrep(x) tests whether an object is an ALTREP
is_mutable(x) tests whether an object is mutable in-place by checking its reference count
get_refcnt(x) returns the reference count for the object

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/insitu')

Future possibilities

In-place radix sort - instead of using qsort()
cummin, cummax etc
negate
diff

In-situ Replacement

insitu_replace() is analogous to replace() but replaces values in the current vector rather than creating a new one.

x <- integer(10)
insitu_replace(x, 6, 1:5)
x

 [1] 0 0 0 0 0 1 2 3 4 5

Click to show/hide benchmark code & results

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Assign values into a vector
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N = c(1e1, 1e2, 1e3, 1e4, 1e5, 1e6)

res_rel <- bench::press(
  N = N,
  {
    x <- numeric(N)
    x[1] <- x[1]
    idx <- seq(1, N/2)
    ins <- as.numeric(idx)
    
    bench::mark(
      replace(x, idx, ins),
      insitu_replace(x, 1, ins),
      check    = TRUE,
      relative = TRUE
    )
  }
)

res_rel %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
replace(x, idx, ins)	1.160156	1.106230	1.000000	NaN
insitu_replace(x, 1, ins)	1.000000	1.000000	1.118310	NaN
replace(x, idx, ins)	1.797336	2.029647	1.000000	2.446429
insitu_replace(x, 1, ins)	1.000000	1.000000	2.281246	1.000000
replace(x, idx, ins)	5.195353	7.137832	1.000000	2.494071
insitu_replace(x, 1, ins)	1.000000	1.000000	6.741992	1.000000
replace(x, idx, ins)	15.738677	25.238643	1.000000	2.499401
insitu_replace(x, 1, ins)	1.000000	1.000000	24.600466	1.000000
replace(x, idx, ins)	19.240119	31.171246	1.000000	2.499940
insitu_replace(x, 1, ins)	1.000000	1.000000	27.534510	1.000000
replace(x, idx, ins)	19.387400	18.192379	1.000000	2.499994
insitu_replace(x, 1, ins)	1.000000	1.000000	17.034955	1.000000

res_abs <- bench::press(
  N = N,
  {
    x <- numeric(N)
    x[1] <- x[1]
    idx <- seq(1, N/2)
    ins <- as.numeric(idx)
    
    bench::mark(
      replace(x, idx, ins),
      insitu_replace(x, 1, ins),
      check    = TRUE,
      relative = FALSE
    )
  }
)

res_abs %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
replace(x, idx, ins)	1.15µs	1.33µs	604227.9275	0B
insitu_replace(x, 1, ins)	1.01µs	1.23µs	626725.4925	0B
replace(x, idx, ins)	1.92µs	2.62µs	320836.0319	1.07KB
insitu_replace(x, 1, ins)	1.05µs	1.26µs	681850.9878	448B
replace(x, idx, ins)	6.01µs	7.62µs	113786.9416	9.86KB
insitu_replace(x, 1, ins)	1.16µs	1.31µs	711556.3865	3.95KB
replace(x, idx, ins)	42.78µs	80.93µs	11838.8043	97.75KB
insitu_replace(x, 1, ins)	2.8µs	3.13µs	299449.9164	39.11KB
replace(x, idx, ins)	417.16µs	726.44µs	1459.5060	976.66KB
insitu_replace(x, 1, ins)	21.53µs	24.7µs	37556.2759	390.67KB
replace(x, idx, ins)	4.68ms	5.03ms	184.7498	9.54MB
insitu_replace(x, 1, ins)	245.95µs	287.6µs	2939.2212	3.81MB

In-situ fill

insitu_fill() is analogous to replace() but assigns the value into the current vector rather than creating a new one.

x <- integer(10)
insitu_fill(x, 3L)
x

 [1] 3 3 3 3 3 3 3 3 3 3

Click to show/hide benchmark code & results

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Assign values into a vector
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# N = c(1e1, 1e2, 1e3, 1e4, 1e5, 1e6)

res_rel <- bench::press(
  N = N,
  {
    x <- numeric(N)
    idx <- 1:N
    ins <- 99
    
    bench::mark(
      replace(x, idx, ins),
      insitu_fill(x, ins),
      check    = TRUE,
      relative = TRUE
    )
  }
)

res_rel %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
replace(x, idx, ins)	1.229236	1.298578	1.000000	NaN
insitu_fill(x, ins)	1.000000	1.000000	1.326658	NaN
replace(x, idx, ins)	1.363341	1.667515	1.000000	Inf
insitu_fill(x, ins)	1.000000	1.000000	1.830421	NaN
replace(x, idx, ins)	1.000000	1.181148	1.000000	Inf
insitu_fill(x, ins)	1.060364	1.000000	1.324551	NaN
replace(x, idx, ins)	1.000000	1.590073	1.000000	Inf
insitu_fill(x, ins)	1.347507	1.000000	1.572959	NaN
replace(x, idx, ins)	1.000000	1.455272	1.000000	Inf
insitu_fill(x, ins)	1.343936	1.000000	1.357076	NaN
replace(x, idx, ins)	1.000000	1.000000	1.013211	Inf
insitu_fill(x, ins)	1.217040	1.111741	1.000000	NaN

res_abs <- bench::press(
  N = N,
  {
    x <- numeric(N)
    idx <- 1:N
    ins <- 99
    
    bench::mark(
      replace(x, idx, ins),
      insitu_fill(x, ins),
      check    = TRUE,
      relative = FALSE
    )
  }
)

res_abs %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
replace(x, idx, ins)	1.15µs	1.35µs	662250.3834	0B
insitu_fill(x, ins)	867ns	1.05µs	850804.0257	0B
replace(x, idx, ins)	1.67µs	2.02µs	386154.9397	1.27KB
insitu_fill(x, ins)	1.26µs	1.36µs	597002.8780	0B
replace(x, idx, ins)	4.29µs	5.64µs	155360.2575	11.81KB
insitu_fill(x, ins)	4.72µs	4.92µs	194406.1723	0B
replace(x, idx, ins)	29.01µs	66.16µs	14534.3837	117.28KB
insitu_fill(x, ins)	38.24µs	41.7µs	22958.4854	0B
replace(x, idx, ins)	273.27µs	621.43µs	1624.1870	1.15MB
insitu_fill(x, ins)	380.05µs	420.89µs	2334.8499	0B
replace(x, idx, ins)	3.25ms	3.7ms	241.1781	11.44MB
insitu_fill(x, ins)	3.69ms	4.21ms	235.6181	0B

In-situ sort

insitu_sort() is analogous to sort() but sorts values in the current vector rather than creating a new one.

x <- sample(10)
insitu_sort(x)
x

 [1]  1  2  3  4  5  6  7  8  9 10

Click to show/hide benchmark code & results

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Assign values into a vector
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# N = c(1e1, 1e2, 1e3, 1e4, 1e5, 1e6)

res_rel <- bench::press(
  N = N,
  {
    x <- runif(N)

    bench::mark(
      sort(x),
      insitu_sort(x),
      check    = TRUE,
      relative = TRUE
    )
  }
)

res_rel %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
sort(x)	44.192865	42.981013	1.000000	NaN
insitu_sort(x)	1.000000	1.000000	40.303405	NaN
sort(x)	26.989432	28.228392	1.000000	Inf
insitu_sort(x)	1.000000	1.000000	29.388349	NaN
sort(x)	6.541023	7.107368	1.000000	Inf
insitu_sort(x)	1.000000	1.000000	7.478798	NaN
sort(x)	1.937674	2.525904	1.000000	Inf
insitu_sort(x)	1.000000	1.000000	2.521864	NaN
sort(x)	1.064732	1.699909	1.000000	Inf
insitu_sort(x)	1.000000	1.000000	1.669044	NaN
sort(x)	1.025600	1.175356	1.000000	Inf
insitu_sort(x)	1.000000	1.000000	1.330278	NaN

res_abs <- bench::press(
  N = N,
  {
    x <- runif(N)
    
    bench::mark(
      sort(x),
      insitu_sort(x),
      check    = TRUE,
      relative = FALSE
    )
  }
)

res_abs %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
sort(x)	40.45µs	47.63µs	19323.2410	0B
insitu_sort(x)	899ns	1.05µs	823655.6466	0B
sort(x)	41.66µs	49.55µs	17223.6604	1.27KB
insitu_sort(x)	1.51µs	1.73µs	530651.7167	0B
sort(x)	47.28µs	57.11µs	15012.7291	11.81KB
insitu_sort(x)	7.04µs	7.86µs	109586.8553	0B
sort(x)	107.95µs	173.51µs	5329.9525	117.28KB
insitu_sort(x)	62.18µs	65.97µs	14349.4585	0B
sort(x)	653.57µs	1.2ms	832.5820	1.15MB
insitu_sort(x)	591.85µs	674.37µs	1450.3867	0B
sort(x)	6.83ms	9.13ms	110.9861	11.44MB
insitu_sort(x)	6ms	6.54ms	151.5278	0B

In-situ Shuffle

insitu_shuffle() is analogous to sample() but shuffles values in the current vector rather than creating a new one.

x <- c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
insitu_shuffle(x)
x

 [1] 9 6 0 3 5 7 8 1 4 2

Click to show/hide benchmark code & results

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Assign values into a vector
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# N = c(1e1, 1e2, 1e3, 1e4, 1e5, 1e6)

res_rel <- bench::press(
  N = N,
  {
    x <- runif(N)

    bench::mark(
      sample(x),
      insitu_shuffle(x),
      insitu_shuffle_fast(x),
      check    = FALSE,
      relative = TRUE
    )
  }
)

res_rel %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
sample(x)	7.385214	7.171458	1.000000	Inf
insitu_shuffle(x)	1.000000	1.000000	7.053456	NaN
insitu_shuffle_fast(x)	2.315175	2.382957	2.972455	Inf
sample(x)	5.043932	6.137506	1.000000	Inf
insitu_shuffle(x)	1.000000	1.000000	5.700903	NaN
insitu_shuffle_fast(x)	1.163097	1.310498	4.336377	Inf
sample(x)	7.971023	7.385535	1.000000	Inf
insitu_shuffle(x)	2.233688	2.114623	3.455347	NaN
insitu_shuffle_fast(x)	1.000000	1.000000	7.182072	Inf
sample(x)	11.935903	13.344195	1.000000	Inf
insitu_shuffle(x)	3.137795	3.202304	4.109921	NaN
insitu_shuffle_fast(x)	1.000000	1.000000	12.875612	Inf
sample(x)	14.665743	15.785546	1.000000	Inf
insitu_shuffle(x)	3.228209	3.517930	4.345945	NaN
insitu_shuffle_fast(x)	1.000000	1.000000	15.129547	Inf
sample(x)	12.858372	12.382391	1.000000	Inf
insitu_shuffle(x)	2.860528	3.340090	3.774192	NaN
insitu_shuffle_fast(x)	1.000000	1.000000	10.934830	Inf

res_abs <- bench::press(
  N = N,
  {
    x <- runif(N)
    
    bench::mark(
      sample(x),
      insitu_shuffle(x),
      insitu_shuffle_fast(x),
      check    = FALSE,
      relative = FALSE
    )
  }
)

res_abs %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
sample(x)	5.89µs	7.16µs	129084.90804	2.49KB
insitu_shuffle(x)	818ns	975ns	952295.33521	0B
insitu_shuffle_fast(x)	1.77µs	2.26µs	414345.47824	2.49KB
sample(x)	9.3µs	11.41µs	83312.86336	4.2KB
insitu_shuffle(x)	1.74µs	2.01µs	446962.15223	0B
insitu_shuffle_fast(x)	2.03µs	2.58µs	364783.29064	2.49KB
sample(x)	41.86µs	46.39µs	20845.99544	18.27KB
insitu_shuffle(x)	11.91µs	13.28µs	71481.19180	0B
insitu_shuffle_fast(x)	5.28µs	6.12µs	150911.04998	2.49KB
sample(x)	419.28µs	500.08µs	1956.51662	158.89KB
insitu_shuffle(x)	112.27µs	120.26µs	7967.50222	0B
insitu_shuffle_fast(x)	35.59µs	38.02µs	24551.59483	2.49KB
sample(x)	5.54ms	6.69ms	143.55062	1.53MB
insitu_shuffle(x)	1.21ms	1.39ms	699.63921	0B
insitu_shuffle_fast(x)	375.44µs	391.24µs	2437.92941	2.49KB
sample(x)	81.23ms	83.06ms	11.88900	15.26MB
insitu_shuffle(x)	17.31ms	22.98ms	44.18255	0B
insitu_shuffle_fast(x)	6.15ms	7.09ms	132.75626	2.49KB

In-situ Reverse

insitu_reverse() is analogous to rev() but reverses values in the current vector rather than creating a new one.

x <- c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
insitu_reverse(x)
x

 [1] 9 8 7 6 5 4 3 2 1 0

Click to show/hide benchmark code & results

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Assign values into a vector
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# N = c(1e1, 1e2, 1e3, 1e4, 1e5, 1e6)

res_rel <- bench::press(
  N = N,
  {
    x <- runif(N)

    bench::mark(
      rev(x),
      insitu_reverse(x),
      check    = TRUE,
      relative = TRUE
    )
  }
)

res_rel %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
rev(x)	4.001531	4.259724	1.000000	NaN
insitu_reverse(x)	1.000000	1.000000	4.248889	NaN
rev(x)	4.519830	5.314951	1.000000	Inf
insitu_reverse(x)	1.000000	1.000000	5.458907	NaN
rev(x)	5.461066	6.297345	1.000000	Inf
insitu_reverse(x)	1.000000	1.000000	6.684822	NaN
rev(x)	6.170470	15.868918	1.000000	Inf
insitu_reverse(x)	1.000000	1.000000	15.590267	NaN
rev(x)	7.360748	17.015706	1.000000	Inf
insitu_reverse(x)	1.000000	1.000000	15.858245	NaN
rev(x)	6.505439	6.468984	1.000000	Inf
insitu_reverse(x)	1.000000	1.000000	6.249604	NaN

res_abs <- bench::press(
  N = N,
  {
    x <- runif(N)
    
    bench::mark(
      rev(x),
      insitu_reverse(x),
      check    = TRUE,
      relative = FALSE
    )
  }
)

res_abs %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
rev(x)	2.54µs	3.35µs	279979.0743	0B
insitu_reverse(x)	641ns	764ns	1148403.6022	0B
rev(x)	3.02µs	3.7µs	231492.5363	1.27KB
insitu_reverse(x)	718ns	820ns	1110216.6455	0B
rev(x)	5.33µs	7.75µs	113639.8907	11.81KB
insitu_reverse(x)	1.03µs	1.15µs	823221.0911	0B
rev(x)	34.01µs	79.71µs	11979.8707	117.28KB
insitu_reverse(x)	4.53µs	4.88µs	190598.4239	0B
rev(x)	278.97µs	716.12µs	1380.1388	1.15MB
insitu_reverse(x)	39.46µs	42.45µs	21911.3579	0B
rev(x)	2.87ms	3.5ms	252.3226	11.44MB
insitu_reverse(x)	425.69µs	525.97µs	1746.0251	0B

In-situ fill with random

insitu_fill_runif() is analogous to runif() but generates values in the current vector rather than creating a new one.

x <- integer(10)
insitu_fill_runif(x, 10, 15)
x

 [1] 14 10 10 14 15 13 11 10 10 11

Click to show/hide benchmark code & results

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Assign values into a vector
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# N = c(1e1, 1e2, 1e3, 1e4, 1e5, 1e6)

res_rel <- bench::press(
  N = N,
  {
    x <- numeric(N)

    bench::mark(
      runif(x),
      insitu_fill_runif(x, 0, 1),
      insitu_fill_runif_fast(x, 0, 1),
      check    = FALSE,
      relative = TRUE
    )
  }
)

res_rel %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
runif(x)	1.892204	1.952124	1.000000	Inf
insitu_fill_runif(x, 0, 1)	1.000000	1.000000	1.937939	NaN
insitu_fill_runif_fast(x, 0, 1)	1.870067	1.896525	1.054534	Inf
runif(x)	2.441160	2.689176	1.000000	Inf
insitu_fill_runif(x, 0, 1)	1.000000	1.000000	2.702906	NaN
insitu_fill_runif_fast(x, 0, 1)	1.209778	1.348808	2.093330	Inf
runif(x)	8.089969	7.102734	1.000000	Inf
insitu_fill_runif(x, 0, 1)	2.883208	2.530203	2.871414	NaN
insitu_fill_runif_fast(x, 0, 1)	1.000000	1.000000	6.659101	Inf
runif(x)	16.993506	19.090761	1.000000	Inf
insitu_fill_runif(x, 0, 1)	5.584250	5.586271	3.393810	NaN
insitu_fill_runif_fast(x, 0, 1)	1.000000	1.000000	18.507435	Inf
runif(x)	19.036940	22.376697	1.000000	Inf
insitu_fill_runif(x, 0, 1)	6.573531	6.956403	3.169354	NaN
insitu_fill_runif_fast(x, 0, 1)	1.000000	1.000000	21.028264	Inf
runif(x)	19.948139	20.726121	1.000000	Inf
insitu_fill_runif(x, 0, 1)	6.616963	6.674905	3.027731	NaN
insitu_fill_runif_fast(x, 0, 1)	1.000000	1.000000	19.864069	Inf

res_abs <- bench::press(
  N = N,
  {
    x <- numeric(N)
    
    bench::mark(
      runif(x),
      insitu_fill_runif(x, 0, 1),
      insitu_fill_runif_fast(x, 0, 1),
      check    = FALSE,
      relative = FALSE
    )
  }
)

res_abs %>%
  select(expression, min, median, `itr/sec`, mem_alloc) %>%
  knitr::kable()

expression	min	median	itr/sec	mem_alloc
runif(x)	1.99µs	2.59µs	336636.38707	2.49KB
insitu_fill_runif(x, 0, 1)	1.07µs	1.31µs	656322.24018	0B
insitu_fill_runif_fast(x, 0, 1)	2.06µs	2.75µs	327837.27244	2.49KB
runif(x)	4.46µs	5.26µs	177614.21164	3.32KB
insitu_fill_runif(x, 0, 1)	1.84µs	2.06µs	439719.78282	0B
insitu_fill_runif_fast(x, 0, 1)	2.2µs	3.02µs	295293.68017	2.49KB
runif(x)	28.69µs	30.94µs	30566.18629	10.35KB
insitu_fill_runif(x, 0, 1)	10.06µs	10.95µs	88317.87574	0B
insitu_fill_runif_fast(x, 0, 1)	3.57µs	4.4µs	206912.05011	2.49KB
runif(x)	277.8µs	348.6µs	2823.69086	80.66KB
insitu_fill_runif(x, 0, 1)	95.31µs	101.88µs	9417.11075	0B
insitu_fill_runif_fast(x, 0, 1)	16.65µs	18.25µs	51459.46531	2.49KB
runif(x)	2.72ms	3.26ms	303.64721	783.79KB
insitu_fill_runif(x, 0, 1)	942.01µs	1.03ms	962.25305	0B
insitu_fill_runif_fast(x, 0, 1)	143.63µs	148.54µs	6491.03605	2.49KB
runif(x)	28.57ms	32.02ms	31.96567	7.63MB
insitu_fill_runif(x, 0, 1)	9.65ms	10.38ms	95.77602	0B
insitu_fill_runif_fast(x, 0, 1)	1.43ms	1.49ms	659.59949	2.49KB

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Run-Length Encoding and The Problem of NAs

Wed, 26 Aug 2020 20:00:00 +1000

Run-Length Encoding

Run-length encoding computes the lengths and values of runs of equal values in a vector

E.g. given a vector c(1, 1, 1, 8, 9, 9), run-length encoding will summarise the data to say that there are “three 1s, one 8 and two 9s”.

In R, this can be done with base::rle()

rle(c(1, 1, 1, 8, 9, 9))

Run Length Encoding
  lengths: int [1:3] 3 1 2
  values : num [1:3] 1 8 9

A problem with `base::rle()` - NA values

base::rle() checks for equality of one value and the next using ==, and if they are different then it signals the end of a run of values, and the start of the next.

The problem with == is that NA values are never considered to equal each other, which leads to multiple NA values in a row not being considered as a run. E.g.

rle(c(1, 1, 1, NA, NA, NA, 2, 2, 2, 2))

Run Length Encoding
  lengths: int [1:5] 3 1 1 1 4
  values : num [1:5] 1 NA NA NA 2

The logic used to explain this is usually along the lines of “NA values are unknown and so would never be equal to each other, so therefore it makes sense they are not considered as a run of identical values”.

That’s true: NA is never equal to anything:

NA == NA

[1] NA

NA == 1

[1] NA

NA == Inf

[1] NA

Rebuttals:

# While not equal to each other, NAs are identical()
identical(NA, NA)

[1] TRUE

# NAs are considered the same in unique()
unique(c(1, 1, 1, 2, 2, NA, NA, NA))

[1]  1  2 NA

This NA handling issue has been raised on the R-devel list many years ago 2011 and today 2020.

Also, Gabe Becker notes that the run-length encoding function in the Bioconductor - S4Vectors package does group the NAs.

I want NAs considered as equal to each other when doing run-length encoding

I acknowledge that NAs are never equal to each other or anything else, but when I do run-length encoding I want them to be grouped together.

I’d be interested to find a case when someone is doing run-length encoding and didn’t want the NAs grouped together. Hit me up on twitter if you can think of one!

`rle2()` - A drop-in replacement for `rle()` that handles NAs sanely

rle2() is a function for run-length encoding that treats NAs as identical, and thus groups them together.

This is a copy of the body of base::rle() with just 1 extra line and 2 changed lines to handle NA values sanely.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' A drop-in replacement for \code{base::rle()} that treats all NAs as identical
#'
#' @param x an atomic vector
#'
#' @return An object of class \code{rle}
#'
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rle2 <- function (x)  {
  stopifnot("'x' must be a vector of an atomic type" = is.atomic(x))

  n <- length(x)
  if (n == 0L) {
    return(structure(list(
      lengths = integer(), values = x)
    ), class = 'rle')
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Where does next value not equal current value?
  # i.e. y will be TRUE at the last index before a change
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  y <- (x[-1L] != x[-n])

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Since NAs are never equal to anything, NAs in 'x' will lead to NAs in 'y'.
  # These current NAs in 'y' tell use nothing - Set all NAs in y to FALSE
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  y[is.na(y)] <- FALSE

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # When a value in x is NA and its successor is not (or vice versa) then that
  # should also count as a value change and location in 'y' should be set to TRUE
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  y <- y | xor(is.na(x[-1L]), is.na(x[-n]))

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Any TRUE locations in 'y' are the end of a run, where the next value
  # changes to something different
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  i <- c(which(y), n)

  structure(list(
    lengths = diff(c(0L, i)),
    values  = x[i]
  ), class = 'rle')
}

x <- c(1, 1, 1, NA, NA, NA, NA, 10, 10)
rle(x)

Run Length Encoding
  lengths: int [1:6] 3 1 1 1 1 2
  values : num [1:6] 1 NA NA NA NA 10

rle2(x)

Run Length Encoding
  lengths: int [1:3] 3 4 2
  values : num [1:3] 1 NA 10

Introducing 'chipmunkcore' - a wrapper for the chipmunk2d physics simulation c library

Thu, 20 Aug 2020 21:47:00 +1000

chipmunkcore

chipmunkcore is a low-level wrapper around the Chipmunk2d rigid body physics simulation library.

There are many low-level functions available, but currently it’s probably best to use the limited functionality available through the simple R6 class provided - ChipmunkBasic

chipmunkcore is just the simulator. To render the positions of bodies in the simulation you’ll need to use ggplot2, cairocore or something else

Read the online documentation here

Pre-requisites

You’ll need to install the Chipmunk2d library on your system.

I only know how to do this on macOS where you can do

brew install chipmunk

If you know how to install this library on other systems, and subsequently compile this package, please let me know by filing an issue, or pinging me on twitter

Installation

After installing the Chipmunk2d C library, you can install this package from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/chipmunkcore')

ToDo

Add other shapes besides circles
Add constraints
Expose more of the underlying C library

Galton Board

For full code, see the vignette

A simple simulation

library(chipmunkcore)
library(ggplot2)
set.seed(1)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialize a simulation space
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cm <- Chipmunk$new()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add fixed segments
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cm$add_segment(-20, 10, -5, 0)
cm$add_segment( 20, 10,  5, 0)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fetch all the segments. Use for plotting
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
segments_df <- cm$get_segments()

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add some bodies. Currently only circular bodies supported
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (i in 1:10) {
  cm$add_body(
    x = runif(1, -20, 20), 
    y = runif(1,  10, 50),
    vx = 10 * rnorm(1),
    vy = 10 * rnorm(1)
  )
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Get the current positions of the bodies. as a data.frame
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
bodies <- cm$get_bodies()
bodies



for (frame in 1:45) {
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Advance the simulation
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  cm$advance(5)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Get the bodies in their new locations
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  bodies <- cm$get_bodies()
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Plot everything
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  p <- ggplot(bodies) + 
    geom_point(aes(x, y, colour = as.factor(idx)), size = 4, na.rm=TRUE) + 
    geom_segment(data = segments_df, aes(x = x1, y = y1, xend = x2, yend = y2)) + 
    coord_fixed() + 
    # theme_void() + 
    theme_minimal() + 
    xlim(-20, 20) + 
    ylim(-10, 50) + 
    theme(legend.position = 'none')
  
  ggsave(sprintf("man/figures/png/%04i.png", frame), p, width = 6, height = 6)
}

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'cairobasic' - an R6 wrapper around cairocore

Tue, 18 Aug 2020 15:39:00 +1000

cairobasic

cairobasic is a package which provides a fast canvas for drawing operations.

This is a really demonstration package showing how cairocore may be made more palatable for programming within R.

This package currently only offers some basic drawing tools, but could easily be forked/expanded to suit different needs.

To get the most out of CairoGraphics at this stage, you would still need to use cairocore, but cairobasic will accumulate features based upon user feedback.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/cairobasic')

Using `cairobasic`

The cairobasic package provides an R6 class (CairoBasic) which keeps track of context information for rendering and the actual rendering surface.

library(cairobasic)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a new 'CairoBasic' object
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
width  <- 800
height <- 400
cb     <- CairoBasic$new(width = width, height = height)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add concentric circles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N <- 10
cb$add_circles(
  x    = rep(width/2, N),
  y    = 0,
  r    = seq(width, 0, length.out = N),
  fill = '#80808020'
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add Lines with rainbow colouring
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N <- 500
cb$add_line_segments(
  x1 = rep(width/2, N),
  y1 = 0,
  x2 = seq(1, width, length.out = N),
  y2 = height,
  colour = rainbow(N, alpha = 0.1)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add rectangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N <- 10

xy <- expand.grid(x = seq(1, width/2, width/32), y = seq(1, height, width/32))
xy <- subset(xy, y < width/2 - x - width/16)

cb$add_rectangles(
  x      = xy$x,
  y      = xy$y,
  width  = width/32,
  height = width/32,
  fill   = terrain.colors(nrow(xy)),
  colour = '#20202020'
)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add polygons
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cx  <- width  * 0.85
cy  <- height * 0.35
ang <- seq(0, 2*pi, pi/3)

x1  <- cx + 50 * sin(ang)
y1  <- cy + 50 * cos(ang)

x2  <- cx + 60 * sin(ang)
y2  <- cy + 60 * cos(ang)

x   <- c(x1, x2)
y   <- c(y1, y2)
idx <- as.integer(c(1, 1, 1, 1, 1, 1, 1,   2, 2, 2, 2, 2, 2, 2))

cb$add_polygons(
  x, y, idx, fill = NA, 
  linewidth = 5,
  colour = c('red', 'blue'))


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add Text
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cb$add_text("{cairobasic}", width*0.65 + 1, 10, fontsize = 50, colour = 'white')
cb$add_text("{cairobasic}", width*0.65    , 11, fontsize = 50, colour = '#606060a0')


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Show it
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cb$show(interpolate = TRUE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Save to PNG
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cb$write_png("output.png")

Working with `cairocore`

Read the cairocore README for more information

library(cairocore)

cairo_set_source_rgba(cb$cr, 1, 0, 0, 0.3)
cairo_set_line_width(cb$cr, 10)
cairo_set_dash(cb$cr, c(10, 15, 25), 3, 0)
cairo_rectangle(cb$cr, 100, 100, width-200, height-200)
cairo_stroke(cb$cr)

cb$show()

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'cairocore' - fast 2d drawing canvas backed by cairo

Mon, 17 Aug 2020 19:53:00 +1000

cairocore

cairocore provides a canvas and tools for fast 2d drawing operations.

It provides a low-level wrapper around the cariographics 2D graphics library (written in C) which provides drawing operations and related functions, with consistent output on multiple platforms and output media (e.g. SVG, PDF, PNG etc).

This package is not a graphics device - you can’t plot to it. Instead it provides a canvas for directly drawing shapes and text.

View the online documentation here

Key Features

Very fast line and shape drawing
Convert canvas surface to/from R arrays - this means you can draw on an array from within R
Alpha-blending and anti-aliasing
Direct control of what pixels get put on a canvas i.e. not having to pass through an intermediate plotting step (e.g. ggplot) or graphics device (e.g. png())

Package Philosophy

cairocore is a one-to-one mapping from R functions to C functions in the cariographics C library.

This package will remain very “C-like”, but other packages are welcome to wrap this cairocore to enable more idiomatic R programming styles.

One such wrapper is cairobasic which offers a subset of the possible drawing operations with a friendlier interface.

Installation Pre-requisite: Cairographics C library + headers

CairoGraphics library installed
See CairoGraphics downloads page for more information on how this might work on your platform.

Install CairoGraphics on Mac OSX

Using homebrew - brew install cairo (this works on my Mac)
Using MacPorts - sudo port install cairo
Using fink

Install CairoGraphics on Linux

Debian/Ubuntu - sudo apt-get install libcairo2-dev
Fedora - sudo yum install cairo-devel
openSUSE - zypper install cairo-devel

Install CairoGraphics on Windows

I haven’t been able to test any of the windows techniques - if you are a windows user, please let me know what worked for you!

CairoGraphics downloads page for more information
Try the following:

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/cairocore')

Documentation + Tutorials

cairocore behaves almost identically to the CairoGraphics C library and in many cases examples from the internet (which are all in C code) may be lightly modified and used as R code.

The documentation for cairocore is mostly a direct translation of the CairoGraphics documentation and has been extracted from the C source files.

View the online documentation here

A great tutorial on using CairoGraphics in C is from zetcode.

Vignettes

I’ve tried to highlight a few interesting features of CairoGrapihcs in the vignettes, but the library is huge and I can’t cover all of it here.

Hopefully there are enough code examples to get you started!

Creating patterns
Drawing on R arrays create a drawing canvas from an R array and draw on it
Drawing simple shapes
Image output formats
Using Transforms by default CairoGraphics considers the origin to be the top left of the page. This vignette sets the transformation matrix on a surface such that the bottom left corner is considered the origin.
Vectorised functions there are some custom functions for drawing multitudes of the same type of element. There is a speed advantage in looping over data within C rather than within R.
Technical - enums in C
Technical - pointers in C
Technical - structs in C

Example - Using `cairocore` as a drawing canvas

Click to show/hide code

library(cairocore)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a surface to draw on.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
width  <- 800
height <- 400

surface <- cairo_image_surface_create(
  format = cairo_format_t$CAIRO_FORMAT_ARGB32, 
  width  = width,
  height = height
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Every surface must have a context in order to operate on it.
# For faster operation, antialiasing can be switched off
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cr <- cairo_create(surface)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Clear the surface to a light grey
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_set_source_rgb(cr, 0.98, 0.98, 0.98)
cairo_paint(cr)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw some red lines
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_set_source_rgba(cr, 1, 0, 0, 0.02)
for (i in seq(width)) {
  cairo_move_to(cr, 0, 0)
  cairo_line_to(cr, i, height)
  cairo_stroke(cr)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw some rectangles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_set_line_width(cr, 0.5)
cairo_set_source_rgba(cr, 0, 0, 1, 0.2)

for (j in seq(1, height, 22)) {
  for (i in seq(width/2, width, 22)) {
    cairo_rectangle(cr, i, j, 20, 20)
    cairo_fill(cr)
  }
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw green circles
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (x in seq(1, width/3, 50)) {
  for (y in seq(height/2, height, 50)) {
    cairo_set_source_rgba(cr, 0, 0.5, 0, 0.1)
    cairo_arc(cr, x, y, radius = 20, 0, 2*pi)
    cairo_fill(cr)
  }
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Get the image surface as a raster
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
raster_out <- cairo_image_surface_get_raster(surface, nchannel = 3)
plot(raster_out, interpolate = FALSE)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Save the surface as a PNG
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_surface_write_to_png(surface, tempfile(fileext = ".png"))
[1] 0

Example - drawing 10,000 alpha blended lines

Click to show/hide code

library(cairocore)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Calculate the end coordinates of a lot of line segments
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
width  <- 1000
height <- 500
N      <- 10000
t      <- seq(0, 2*pi, length.out = N)
x1     <- width  * sin(t)
x2     <- width  * sin(2 * t + pi/2)
y1     <- height * cos(t)
y2     <- height * cos(4*t + pi/2)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a surface to draw on.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
surface <- cairo_image_surface_create(
  format = cairo_format_t$CAIRO_FORMAT_ARGB32, 
  width  = width,
  height = height
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Every surface must have a context in order to operate on it.
# For faster operation, antialiasing can be switched off
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cr <- cairo_create(surface)
# cairo_set_antialias(cr, cairo_antialias_t$CAIRO_ANTIALIAS_NONE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Clear the surface to a light grey
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_set_source_rgb(cr, 0.98, 0.98, 0.98)
cairo_paint(cr)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Set the drawing colour for subsequent operations
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_set_source_rgba(cr, 0.2, 0.3, 1, 0.01)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw each line - 
#   this seems laborious but it is idiomatic C/cairo programming style
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (i in seq(N)) {
  cairo_move_to(cr, x1[i], y1[i])
  cairo_line_to(cr, x2[i], y2[i])
  cairo_stroke(cr)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Write some text on the cairo surface
# `cairo_font_slant_t` and `cairo_font_weight_t` are enums in C which have 
# been encoded as lists in R.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_select_font_face (
  cr, 
  family = "sans", 
  slant  = cairo_font_slant_t$CAIRO_FONT_SLANT_NORMAL, 
  weight = cairo_font_weight_t$CAIRO_FONT_WEIGHT_BOLD
)

cairo_set_font_size(cr, 57.0)
cairo_set_source_rgba(cr, 0, 0, 0, 0.3) 
cairo_move_to (cr, 5.0, 60.0)
cairo_show_text (cr, "{cairocore}")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Get the image surface as a raster
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
raster_out <- cairo_image_surface_get_raster(surface, nchannel = 3)
plot(raster_out, interpolate = FALSE)

Example - taking an array in R, drawing on it, returning it to R

Click to show/hide code

library(cairocore)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Let's grab the volcano
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arr <- (t(volcano) - min(volcano))/(max(volcano) - min(volcano))
plot(as.raster(arr), interpolate = FALSE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise a surface from the array
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
surface <- cairo_image_surface_create_from_array(arr)
cr      <- cairo_create(surface)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw a circle on the cairo surface
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_arc(cr, 70, 15, 10, 0, 2*pi)
cairo_set_line_width(cr, 3);
cairo_set_source_rgba(cr, 255/255, 99/255, 71/255, 0.8)
cairo_stroke(cr)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Write some text on the cairo surface
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
cairo_select_font_face (cr, "serif", cairo_font_slant_t$CAIRO_FONT_SLANT_NORMAL, cairo_font_weight_t$CAIRO_FONT_WEIGHT_BOLD)
cairo_set_font_size (cr, 17.0)
cairo_set_source_rgb (cr, 0.2, 0.6, 1.0) 
cairo_move_to (cr, 2.0, 56.0)
cairo_show_text (cr, "{cairocore}")

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fetch the drawing surface as an array
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
array_out <- cairo_image_surface_get_array(surface=surface)
plot(as.raster(array_out), interpolate = FALSE)

Acknowledgements

R Core for developing and maintaining R
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'spng' - In-memory decoding of PNG images

Wed, 05 Aug 2020 20:22:00 +1000

spng

spng offers in-memory decompression of PNG images to vectors of raw values.

This is useful if you have bytes representing a PNG image (e.g. from a database) and need to decompress these to an array representation within R.

spng is a R wrapper for libspng.

libpng API docs

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/spng')

What’s in the box

depng(raw_vec, fmt, flags) - convert a vector of raw values containing a PNG image into a vector of raw bytes representing individual pixel values.
get_info(raw_vec) - interrogate a vector of raw values containing a PNG image to determine image information i.e. width, height, bit_depth, color_type, compression_method, filter_method, interlace_method.

Example: Decompress a PNG in memory

library(spng)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# A PNG file everyone should have!
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
png_file <- system.file("img", "Rlogo.png", package="png")
img <- magick::image_read(png_file)
img

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Read in the raw bytes
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
png_data <- readBin(png_file, 'raw', n = file.size(png_file))
png_data[1:100]
  [1] 89 50 4e 47 0d 0a 1a 0a 00 00 00 0d 49 48 44 52 00 00 00 64 00 00 00 4c 08
 [26] 06 00 00 00 9b 1d 12 0f 00 00 00 06 62 4b 47 44 00 ff 00 ff 00 ff a0 bd a7
 [51] 93 00 00 00 09 70 48 59 73 00 00 2e 23 00 00 2e 23 01 78 a5 3f 76 00 00 00
 [76] 07 74 49 4d 45 07 d5 02 10 10 08 0e 97 b9 27 bc 00 00 20 00 49 44 41 54 78

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Get info about the PNG 
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(png_info <- spng::png_info(png_data))
$width
[1] 100

$height
[1] 76

$bit_depth
[1] 8

$color_type
[1] 6

$compression_method
[1] 0

$filter_method
[1] 0

$interlace_method
[1] 0

$color_desc
[1] "RGB + Alpha"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Unpack the raw PNG bytes into RGB 8-bits-per-color packed format. 
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
img_data <- spng::depng(png_data, fmt = spng_format$SPNG_FMT_RGB8)
img_data[1:200]
  [1] 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
 [26] 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
 [51] 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
 [76] 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
[101] 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 c6 c8 c5 98 9b
[126] 96 8f 93 8c 87 8b 84 83 87 80 81 85 7e 80 84 7d 7e 82 7a 81 85 7e 7e 83 7b
[151] 7e 83 7b 7e 83 7b 78 7d 75 80 85 7d 7e 82 7b 80 84 7d 81 85 7e 88 8c 85 9a
[176] 9d 97 be bf bc 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Pick the green channel and plot as greyscale
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N <- length(img_data)
mat <- matrix(img_data[seq(2, N, 3)], nrow = png_info$width, ncol = png_info$height)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Image had an alpha channel, let's replace that with white background
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mat[mat == 0] <- as.raw(255)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# PNG bytes are in row-major order. R is in column major order
# so need to transpose to view correctly
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
plot(as.raster(t(mat)))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Construct an array by plucking the relevant bytes.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arr <- array(
  c(
    img_data[seq(1, N, 3)], # R
    img_data[seq(2, N, 3)], # G
    img_data[seq(3, N, 3)]  # B
  ),
  dim = c(png_info$width, png_info$height, 3)
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# This array had an alpha channel. Let's replace the background with white.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arr[arr == 0] <- as.raw(255)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# PNG bytes are in row-major order. R is in column major order
# so need to transpose to view correctly
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
arr <- aperm(arr, c(2, 1, 3))
plot(as.raster(arr))

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'pixelweaver' - Convert arrays/matrices to packed ARGB32 colour format

Mon, 03 Aug 2020 20:34:00 +1000

pixelweaver

pixelweaver provides functions for converting R matrices and arrays into a common packed integer representation - ARGB32

The ARGB32 data is stored in memory and referenced by an external pointer. This data can then either:

manipulated and then converted back to matrix or array
be passed to other C library wrappers written in R which understand external pointers.
converted to a vector of raw values

Why?

Rstats commonly stores pixel information in arrays, where the R, G, B and A values are specified as separate planes of an array (in that order). Values in the array are commonly real numbers in the range [0, 1]

Very few C graphics libraries support this planar colour representation.

One common format C libraries support is ARGB32 - where a single byte is used to represent each of the A, R, G and B values (each value is in the range [0, 255]). These bytes are then lumped together as a 4-byte sequence.

pixelweaver provides functions for converting R’s planar colour representation to/from the packed ARGB32 representation.

An overview/schematic of the pixel representations and where pixelweaver sits is illustrated below.

Future possibilities

Support copying into pre-allocated arrays to avoid having to allocate new memory each time.
Faster algorithms for the transpose and shuffle. MMX? SSE? AVX?
Other pixel formats e.g. RGBA32
Support for big-endian systems (are there any such systems in common use with R?)

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/pixelweaver')

What’s in the box

argb32_to_planar(), planar_to_argb32() - convert matrices and arrays to/from packed ARGB32 format. These functions store the ARGB32 data as a sequence of bytes in memory and return an external pointer to this memory.
argb32_to_raw(), raw_to_argb32() - convert the package ARGB32 format from an external pointer (to data in memory) to a vector of raw values in R.

Conversion of an RGBA array to ARGB32 format and back again.

library(pixelweaver)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create an an array with 3 planes representing RGB colour data
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(arr <- array(seq(4*3*3)/36, c(4, 3, 3)))
, , 1

           [,1]      [,2]      [,3]
[1,] 0.02777778 0.1388889 0.2500000
[2,] 0.05555556 0.1666667 0.2777778
[3,] 0.08333333 0.1944444 0.3055556
[4,] 0.11111111 0.2222222 0.3333333

, , 2

          [,1]      [,2]      [,3]
[1,] 0.3611111 0.4722222 0.5833333
[2,] 0.3888889 0.5000000 0.6111111
[3,] 0.4166667 0.5277778 0.6388889
[4,] 0.4444444 0.5555556 0.6666667

, , 3

          [,1]      [,2]      [,3]
[1,] 0.6944444 0.8055556 0.9166667
[2,] 0.7222222 0.8333333 0.9444444
[3,] 0.7500000 0.8611111 0.9722222
[4,] 0.7777778 0.8888889 1.0000000
plot(as.raster(arr), interpolate = FALSE)



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Convert the R planar colour representation to packed ARGB32 format 
# This is a pointer to a memory location that contains the data
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
argb32_ptr <- planar_to_argb32(arr, maxval = 1)
argb32_ptr
<pointer: 0x7f9fb8577770>
attr(,"class")
[1] "unsigned char"


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# View the raw data. Note the value = 255 every 4th value - this is the 
# default alpha value set for each pixel
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
as.integer(argb32_to_raw(argb32_ptr))
 [1] 177  92   7 255 205 120  35 255 233 148  63 255 184  99  14 255 212 127  42
[20] 255 240 155  70 255 191 106  21 255 219 134  49 255 247 162  77 255 198 113
[39]  28 255 226 141  56 255 255 170  85 255


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Convert the R, G and Blue values from the packed ARGB32 representation 
# back into the original representation
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(arr_out <- argb32_to_planar(argb32_ptr, 'rgb'))
, , 1

           [,1]      [,2]      [,3]
[1,] 0.02745098 0.1372549 0.2470588
[2,] 0.05490196 0.1647059 0.2745098
[3,] 0.08235294 0.1921569 0.3019608
[4,] 0.10980392 0.2196078 0.3333333

, , 2

          [,1]      [,2]      [,3]
[1,] 0.3607843 0.4705882 0.5803922
[2,] 0.3882353 0.4980392 0.6078431
[3,] 0.4156863 0.5254902 0.6352941
[4,] 0.4431373 0.5529412 0.6666667

, , 3

          [,1]      [,2]      [,3]
[1,] 0.6941176 0.8039216 0.9137255
[2,] 0.7215686 0.8313725 0.9411765
[3,] 0.7490196 0.8588235 0.9686275
[4,] 0.7764706 0.8862745 1.0000000
plot(as.raster(arr_out), interpolate = FALSE)



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Convert the R, G and Blue values from the packed ARGB32 representation 
# back into a grey matrix using  0.3R + 0.59G + 0.11B
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(mat_out <- argb32_to_planar(argb32_ptr, 'grey'))
          [,1]      [,2]      [,3]
[1,] 0.2974510 0.4072549 0.5170588
[2,] 0.3249020 0.4347059 0.5445098
[3,] 0.3523529 0.4621569 0.5719608
[4,] 0.3798039 0.4896078 0.6033333
plot(as.raster(mat_out), interpolate = FALSE)

Technical bits

ARGB32 or ARGB8888 format.
Each of A, R, G, B gets 1 byte (8 bits)
Together these 4 bytes fit in a standard ‘int32’
‘A’ (alpha) is in the most significant byte
x86 systems are little-endian so when viewing these bytes one at a time, the order will be B, G, R, A. i.e. from least signficant to most significant byte

Acknowledgements

R Core for developing and maintaining the language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'simpletrie' - a simple trie written in pure R (a.k.a. a tool for cheating at scrabble)

Sat, 01 Aug 2020 21:11:00 +1000

simpletrie

simpletrie is a simple trie implementation in plain R code.

A trie is a structure for representing certain data as a tree of nodes. This data representation allows for fast queries of certain types.

simpletrie can build a trie from 175k words in about 3s.

What’s in the box

trie_create() - create a trie, and optionally initialise with a dictionary of words
trie_insert() - insert words into a trie
trie_find_subwords() - find all sub-words in the trie using the characters in the given word

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/simpletrie')

Example: Finding sub-words from a given word

My main use-case for simpletrie is for looking up scrabble words i.e. to find all possible sub-words of a given word with:

the characters in any order
being able to specify a wildcard to indicate that any letter can be used i.e. the . character

library(simpletrie)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Read the ENABLE word list
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
words <- tolower(readLines("enable1.txt"))
length(words)
[1] 172821

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create trie strcture
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
system.time({
  trie <- trie_create(words)
})
   user  system elapsed 
  1.762   0.049   1.820 

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Find all words which can be made with 'hi.rstats'
# '.' is a wildcard, and can match any letter. (Like a blank tile in scrabble)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
system.time({
  subwords <- trie_find_subwords(trie, 'hi.rstats')
})
   user  system elapsed 
  0.109   0.003   0.113 

length(subwords)
[1] 2304
head(subwords, 100)
  [1] "hi"       "hire"     "hires"    "his"      "hist"     "hists"   
  [7] "hists"    "hiss"     "hisser"   "hissy"    "hisn"     "hiss"    
 [13] "hist"     "hists"    "hit"      "hits"     "hitter"   "hitters" 
 [19] "hits"     "hiatus"   "hic"      "hid"      "hie"      "hies"    
 [25] "hilt"     "hilts"    "hila"     "hilar"    "him"      "hin"     
 [31] "hins"     "hint"     "hints"    "hip"      "hips"     "his"     
 [37] "hiss"     "hist"     "hists"    "hit"      "hits"     "ha"      
 [43] "hair"     "hairs"    "hairs"    "hairy"    "haik"     "haiks"   
 [49] "hail"     "hails"    "hair"     "hairs"    "harsh"    "hart"    
 [55] "harts"    "harts"    "harass"   "hard"     "hards"    "hare"    
 [61] "hares"    "hark"     "harks"    "harl"     "harls"    "harm"    
 [67] "harms"    "harp"     "harpist"  "harpists" "harps"    "hart"    
 [73] "harts"    "has"      "hast"     "hastier"  "hastiest" "haste"   
 [79] "hastes"   "hasty"    "hash"     "hasp"     "hasps"    "hast"    
 [85] "hat"      "hats"     "hatter"   "hatters"  "hate"     "hater"   
 [91] "haters"   "hates"    "hath"     "hats"     "haar"     "haars"   
 [97] "habit"    "habits"   "had"      "hadst"

What’s a trie?

A trie is an ordered data structure represented as a tree of nodes.

The image below shows a very small trie which represents the words: ‘cat’, ‘cog’, ‘dog’ and ‘dote.’

This representation allows for very fast queries of certain types.

Technical bits

The trie is implemented here as nested environments. Environments are created with new.env(parent = emptyenv(), hash = FALSE).

Using the emptyenv() as parent saves some memory, as the parent environment is never needed in this process.

hash is set to FALSE as using a hash table expands the memory usage by quite a bit - even if size is set to limit the initial hash table size.

Using a hash table on the environment doesn’t appreciably change the speed of trie creation or preforming look-ups.

Environments are used instead of lists as I make use of the reference semantics of environment objects when building the trie.

Acknowledgements

R Core for developing and maintaining such a wonderful language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'frak' - a julia set fractal generator

Thu, 16 Jul 2020 20:41:00 +1000

frak

frak is a small R package to generate fractals - currently just Julia Sets.

I needed a fast way to generate test images for testing other software, with images that

are fast to produce
are interesting, not just white noise
8-bits-per-pixel, so the value can fit in an R raw vector or a C uint8_t vector.
can be be panned, zoomed and changed with simple changes to the input variables

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/frak')

What’s in the box?

julia(cx, cy, movex, movey, zoom, size, max_iter) generate a julia set, where cx and cy are the components of imageinary iteration variable c.

Returned array of raw values represents the iteration count at which a particular location veered towards infinity. These values are scaled to span the full range from allowable within a raw vector (i.e. the whole numbers from 0 to 255)

Example: Generate a julia set

library(frak)

fractal <- julia(cx = -0.7, cy = 0.27, zoom = 1, size = 400, max_iter = 255)
mode(fractal) <- 'integer'
plot(as.raster(fractal/255))

Example: colour the image with viridis

library(viridisLite)

# generate a fractal
fractal <- julia(cx = -0.74, cy = 0.17, zoom = 3, size = 400, max_iter = 100)
mode(fractal) <- 'integer'

# Grab a palette from viridis
pal <- rev(viridisLite::viridis(256))

# Recode the values with the palette. Lowest raw value is 0, so offset by 1.
fractal_raster   <- fractal
fractal_raster[] <- pal[fractal_raster + 1]

plot(as.raster(fractal_raster))

Example: git file rendered from multiple frames

Click to show/hide code to generate gif

library(foist)
library(displease)
library(frak)

dir.create('/img/frak/anim', showWarnings = FALSE)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Use {displease} to get a pleasing motion as the zoom is performed
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N <- 100
zoom <- displease::seq_ease(1, 1000, n = N, type = 'exp-in')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Loop: create an image dump it to file.
# Using {foist} here for fast image output
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (i in seq(N)) {
  frac <- frak::julia(cx = -0.71, zoom = zoom[i], movex = 0.1)
  mode(frac) <- 'integer'
  frac <- frac/255
  
  filename <- sprintf("/img/frak/anim/%03i.png", i)
  
  foist::write_png(
    data                 = frac, 
    filename             = filename, 
    pal                  = foist::vir$magma, 
    convert_to_row_major = FALSE
  )
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create the animation using imagemagick and delete the source frames
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
system("convert /img/frak/anim/*.png /img/frak/anim.gif")
unlink("/img/frak/anim/", recursive = TRUE)

Benchmark

Creating a julia set in C is about 100x faster than using plain R (as in the Julia package on CRAN)

Click to show/hide bench::mark() code

suppressPackageStartupMessages({
  library(Julia)
  library(frak)
  library(ggplot2)
  library(dplyr)
  library(tidyr)
})

size <- 400

# Julia::JuliaImage does at most 50 iterations
res <- bench::mark(
  `Julia::JuliaImage()` = Julia::JuliaImage(imageN = size, centre = 0.0, L = 4, C = 1-1.6180339887),
  `frak::julia()`       = julia(size = size, max_iter = 50),
  check = FALSE
)
Warning: Some expressions had a GC in every iteration; so filtering is disabled.

expression	min	median	itr/sec
Julia::JuliaImage()	802.68ms	802.68ms	1.24582
frak::julia()	7.57ms	7.92ms	115.48860

Acknowledgements

R Core for developing and maintaining such a wonderful language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'displease' - a package for non-linear numeric inteprolation

Tue, 14 Jul 2020 19:48:00 +1000

displease

The displease package provides non-linear interpolation between numeric values.

It is a replacement for seq() for when you want a sequence between two values which is not equally spaced.

Easing can look much better than strict linear interpolation when applied to objects moving spatially.

displease = displ + ease. The results are often used for animating visual displacement, and the non-linear interpolation is performed by applying an easing function.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/displease)

What’s in the box?

seq_ease(x1, x2, n, type) - create a sequence of length n between x1 and x2. Apply the easing function given by type.
type is one of: sine-in, sine-out, sine-in-out, quad-in, quad-out, quad-in-out, cubic-in, cubic-out, cubic-in-out, quart-in, quart-out, quart-in-out, quint-in, quint-out, quint-in-out, exp-in, exp-out, exp-in-out, circle-in, circle-out, circle-in-out, back-in, back-out, back-in-out, elastic-in, elastic-out, elastic-in-out

The following graph shows the seq_ease() output for n = 100 for all the different easing functions with given extens of x1 = 0 and x2 = 1

Example

library(displease)

# normal linear interpolation using seq()
(y_linear       <- seq(1, 10, length.out = 10))
 [1]  1  2  3  4  5  6  7  8  9 10

# Non-linear interpolation using {displease}
(y_cubic_in     <- seq_ease(1, 10, n=10, type = 'cubic-in'))
 [1]  1.000000  1.012346  1.098765  1.333333  1.790123  2.543210  3.666667
 [8]  5.234568  7.320988 10.000000
(y_cubic_in_out <- seq_ease(1, 10, n=10, type = 'cubic-in-out'))
 [1]  1.000000  1.049383  1.395062  2.333333  4.160494  6.839506  8.666667
 [8]  9.604938  9.950617 10.000000

plot(1:10, y_linear      , type = 'b')

plot(1:10, y_cubic_in    , type = 'b')

plot(1:10, y_cubic_in_out, type = 'b')

Animated example

Acknowledgements

R Core for developing and maintaining such a wonderful language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'miranda' - a package of fast, modern, uniform pseudo-random number generators

Thu, 09 Jul 2020 22:32:00 +1000

miranda

The miranda packages includes some modern pseudo-random number generators (PRNGs). These are up to 20x faster than the built-in PRNGs in R.

PRNG summary

PRNG	BigCrush result	Reference
xoshiro256p	“No Systematic Failures”	http://prng.di.unimi.it/
lehmer64	Passes	Lemire’s blog
splitmix64	Passes	source
romutrio	Passes	romu-random.org
runif() [Mersenne Twister]	Two failures

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/miranda)

`xoshiro256p`

library(miranda)

# Set the seed
set_seed_xoshiro256p(2020)

# Get the internal state of the generator. 32 bytes.
(state <- get_state_xoshiro256p())
 [1] ee 6d 45 f5 0b 1c e9 8e 81 89 5b 6b ee ca 13 07 d9 3f 76 fe 13 4f c2 33 44
[26] 3c a9 de 5e b7 56 f9

# Generate some uniform random numbers from xoshiro256+
runif_xoshiro256p(5)
[1] 0.5322239 0.7788869 0.4601653 0.8475389 0.9540731

# Jump ahead. As if 2^128 numbers had been generated
jump_xoshiro256p()

# Generate some uniform random numbers from xoshiro256+
runif_xoshiro256p(5)
[1] 0.5714143 0.5006207 0.6907487 0.2625934 0.5053289

# reset the state to a prior value
set_state_xoshiro256p(state)

# Generate some uniform random numbers from xoshiro256+
runif_xoshiro256p(5)
[1] 0.5322239 0.7788869 0.4601653 0.8475389 0.9540731

Benchmark: Generating 1 million uniform random numbers

Click to show/hide bench::mark() code

N <- 1e6
res <- bench::mark(
  runif_xoshiro256p(N),
  runif_lehmer64(N),
  runif_splitmix64(N),
  runif_romutrio(N),
  runif(N),
  check = FALSE
)

The PRNGs in this package all roughly run at the same speed
At their best, these PRNGs are about 20x faster than runif()

Acknowledgements

R Core for developing and maintaining such a wonderful language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

The quality of R's Random Number Generators

Tue, 07 Jul 2020 21:02:00 +1000

A mini-exploration of the quality R’s random number generators.

In general, we want pseudo-random number generators (PRNGs) which have (among other things) 2 key properties:

They should be random
They should be fast

There are other considerations (e.g. period, availability of multiple streams, jump-aheads etc), but I’m not going there (nor am I considering cryptographic security).

R’s built-in PRNGs

R has 7 built-in PRNGs. These are accessible by calling RNGkind(name) to switch the backend to use a particular PRNG. The user-facing code remains the same e.g. runif(), rnorm()

Mersenne-Twister
- The default PRNG in R
- Also known as: MT19937
- Developed by: Matsumoto and Nishimura, 1997
Wichmann-Hill
- A combined linear congruential generator (LCG)
- Developed by: Wichman and Hill, 1982
Marsaglia-Multicarry
- Developed by: Marsaglia, 1997
Super-Duper
- Developed by: Marsaglia in the 70s
Knuth-TAOCP-2002
- generalized feedback shift-register generator (GFSR) using lagged Fibonacci sequences
- Developed by: Knuth, 2002
Knuth-TAOCP
- Another GFSR using using lagged Fibonacci sequences
- Developed by: Knuth, 1997
L’Ecuyer-CMRG
- A combined multiple recursive generator
- Developed by: L’Ecuyer, 1999
- Defined in this paper Good Parameters and Implementations for Combined Multiple Recursive Random Number Generators (pdf)
- Also known as: MRG32ka

Testing built-in PRNGs for quality

A 2007 paper which reviews many PRNGs and tests then for quality is L’Ecuyer’s TestU01: A C Library for Empirical Testing of Random Number Generators (pdf)

I’ve summarised Table 1 from this paper for the PRNGs which are available in base R. In this summary I only include the BigCrush numbers. The full version of Table 1 is included at the end of this post;

Year	RNGkind	Alias	Big Crush Errors
1970s	Super Duper	Super Duper 73	Test not run as there were too many errors already at lower levels
1982	Wichmann-Hill		22
1997	Mersenne Twister	MT19937	2
1997	Marsaglia-Multicarry	R-Multicarry	Test not run as there were too many errors already at lower levels
1997	Knuth-TAOCP	Knuth.ran_array2	4
1999	L’Ecuyer-CMRG	MRG32k3a	0
2002	Knuth-TAOCP-2002	Knuth.ranf_array2	0

Notes on built-in PRNG quality:

R’s default PRNG (Mersenne-Twister) fails 2 test on BigCrush
Only L’Ecuyer and Knuth-TAOCP-2002 pass the BigCrush tests with no failures
The other PRNGs seem to perform quite badly with either multiple failures on BigCrush, or so many failures on SmallCrush and Crush that it wasn’t even worth testing then on BigCrush
There appears to be a trend that more recent PRNGs have fewer failures on BigCrush.
The most recent PRNG is 18 years old! What’s happened since then in PRNG development?

Testing built-in PRNGs for speed

Click to show/hide benchmark code

library(ggplot2)
library(bench)

rng_kinds <- c( 
  'Mersenne-Twister',   
  'Wichmann-Hill',        
  'Marsaglia-Multicarry', 
  'Super-Duper',           
  'Knuth-TAOCP-2002',     
  'Knuth-TAOCP',          
  "L'Ecuyer-CMRG"         
  )

N <- 1e6

fun <- function(rng_kind) {
  RNGkind(kind = rng_kind)
  res <- bench::mark(runif(N))
  res$expression <- rng_kind
  res
}

baser <- lapply(rng_kinds, fun)
baser <- do.call(rbind, baser)

plot(baser) + 
  labs(title = "Benchmark: runif() generation of 1e6 random numbers")

Notes on built-in PRNG speed:

All the built-in PRNGs are about the same speed
Not sure if this is a characteristic of the way they are included within R - there may be a lot of setup/call overhead that is overshadowing the timing of the actual random number generation.

Appendix: Full PRNG comparison table.

This is an extract from L’Ecuyer’s TestU01: A C Library for Empirical Testing of Random Number Generators (pdf)

How to read this table:

The numbers in the last 3 rows are the number of failures for a particular statistical test i.e. SmallCrush, Crush and BigCrush.
- A number in brackets e.g. (12) indicates a suspect p-value, but not necessarily a failure.
The second column is the log2 of the period of the generator (how long before it loops back to the start)
t-32 and t-64 are the times to generate 10^8 random numbers on a 32 and 64-bit machine (see the paper for actual specs)

Appendix: Other resources:

Correction to random number generation in R3.6.0 - here and here
John Cook looks at few modern PRNGs in his 2017 blog post Testing RNGs with PractRand
PCG PRNG
Some criticism on the claims around PCG - here
Good Practice in (Pseudo) Random Number Generationfor Bioinformatics Applications

Introducing terse - a package for compact output of lists and data.frames

Wed, 01 Jul 2020 22:32:00 +1000

terse

terse is an alternative to str() that aims to be more succinct for simple objects.

It was built with (nested) list output in mind, but handles data.frames and many other standard data structures in R.

Features

Compact output
ANSI colour (configurable)
Alignment of indexes at start of each row, such that names at the same depth are aligned under each other
Alignment of values within data.frames

Limitations

Currently supports the standard vector types and lists
Lists are always recursed in to (there is currently no option to limit the recursion depth)
Weirder data structures might not work how you want - e.g. list-columns in data.frames, R6 objects etc.

If you find a common case that doesn’t produce nice output, please file an issue (or PR!).

Installation

You can install from GitHub with:

# install.packages("devtools")
devtools::install_github("coolbutuseless/terse")

Terse `data.frame` output

Simple data.frame output

library(terse)
terse(mtcars)

Click here to show/hide - Comparison to str() and glimpse()

str(mtcars)

'data.frame':   32 obs. of  11 variables:
 $ mpg : num  21 21 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 ...
 $ cyl : num  6 6 4 6 8 6 8 4 4 6 ...
 $ disp: num  160 160 108 258 360 ...
 $ hp  : num  110 110 93 110 175 105 245 62 95 123 ...
 $ drat: num  3.9 3.9 3.85 3.08 3.15 2.76 3.21 3.69 3.92 3.92 ...
 $ wt  : num  2.62 2.88 2.32 3.21 3.44 ...
 $ qsec: num  16.5 17 18.6 19.4 17 ...
 $ vs  : num  0 0 1 1 0 1 0 1 1 1 ...
 $ am  : num  1 1 1 0 0 0 0 0 0 0 ...
 $ gear: num  4 4 4 3 3 3 3 4 4 4 ...
 $ carb: num  4 4 1 1 2 1 4 2 2 4 ...

dplyr::glimpse(mtcars)

Rows: 32
Columns: 11
$ mpg  <dbl> 21.0, 21.0, 22.8, 21.4, 18.7, 18.1, 14.3, 24.4, 22.8, 19.2, 17.8…
$ cyl  <dbl> 6, 6, 4, 6, 8, 6, 8, 4, 4, 6, 6, 8, 8, 8, 8, 8, 8, 4, 4, 4, 4, 8…
$ disp <dbl> 160.0, 160.0, 108.0, 258.0, 360.0, 225.0, 360.0, 146.7, 140.8, 1…
$ hp   <dbl> 110, 110, 93, 110, 175, 105, 245, 62, 95, 123, 123, 180, 180, 18…
$ drat <dbl> 3.90, 3.90, 3.85, 3.08, 3.15, 2.76, 3.21, 3.69, 3.92, 3.92, 3.92…
$ wt   <dbl> 2.620, 2.875, 2.320, 3.215, 3.440, 3.460, 3.570, 3.190, 3.150, 3…
$ qsec <dbl> 16.46, 17.02, 18.61, 19.44, 17.02, 20.22, 15.84, 20.00, 22.90, 1…
$ vs   <dbl> 0, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0…
$ am   <dbl> 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0…
$ gear <dbl> 4, 4, 4, 3, 3, 3, 3, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 4, 4, 4, 3, 3…
$ carb <dbl> 4, 4, 1, 1, 2, 1, 4, 2, 2, 4, 4, 3, 3, 3, 4, 4, 4, 1, 2, 1, 1, 2…

Terse `data.frame` output - plain ASCII

Simple data.frame output without ANSI

terse(mtcars, config = list(ansi = FALSE), width = 100)

mtcars$mpg  d32 21   , 21   , 22.8 , 21.4 , 18.7 , 18.1 , 14.3 , 24.4 , 22.8 , 19.2 , 17.8 , 16 ...
mtcars$cyl  d32 6    , 6    , 4    , 6    , 8    , 6    , 8    , 4    , 4    , 6    , 6    , 8  ...
mtcars$disp d32 160  , 160  , 108  , 258  , 360  , 225  , 360  , 146.7, 140.8, 167.6, 167.6, 27 ...
mtcars$hp   d32 110  , 110  , 93   , 110  , 175  , 105  , 245  , 62   , 95   , 123  , 123  , 18 ...
mtcars$drat d32 3.9  , 3.9  , 3.85 , 3.08 , 3.15 , 2.76 , 3.21 , 3.69 , 3.92 , 3.92 , 3.92 , 3. ...
mtcars$wt   d32 2.62 , 2.875, 2.32 , 3.215, 3.44 , 3.46 , 3.57 , 3.19 , 3.15 , 3.44 , 3.44 , 4. ...
mtcars$qsec d32 16.46, 17.02, 18.61, 19.44, 17.02, 20.22, 15.84, 20   , 22.9 , 18.3 , 18.9 , 17 ...
mtcars$vs   d32 0    , 0    , 1    , 1    , 0    , 1    , 0    , 1    , 1    , 1    , 1    , 0  ...
mtcars$am   d32 1    , 1    , 1    , 0    , 0    , 0    , 0    , 0    , 0    , 0    , 0    , 0  ...
mtcars$gear d32 4    , 4    , 4    , 3    , 3    , 3    , 3    , 4    , 4    , 4    , 4    , 3  ...
mtcars$carb d32 4    , 4    , 1    , 1    , 2    , 1    , 4    , 2    , 2    , 4    , 4    , 3  ...

Terse nested `list` output

ll <- list(
  apple = list(
    bob = list(c = 1:3),
    c = list(
      list(d = head(mtcars))
    ),
    ddd = setNames(1:26, letters)
  )
)

terse(ll, config = list(nth = 4, colour_nth = 'red'))

Click here to show/hide - Comparison to str()

str(ll)

List of 1
 $ apple:List of 3
  ..$ bob:List of 1
  .. ..$ c: int [1:3] 1 2 3
  ..$ c  :List of 1
  .. ..$ :List of 1
  .. .. ..$ d:'data.frame': 6 obs. of  11 variables:
  .. .. .. ..$ mpg : num [1:6] 21 21 22.8 21.4 18.7 18.1
  .. .. .. ..$ cyl : num [1:6] 6 6 4 6 8 6
  .. .. .. ..$ disp: num [1:6] 160 160 108 258 360 225
  .. .. .. ..$ hp  : num [1:6] 110 110 93 110 175 105
  .. .. .. ..$ drat: num [1:6] 3.9 3.9 3.85 3.08 3.15 2.76
  .. .. .. ..$ wt  : num [1:6] 2.62 2.88 2.32 3.21 3.44 ...
  .. .. .. ..$ qsec: num [1:6] 16.5 17 18.6 19.4 17 ...
  .. .. .. ..$ vs  : num [1:6] 0 0 1 1 0 1
  .. .. .. ..$ am  : num [1:6] 1 1 1 0 0 0
  .. .. .. ..$ gear: num [1:6] 4 4 4 3 3 3
  .. .. .. ..$ carb: num [1:6] 4 4 1 1 2 1
  ..$ ddd: Named int [1:26] 1 2 3 4 5 6 7 8 9 10 ...
  .. ..- attr(*, "names")= chr [1:26] "a" "b" "c" "d" ...

Notes on output

The output consists of 3 sections:

Names and indices (on the left)
Compact type + length information
Vectors of values (on the right)

The green output consists of a single character for type information, followed by a length (the number of elements in this vector)

Click to show/hide list of all type information

a - array
m - matrix
l - logical
f - factor
p - POSIXct
P - POSIXlt
D - Date
n - name
i - integer
d - double
r - raw
c - character
C - complex
N - null
K - call
F - function
E - environment
e - expression
L - list
x - unknown

Config

terse() takes a config argument which must be a named list. Possible elements are:

ansi - Use ANSI colouring? default: TRUE
soft - non-highlight colour. default: grey40
gsep - separator for vector output. default: ,
colour_nth - colour for every nth vector element. default: blue4
colour_all - colour for all other vector elements. default: grey40
colour_type - colour for the type/length meta information. default: seagreen
nth - interval for colouring vector elements. default: 0 (off)

Acknowledgements

R Core & CRAN maintainers for giving me a playground
Brodie Gaslam for the excellent ANSI tools in fansi
Deemah and Jonathan Carroll for helping me find a good name

simplec, simplecall, simplercpp - demo packages incorporating C code

Tue, 30 Jun 2020 20:32:00 +1000

3 demo packages

In the process of working out how to best call C code in an R package, I created 3 small demonstration packages showing how C code can be included and called within a package.

simplec A package using .C() to interface with C code
simplecall A package using .Call() to interface with C code
simplercpp A package using {Rcpp} to interface with C code

Rough comparison of `.C()`, `.Call()` and `{Rcpp}`

	.C()	.Call()	Rcpp
Overview	No real understanding of R objects	Need to understand SEXP macros & internals	C++ classes hide the complexity of the SEXP internals
What code?	Basic C code. Numeric calcs.	Complex C code. Can manipulate R objects from C	Complex C and C++ code involving numerics and R objects
Pros	Simple to understand and use	Simple. No unnecessary copying.	Great documentation. Wrapping of R objects very intuitive.
Cons	Too simple for most interesting things	Need to understand SEXP & R internals
Cons	Performs copying of data to call functions
Demo R package	{simplec}	{simplecall}	{simplercpp}

Introducing 'zstdlite' - fast, configurable, in-memory compression of numeric vectors with Zstandard

Fri, 19 Jun 2020 21:42:00 +1000

zstdlite

zstdlite provides access to the very fast (and highly configurable) compression in zstd for performing in-memory compression.

The scope of this package is limited - it aims to provide functions for direct hashing of vectors which contain raw, integer, real, complex or logical values. It does this by operating on the data payload within the vectors, and gains significant speed by not serializing the R object itself. If you wanted to compress arbitrary R objects, you must first manually convert into a raw vector representation using base::serialize().

For a more general solution to fast serialization of R objects, see the fst or qs packages.

Currently zstd code provided with this package is v1.4.5.

Design Choices

zstdlite will compress the data payload within a numeric-ish vector, and not the R object itself.

Limitations

As it is the data payload of the vector that is being compressed, this does not include any notion of the container for that data i.e dimensions or other attributes are not compressed with the data.
Values must be of type: raw, integer, real, complex or logical.
Decompressed values are always returned as a vector i.e. all dimensional information is lost during compression.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/zstdlite)

Compressing 1 million Integers

zstdlite supports the direct compression of raw, integer, real, complex and logical vectors.

These vectors do not need to be serialized first to a raw representation, instead the data-payload within these vectors is compressed.

library(zstdlite)
library(lz4lite)

N                 <- 1e6
input_ints        <- sample(1:5, N, prob = (1:5)^2, replace = TRUE)
compressed_lo     <- zstd_compress(input_ints)
compressed_hi     <- zstd_compress(input_ints, level = 100)
compressed_lo_lz4 <- lz4_compress(input_ints, acc = 1)
compressed_hi_lz4 <- lz4_compress(input_ints, use_hc = TRUE, hc_level = 12)

Click here to show/hide benchmark code

library(zstdlite)

res <- bench::mark(
  zstd_compress(input_ints, level =  -5),
  zstd_compress(input_ints, level =   1),
  zstd_compress(input_ints, level =   3),
  zstd_compress(input_ints, level =  10),
  zstd_compress(input_ints, level =  22),
  lz4_compress (input_ints, acc = 1),
  lz4_compress (input_ints, use_hc = TRUE, hc_level = 12),
  check = FALSE
)

package	expression	median	itr/sec	MB/s	compression_ratio
zstdlite	zstd_compress(input_ints, level = -5)	14.29ms	69	266.9	0.150
zstdlite	zstd_compress(input_ints, level = 1)	14.5ms	69	263.1	0.131
zstdlite	zstd_compress(input_ints, level = 3)	14.28ms	70	267.1	0.131
zstdlite	zstd_compress(input_ints, level = 10)	87.92ms	11	43.4	0.106
zstdlite	zstd_compress(input_ints, level = 22)	2.33s	0	1.6	0.075
lz4lite	lz4_compress(input_ints, acc = 1)	6.4ms	158	596.0	0.306
lz4lite	lz4_compress(input_ints, use_hc = TRUE, hc_level = 12)	10.87s	0	0.4	0.122

Decompressing 1 million integers

Click here to show/hide benchmark code

res <- bench::mark(
  zstd_decompress(compressed_lo),
  zstd_decompress(compressed_hi),
  lz4_decompress(compressed_lo_lz4),
  lz4_decompress(compressed_hi_lz4),
  check = FALSE
)

package	expression	median	itr/sec	MB/s
zstdlite	zstd_decompress(compressed_lo)	7.98ms	121	477.9
zstdlite	zstd_decompress(compressed_hi)	2.38ms	414	1603.8
lz4lite	lz4_decompress(compressed_lo_lz4)	1.53ms	651	2492.2
lz4lite	lz4_decompress(compressed_hi_lz4)	1.14ms	863	3333.9

Technical bits

Why only vectors of raw, integer, real, complex or logical?

R objects can be considered to consist of:

a header - giving information like length and information for the garbage collector
a body - data of some kind.

The vectors supported by zstdlite are those vectors whose body consists of data that is directly interpretable as a contiguous sequence of bytes representing numerical values.

Other R objects (like lists or character vectors) are really collections of pointers to other objects, and do not live in memory as a contiguous sequence of byte data.

How it works.

Compression

Given a pointer to a standard numeric vector from R (i.e. an SEXP pointer).
Ignore any attributes or dimension information- just compress the data payload within the object.
Prefix the compressed data with an 4 byte header giving the SEXP type.
Return a raw vector to the user containing the compressed bytes.

Decompression

Strip off the 4-bytes of header information.
Feed the other bytes in to the ZSTD decompression function written in C
Use the header to decide what sort of R object this is.
Decompress the data into an R object of the correct type.
Return the R object to the user.

Note: matrices and arrays may also be passed to zstd_compress(), but since no attributes are retained (e.g. dims), the uncompressed object returned by zstd_decompress() can only be a simple vector.

Framing of the compressed data

zstdlite prefixes the standard Zstandard frame with some extra bytes.
The compressed representation is the compressed data prefixed with a custom 8 byte header consisting of
- ‘ZST’
- 1-byte for SEXP type i.e. INTSXP, RAWSXP, REALSXP or LGLSXP
This data representation
- is compatible with the standard Zstandard frame format if the leading bytes are removed.
- is likely to evolve (so currently do not plan on compressing something in one version of zstdlite and decompressing in another version.)

Acknowledgements

Yann Collett for releasing, maintaining and advancing lz4 and zstd
R Core for developing and maintaining such a wonderful language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'lz4lite' - extremely fast compression with LZ4

Tue, 16 Jun 2020 20:22:00 +1000

lz4lite

lz4lite provides access to the extremely fast compression in lz4 for performing in-memory compression.

The scope of this package is limited - it aims to provide functions for direct hashing of vectors which contain raw, integer, real or logical values. If you wanted to compress arbitrary R objects, you must first convert into a raw vector representation using base::serialize().

For a more general solution to fast serialization of R objects, see the fst or qs packages.

Currently lz4 code provided with this package is v1.9.3.

Design Choices

lz4lite will compress the data payload within a numeric-ish vector, and not the R object itself.

Limitations

As it is the data payload of the vector that is being compressed, this does not include any notion of the container for that data i.e dimensions or other attributes are not compressed with the data.
Values must be of type: raw, integer, real or logical.
Decompressed values are always returned as a vector i.e. all dimensional information is lost during compression.

What’s in the box

lz4compress()
- compress the data within a vector of raw, integer, real or logical values
- set use_hc = TRUE to use the High Compression variant of LZ4. This variant can be slow to compress, but with higher compression ratios, and it retains the fast decompression speed i.e. multiple gigabytes per second!
lz4decompress() - decompress a compressed representation that was created with lz4compress()

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/lz4lite)

Compressing 1 million Integers

lz4lite supports the direct compression of raw, integer, real and logical vectors.

On this test data, compression speed is ~600 MB/s, and decompression speed is ~3GB/s

library(lz4lite)

N             <- 1e6
input_ints    <- (sample(seq(1:5), N, prob = (1:5)^2, replace = TRUE))
compressed_lo <- lz4_compress(input_ints)
compressed_hi <- lz4_compress(input_ints, use_hc = TRUE, hc_level = 12)

Click here to show/hide benchmark code

library(lz4lite)

res <- bench::mark(
  lz4_compress(input_ints, acc   =   1),
  lz4_compress(input_ints, acc   =  10),
  lz4_compress(input_ints, acc   =  20),
  lz4_compress(input_ints, acc   =  50),
  lz4_compress(input_ints, acc   = 100),
  lz4_compress(input_ints, use_hc = TRUE, hc_level =   1),
  lz4_compress(input_ints, use_hc = TRUE, hc_level =   2),
  lz4_compress(input_ints, use_hc = TRUE, hc_level =   4),
  lz4_compress(input_ints, use_hc = TRUE, hc_level =   8),
  lz4_compress(input_ints, use_hc = TRUE, hc_level =  12),
  check = FALSE
)

expression	median	itr/sec	MB/s	compression_ratio
lz4_compress(input_ints, acc = 1)	6.36ms	157	599.7	0.306
lz4_compress(input_ints, acc = 10)	6.19ms	162	616.6	0.306
lz4_compress(input_ints, acc = 20)	6.11ms	163	624.5	0.306
lz4_compress(input_ints, acc = 50)	6.13ms	162	622.1	0.306
lz4_compress(input_ints, acc = 100)	6.19ms	163	616.7	0.306
lz4_compress(input_ints, use_hc = TRUE, hc_level = 1)	34.38ms	29	110.9	0.294
lz4_compress(input_ints, use_hc = TRUE, hc_level = 2)	33.76ms	29	113.0	0.294
lz4_compress(input_ints, use_hc = TRUE, hc_level = 4)	67.82ms	15	56.3	0.233
lz4_compress(input_ints, use_hc = TRUE, hc_level = 8)	453.89ms	2	8.4	0.167
lz4_compress(input_ints, use_hc = TRUE, hc_level = 12)	11.34s	0	0.3	0.122

Decompressing 1 million integers

Decompression speed varies slightly depending upon the compressed size.

Click here to show/hide benchmark code

res <- bench::mark(
  lz4_decompress(compressed_lo),
  lz4_decompress(compressed_hi)
)

expression	median	itr/sec	MB/s
lz4_decompress(compressed_lo)	1.52ms	633	2504.7
lz4_decompress(compressed_hi)	1.14ms	897	3349.9

Technical bits

How it works.

Compression

Given a pointer to a standard numeric vector from R, an SEXP
Ignoring any attributes or dimensions, compress the data payload within the object.
Prefix the compressed data with an 8 byte header giving size and SEXP type
Return a raw vector to the user containing the compressed bytes.

Decompression

Strip off the header information
Feed the raw bytes in to the C LZ4 decompression function
Use the header to decide what sort of R object this is
Uncompress the data into an R object of the correct type.
Return the R object to the user

Note: matrices and arrays may also be passed to lz4_compress(), but since no attributes are retained (e.g. dims), the uncompressed object returned by lz4_decompress() can only be a simple vector.

Framing of the compressed data

lz4lite does not use the standard LZ4 frame to store data.
The compressed representation is the compressed data prefixed with a custom 8 byte header consisting of
- ‘LZ4’
- 1-byte for SEXP type i.e. INTSXP, RAWSXP, REALSXP or LGLSXP
- 4-bytes representing an integer i.e. the number of bytes in the original uncompressed data.
This data representation
- is not compatible with the standard LZ4 frame format.
- is likely to evolve (so currently do not plan on compressing something in one version of lz4lite and decompressing in another version).

Acknowledgements

Yann Collett for releasing, maintaining and advancing lz4 and zstd
R Core for developing and maintaining such a wonderful language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing 'xxhashr' - extremely fast hashing with xxHash

Fri, 12 Jun 2020 20:35:00 +1000

xxhashr

xxhashr provides simple access to the very fast hashing functions in xxHash.

The package provides support for hashing of vectors, matrices and arrays which contain raw, integer, real or logical values. To hash arbitrary R objects, use base::serialize() to first turn the object into a vector of raw bytes.

Limitations

It is the underlying data of the vector or matrix that is being hashed, and this does not include any notion of the container for that data. This means that a vector and array which contain the same data will hash to the same value - regardless of the dimensions.
xxHash v0.7.x includes the experimental xxh3 and xxh128 hash functionx. From the documentation: “The algorithm is currently in development, meaning its return values might still change in future versions. However, the API is stable, and can be used in production, typically for generation of ephemeral hashes (produced and consumed in same session)”.
xxHash is a non-cryptographic hash.

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/xxhashr)

Optimisation via `Makevars`

To get the most out of what xxHash offers, it’s important to set some optimisation flags for your machine. The important compiler flags to set are -O3 and -march=native.

Here are 2 possible ways to do this:

Copy src/Makevars.custom to src/Makevars re-build package.
Edit your ~/.R/Makevars to include CFLAGS = -O3 -march=native (this will change flags for all future compilation, and should probably be used with caution)

Simple hashing

library(xxhashr)

vec <- raw(1e6)

xxhashr::xxhash32(vec)
[1] "5fff0bcb"

xxhashr::xxhash64(vec)
[1] "8a76d36d39caaecc"

xxhashr::xxhash128(vec)
[1] "118fde282639e0a3b5ce7c14a206fb68"

xxhashr::xxh3_64bits(vec)
[1] "b5ce7c14a206fb68"

Hashing 1 million raw bytes

xxhashr::xxh3_64bits() hashes data at around 25 GB/s for this input data size.

Since digest::digest() can hash raw bytes like xxhashr the speeds for xxhashr::xxhash64() and digest(algo = 'xxhash64') are about the same.

Click here to show/hide benchmark code

library(digest)

N   <- 1e6
vec <- raw(N)

res <- bench::mark(
  xxhash32(vec),
  xxhash64(vec),
  xxhash128(vec),
  xxh3_64bits(vec),
  digest(vec, algo = 'xxhash32', serialize = FALSE),
  digest(vec, algo = 'xxhash64', serialize = FALSE),
  check = FALSE
)

Table 1: Hashing 1 million raw bytes
expression	median	itr/sec	GB/s
xxhash32(vec)	158.7µs	6080	5.9
xxhash64(vec)	79.5µs	11952	11.7
xxhash128(vec)	34µs	27687	27.4
xxh3_64bits(vec)	32µs	29544	29.1
digest(vec, algo = “xxhash32”, serialize = FALSE)	310.7µs	3093	3.0
digest(vec, algo = “xxhash64”, serialize = FALSE)	114µs	8394	8.2

Hashing 1 thousand raw bytes

At smaller data sizes, the call overhead becomes more significant, and the overall throughput drops drastically.

xxhashr is about 20x faster than digest::digest() in this case.

Click here to show/hide benchmark code

N <- 1024L
vec <- raw(N)

res <- bench::mark(
  xxhash32(vec),
  xxhash64(vec),
  xxhash128(vec),
  xxh3_64bits(vec),
  digest(vec, algo = 'xxhash32', serialize = FALSE),
  digest(vec, algo = 'xxhash64', serialize = FALSE),
  check = FALSE
)

Table 2: Hashing 1000 raw bytes
expression	median	itr/sec	GB/s
xxhash32(vec)	1.06µs	872697	0.898
xxhash64(vec)	1.01µs	912220	0.946
xxhash128(vec)	1.02µs	908029	0.936
xxh3_64bits(vec)	1.04µs	885477	0.915
digest(vec, algo = “xxhash32”, serialize = FALSE)	31.87µs	29611	0.030
digest(vec, algo = “xxhash64”, serialize = FALSE)	31.44µs	29787	0.030

Hashing 1 million numeric values

In the case of integers, doubles and logical values, xxhashr will hash the data values directly, while digest::digest() must first serialize them to raw bytes.

As a result, xxhashr::xxhash128() is about 100x faster than digest::digest(), and operates at about 20 GB/s (on my machine).

Click here to show/hide benchmark code

N   <- 1e6
vec <- numeric(N)

res <- bench::mark(
  xxhash32(vec),
  xxhash64(vec),
  xxhash128(vec),
  xxh3_64bits(vec),
  digest(vec, algo = 'xxhash32', serialize = TRUE),
  digest(vec, algo = 'xxhash64', serialize = TRUE),
  check = FALSE
)

Table 3: Hashing 1 million numeric values
expression	median	itr/sec	GB/s
xxhash32(vec)	1.33ms	734	5.6
xxhash64(vec)	679.23µs	1437	11.0
xxhash128(vec)	313.31µs	2960	23.8
xxh3_64bits(vec)	295.4µs	3116	25.2
digest(vec, algo = “xxhash32”, serialize = TRUE)	36.94ms	27	0.2
digest(vec, algo = “xxhash64”, serialize = TRUE)	32.09ms	31	0.2

Hashing 1 million integer values

In the case of integers, doubles and logical values, xxhashr will hash the data values directly, while digest::digest() must first serialize them to raw bytes.

The hashFunction package offers a few hashes that work directly with integer values.

xxhashr::xxhash128() is about 100x faster than digest::digest(), and about 5x faster than hashFunction hashes.

Click here to show/hide benchmark code

library(hashFunction)
N <- 1e6
vec <- integer(N)

res <- bench::mark(
  xxhash32(vec),
  xxhash64(vec),
  xxhash128(vec),
  xxh3_64bits(vec),
  digest(vec, algo = 'xxhash32', serialize = TRUE),
  digest(vec, algo = 'xxhash64', serialize = TRUE),
  murmur3.32(vec),
  cityhash.64(vec),
  spooky.32(vec),
  check = FALSE
)

Table 4: Hashing 1 million integer values
expression	median	itr/sec	GB/s
xxhash32(vec)	640.3µs	1499	5.8
xxhash64(vec)	325.7µs	2916	11.4
xxhash128(vec)	140.2µs	6710	26.6
xxh3_64bits(vec)	128.1µs	7071	29.1
digest(vec, algo = “xxhash32”, serialize = TRUE)	13.8ms	71	0.3
digest(vec, algo = “xxhash64”, serialize = TRUE)	12.7ms	78	0.3
murmur3.32(vec)	563.2µs	1586	6.6
cityhash.64(vec)	636.8µs	947	5.9
spooky.32(vec)	602.3µs	1134	6.2

Acknowledgements

Yann Collett for releasing, maintaining and advancing xxHash
R Core for developing and maintaining such a great language.
CRAN maintainers, for patiently shepherding packages onto CRAN and maintaining the repository

Introducing the 'defaultlist' package - R list objects with a user-defined default value.

Wed, 13 May 2020 21:58:00 +1000

defaultlist

defaultlist provides an object which behaves like a normal R list, but which has a user-defined default value when the requested element is not present.

Regular list objects will return NULL when an unknown character index is used, or throw an error if a numeric index is beyond the length of the list.

A defaultlist in these situations will instead return a default value set by the user during initialisation.

Why?

Use defaultlist objects if you would like to:

avoid having to initialise for every entry
avoid having to check whether an entry exists before accessing

What’s in the box?

dlist(..., .default) - used to construct a new defaultlist. Same syntax as list() but needs an additional argument to set the default value
empty_dlist(.default) - create an empty list with the given default.
as.dlist() - identical to as.list() except it requires an additional argument to set the default value

Installation

You can install from GitHub with:

# install.package('remotes')
remotes::install_github('coolbutuseless/defaultlist')

Basic Example

In this example a defaultlist is created which will return FALSE for any access to an unknown element. Besides this, it will bevave identically to a normal list() object.

haystack <- empty_dlist(FALSE)
haystack$surprise <- TRUE

haystack[['hello']]
[1] FALSE
haystack$mcfly
[1] FALSE
haystack[['surprise']]
[1] TRUE
haystack$surprise
[1] TRUE

haystack[11:13]
[[1]]
[1] FALSE

[[2]]
[1] FALSE

[[3]]
[1] FALSE

[.default = FALSE]
haystack[c('x', 'y')]
$x
[1] FALSE

$y
[1] FALSE

[.default = FALSE]

Example: Counters

When counting from a stream of unknown objects, using a normal list can get a little messy as for each object pulled from the stream there needs to be an explicit check to see if the value is already in the list or not.

Using a defaultlist lets you avoid lots of checking, and assume that for any object not in the list, the count is zero.

census <- empty_dlist(0)

population <- c('andy', 'bob', 'carol', 'carol')

for (name in population) {
  census[[name]] <- census[[name]] + 1
}

census

$andy
[1] 1

$bob
[1] 1

$carol
[1] 2

[.default = 0]

census$mike

[1] 0

Extra Credit Example - using nested defaultlists

In this example, nested defaultlists are used to determine the most common pairing of elements in a stream of unknown values.

This implementation does not need to know anything about the possible values in the stream beforehand, and does not need to explicitly test for list membership for every new token plucked from the stream.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a stream of characters heavily weighted towards 'a' and 'e'
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
set.seed(1)
stream <- sample(letters[1:5], 1000, replace = TRUE, prob = c(5, 1, 1, 1, 4))
head(stream)

[1] "a" "a" "e" "d" "a" "d"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create nested defaultlists
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
counter <- empty_dlist(empty_dlist(0))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Count the pair of characters (prev, this)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (idx in 2:length(stream)) {
  this <- stream[[idx]]
  prev <- stream[[idx  - 1]]
  counter[[prev]][[this]] <- counter[[prev]][[this]] + 1
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# The most probable letter pair in the stream is: a-a
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sort(unlist(counter), decreasing = TRUE)

a.a a.e e.a e.e a.b b.a b.e d.a a.c e.b a.d c.e c.a e.c e.d d.e b.b c.b c.c d.b 
178 138 137 108  41  39  37  35  32  32  30  30  30  28  27  19   8   8   8   7 
d.c b.d b.c d.d c.d 
  7   7   5   4   4

Acknowledgements

R Core & CRAN maintainers for giving me a playground
Hadley Wickham for testthat which allowed test-driver-development, without which this package never would have worked.

defaultlist - an R list with a user-defined default value. Take 2

Tue, 12 May 2020 20:18:00 +1000

Problem: I want a list with a user-defined default value

The default list in R is great, but sometimes I’d like it to return something other than NULL if a name isn’t in the list.

Some motivating examples and initial implementation is yesterday’s post

What’s new since yesterday?

Can now store a NULL in a defaultlist without it being replaced with the default value
defaultdict now responds correctly for both character and integer indexing.
Added [ extraction (in addition to [[ and $)

`defaultlist` implementation

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create a list with a default value
#'
#' This behaves exactly like a 'list()' object, except if the requested value
#' does not exist, a default value is returned (instead of NULL).
#'
#' v0.1 2020-05-11  
#'      Initial release.  
#' v0.2 2020-05-12 
#'      Can now store 'NULL' in list properly. 
#'      Added `[` access
#'      Handle defaults when indexing by a numeric
#'
#' Similar to a `defaultdict` in Python
#'
#' @param value default value to return if item not in list
#'
#' @return new `defaultlist` object
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
defaultlist <- function(value) {
  structure(list(), class = 'defaultlist', value = value)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fetch value from defaultlist: [[]] or $
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`[[.defaultlist` <- `$.defaultlist` <- function(x, y) {
  if ((is.character(y) && y %in% names(x)) || 
    (is.numeric(y) && as.integer(y) <= length(x))) {
      NextMethod()
    } else {
      attr(x, 'value')
    }
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fetch value from defaultlist: []
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`[.defaultlist` <- function(x, y) {
  if ((is.character(y) && y %in% names(x)) || 
    (is.numeric(y) && as.integer(y) <= length(x))) {
      NextMethod()
    } else if (is.character(y)) {
      setNames(list(attr(x, 'value')), y)
    } else {
      list(attr(x, 'value'))
    }
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Print like a list
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
print.defaultlist <- function(x, ...) {
  attr(x, 'value') <- NULL
  attr(x, 'class') <- NULL
  print(x)
}

Example - `defaultlist` with a default of FALSE

haystack <- defaultlist(FALSE)
haystack$surprise <- TRUE

haystack[['hello']]
[1] FALSE
haystack$mcfly
[1] FALSE
haystack[['surprise']]
[1] TRUE
haystack$surprise
[1] TRUE

`defaultlist` in action - list with a default of ‘0’

counter <- defaultlist(0)

things <- c('andy', 'bob', 'carol', 'carol')

for (thing in things) {
  counter[[thing]] <- counter[[thing]] + 1
}

counter

$andy
[1] 1

$bob
[1] 1

$carol
[1] 2

Extra Credit Example - using nested defaultlists to count most common letter pairs in a stream of unknown characters

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create nested defaultlists
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
counter <- defaultlist(defaultlist(0))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a stream of characters heavily weighted towards 'a' and 'e'
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
set.seed(1)
stream <- sample(letters[1:5], 1000, replace = TRUE, prob = c(5, 1, 1, 1, 4))
head(stream)

[1] "a" "a" "e" "d" "a" "d"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Count the pair of characters (prev, this)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (idx in 2:length(stream)) {
  this <- stream[[idx]]
  prev <- stream[[idx  - 1]]
  counter[[prev]][[this]] <- counter[[prev]][[this]] + 1
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# The most probable letter pair in the stream is: a-a
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sort(unlist(counter), decreasing = TRUE)

a.a a.e e.a e.e a.b b.a b.e d.a a.c e.b a.d c.e c.a e.c e.d d.e b.b c.b c.c d.b 
178 138 137 108  41  39  37  35  32  32  30  30  30  28  27  19   8   8   8   7 
d.c b.d b.c d.d c.d 
  7   7   5   4   4

defaultlist - an R list with a default value

Mon, 11 May 2020 20:53:00 +1000

Problem: I want a list with a default value

The default list in R is great, but sometimes I’d like it to return something other than NULL if a name isn’t in the list.

Contrived motivating example

Say I want to use a list as a counter for elements in a stream of data, but I’m not sure before-hand what elements are present. Each time I want to increase the count of a particular name, I first have to manually check if the name is already in the list. If it is, then add 1 to that location, otherwise set the counter for that item to 1.

counter <- list()

things <- c('bob', 'david', 'kate', 'susan', 'susan')

for (thing in things) {
  if (thing %in% names(counter)) {
    counter[[thing]] <- counter[[thing]] + 1L
  } else {
    counter[[thing]] <- 1
  }
}

counter

$bob
[1] 1

$david
[1] 1

$kate
[1] 1

$susan
[1] 2

This is fine, but if I’ve got a lot of counters, I’d like something a bit less clunky.

Preferred syntax

I want something which looks pretty much like a list, but if the requested name is not in the list, then the default value is returned, rather than NULL.

In the case of a counter, I want this new defaultlist to return 0 if the requested name is not present.

counter <- defaultlist(0)

things <- c('bob', 'david', 'kate', 'susan', 'susan')

for (thing in things) {
  counter[[thing]] <- counter[[thing]] + 1
}

`defaultlist` implementation

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create a list with a default value
#'
#' This behaves exactly like a 'list()' object, except if the requested value
#' does not exist, a default value is returned (instead of NULL).
#'
#' Similar to a `defaultdict` in Python
#'
#' @param value default value to return if item not in list
#'
#' @return new `defaultlist` object
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
defaultlist <- function(value) {
  structure(list(), class = 'defaultlist', value = value)
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fetch value from defaultlist
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
`[[.defaultlist` <- `$.defaultlist` <- function(x, y) {
  res <- unclass(x)[[y]] 
  if (is.null(res)) attr(x, 'value') else res
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Print like a list
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
print.defaultlist <- function(x, ...) {
  attr(x, 'value') <- NULL
  attr(x, 'class') <- NULL
  print(x)
}

`defaultlist` in action - list with a default of ‘0’

counter <- defaultlist(0)

things <- c('bob', 'david', 'kate', 'susan', 'susan')

for (thing in things) {
  counter[[thing]] <- counter[[thing]] + 1
}

counter

$bob
[1] 1

$david
[1] 1

$kate
[1] 1

$susan
[1] 2

Example - `defaultlist` with a default of FALSE

haystack <- defaultlist(FALSE)
haystack[['surprise']] <- TRUE

haystack[['hello?']]
[1] FALSE
haystack$mcfly
[1] FALSE
haystack[['anyone home?']]
[1] FALSE
haystack[['surprise']]
[1] TRUE

Extra Credit Example - using nested defaultlists to count most common letter pairs in a stream of unknown characters

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create nested defaultlists
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
counter <- defaultlist(defaultlist(0))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a stream of characters heavily weighted towards 'a' and 'e'
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
set.seed(1)
stream <- sample(letters[1:5], 1000, replace = TRUE, prob = c(5, 1, 1, 1, 4))
head(stream)

[1] "a" "a" "e" "d" "a" "d"

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Count the pair of characters (prev, this)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (idx in 2:length(stream)) {
  this <- stream[[idx]]
  prev <- stream[[idx  - 1]]
  counter[[prev]][[this]] <- counter[[prev]][[this]] + 1
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# The most probable letter pair in the stream is: a-a
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sort(unlist(counter), decreasing = TRUE)

a.a a.e e.a e.e a.b b.a b.e d.a a.c e.b a.d c.e c.a e.c e.d d.e b.b c.b c.c d.b 
178 138 137 108  41  39  37  35  32  32  30  30  30  28  27  19   8   8   8   7 
d.c b.d b.c d.d c.d 
  7   7   5   4   4

Introducing 'gridfont' - a vector font

Fri, 08 May 2020 20:33:00 +1000

gridfont

An R repackaging of the gridfont vector font created by inconvergent.

This package is similar to the packages hershey and arcadefont in that it provides point and stroke information, but how this is actually rendered is up to you.

In the examples below ggplot is used to render the strokes for each glyph as geom_path objects.

What’s in the box?

original_df - a data.frame of coordinates and stroke information for all the provided glyphs for the original version of the font.
smooth_df - a data.frame of coordinates and stroke information for all the provided glyphs for the smooth version of the font.
create_text_df() - a function to create stroke information for all the characters in a given string, and offset them appropriately (vertically and horizontally) so that they are ready to render.
original_json, smooth_json the original JSON data read in using jsonlite and provided as list objects.

Installation

You can install from github with:

# install.packages('remotes')
remotes::install_github("coolbutuseless/gridfont")

License

This package is made available under the MIT license. See the file “LICENCSE”.

The original font data was made available by Anders Hoff (a.k.a Inconvergent) also under the MIT license. See the file “LICENSE-font”

Sample sheet for the ‘original’ font

ggplot(gridfont::original_df, aes(x, y)) +
  geom_path(aes(group = as.factor(stroke)), na.rm=TRUE) +
  coord_equal() +
  theme_void() + 
  facet_wrap(~char)  + 
  theme(
    strip.background = element_blank(),
    strip.text.x     = element_blank()
  )

Sample sheet for the ‘smooth’ font

ggplot(gridfont::smooth_df, aes(x, y)) +
  # geom_point() +
  geom_path(aes(group = as.factor(stroke)), na.rm=TRUE) +
  coord_equal() +
  theme_void() + 
  facet_wrap(~char)  + 
  theme(
    strip.background = element_blank(),
    strip.text.x     = element_blank()
  )

Creating blocks of text

gridfont includes create_text_df() as an easy way to create stroke data for all the characters from a given string.

text    <- 'hello  #RStats\noriginal {gridfont}'
plot_df <- create_text_df(text, font='original')

ggplot(plot_df, aes(x, y)) +
  geom_path(aes(group = interaction(char_idx, stroke)), na.rm=TRUE) +
  coord_equal() +
  theme_void()

text    <- 'hello  #RStats\nsmooth {gridfont}'
plot_df <- create_text_df(text, font='smooth')

ggplot(plot_df, aes(x, y)) +
  geom_path(aes(group = interaction(char_idx, stroke)), na.rm=TRUE) +
  coord_equal() +
  theme_void()

Animated rendering

Now that all the stroke information is available, we can render each stroke, character-by-character to get a “writing” effect.

Introducing 'arcadefont' - an oldschool arcade vector font (Happy Star Wars Day)

Mon, 04 May 2020 20:58:00 +1000

arcadefont

arcadefont provides raw vector data for an 80s arcade vector font - similar to that seen in Battlezone or Star Wars. It is a fixed-width, caps-only font.

This package was released on “May the 4th” 2020 - i.e. “Star Wars Day”.

This is similar to the hershey vector font package in that it provides point and stroke information, but how this is actually rendered is up to you.

In the examples below ggplot is used to render the strokes for each glyphs as geom_path objects.

What’s in the box?

arcade_df - a data.frame of coordinates and stroke information for all the provided glyphs.
create_text_df() - a function to create stroke information for all the characters in a given string, and offset them appropriately (vertically and horizontally) so that they are ready to render.

Installation

You can install from GitHub with:

# install.packages("remotes")
remotes::install_github("coolbutuseless/arcadefont")

Vector data source - `arcade_df`

The following output shows the data for the letter A contained in the arcade_df data.frame.

letter - character represented in this data, in this case “A”
stroke - grouping variable for the points belonging to the same stroke. The letter ‘A’ is made of 2 strokes: 1. the frame of the A shape 2. the crossbar.
x,y - coordinates of points which make up a stroke. Are point coordinates are integer locations on a 9x9 grid.
idx - ordering index of points within each stroke

arcadefont::arcade_df %>%
  filter(letter == 'A') %>%
  knitr::kable()

letter	stroke	x	y	idx
A	1	0	0	1
A	1	0	6	2
A	1	4	8	3
A	1	8	6	4
A	1	8	0	5
A	2	0	3	1
A	2	8	3	2

Font Sample Sheet

A rendering of all the glyphs represented in arcade_df.

library(ggplot2)
library(arcadefont)

ggplot(arcadefont::arcade_df, aes(x, y)) + 
  geom_path(aes(group=stroke)) + 
  coord_fixed() + 
  theme_void() + 
  facet_wrap(~letter)  + 
  theme(
    strip.background = element_blank(),
    strip.text.x     = element_blank()
  )

Create data for sequences of characters

A simple way to create all the strokes for lines of text is to use create_text_df().

This function will offset the characters along a row of text, and arrange the characters over multiple lines.

text    <- "Hello #RStats!\n@coolbutuseless"
text_df <- arcadefont::create_text_df(text, dx = 2, dy = 3)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot it!
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(text_df, aes(x, y)) +
  geom_path(aes(group=interaction(char_idx, stroke))) +
  coord_fixed() +
  theme_void()

Recreation of instructions screen for “Star Wars - The Arcade Game”

Star Wars is a 3D vector graphics arcade game released in 1983. See more on wikipedia and playthrough video.

When running in ‘attract mode’ the arcade machine displayed information such as the high score table and instructions for playing.

Here I’ve recreated the instructions screen - colours too!

library(dplyr)
library(ggplot2)
library(arcadefont)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Full text of the instructions screen
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
text <- "
    score                         0 wave
       00      game over
             1 coin 1 play

    flight instructions to red five

  1.   your x-wing is equiped with an
   invisible deflector shield that
   will protect you for 8 collisions.

  2.   deflector strength is lost when
   a firevall impacts your shield or
   what you strike a laser tower or
   trench catwalk.

  3.   aim your lasers with cursor to
   explode empire tie fighters laser
   tower tops and trench turrets.

  4.   shoot fireballs before they
   impact your shield.

  5. the rebel force is depending on
   you to stop the empire by blowing
   up the death star."


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create the text in the arcade font and set some colours
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
text_df <- arcadefont::create_text_df(text, dx = 2, dy = 3)
text_df <- text_df %>% mutate(
  colour = case_when(
    line == 2 & letter == '0' ~ 'green',
    line == 2                 ~ 'red',
    line == 3 & letter == '0' ~ 'green',
    line == 3                 ~ 'cyan',
    line == 4                 ~ 'yellow',
    TRUE                      ~ 'red'
  )
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Plot it!
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ggplot(text_df, aes(x, y)) +
  geom_path(aes(group=interaction(char_idx, stroke), colour = I(colour))) +
  coord_fixed() +
  theme_void() +
  theme(panel.background = element_rect(fill = 'black'))

Introducing devoutansi - an ANSI graphics device

Thu, 30 Apr 2020 20:27:00 +1000

devoutansi

devoutansi is a graphics output device for R which will output graphics as text files with ANSI colouring.

Installation

You can install from GitHub with:

# install.packages("remotes")
remotes::install_github("coolbutuseless/devout")     # devout framework
remotes::install_github("coolbutuseless/miniansi")   # ANSI doc creator
remotes::install_github("coolbutuseless/devoutansi") # this device

Limitations

No current support for clipping paths or rasters.
Text positioning and spacing will always be a little off
Rotated text (except for 0 and 90 degrees) is probably going to be placed incorrectly.
No support for transparency i.e. alpha has no effect other then to suppress rendering completely when alpha = 0

Basic Usage

Use devoutansi::ansi() as you would the pdf() or png() device.

The output will be written as ANSI characters to the screen, or a text file if specified.

Note: - Because you can’t readily view ANSI in an HTML document, all images included are screenshots of the output in my terminal.

Note: Click any image to view its ANSI text

library(ggplot2)
library(devoutansi)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# PNG output of plot
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
p <- ggplot(mtcars) +
  geom_bar(aes(as.factor(cyl), fill = as.factor(cyl)), colour = NA) +
  theme_minimal() + 
  theme(
    panel.grid   = element_blank()
  ) +
  labs(
    title    = "{devoutansi} - ANSI graphics device",
    subtitle = "Hello #RStats"
  ) 

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ANSI output
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
devoutansi::ansi(filename = "/img/devoutansi/mtcars1.txt", width = 120)
  p 
invisible(dev.off())

Warning in file(con, "w"): cannot open file '/img/devoutansi/mtcars1.txt': No
such file or directory

Warning in dev.off(): rdevice_close: Evaluation error: cannot open the
connection.

All the demo plots on this page are available as their ANSI txt files by clicking on the images.

`geom_density()`

Click to show/hide code

library(ggplot2)

p <- ggplot(mtcars) +
  geom_density(aes(mpg, fill = as.factor(cyl))) + 
  theme_minimal() +
  theme(
    panel.grid      = element_blank(), 
    legend.key.size = unit(5, 'in')
  ) + 
  scale_fill_viridis_d() + 
  labs(
    title    = "{devoutansi} - ANSI graphics device",
    subtitle = "filled polygons (geom_density)"
  )

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ANSI output
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
devoutansi::ansi("/img/devoutansi/mtcars3.txt", width = 150)
p
invisible(dev.off())

Warning in file(con, "w"): cannot open file '/img/devoutansi/mtcars3.txt': No
such file or directory

Warning in dev.off(): rdevice_close: Evaluation error: cannot open the
connection.

`geom_density()` in ASCII only

Click to show/hide code

Extra options for ASCII mode:

char_lookup_table set to 1, 2 or 3 to select the character set
pow nonlinear intensity remapping using this exponent. default 1

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ANSI output
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
devoutansi::ansi("/img/devoutansi/mtcars3-ascii.txt", width = 150, plain_ascii = TRUE)
p
invisible(dev.off())

Warning in file(con, "w"): cannot open file '/img/devoutansi/mtcars3-ascii.txt':
No such file or directory

Warning in dev.off(): rdevice_close: Evaluation error: cannot open the
connection.

`geom_sf()`

Click to show/hide code

library(dplyr)
library(sf)
library(ggplot2)
library(devoutansi)

nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
nc <- nc %>% filter(between(CNTY_ID, 1820, 1830))

p <- ggplot(nc) +
  geom_sf(aes(fill = NAME)) +
  theme_bw(15) +
  theme(legend.key.size = unit(5, 'in')) + 
  scale_fill_brewer(palette = 'Dark2') + 
  labs(
    title    = "{devoutansi} - ANSI graphics device",
    subtitle = "filled polygons (geom_density)"
  )

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ANSI output
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
devoutansi::ansi("/img/devoutansi/geom-sf.txt", width = 150)
p
invisible(dev.off())

Warning in file(con, "w"): cannot open file '/img/devoutansi/geom-sf.txt': No
such file or directory

Warning in dev.off(): rdevice_close: Evaluation error: cannot open the
connection.

`pie` plot from base R

Click to show/hide code

devoutansi::ansi("/img/devoutansi/pie.txt", width = 180)
pie(c(cool = 4, but = 2, use = 1, less = 8), main = "ANSI graphics device - Base pie plot")
invisible(dev.off())

Warning in file(con, "w"): cannot open file '/img/devoutansi/pie.txt': No such
file or directory

Warning in dev.off(): rdevice_close: Evaluation error: cannot open the
connection.

`geom_histogram()`

Click to show/hide code

library(ggplot2)

p <- ggplot(mtcars) +
  geom_histogram(aes(mpg, fill = as.factor(cyl)), bins = 20) + 
  theme_minimal() +
  theme(
    panel.grid      = element_blank(),
    legend.key.size = unit(5, 'in')
  ) + 
  labs(
    title    = "{devoutansi} - ANSI graphics device",
    subtitle = "ggraph"
  ) + 
  scale_fill_brewer(palette = 'Set2')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ANSI output
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ansi("/img/devoutansi/mtcars2.txt", width = 150)
p
invisible(dev.off())

Warning in file(con, "w"): cannot open file '/img/devoutansi/mtcars2.txt': No
such file or directory

Warning in dev.off(): rdevice_close: Evaluation error: cannot open the
connection.

`ggraph`

Click to show/hide code

library(ggplot2)
library(ggraph)
library(tidygraph)
library(dplyr)

set.seed(1)
simple <- create_notable('bull') %>%
  mutate(name = c('But', 'Use', 'Cool', 'Less', 'Mike')) %>%
  activate(edges) %>%
  mutate(type = sample(c('friend', 'foe'), 5, TRUE))

p <- ggraph(simple, layout = 'graphopt') +
  geom_edge_link0(colour = 'grey70') +
  geom_node_text(aes(label = name), size = 10) + 
  theme_void() + 
  labs(
    title    = "{devoutansi} - ANSI graphics device",
    subtitle = "ggraph"
  )

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ANSI output
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ansi("/img/devoutansi/ggraph.txt", width = 150)
p
invisible(dev.off())

Warning in file(con, "w"): cannot open file '/img/devoutansi/ggraph.txt': No
such file or directory

Warning in dev.off(): rdevice_close: Evaluation error: cannot open the
connection.

Introducing miniansi - a package for creating simple ANSI documents

Wed, 29 Apr 2020 20:27:00 +1000

miniansi

`miniansi` is a package for creating simple ANSI documents.

miniansi is an R package for creating coloured ANSI output.

miniansi currently has quite a minimal feature set, as only enough was included such that it could act as a graphics output device for R.

Installation

You can install from GitHub with:

# install.packages("remotes")
remotes::install_github("coolbutuseless/miniansi")

Future possibilities

Slice documents, copy one document into another
Image/raster support
Manually simulate alpha blending by tinting colours
Anti-aliasing
Figlet support

Simple example of creating an ANSI document

library(miniansi)

doc <- ANSI$new(width = 80, height = 20, background = 'cornflowerblue')
doc$rect(5, 5, 15, 15, colour = 'red', fill = 'white')
doc$line(1, 1, 80, 20, 'gold')
doc$circle(25, 10, r = 17, colour = 'darkgreen', fill = NA)
doc$text(50,  5, "Hello #RStats" , angle = 90, colour = 'brown')
doc$text(60, 20, "coolbutuseless", angle =  0)

doc

Aspect ratio tweaks

Working with ANSI is often painful due to the fundamental pixel unit not being square.

miniansi includes a mode which lets you specify the aspect ratio of the font, and tries to adjust everything else (by scaling the y values) so that square things still look square.

Use the font_aspect argument during initialisation to let miniansi know how to compensate for aspect ratio.

This mode has its own problems (as evidenced in the plot below). Note:

The Good:

The rect sides now actually look (nearly) the same length

The Bad:

Even though the document is only nominally 20 characters high, because of the y-coord adjustment, the visible plotting area is larger i.e. doc$max_height = height/font_aspect
Vertical text writing will never work properly in this mode.

The Weird:

Circles are always fudged by miniansi to look circular. This was a deliberate choice in order to work sanely with grid graphics and ggplot2::geom_point

library(miniansi)

doc <- ANSI$new(width = 80, height = 20, background = 'cornflowerblue', font_aspect = 0.45)

max_height <- doc$max_height

doc$rect(5, 5, 15, 15, colour = 'red', fill = 'white')
doc$line(1, 1, 80, max_height, 'gold')
doc$circle(25, 10, r = 17, colour = 'darkgreen', fill = NA)
doc$text(50,  5, "Hello #RStats" , angle = 90, colour = 'black')
doc$text(60, 20, "coolbutuseless", angle =  0)

doc

Alternate logo - Rendering a vector font to ANSI

library(dplyr)
library(hershey)  # Hershey Vector Fonts: https://github.com/coolbutuseless/hershey

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise a document
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
doc <- ANSI$new(width = 110, height = 50, font_aspect = 0.4, background = 'white')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Set some sizes
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
w  <- 110
h  <- doc$max_height
ll <- h/2.1

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Set up a hexagon
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
polygon_df <- tibble(
  angle = seq(0, 2*pi, length.out = 7) + pi/6,
  x     = ll * cos(angle) + w/2,
  y     = ll * sin(angle) + h/2
)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw the polygon
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
doc$polygon(polygon_df$x, polygon_df$y, fill = 'cornflowerblue', colour = 'darkblue')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Set up the letter R
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
letter_r <- hershey::hershey %>%
  filter(char == 'R', font == 'music') %>%
  mutate(
    x = 3.3 *  x,
    y = 3.3 * -y,
    
    x = x + w/2,
    y = y + h/2 + 2
  )


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Draw the letter
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
letter_r %>% 
  group_by(stroke) %>% 
  group_walk(~doc$polyline(.x$x, .x$y, colour = 'darkred'))


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# print
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
doc

Animation

This is a gif capture of this code running in my terminal. I definitely tweaked the frame rate up, as capturing a clean set of images in the terminal was hard.

library(miniansi)
library(dplyr)
library(hershey)  # Hershey Vector Fonts: https://github.com/coolbutuseless/hershey

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Set up the positions for each frame
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
xoffs  <- seq(135, -265, -10)
angles <- seq(pi/6, pi/2, length.out = length(xoffs))


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Loop over all frames
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (idx in seq_along(xoffs)) {
  
  xoff  <- xoffs[idx]
  angle <- angles[idx]
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Set up an ANSI document
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  doc <- ANSI$new(width = 110, height = 50, font_aspect = 0.4, background = 'white')

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Define some sizes
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  w  <- 110
  h  <- doc$max_height
  ll <- h/2.3
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # draw a rotated hexagon
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  polygon_df <- tibble(
    angle = seq(0, 2*pi, length.out = 7) + angle,
    x     = ll * cos(angle) + w/2,
    y     = ll * sin(angle) + h/2
  )
  
  doc$polygon(polygon_df$x, polygon_df$y, fill = 'cornflowerblue', colour = NA)
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Create a word in the hershey 'meteorology' font
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  rstats <- hershey::create_string_df("RStats", font = 'meteorology') %>%
    mutate(
      x = 3 *  x,
      y = 3 * -y,
      y = y + h/2,
      x = x + xoff  # (-2*w-45), w+25 => -265, 135
    )
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Draw the word using polylines for each stroke for each character
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  rstats %>% 
    group_by(char_idx, stroke) %>% 
    group_walk(~doc$polyline(.x$x, .x$y, colour = 'darkred'))
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Print the frame, reset the cursor to top of screen for a slightly 
  # cleaner render
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  print(doc)
  cat("\033[0;0H")
  Sys.sleep(0.2)
}

Scanline Polygon Fill Algorithm in Plain R (with bonus ANSI colour!)

Tue, 28 Apr 2020 20:30:00 +1000

Why the Hell would you do this?

Polygon filling is ubiquitous in computer graphics, with modern GPU hardware rendering approximately 1 Billion polygons per second.

So why have I regressed to 30 years ago and hand-rolled a scanline polygon filling algorithm in plain R?

I needed it
I hadn’t written one since Computer Graphics 101 - so many years ago.
I was interested to see how much the built-in R data structures would help - mainly the use of data.frames to hold the edge lists.

Specifications

Specifications for my use case

Base R only - I don’t want to compile C code or pull in some other dependency.
Integer coordinates only. Everything will be rounded to an integer as I’m not anti-aliasing or anything fancy.
Polygons only expected to be a maximum of about 100x100 pixels, so speed won’t be a huge factor.

Scanline Polygon Fill

See wikipedia for an overview of scanline rendering.

The code here is broken in to 2 functions:

make_edges() creates edge information for each pair of vertices in the polygon
fill_polygon() fills the polygon specified by vectors of vertices.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Make edge information structure from polygon vertex coords
#'
#' @param xs,ys vertex coords
#'
#' @return data.frame
#'
#' @importFrom utils head tail
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
make_edges <- function(xs, ys) {

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Ensure we have a closed loop
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  N <- length(xs)
  if (!(xs[1] == xs[N] && ys[1] == ys[N])) {
    xs <- c(xs, xs[1])
    ys <- c(ys, ys[1])
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Basic edge structure: the 2 vertices
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  edges <- data.frame(
    x1 = head(xs, -1),
    y1 = head(ys, -1),
    x2 = tail(xs, -1),
    y2 = tail(ys, -1)
  )

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Enhanced edge structure
  #  - ymin,ymax the extents of this edge
  #  - x the x coordinate of ymin
  #  - igrad inverse gradient (used to increment the x as we step through the
  #          y scanlines)
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  edges <- transform(
    edges,
    ymin  = pmin(y1, y2),
    ymax  = pmax(y1, y2),
    x     = ifelse(y2 > y1, x1, x2),
    igrad = (x2 - x1)/(y2 - y1)
  )

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # order by increasing ymin
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  edges <- edges[order(edges$ymin),]

  edges
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Fill a polygon
#'
#' @param mat matrix to fill
#' @param xs,ys coordinates of vertices (integers)
#' @param fill fill value. usually a character.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fill_polygon <- function(mat, xs, ys, fill) {
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Ensure we only have integers
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  xs <- round(as.integer(xs))
  ys <- round(as.integer(ys))

  stopifnot(length(xs) == length(ys))

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Initialise the edge lists
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  all_edges <- make_edges(xs, ys)
  active    <- NULL

  if (nrow(all_edges) < 3) {
    return(mat)
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Set the vertices
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  mat[cbind(ys, xs)] <- fill

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Draw any horizontal edges and remove from list
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  hedges    <- subset(all_edges, y1 == y2)
  all_edges <- subset(all_edges, y1 != y2)

  for (i in seq_len(nrow(hedges))) {
    hedge_row <- hedges[i, ]
    ys <- hedge_row$y1
    xs <- hedge_row$x1:hedge_row$x2
    mat[ys, xs] <- fill
  }

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # For each 'y' scanline
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  for (yscan in min(all_edges$ymin):max(all_edges$ymax)) {

    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Add new active edges to 'active', and remove from 'all_edges'
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    new_active <- subset(all_edges, ymin == yscan)
    all_edges  <- subset(all_edges, ymin >  yscan)

    active     <- rbind(active, new_active)

    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Remove any active edges which the scanline has passed.
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    active <- subset(active, ymax > yscan)

    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Check if all edges have been processed
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    if (nrow(all_edges) == 0 && nrow(active) == 0) {
      break
    }

    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Arrange active list by x
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    active <- active[order(active$x),]

    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # For each pair of edges, draw the scanline between them
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    for (pidx in seq(1, nrow(active), by=2)) {
      x1 <- as.integer(round(active$x[pidx    ]))
      x2 <- as.integer(round(active$x[pidx + 1]))
      ys <- yscan
      xs <- x1:x2

      mat[ys, xs] <- fill
    }

    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Increment the x position of the active edges
    #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    active$x <- active$x + active$igrad

  }

  mat
}

Draw a filled hexagon in ASCII

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a hexagon.  Distort in the x axis for better visual appearance since
# fonts are alwyas wider than they are tall.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
polygon_df <- tibble(
  angle = seq(0, 2*pi, length.out = 7) + pi/6,
  x     = 2.3 * (8 * cos(angle) + 11),
  y     = 8 * sin(angle) + 11
)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise a blank matrix and draw the polygon on it.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mat <- matrix('.', 20, 50)
mat <- fill_polygon(mat, xs = polygon_df$x, ys = polygon_df$y, fill = '#')

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add some text and dump the canvas to the console
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mat[11, 18:31] <- strsplit('Hello #RStats!', '')[[1]]
cat(apply(mat, 1, paste, collapse = ""), sep="\n")

..................................................
..................................................
........................#.........................
....................##########....................
................####################..............
............#############################.........
........#################################.........
........#################################.........
........#################################.........
........#################################.........
........#########Hello #RStats!##########.........
........#################################.........
........#################################.........
........#################################.........
........#################################.........
............#########################.............
................#################.................
....................#########.....................
........................#.........................
..................................................

Drawing with ANSI

Instead of just ASCII characters, you would use ANSI colours to make something prettier. Here I’ll use ransid for the ANSI codes (but in general you will probably want to use something well-designed like crayon)

Note: ANSI colours won’t display in an Rmarkdown document (as far as I know), so I’ve just taken a screen capture of my terminal and included the image.

library(ransid)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Define some ANSI strings for the colours I want
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dark_bg  <- paste0(col2bg('darkblue' ), ' ')
light_bg <- paste0(col2bg('lightblue'), ' ')
text_fg  <- paste0(col2fg('red'   ))
text_bg  <- paste0(col2bg('yellow'))

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Initialise a matrix with a light background and draw the polygon on it.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mat <- matrix(light_bg, 20, 50)
mat <- fill_polygon(mat, xs = polygon_df$x, ys = polygon_df$y, fill=dark_bg)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Add some text and dump the canvas to the console
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
mat[11, 18:31] <- paste0(text_fg, text_bg, strsplit('Hello #RStats!', '')[[1]])
res <- paste0(apply(mat, 1, paste, collapse = ""), collapse="\n")
cat(res)

Animating the ANSI

Dump ANSI to the console and screencapture it to a gif. Inelegant, but it works for now.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Create a hexagon.  Distort in the x axis for better visual appearance since
# fonts are alwyas wider than they are tall.
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
for (start_angle in seq(pi/6, pi/2, length.out = 30)) {
  polygon_df <- tibble(
    angle = seq(0, 2*pi, length.out = 7) + start_angle,
    x     = 2.3 * (16 * cos(angle) + 21),
    y     = 16 * sin(angle) + 21
  )
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Initialise a matrix with a light background and draw the polygon on it.
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  mat <- matrix(light_bg, 40, 100)
  mat <- fill_polygon(mat, xs = polygon_df$x, ys = polygon_df$y, fill=dark_bg)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Add some text and dump the canvas to the console
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  mat[21, 41:54] <- paste0(text_fg, text_bg, strsplit('Hello #RStats!', '')[[1]])
  cat(paste0(apply(mat, 1, paste, collapse = ""), sep="\n"))
  Sys.sleep(0.3)
}

Introducing 'ransid' - a simple image to ANSI converter

Mon, 27 Apr 2020 14:46:00 +1000

ransid

ransid converts images to ANSI text which can be displayed in the console.

Why?

Because.
R pranks!

Note to be confused with:

ransid - Rust ANSI Driver

Installation

You can install ransid from github with:

# install.packages('remotes')
remotes::install_github("coolbutuseless/ransid")

Example

Note - because ANSI is for display in a terminal, it does not render in a markdown document. The following images are screenshots of my Rstudio terminal

im <- image_read(system.file('img', 'Rlogo.png', package = 'png'))
cat(im2ansi(im, width = 120))

im <- magick::image_read('https://www.fillmurray.com/300/250')
cat(im2ansi(im, width = 120))

im <- magick::image_read('https://placekitten.com/300/200')
cat(im2ansi(im, width = 120))

Introducing devoutdrawio - A graphics device which outputs to draw.io format

Thu, 23 Apr 2020 19:47:00 +1000

devoutdrawio

drawio is an open source web and desktop application for creating and editing structured diagrams.

devoutdrawio is a new graphics output device for R which will output graphics in the drawio XML format suitable for editing in drawio.

Why drawio?

drawio allows you to quickly edit structured documents online for free. By outputting in a format suitable for drawio, you can output graphics from R and then manually edit individual elements, lines and polygons to suite your needs.

Installation

You can install from GitHub with:

# install.packages("remotes")
remotes::install_github("coolbutuseless/devout")       # devout framework
remotes::install_github("coolbutuseless/minidrawio")   # draw.io doc creator
remotes::install_github("coolbutuseless/devoutdrawio") # this device

Limitations

No current support for clipping paths or rasters.
Text positioning and spacing is still a little off
Rotated text (except for 0 and 90 degrees) is probably going to be placed incorrectly.
No code has been written to handle changes to the font family so you’re stuck with helvetica for now.

Basic Usage

Use devoutdrawio::drawio as you would the pdf() or png() device.

The output will be written to an XML file in the draw.io format.

You can then load this into the draw.io web app.

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# PNG output of plot
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
p <- ggplot(mtcars) +
    geom_density(aes(mpg, fill = as.factor(cyl)), colour = NA) +
    theme_bw() +
    labs(title = "Hello #RStats", subtitle = "{devoutdrawio} - draw.io graphics device")
  print(p)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Save to drawio XML format
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
drawio("/img/devoutdrawio/mtcars.xml")
print(p)
invisible(dev.off())

Examples: click to view and edit on draw.io

Click on an image to take you to a draw.io preview page. At the bottom of that page, click on the pencil icon to edit the image in the draw.io web app.

The XML draw.io plots can be downloaded from here: 1, 2, 3, 4

Editing in drawio - moving, adding text, changing colours

Rather than outputting a plot as an array of pixels, the devoutdrawio device outputs the plot as a collection of geometric elements.

These elements can then be manipulated, resized, deleted or altered, all from within the drawio web interface.

V1	V2	V3	V4	V5	V6	V7	V8
1	5	8	6	3	7	2	4
1	6	8	3	7	4	2	5
1	7	4	6	8	2	5	3
1	7	5	8	2	4	6	3
2	4	6	8	3	1	7	5
2	5	7	1	3	8	6	4
2	5	7	4	1	8	6	3
2	6	1	7	4	8	3	5
2	6	8	3	1	4	7	5
2	7	3	6	8	5	1	4

V1	V2	V3	V4	V5	V6	V7	V8
1	5	8	6	3	7	2	4
1	6	8	3	7	4	2	5
1	7	4	6	8	2	5	3
1	7	5	8	2	4	6	3
2	4	6	8	3	1	7	5
2	5	7	1	3	8	6	4
2	5	7	4	1	8	6	3
2	6	1	7	4	8	3	5
2	6	8	3	1	4	7	5
2	7	3	6	8	5	1	4

coolbutuseless

Toy WASM interpreter in base R

WASM

C function to calculate factorial(n)

factorial(n) in WAT (human readable WASM text)

Compile WAT to WASM

WASM raw bytes

WASM virtual stack machine

Other cheats:

Warnings

Stack

Define the functions

factorial(3) running in WASM

factorial(3) running in WASM (verbose)

What’s next?

AnotherWorld game written + playable in R (with {nara} and {eventloop})

AnotherWorld playable game in R

You can play this game today in R!!

Gameplay in R

Installation

Controls

Play the game

GamePlay

Game walkthrough on the Amiga

Screenshots of the R version

ToDo

Requirements

Limitation - WindowsOS

Limitation - Flickering Cursor

Reference Source Code

Challenges

0-based vs 1-based indexing

bitwise operations

‘Bytekiller’ compression

Pacman game written in R with {nara} and {eventloop}

Pacman-style game in R

Gameplay

Controls

Installation

Requirements

Limitation - WindowsOS

Limitation - Flickering Cursor

Introducing {nara} for nativeRaster handling for fast in-memory rendering buffers

nara

Why?

Example

Details

What is a nativeRaster and why is it fast?

In-place operation

Anti-aliasing/Interpolation

Installation

Vignettes

Static Rendering: Example

Static Rendering: Displaying Sprites

Blit the first dino frame onto a native raster canvas.

Dynamic (realtime) Rendering: Walking Dino

Live screen recording

Dino Multi-Ball

Live screen recording

Coordinate System

Benchmark raster vs nativeRaster

Future possibilities

Acknowledgements

World's simplest R music system. Part 3 - Non-sinusoidal Waveforms

Introduction

Utilities developed in prior posts

Create simple note with different waveforms

Sine

Square

Triangle

Sawtooth

World’s simplest R music system - with linear ADSR profile shaping + sawtooth waveform

Different waveforms sound different

Live capture of “Mary had a little lamb” - with ADSR note shaping + sawtooth waveform

Live capture of “Mary had a little lamb” - with ADSR note shaping + sine waveform

World's simplest R music system. Part 2 - linear ADSR note shaping

Introduction

Create naive note

Raw note

Shape of a naive note

C function to calculate `factorial(n)`

`factorial(n)` in WAT (human readable WASM text)

`factorial(3)` running in WASM

`factorial(3)` running in WASM (verbose)

`AnotherWorld` playable game in R

What is a `nativeRaster` and why is it fast?

Benchmark `raster` vs `nativeRaster`

Fake Terrain with `ambient`

V1	V2	V3	V4	V5	V6	V7	V8
1	5	8	6	3	7	2	4
1	6	8	3	7	4	2	5
1	7	4	6	8	2	5	3
1	7	5	8	2	4	6	3
2	4	6	8	3	1	7	5
2	5	7	1	3	8	6	4
2	5	7	4	1	8	6	3
2	6	1	7	4	8	3	5
2	6	8	3	1	4	7	5
2	7	3	6	8	5	1	4