**Higher Order Functions**, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)

Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.

There is a celebrated Commodore 64 program that randomly prints outs `/`

and `\`

characters and fills the screen with neat-looking maze designs. It is just one
line of code, but there is a whole book written about
it.

10 PRINT CHR$(205.5+RND(1)); : GOTO 10

The basic idea, from my reading of the code, is that `CHR$(205)`

is `\`

,
`CHR$(206)`

is `/`

, and the program randomly selects between the two by adding a
random number to 205.5. Endlessly looping over this command fills the screen
with that pleasing maze pattern.

In R, we could replicate this functionality with by randomly sampling the slashes:

sample_n_slashes <- function(n) { sample(c("/", "\\"), size = n, replace = TRUE) } withr::with_options( list(width = 40), cat(sample_n_slashes(800), sep = "", fill = TRUE) ) #> //////\/\\/\/\/\/\\//\\\\//\//\/\//\///\ #> \\\/\//\\/\/////////////\\/\//\\\/\//\\\ #> /\\/\/\//\/\/\\/\\/\/\//\\\\//\/\\\/\/// #> \\//\/\\\/\///\\/\/\/////\//\///\/\/\//\ #> /\/\//\///\//\//\//\/\//\\/\\\\\/\\\//\/ #> //\\\\\//////\//\//\/\//\\////\/\\\/\/\/ #> \\////\/\\/\////\//////\\/\\/////\/////\ #> /\/\/\/\/\\///\/\\\\/\/\\//\/\\/\\\\\\// #> //\\\/\///\///\/\\\//\//\\\\//\\/\\/\/\/ #> /\\/\//\\//\/\\\\\/\\\/\\\/\/\/\/\////\/ #> /\//\\//\////\\\///\//\/\\\/\\///\//\\\\ #> /\//\\////\/\\\//\\\//\/\///\\\\\/\/\\// #> \\////\\/\\\\\\///\///\//\\\/\\\\//\//// #> \\\///\/\//\//\/\//\/\/\\\/\/\\///\///// #> \\/\\//\\\\\\///\\\\/\\/\\//\//\\\/\\/\/ #> ////\\\////\/\\\\\/////\/\\\////\\///\\\ #> \//\\\//\///\/\\\\//\\\////\\//\\/\/\//\ #> \/\//\\//\\///\\\\\\//\///\/\\\\\\\\/\\/ #> ///\/\//\\/\/\\\\\\\\/\///\//\\///\\//\\ #> /////\\///\/\\/\/\\//\\//\/\\/\//\//\\\\

where `withr::with_options()`

lets us temporarily change the print width and
`cat()`

concatenates the slashes and prints out the characters as text.

We can also make this much prettier by drawing the patterns using ggplot2.

## Drawing line segments with ggplot2

Instead of writing out slashes, we will draw a grid of diagonal line segments,
some of which will be flipped at random. To draw a segment, we need a starting
*x*–*y* coordinate and an ending *x*–*y* coordinate. `geom_segment()`

will
connect the two coordinates with a line. Here’s a small example where we draw
four “slashes”.

library(ggplot2) library(dplyr) data <- tibble::tribble( ~row, ~col, ~x_start, ~x_end, ~y_start, ~y_end, 1, 1, 0, 1, 0, 1, 1, 2, 1, 2, 1, 0, # flipped 2, 1, 0, 1, 1, 2, 2, 2, 1, 2, 1, 2) ggplot(data) + aes(x = x_start, xend = x_end, y = y_start, yend = y_end) + geom_segment()

The programming task now is to make giant grid of these slashes. Let’s start
with an observation: To draw two slashes, we needed three *x*
values: 0, 1, 2. The first two served as segment starts and the last two
as segment ends. The same idea applies to the *y* values. We can generate a
bunch of starts and ends by taking a sequence of steps and removing the first
and last elements.

# We want a 20 by 20 grid rows <- 20 cols <- 20 x_points <- seq(0, 1, length.out = cols + 1) x_starts <- head(x_points, -1) x_ends <- tail(x_points, -1) y_points <- seq(0, 1, length.out = rows + 1) y_starts <- head(y_points, -1) y_ends <- tail(y_points, -1)

Each `x_starts`

–`x_ends`

pair is a column in the grid, and each
`y_starts`

–`y_ends`

is a row in the grid. To make a slash at each
row–column combination, we have to map out all the combinations of the rows
and columns. We can do this with `crossing()`

which creates all *crossed*
combinations of values. (If it helps, you might think of *crossed* like crossed
experiments or the
Cartesian cross product of
sets.)

grid <- tidyr::crossing( # columns data_frame(x_start = x_starts, x_end = x_ends), # rows data_frame(y_start = y_starts, y_end = y_ends)) %>% # So values move left to right, bottom to top arrange(y_start, y_end) # 400 rows because 20 rows x 20 columns grid #> # A tibble: 400 x 4 #> x_start x_end y_start y_end #> <dbl> <dbl> <dbl> <dbl> #> 1 0 0.05 0 0.05 #> 2 0.05 0.1 0 0.05 #> 3 0.1 0.15 0 0.05 #> 4 0.15 0.2 0 0.05 #> 5 0.2 0.25 0 0.05 #> 6 0.25 0.3 0 0.05 #> 7 0.3 0.35 0 0.05 #> 8 0.35 0.4 0 0.05 #> 9 0.4 0.45 0 0.05 #> 10 0.45 0.5 0 0.05 #> # ... with 390 more rows

We can confirm that the segments in the grid fill out a plot. (I randomly color the line segments to make individual ones visible.)

ggplot(grid) + aes( x = x_start, y = y_start, xend = x_end, yend = y_end, color = runif(400)) + geom_segment(size = 1) + guides(color = FALSE)

Finally, we need to flip slashes at random. A segment becomes flipped if the
`y_start`

and `y_end`

are swapped. In the code below, we flip the slash in each
row if a randomly drawn number between 0 and 1 is less than .5. For style, we
also use `theme_void()`

to strip away the plotting theme, leaving us with just
the maze design.

p_flip <- .5 grid <- grid %>% arrange(y_start, y_end) %>% mutate( p_flip = p_flip, flip = runif(length(y_end)) <= p_flip, y_temp1 = y_start, y_temp2 = y_end, y_start = ifelse(flip, y_temp2, y_temp1), y_end = ifelse(flip, y_temp1, y_temp2)) %>% select(x_start:y_end, p_flip) ggplot(grid) + aes(x = x_start, y = y_start, xend = x_end, yend = y_end) + geom_segment(size = 1, color = "grey20") last_plot() + theme_void()

Now, we wrap all these steps together into a pair of functions.

make_10_print_data <- function(rows = 20, cols = 20, p_flip = .5) { x_points <- seq(0, 1, length.out = cols + 1) x_starts <- head(x_points, -1) x_ends <- tail(x_points, -1) y_points <- seq(0, 1, length.out = rows + 1) y_starts <- head(y_points, -1) y_ends <- tail(y_points, -1) grid <- tidyr::crossing( data.frame(x_start = x_starts, x_end = x_ends), data.frame(y_start = y_starts, y_end = y_ends)) grid %>% arrange(y_start, y_end) %>% mutate( p_flip = p_flip, flip = runif(length(y_end)) <= p_flip, y_temp1 = y_start, y_temp2 = y_end, y_start = ifelse(flip, y_temp2, y_temp1), y_end = ifelse(flip, y_temp1, y_temp2)) %>% select(x_start:y_end, p_flip) } draw_10_print <- function(rows = 20, cols = 20, p_flip = .5) { grid <- make_10_print_data(rows = rows, cols = cols, p_flip = p_flip) ggplot(grid) + aes(x = x_start, y = y_start, xend = x_end, yend = y_end) + geom_segment(size = 1, color = "grey20") }

## Now the fun part: custom flipping probabilities

We can vary the probability of flipping the slashes. For example, we can use the density of a normal distribution to make flipping more likely for central values and less likely for more extreme values.

xs <- seq(0, 1, length.out = 40) p_flip <- dnorm(seq(-4, 4, length.out = 40)) ggplot(data.frame(x = xs, y = p_flip)) + aes(x, y) + geom_line() + labs( x = "x position", y = "p(flipping)", title = "normal density") # We repeat p_flip for each row of the grid draw_10_print(rows = 40, cols = 40, p_flip = rep(p_flip, 40)) + theme_void()

We can use the cumulative density of the normal distribution so that
flipping becomes more likely as *x* increases.

xs <- seq(0, 1, length.out = 40) p_flip <- pnorm(seq(-4, 4, length.out = 40)) ggplot(data.frame(x = xs, y = p_flip)) + aes(x, y) + geom_line() + labs( x = "x position", y = "p(flipping)", title = "cumulative normal") draw_10_print(rows = 40, cols = 40, p_flip = rep(p_flip, 40)) + theme_void()

The Cauchy distribution is said to have “thicker” tails than the normal distribution, so here it shows more flips on the left and right extremes.

xs <- seq(0, 1, length.out = 40) p_flip <- dcauchy(seq(-4, 4, length.out = 40)) ggplot(data.frame(x = xs, y = p_flip)) + aes(x, y) + geom_line() + labs( x = "x position", y = "p(flipping)", title = "Cauchy density") draw_10_print(rows = 40, cols = 40, p_flip = rep(p_flip, 40)) + theme_void()

The exponential distribution is a spike that quickly peters out. We can make a probability “bowl” by splicing an exponential and a reversed exponential together.

# Use flipped exponential densities as probabilities p_flip <- c(dexp(seq(0, 4, length.out = 20)), dexp(seq(4, 0, length.out = 20))) ggplot(data.frame(x = xs, y = p_flip)) + aes(x, y) + geom_line() + labs( x = "x position", y = "p(flipping)", title = "exponential + flipped exponential") draw_10_print(rows = 40, cols = 40, p = rep(p_flip, 40)) + theme_void()

We might have the probabilities increase by 10% from row to row. In the code below, I use a simple loop to boost some random probability values by 10% from row to row. This gives us nice streaks in the grid as a column starts to flip for every row.

boost_probs <- function(p_flip, nrows, factor = 1.1) { output <- p_flip for (i in seq_len(nrows - 1)) { p_flip <- p_flip * factor output <- c(output, p_flip) } output } draw_10_print(cols = 40, rows = 40, p = boost_probs(runif(40), 40, 1.1)) + theme_void()

The probabilities can be anything we like. Here I compute the frequency of
English alphabet letters as they appear in *Pride and Prejudice* and based the
flipping probability on those values.

char_counts <- janeaustenr::prideprejudice %>% tolower() %>% stringr::str_split("") %>% unlist() %>% table() letter_counts <- char_counts[letters] %>% as.vector() p_letter <- letter_counts / sum(letter_counts) ggplot(data.frame(x = letters, y = p_letter)) + aes(x, y, label = x) + geom_text() + labs( x = NULL, y = "p(letter)", title = "letter frequencies in Pride and Prejudice")

draw_10_print(cols = 26, rows = 80, p = rep(p_letter, 80)) + theme_void()

**leave a comment**for the author, please follow the link and comment on their blog:

**Higher Order Functions**.

R-bloggers.com offers

**daily e-mail updates**about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.

Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.