Overview

• What is a function factory?
  • Function factories and manufactured functions
  • Manufactured function environments
  • Promises and force
  • {factory}
• Why use a function factory?
  • Stateful functions
  • ggplot2
  • Expensive calculations

library(rlang)

## 
## Attaching package: 'rlang'

## The following objects are masked from 'package:purrr':
## 
##     %@%, as_function, flatten, flatten_chr, flatten_dbl, flatten_int,
##     flatten_lgl, flatten_raw, invoke, list_along, modify, prepend,
##     splice

library(ggplot2)
library(scales)

## 
## Attaching package: 'scales'

## The following object is masked from 'package:purrr':
## 
##     discard

## The following object is masked from 'package:readr':
## 
##     col_factor

# remotes::install_github("jonthegeek/factory")
library(factory)

Function factories and manufactured functions

# Function factory
power1 <- function(exponent) {
  function(x) {
    x ^ exponent
  }
}
# Manufactured functions
square1 <- power1(2)
cube1 <- power1(3)
square1(8)

## [1] 64

Manufactured function environments

square1

## function(x) {
##     x ^ exponent
##   }
## <environment: 0x55c87035f430>

cube1

## function(x) {
##     x ^ exponent
##   }
## <bytecode: 0x55c870b278c0>
## <environment: 0x55c8703c0a98>

c(fn_env(square1)$exponent, fn_env(cube1)$exponent)

## [1] 2 3

Promise dangers

Lazy evaluation + factories = danger

my_exponent <- 2
square1b <- power1(my_exponent)
my_exponent <- 3
square1b(2)

## [1] 8

Forcing evaluation

force forces evaluation

power2 <- function(exponent) {
  force(exponent)
  function(x) {
    x ^ exponent
  }
}

(technically just exponent instead of force(exponent) does the same thing)

{factory}

• I created a package to handle some of the fancy stuff.
• Maybe discuss internals in Chapter 19?

power3 <- factory::build_factory(
  function(x) {
    x ^ exponent
  },
  exponent
)
my_exponent <- 2
square3 <- power3(my_exponent)
my_exponent <- 3
square3(2)

## [1] 4

square3

## function (x) 
## {
##     x^2
## }

Stateful functions

new_guessing_game <- function() {
  target <- sample(1:100, 1)
  previous_diff <- NA_integer_
  function(guess) {
    if (guess %in% 1:100) {
      if (guess == target) {
        message("Correct!")
        return(invisible(TRUE))
      }
      new_diff <- abs(target - guess)
      if (is.na(previous_diff) || new_diff == previous_diff) {
        message("Try again!")
      } else if (new_diff < previous_diff) message("Warmer!")
      else message("Colder!")
      previous_diff <<- new_diff
    } else stop("Your guess should be between 1 and 100.")
    return(invisible(FALSE))
  }
}

Stateful functions (cont)

guess <- new_guessing_game()
guess(50)

## Try again!

guess(75)

## Colder!

guess(50)

## Warmer!

guess(25)

## Warmer!

guess(50)

## Colder!

{ggplot2}

Lots of ggplot2 functions accept functions as arguments

?ggplot2::geom_histogram

binwidth The width of the bins. Can be specified as a numeric value or as a function that calculates width from unscaled x. Here, "unscaled x" refers to the original x values in the data, before application of any scale transformation. When specifying a function along with a grouping structure, the function will be called once per group...

{scales}

The {scales} package is full of function factories.

scales::number_format

## function (accuracy = NULL, scale = 1, prefix = "", suffix = "", 
##     big.mark = " ", decimal.mark = ".", trim = TRUE, ...) 
## {
##     force_all(accuracy, scale, prefix, suffix, big.mark, decimal.mark, 
##         trim, ...)
##     function(x) number(x, accuracy = accuracy, scale = scale, 
##         prefix = prefix, suffix = suffix, big.mark = big.mark, 
##         decimal.mark = decimal.mark, trim = trim, ...)
## }
## <bytecode: 0x55c86e395628>
## <environment: namespace:scales>

Expensive calculations

boot_model <- function(df, formula) {
  # Pretend these calculations would be slow
  mod <- lm(formula, data = df)
  fitted_vals <- unname(fitted(mod))
  resid_vals <- unname(resid(mod))
  rm(mod) # Or use {factory} and this won't be necessary!
  function() {
    fitted_vals + sample(resid_vals)
  }
}
boot_mtcars1 <- boot_model(mtcars, mpg ~ wt)
head(boot_mtcars1())

## [1] 21.39959 20.81963 20.98059 20.96952 16.11920 20.53945

head(boot_mtcars1())

## [1] 22.36284 18.01441 20.34280 22.20594 20.10120 16.18225

Expensive calculations (cont)

boot_mtcars1

## function() {
##     fitted_vals + sample(resid_vals)
##   }
## <environment: 0x55c86d43d068>

head(rlang::fn_env(boot_mtcars1)$fitted_vals)

## [1] 23.28261 21.91977 24.88595 20.10265 18.90014 18.79325

head(rlang::fn_env(boot_mtcars1)$resid_vals)

## [1] -2.2826106 -0.9197704 -2.0859521  1.2973499 -0.2001440 -0.6932545