├── .Rbuildignore ├── .github └── CONTRIBUTING.md ├── .gitignore ├── .travis.yml ├── CODE_OF_CONDUCT.md ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── NEWS.md ├── R ├── build_factory.R ├── factory-package.R ├── utils-pipe.R ├── utils-tidy-eval.R └── utils.R ├── README.Rmd ├── README.md ├── appveyor.yml ├── codecov.yml ├── factory.Rproj ├── man ├── body_insert.Rd ├── body_replace.Rd ├── build_factory.Rd ├── digested_is.Rd ├── factory-package.Rd ├── figures │ ├── factory.png │ └── factory.svg └── pipe.Rd ├── tests ├── testthat.R └── testthat │ ├── test-build_factory.R │ └── test-utils.R └── vignettes ├── .gitignore ├── building_a_factory.Rmd └── examples.Rmd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^LICENSE\.md$ 4 | ^CODE_OF_CONDUCT\.md$ 5 | ^README\.Rmd$ 6 | ^\.travis\.yml$ 7 | ^codecov\.yml$ 8 | ^\.github$ 9 | ^appveyor\.yml$ 10 | ^cran-comments\.md$ 11 | ^CRAN-RELEASE$ 12 | -------------------------------------------------------------------------------- /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to factory 2 | 3 | This outlines how to propose a change to factory. 4 | 5 | ### Fixing typos 6 | 7 | Small typos or grammatical errors in documentation may be edited directly using 8 | the GitHub web interface, so long as the changes are made in the _source_ file. 9 | 10 | * YES: you edit a roxygen comment in a `.R` file below `R/`. 11 | * NO: you edit an `.Rd` file below `man/`. 12 | 13 | ### Prerequisites 14 | 15 | Before you make a substantial pull request, you should always file an issue and 16 | make sure someone from the team agrees that it’s a problem. If you’ve found a 17 | bug, create an associated issue and illustrate the bug with a minimal 18 | [reprex](https://www.tidyverse.org/help/#reprex). 19 | 20 | ### Pull request process 21 | 22 | * We recommend that you create a Git branch for each pull request (PR). 23 | * Look at the Travis and AppVeyor build status before and after making changes. 24 | The `README` should contain badges for any continuous integration services used 25 | by the package. 26 | * New code should follow the tidyverse [style guide](http://style.tidyverse.org). 27 | You can use the [styler](https://CRAN.R-project.org/package=styler) package to 28 | apply these styles, but please don't restyle code that has nothing to do with 29 | your PR. 30 | * We use [roxygen2](https://cran.r-project.org/package=roxygen2), with 31 | [Markdown syntax](https://cran.r-project.org/web/packages/roxygen2/vignettes/markdown.html), 32 | for documentation. 33 | * We use [testthat](https://cran.r-project.org/package=testthat). Contributions 34 | with test cases included are easier to accept. 35 | * For user-facing changes, add a bullet to the top of `NEWS.md` below the 36 | current development version header describing the changes made followed by your 37 | GitHub username, and links to relevant issue(s)/PR(s). 38 | 39 | ### Code of Conduct 40 | 41 | Please note that the factory project is released with a 42 | [Contributor Code of Conduct](CODE_OF_CONDUCT.md). By contributing to this 43 | project you agree to abide by its terms. 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | inst/doc 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | cache: packages 5 | after_success: 6 | - Rscript -e 'covr::codecov()' 7 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Code of Conduct 2 | 3 | As contributors and maintainers of this project, we pledge to respect all people who contribute through reporting issues, posting feature requests, updating documentation, submitting pull requests or patches, and other activities. 4 | 5 | We are committed to making participation in this project a harassment-free experience for everyone, regardless of level of experience, gender, gender identity and expression, sexual orientation, disability, personal appearance, body size, race, ethnicity, age, or religion. 6 | 7 | Examples of unacceptable behavior by participants include the use of sexual language or imagery, derogatory comments or personal attacks, trolling, public or private harassment, insults, or other unprofessional conduct. 8 | 9 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct. Project maintainers who do not follow the Code of Conduct may be removed from the project team. 10 | 11 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by opening an issue or contacting one or more of the project maintainers. 12 | 13 | This Code of Conduct is adapted from the Contributor Covenant (https://www.contributor-covenant.org), version 1.0.0, available at https://contributor-covenant.org/version/1/0/0/. 14 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: factory 2 | Type: Package 3 | Title: Build Function Factories 4 | Version: 0.1.0.9000 5 | Authors@R: 6 | c(person(given = "Jon", 7 | family = "Harmon", 8 | role = c("aut", "cre"), 9 | email = "jonthegeek@gmail.com", 10 | comment = c(ORCID = "0000-0003-4781-4346") 11 | ), 12 | person(given = "Tyler Grant", 13 | family = "Smith", 14 | role = "ctb" 15 | ) 16 | ) 17 | Description: Function factories are functions that make functions. They can be 18 | confusing to construct. Straightforward techniques can produce functions 19 | that are fragile or hard to understand. While more robust techniques exist 20 | to construct function factories, those techniques can be confusing. This 21 | package is designed to make it easier to construct function factories. 22 | URL: https://github.com/jonthegeek/factory 23 | BugReports: https://github.com/jonthegeek/factory/issues 24 | License: MIT + file LICENSE 25 | Encoding: UTF-8 26 | LazyData: true 27 | RoxygenNote: 7.1.0 28 | Imports: 29 | purrr (>= 0.3.2), 30 | rlang (>= 0.4.0), 31 | magrittr 32 | Suggests: 33 | testthat (>= 2.1.0), 34 | covr, 35 | roxygen2, 36 | knitr, 37 | rmarkdown, 38 | ggplot2, 39 | grDevices, 40 | scales, 41 | bench 42 | VignetteBuilder: knitr 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2019 2 | COPYRIGHT HOLDER: Jon Harmon 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2019 Jon Harmon 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export("%>%") 4 | export(body_insert) 5 | export(body_replace) 6 | export(build_factory) 7 | importFrom(magrittr,"%>%") 8 | importFrom(rlang,":=") 9 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # factory 0.1.0.9000 2 | 3 | * Refactored for cleaner code (@TylerGrantSmith). 4 | * Added vignettes for Advanced R examples (@jonthegeek). 5 | * Added ability to pass dots from factory to internal functions (@jonthegeek, #23). 6 | * Added ability to set internal variables in the factory (@jonthegeek, #26). 7 | 8 | # factory 0.1.0 9 | 10 | * Fixed ... arguments (exp example tricked me) (@jonthegeek). 11 | * Fixed NULL default arguments (@jonthegeek). 12 | * Added a vignette (@jonthegeek, #5). 13 | 14 | # factory 0.0.4.9000 15 | 16 | * No longer need to use weird empty = in argument list (@jonthegeek, #4). 17 | * Changed the main function to build_factory (a verb) (@jonthegeek, #11). 18 | 19 | # factory 0.0.3 20 | 21 | * Got rid of .error_message argument to factory (@jonthegeek). 22 | 23 | # factory 0.0.2 24 | 25 | * Added a `NEWS.md` file to track changes to the package. (@jonthegeek) 26 | * Cleaner `replacement` implementation in `factory` (@jimhester, #1). 27 | -------------------------------------------------------------------------------- /R/build_factory.R: -------------------------------------------------------------------------------- 1 | #' Easily Build Function Factories 2 | #' 3 | #' @param fun A function to turn into a factory. 4 | #' @param ... Arguments for the factory function. Things on the RHS will be 5 | #' evaluated before building your factory unless explicitly quoted with 6 | #' \code{quote}. See examples. 7 | #' @param .pass_dots A logical indicating whether the factory should accept 8 | #' additional arguments (...) to pass on to methods. In order for this to 9 | #' work, the manufactured function *must* also include dots, and the input 10 | #' \code{fun} must indicate where those dots are used. 11 | #' @param .internal_variables A named list of additional code to run to create 12 | #' additional variables used by the factory. 13 | #' 14 | #' @return A function factory. 15 | #' @export 16 | #' 17 | #' @examples 18 | #' y <- 2 19 | #' power <- build_factory( 20 | #' fun = function(x) { 21 | #' x^exponent 22 | #' }, 23 | #' exponent 24 | #' ) 25 | #' square <- power(y) 26 | #' square(2) 27 | #' y <- 7 28 | #' square(2) 29 | #' 30 | #' base_bins <- build_factory( 31 | #' .internal_variables = list( 32 | #' nclass_fun = switch( 33 | #' type, 34 | #' Sturges = nclass.Sturges, 35 | #' scott = nclass.scott, 36 | #' FD = nclass.FD, 37 | #' stop("Unknown type", call. = FALSE) 38 | #' ) 39 | #' ), 40 | #' fun = function(x) { 41 | #' (max(x) - min(x) / nclass_fun(x)) 42 | #' }, 43 | #' type 44 | #' ) 45 | #' base_bins("Sturges") 46 | build_factory <- function(fun, 47 | ..., 48 | .pass_dots = FALSE, 49 | .internal_variables = NULL) { 50 | if (!...length()) { 51 | stop("You must provide at least one argument to your factory.") 52 | } 53 | 54 | dots <- rlang::enquos(...) 55 | dots_names <- names(rlang::quos_auto_name(dots)) 56 | args <- as.list(dots) %>% 57 | purrr::modify_if( 58 | ~ (rlang::is_quosure(.) && rlang::quo_is_null(.)), 59 | ~ rlang::list2(NULL) 60 | ) %>% 61 | purrr::modify_if( 62 | ~ (rlang::is_quosure(.) && rlang::quo_is_missing(.)), 63 | ~ rlang::list2(rlang::missing_arg()) 64 | ) %>% 65 | purrr::modify_if( 66 | names(dots) == "", 67 | ~ rlang::list2(rlang::missing_arg()) 68 | ) %>% 69 | purrr::modify_if( 70 | rlang::is_quosure, 71 | ~ rlang::list2(rlang::eval_tidy(.)) 72 | ) %>% 73 | purrr::flatten() %>% 74 | purrr::set_names(dots_names) 75 | 76 | # I can't find a way to do this neatly with rlang. I want the user to pass 77 | # bare code in a list, and I don't want to evaluate that code. !!! unquotes 78 | # and thus breaks, so instead I need to enexpr and then pull the result apart. 79 | to_do <- rlang::enexpr(.internal_variables) 80 | if (length(to_do)) { 81 | if (as.character(to_do[[1]]) != "list") { 82 | stop(".internal_variables must be a named list of code.") 83 | } 84 | to_do[[1]] <- NULL 85 | 86 | # We need to catch anything in .internal_variables when we update the 87 | # function. 88 | dots_names <- rlang::list2(!!!names(to_do), !!!dots_names) 89 | } 90 | 91 | # multiple_funs <- rlang::enexpr(fun) 92 | # return(multiple_funs) 93 | 94 | # We also need to update the function body. 95 | body(fun) <- purrr::reduce( 96 | dots_names, 97 | ~ body_replace( 98 | fn_body = ..1, 99 | target = ..2, 100 | replacement = rlang::call2("!!", rlang::sym(..2)) 101 | ), 102 | .init = body(fun) 103 | ) 104 | 105 | child_fn <- rlang::expr({ 106 | rlang::new_function( 107 | args = !!formals(fun), 108 | body = rlang::expr(!!body(fun)), 109 | env = rlang::caller_env() 110 | ) 111 | }) 112 | 113 | if (.pass_dots) { 114 | args <- rlang::pairlist2( 115 | !!!args, 116 | "..." = 117 | ) 118 | old_fun <- fun 119 | 120 | # If they want to pass ... to the child, we *add* !!!dots. Else we replace 121 | # ... with !!!dots. 122 | if ("..." %in% names(formals(fun))) { 123 | body(fun) <- body_insert( 124 | fn_body = body(fun), 125 | insertion = quote(!!!dots), 126 | before = quote(...) 127 | ) 128 | } else { 129 | body(fun) <- body_replace( 130 | fn_body = body(fun), 131 | target = quote(...), 132 | replacement = quote(!!!dots) 133 | ) 134 | } 135 | 136 | if (identical(old_fun, fun)) { 137 | stop("fun must contain ... when .pass_dots is TRUE.") 138 | } 139 | 140 | # Update child_fun. 141 | child_fn <- rlang::expr({ 142 | rlang::new_function( 143 | args = !!formals(fun), 144 | body = rlang::expr(!!body(fun)), 145 | env = rlang::caller_env() 146 | ) 147 | }) %>% 148 | body_insert( 149 | insertion = quote(dots <- list(...)) 150 | ) 151 | } 152 | 153 | if (length(to_do)) { 154 | child_fn <- purrr::reduce2( 155 | # We want to insert the to_do items at the top, with the first one ending 156 | # up first, so we need to insert them in reverse order. 157 | rev(names(to_do)), 158 | rev(to_do), 159 | ~ body_insert( 160 | fn_body = ..1, 161 | insertion = rlang::call2( 162 | rlang::expr(`<-`), 163 | rlang::sym(..2), 164 | ..3 165 | ) 166 | ), 167 | .init = child_fn 168 | ) 169 | } 170 | 171 | return( 172 | rlang::new_function( 173 | args = args, 174 | body = child_fn, 175 | env = rlang::caller_env() 176 | ) 177 | ) 178 | } 179 | 180 | # build_factory.list <- function(fun, 181 | # ..., 182 | # .pass_dots = FALSE, 183 | # .internal_variables = NULL) { 184 | # # The structure of the list is somewhat complicated and strict. Check that 185 | # # first. 186 | # if (length(list) != 1) { 187 | # stop("We can currently only make the function choice based on", 188 | # " 1 argument.", 189 | # " If you need something more complex, perhaps try", 190 | # " .internal_variables.") 191 | # } 192 | # control_variable <- names(fun) 193 | # if (! (control_variable %in% dots_names)) { 194 | # stop( 195 | # "For now at least, you must supply the name of the control variable", 196 | # "in the ... of the build_factory call." 197 | # ) 198 | # } 199 | # 200 | # new_call <- rlang::call2( 201 | # switch, 202 | # rlang::sym(control_variable), 203 | # !!!fun[[1]], 204 | # quote(stop("Unknown value for function chooser.")) 205 | # ) 206 | # 207 | # new_fun <- rlang::new_function( 208 | # args = args, 209 | # body = new_call, 210 | # env = rlang::caller_env() 211 | # ) 212 | # 213 | # return( 214 | # build_factory( 215 | # new_fun, 216 | # ..., 217 | # .pass_dots, 218 | # .internal_variables 219 | # ) 220 | # ) 221 | # } 222 | -------------------------------------------------------------------------------- /R/factory-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | "_PACKAGE" 3 | 4 | # The following block is used by usethis to automatically manage 5 | # roxygen namespace tags. Modify with care! 6 | ## usethis namespace: start 7 | ## usethis namespace: end 8 | NULL 9 | -------------------------------------------------------------------------------- /R/utils-pipe.R: -------------------------------------------------------------------------------- 1 | #' Pipe operator 2 | #' 3 | #' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. 4 | #' 5 | #' @name %>% 6 | #' @rdname pipe 7 | #' @keywords internal 8 | #' @export 9 | #' @importFrom magrittr %>% 10 | #' @usage lhs \%>\% rhs 11 | NULL 12 | -------------------------------------------------------------------------------- /R/utils-tidy-eval.R: -------------------------------------------------------------------------------- 1 | #' Digested is 2 | #' 3 | #' Tidy evaluation uses a special parameter assignment operator, \code{:=}. See 4 | #' \code{\link[rlang]{quasiquotation}} for more information. 5 | #' 6 | #' @importFrom rlang := 7 | #' @name := 8 | #' @rdname digested_is 9 | #' @keywords internal 10 | #' @param lhs An expression that evaluates to a character or a symbol (used as a 11 | #' function parameter). 12 | #' @param rhs The thing to assign to that parameter. 13 | NULL 14 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | #' Replace Parts of a Function Body 2 | #' 3 | #' Replace quoted targets in the body of a function with quoted replacements. 4 | #' 5 | #' @param fn_body The body of a function (as found via body(fun)). 6 | #' @param target A quoted expression to replace. 7 | #' @param replacement A quoted expression with which the target should be 8 | #' replaced. 9 | #' 10 | #' @return A function body with the target replaced anywhere it occurs. 11 | #' @export 12 | #' 13 | #' @examples 14 | #' fun <- function(x) { 15 | #' x^exp 16 | #' } 17 | #' body_replace(body(fun), quote(exp), quote(!!exp)) 18 | body_replace <- function(fn_body, target, replacement) { 19 | if (!is.null(fn_body) && fn_body == target) { 20 | return(replacement) 21 | } else if (length(fn_body) > 1) { 22 | # Break it down into pieces, and run each through fn_replace. 23 | for (i in seq_along(fn_body)) { 24 | # Replacing an existing NULL with NULL removes that part of the body. 25 | # Instead skip it if it's NULL. 26 | if (!is.null(fn_body[[i]])) { 27 | fn_body[[i]] <- body_replace(fn_body[[i]], target, replacement) 28 | } 29 | } 30 | } 31 | return(fn_body) 32 | } 33 | 34 | #' Insert Into a Function Body 35 | #' 36 | #' Insert quoted insertions at the start of a function body (after the opening 37 | #' of the function). 38 | #' 39 | #' @param fn_body The body of a function (as found via body(fun)). 40 | #' @param insertion A quoted expression to add at the beginning of the function. 41 | #' 42 | #' @return A function body with the insertion. Note: If before is specified and 43 | #' is not found anywhere in fn_body, fn_body is returned unaltered. 44 | #' @export 45 | #' 46 | #' @examples 47 | #' fun <- function(x) { 48 | #' x + 1 49 | #' } 50 | #' body_insert(body(fun), quote(x + 2)) 51 | body_insert <- function(fn_body, insertion, before = NULL) { 52 | if (is.null(before)) { 53 | if (fn_body[[1]] == quote(`{`)) { 54 | # fn_body[[1]] will be {. Everything after that has to bump forward 1, and 55 | # then replace fn_body[[2]] with the insertion. 56 | fn_body <- .body_insert_location(fn_body, insertion, 2) 57 | } else { 58 | stop("Please wrap your function in {}.") 59 | } 60 | } else { 61 | # Find the level where before occurs. Insert insertion on that level, before 62 | # `before`. Which feels like it should be recursive. If I don't find 63 | # `before` I return fn_body unaltered. 64 | if (length(fn_body) > 1) { 65 | if (any(as.list(fn_body) == before)) { 66 | # Do the insertion. Things before `before` are unchanged, things after 67 | # `before` should move 1 higher in the list, and then the spot occupied 68 | # by before should become insertion. 69 | target_location <- which(as.list(fn_body) == before) 70 | fn_body <- .body_insert_location(fn_body, insertion, target_location) 71 | } else { 72 | # Check each element of fn_body. 73 | for (i in seq_along(fn_body)) { 74 | fn_body[[i]] <- body_insert(fn_body[[i]], insertion, before) 75 | } 76 | } 77 | } 78 | } 79 | 80 | return(fn_body) 81 | } 82 | 83 | .body_insert_location <- function(fn_body, insertion, target_location) { 84 | for (i in rev(seq_along(fn_body))) { 85 | if (i >= target_location) { 86 | fn_body[[i + 1]] <- fn_body[[i]] 87 | } 88 | } 89 | fn_body[[target_location]] <- insertion 90 | return(fn_body) 91 | } 92 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r, include = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>", 11 | fig.path = "man/figures/README-", 12 | out.width = "100%" 13 | ) 14 | ``` 15 | # factory 16 | 17 | 18 | [![Lifecycle: maturing](https://img.shields.io/badge/lifecycle-maturing-blue.svg)](https://www.tidyverse.org/lifecycle/#maturing) 19 | [![Travis build status](https://travis-ci.org/jonthegeek/factory.svg?branch=master)](https://travis-ci.org/jonthegeek/factory) 20 | [![AppVeyor build status](https://ci.appveyor.com/api/projects/status/github/jonthegeek/factory?branch=master&svg=true)](https://ci.appveyor.com/project/jonthegeek/factory) 21 | [![Codecov test coverage](https://codecov.io/gh/jonthegeek/factory/branch/master/graph/badge.svg)](https://codecov.io/gh/jonthegeek/factory?branch=master) 22 | [![CRAN status](https://www.r-pkg.org/badges/version/factory)](https://CRAN.R-project.org/package=factory) 23 | 24 | 25 | The goal of factory is to make construction of function factories more straightforward, without requiring the user to learn the `rlang` package. 26 | 27 | ## Installation 28 | 29 | Install the released version of factory from CRAN: 30 | 31 | ```{r cran, eval = FALSE} 32 | install.packages("factory") 33 | ``` 34 | 35 | Or install the development version from [GitHub](https://github.com/jonthegeek/factory) with: 36 | 37 | ```{r dev, eval = FALSE} 38 | # install.packages("remotes") 39 | remotes::install_github("jonthegeek/factory") 40 | ``` 41 | 42 | ## Motivation 43 | 44 | Function factories are functions that make functions. 45 | They can be confusing to work with. 46 | For example, as we'll see below, they can produce functions that are fragile, or that are confusing to work with as a user. 47 | 48 | WARNING: All code shown below is "wrong" in some way until we get to the example at the end! These examples show the dangers of working with function factories, and why this package exists. 49 | 50 | (examples adapted from [Advanced R by Hadley Wickham (2nd Edition), 10.2.3: Forcing Evaluation](https://adv-r.hadley.nz/function-factories.html#forcing-evaluation)) 51 | 52 | ### The Simplest Factories are Fragile 53 | 54 | `power1` is a function factory. 55 | It returns a function based on the `exponent` argument. 56 | 57 | ```{r power1} 58 | power1 <- function(exponent) { 59 | function(x) { 60 | x ^ exponent 61 | } 62 | } 63 | ``` 64 | 65 | For many use cases, `power1` works fine. 66 | For example, we can define a square function by calling `power1` with `exponent = 2`. 67 | 68 | ```{r power1-simple-usage} 69 | square1 <- power1(2) 70 | square1(2) 71 | # 2 ^ 2 = 4 72 | square1(3) 73 | # 3 ^ 2 = 9 74 | ``` 75 | 76 | However, `power1` is fragile. 77 | Let's think about what the definition of power1 *means.* 78 | The function returned by `power1` raises its argument to whatever the `exponent` variable is defined as. 79 | Let's see what happens if we use a variable in the global environment to define our `square` function. 80 | 81 | ```{r power1-fragile} 82 | my_exponent <- 2 83 | square1a <- power1(my_exponent) 84 | ``` 85 | 86 | Due to R's lazy evaluation, when we call `power1`, the `exponent` variable gets a promise to take on the value of the `my_exponent` variable. 87 | But `my_exponent` doesn't actually have the value of `2` yet. 88 | Until we *use* `my_exponent`, it has a *promise* to get the value of `2`. 89 | If we call `square1a` right away, it works as expected. 90 | 91 | ```{r power1-fragile-seems-ok} 92 | square1a(2) 93 | # 2 ^ 2 = 4 94 | my_exponent <- 3 95 | square1a(3) 96 | # 3 ^ 2 = 9 97 | ``` 98 | 99 | The `my_exponent` promise (which was passed in during the definition of `square1a`) resolves to `2` the first time it is needed (when `square1a` is first called). 100 | After that initial call, that is the value used in `square1a` forever. 101 | 102 | But if `my_exponent` changes between definition of our function and first call of that function, we get a different result. 103 | 104 | ```{r power1-fragile-breaks} 105 | my_exponent <- 2 106 | square1b <- power1(my_exponent) 107 | my_exponent <- 3 108 | square1b(2) 109 | # 2 ^ 3 = 8 110 | square1b(3) 111 | # 3 ^ 3 = 27 112 | ``` 113 | 114 | What happened? 115 | When `square1b` was defined, `my_exponent` was passed in as a *promise.* 116 | However, before `my_exponent` was ever actually *used*, its value changed. 117 | The promise isn't evaluated *until it is used,* which, in this case, is the first time `square1b` is called. 118 | Once the promise is evaluated, its value is "fixed," and the function works as expected. 119 | 120 | ### Forcing Arguments Trades Fragility for Complexity 121 | 122 | We can make factories that are less fragile, if we remember to `force` the variables. 123 | 124 | ```{r power2} 125 | power2 <- function(exponent) { 126 | force(exponent) # Gah, easy to forget! 127 | function(x) { 128 | x ^ exponent 129 | } 130 | } 131 | 132 | my_exponent <- 2 133 | square2 <- power2(my_exponent) 134 | my_exponent <- 3 135 | square2(2) 136 | # 2 ^ 2 = 4 137 | square2(3) 138 | # 3 ^ 2 = 9 139 | ``` 140 | 141 | Why does this work? 142 | The `force` function forces the evaluation of its argument. 143 | We don't really need to use `force`, per se. 144 | Any function that forces evaluation would work, but `force` makes it obvious why we're doing it. 145 | For example, we could produce the same result by `message`ing within the factory. 146 | 147 | ```{r power2-message} 148 | power2b <- function(exponent) { 149 | message("The exponent's value is ", exponent) 150 | function(x) { 151 | x ^ exponent 152 | } 153 | } 154 | 155 | my_exponent <- 2 156 | square2b <- power2b(my_exponent) 157 | my_exponent <- 3 158 | square2b(2) 159 | # 2 ^ 2 = 4 160 | square2b(3) 161 | # 3 ^ 2 = 9 162 | ``` 163 | 164 | Since the value of `exponent` is needed for the message, the promise is evaluated when the factory is invoked, and the resulting function is stable. 165 | 166 | While such factories are more stable, it's easy to miss a `force`. 167 | And, in both of these cases, the resulting functions are difficult to understand as a user. 168 | 169 | ```{r resulting-functions} 170 | square1 171 | square2 172 | cube <- power2(3) 173 | cube 174 | ``` 175 | 176 | It isn't clear what these functions will do, since the definitions of `exponent` are hidden inside the function environments. 177 | 178 | ### Using rlang 179 | 180 | We can use {rlang} to make functions that are easier to understand, but building the function factory is much more difficult (from [Advanced R by Hadley Wickham (2nd Edition), 19.7.4: Creating functions](https://adv-r.hadley.nz/quasiquotation.html#new-function)): 181 | 182 | ```{r power3} 183 | power3 <- function(exponent) { 184 | rlang::new_function( 185 | rlang::exprs(x = ), 186 | rlang::expr({ 187 | x ^ !!exponent 188 | }), 189 | rlang::caller_env() 190 | ) 191 | } 192 | ``` 193 | 194 | The resulting functions look like a "normal" function, though, and are thus easier for users to understand. 195 | 196 | ```{r square3} 197 | square3 <- power3(2) 198 | square3 199 | ``` 200 | 201 | The {rlang} calls are very difficult to understand, though. 202 | It would be nice to get the stability and interpretability of the rlang-produced functions, with the ease-of-programming of the simplest function factories. 203 | 204 | 205 | ## Enter {factory} 206 | 207 | The goal of `factory` is to make function factories as straightforward to create as in `power1`, but to make the resulting functions make as much sense as in `power3`. 208 | Right now, the calls are still a *little* more complicated than I would like, but they're definitely easier to understand than the {rlang} calls. 209 | 210 | ```{r power4} 211 | library(factory) 212 | power4 <- build_factory( 213 | fun = function(x) { 214 | x ^ exponent 215 | }, 216 | exponent 217 | ) 218 | 219 | my_exponent <- 2 220 | square4 <- power4(my_exponent) 221 | my_exponent <- 3 222 | square4(2) 223 | # 2 ^ 2 = 4 224 | ``` 225 | 226 | The resulting function makes sense, as with `power3`. 227 | 228 | ```{r square4} 229 | square4 230 | ``` 231 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # factory 5 | 6 | 7 | 8 | [![Lifecycle: 9 | maturing](https://img.shields.io/badge/lifecycle-maturing-blue.svg)](https://www.tidyverse.org/lifecycle/#maturing) 10 | [![Travis build 11 | status](https://travis-ci.org/jonthegeek/factory.svg?branch=master)](https://travis-ci.org/jonthegeek/factory) 12 | [![AppVeyor build 13 | status](https://ci.appveyor.com/api/projects/status/github/jonthegeek/factory?branch=master&svg=true)](https://ci.appveyor.com/project/jonthegeek/factory) 14 | [![Codecov test 15 | coverage](https://codecov.io/gh/jonthegeek/factory/branch/master/graph/badge.svg)](https://codecov.io/gh/jonthegeek/factory?branch=master) 16 | [![CRAN 17 | status](https://www.r-pkg.org/badges/version/factory)](https://CRAN.R-project.org/package=factory) 18 | 19 | 20 | The goal of factory is to make construction of function factories more 21 | straightforward, without requiring the user to learn the `rlang` 22 | package. 23 | 24 | ## Installation 25 | 26 | Install the released version of factory from CRAN: 27 | 28 | ``` r 29 | install.packages("factory") 30 | ``` 31 | 32 | Or install the development version from 33 | [GitHub](https://github.com/jonthegeek/factory) with: 34 | 35 | ``` r 36 | # install.packages("remotes") 37 | remotes::install_github("jonthegeek/factory") 38 | ``` 39 | 40 | ## Motivation 41 | 42 | Function factories are functions that make functions. They can be 43 | confusing to work with. For example, as we’ll see below, they can 44 | produce functions that are fragile, or that are confusing to work with 45 | as a user. 46 | 47 | WARNING: All code shown below is “wrong” in some way until we get to the 48 | example at the end\! These examples show the dangers of working with 49 | function factories, and why this package exists. 50 | 51 | (examples adapted from [Advanced R by Hadley Wickham (2nd 52 | Edition), 10.2.3: Forcing 53 | Evaluation](https://adv-r.hadley.nz/function-factories.html#forcing-evaluation)) 54 | 55 | ### The Simplest Factories are Fragile 56 | 57 | `power1` is a function factory. It returns a function based on the 58 | `exponent` argument. 59 | 60 | ``` r 61 | power1 <- function(exponent) { 62 | function(x) { 63 | x ^ exponent 64 | } 65 | } 66 | ``` 67 | 68 | For many use cases, `power1` works fine. For example, we can define a 69 | square function by calling `power1` with `exponent = 2`. 70 | 71 | ``` r 72 | square1 <- power1(2) 73 | square1(2) 74 | #> [1] 4 75 | # 2 ^ 2 = 4 76 | square1(3) 77 | #> [1] 9 78 | # 3 ^ 2 = 9 79 | ``` 80 | 81 | However, `power1` is fragile. Let’s think about what the definition of 82 | power1 *means.* The function returned by `power1` raises its argument to 83 | whatever the `exponent` variable is defined as. Let’s see what happens 84 | if we use a variable in the global environment to define our `square` 85 | function. 86 | 87 | ``` r 88 | my_exponent <- 2 89 | square1a <- power1(my_exponent) 90 | ``` 91 | 92 | Due to R’s lazy evaluation, when we call `power1`, the `exponent` 93 | variable gets a promise to take on the value of the `my_exponent` 94 | variable. But `my_exponent` doesn’t actually have the value of `2` yet. 95 | Until we *use* `my_exponent`, it has a *promise* to get the value of 96 | `2`. If we call `square1a` right away, it works as expected. 97 | 98 | ``` r 99 | square1a(2) 100 | #> [1] 4 101 | # 2 ^ 2 = 4 102 | my_exponent <- 3 103 | square1a(3) 104 | #> [1] 9 105 | # 3 ^ 2 = 9 106 | ``` 107 | 108 | The `my_exponent` promise (which was passed in during the definition of 109 | `square1a`) resolves to `2` the first time it is needed (when `square1a` 110 | is first called). After that initial call, that is the value used in 111 | `square1a` forever. 112 | 113 | But if `my_exponent` changes between definition of our function and 114 | first call of that function, we get a different result. 115 | 116 | ``` r 117 | my_exponent <- 2 118 | square1b <- power1(my_exponent) 119 | my_exponent <- 3 120 | square1b(2) 121 | #> [1] 8 122 | # 2 ^ 3 = 8 123 | square1b(3) 124 | #> [1] 27 125 | # 3 ^ 3 = 27 126 | ``` 127 | 128 | What happened? When `square1b` was defined, `my_exponent` was passed in 129 | as a *promise.* However, before `my_exponent` was ever actually *used*, 130 | its value changed. The promise isn’t evaluated *until it is used,* 131 | which, in this case, is the first time `square1b` is called. Once the 132 | promise is evaluated, its value is “fixed,” and the function works as 133 | expected. 134 | 135 | ### Forcing Arguments Trades Fragility for Complexity 136 | 137 | We can make factories that are less fragile, if we remember to `force` 138 | the variables. 139 | 140 | ``` r 141 | power2 <- function(exponent) { 142 | force(exponent) # Gah, easy to forget! 143 | function(x) { 144 | x ^ exponent 145 | } 146 | } 147 | 148 | my_exponent <- 2 149 | square2 <- power2(my_exponent) 150 | my_exponent <- 3 151 | square2(2) 152 | #> [1] 4 153 | # 2 ^ 2 = 4 154 | square2(3) 155 | #> [1] 9 156 | # 3 ^ 2 = 9 157 | ``` 158 | 159 | Why does this work? The `force` function forces the evaluation of its 160 | argument. We don’t really need to use `force`, per se. Any function that 161 | forces evaluation would work, but `force` makes it obvious why we’re 162 | doing it. For example, we could produce the same result by `message`ing 163 | within the factory. 164 | 165 | ``` r 166 | power2b <- function(exponent) { 167 | message("The exponent's value is ", exponent) 168 | function(x) { 169 | x ^ exponent 170 | } 171 | } 172 | 173 | my_exponent <- 2 174 | square2b <- power2b(my_exponent) 175 | #> The exponent's value is 2 176 | my_exponent <- 3 177 | square2b(2) 178 | #> [1] 4 179 | # 2 ^ 2 = 4 180 | square2b(3) 181 | #> [1] 9 182 | # 3 ^ 2 = 9 183 | ``` 184 | 185 | Since the value of `exponent` is needed for the message, the promise is 186 | evaluated when the factory is invoked, and the resulting function is 187 | stable. 188 | 189 | While such factories are more stable, it’s easy to miss a `force`. And, 190 | in both of these cases, the resulting functions are difficult to 191 | understand as a user. 192 | 193 | ``` r 194 | square1 195 | #> function(x) { 196 | #> x ^ exponent 197 | #> } 198 | #> 199 | square2 200 | #> function(x) { 201 | #> x ^ exponent 202 | #> } 203 | #> 204 | cube <- power2(3) 205 | cube 206 | #> function(x) { 207 | #> x ^ exponent 208 | #> } 209 | #> 210 | #> 211 | ``` 212 | 213 | It isn’t clear what these functions will do, since the definitions of 214 | `exponent` are hidden inside the function environments. 215 | 216 | ### Using rlang 217 | 218 | We can use {rlang} to make functions that are easier to understand, but 219 | building the function factory is much more difficult (from [Advanced R 220 | by Hadley Wickham (2nd Edition), 19.7.4: Creating 221 | functions](https://adv-r.hadley.nz/quasiquotation.html#new-function)): 222 | 223 | ``` r 224 | power3 <- function(exponent) { 225 | rlang::new_function( 226 | rlang::exprs(x = ), 227 | rlang::expr({ 228 | x ^ !!exponent 229 | }), 230 | rlang::caller_env() 231 | ) 232 | } 233 | ``` 234 | 235 | The resulting functions look like a “normal” function, though, and are 236 | thus easier for users to understand. 237 | 238 | ``` r 239 | square3 <- power3(2) 240 | square3 241 | #> function (x) 242 | #> { 243 | #> x^2 244 | #> } 245 | ``` 246 | 247 | The {rlang} calls are very difficult to understand, though. It would be 248 | nice to get the stability and interpretability of the rlang-produced 249 | functions, with the ease-of-programming of the simplest function 250 | factories. 251 | 252 | ## Enter {factory} 253 | 254 | The goal of `factory` is to make function factories as straightforward 255 | to create as in `power1`, but to make the resulting functions make as 256 | much sense as in `power3`. Right now, the calls are still a *little* 257 | more complicated than I would like, but they’re definitely easier to 258 | understand than the {rlang} calls. 259 | 260 | ``` r 261 | library(factory) 262 | power4 <- build_factory( 263 | fun = function(x) { 264 | x ^ exponent 265 | }, 266 | exponent 267 | ) 268 | 269 | my_exponent <- 2 270 | square4 <- power4(my_exponent) 271 | my_exponent <- 3 272 | square4(2) 273 | #> [1] 4 274 | # 2 ^ 2 = 4 275 | ``` 276 | 277 | The resulting function makes sense, as with `power3`. 278 | 279 | ``` r 280 | square4 281 | #> function (x) 282 | #> { 283 | #> x^2 284 | #> } 285 | ``` 286 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # DO NOT CHANGE the "init" and "install" sections below 2 | 3 | # Download script file from GitHub 4 | init: 5 | ps: | 6 | $ErrorActionPreference = "Stop" 7 | Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 8 | Import-Module '..\appveyor-tool.ps1' 9 | 10 | install: 11 | ps: Bootstrap 12 | 13 | cache: 14 | - C:\RLibrary 15 | 16 | environment: 17 | NOT_CRAN: true 18 | # env vars that may need to be set, at least temporarily, from time to time 19 | # see https://github.com/krlmlr/r-appveyor#readme for details 20 | # USE_RTOOLS: true 21 | # R_REMOTES_STANDALONE: true 22 | 23 | # Adapt as necessary starting from here 24 | 25 | build_script: 26 | - travis-tool.sh install_deps 27 | 28 | test_script: 29 | - travis-tool.sh run_tests 30 | 31 | on_failure: 32 | - 7z a failure.zip *.Rcheck\* 33 | - appveyor PushArtifact failure.zip 34 | 35 | artifacts: 36 | - path: '*.Rcheck\**\*.log' 37 | name: Logs 38 | 39 | - path: '*.Rcheck\**\*.out' 40 | name: Logs 41 | 42 | - path: '*.Rcheck\**\*.fail' 43 | name: Logs 44 | 45 | - path: '*.Rcheck\**\*.Rout' 46 | name: Logs 47 | 48 | - path: '\*_*.tar.gz' 49 | name: Bits 50 | 51 | - path: '\*_*.zip' 52 | name: Bits 53 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | patch: 10 | default: 11 | target: auto 12 | threshold: 1% 13 | -------------------------------------------------------------------------------- /factory.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | StripTrailingWhitespace: Yes 16 | 17 | BuildType: Package 18 | PackageUseDevtools: Yes 19 | PackageInstallArgs: --no-multiarch --with-keep.source 20 | PackageRoxygenize: rd,collate,namespace 21 | -------------------------------------------------------------------------------- /man/body_insert.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{body_insert} 4 | \alias{body_insert} 5 | \title{Insert Into a Function Body} 6 | \usage{ 7 | body_insert(fn_body, insertion, before = NULL) 8 | } 9 | \arguments{ 10 | \item{fn_body}{The body of a function (as found via body(fun)).} 11 | 12 | \item{insertion}{A quoted expression to add at the beginning of the function.} 13 | } 14 | \value{ 15 | A function body with the insertion. Note: If before is specified and 16 | is not found anywhere in fn_body, fn_body is returned unaltered. 17 | } 18 | \description{ 19 | Insert quoted insertions at the start of a function body (after the opening 20 | of the function). 21 | } 22 | \examples{ 23 | fun <- function(x) { 24 | x + 1 25 | } 26 | body_insert(body(fun), quote(x + 2)) 27 | } 28 | -------------------------------------------------------------------------------- /man/body_replace.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{body_replace} 4 | \alias{body_replace} 5 | \title{Replace Parts of a Function Body} 6 | \usage{ 7 | body_replace(fn_body, target, replacement) 8 | } 9 | \arguments{ 10 | \item{fn_body}{The body of a function (as found via body(fun)).} 11 | 12 | \item{target}{A quoted expression to replace.} 13 | 14 | \item{replacement}{A quoted expression with which the target should be 15 | replaced.} 16 | } 17 | \value{ 18 | A function body with the target replaced anywhere it occurs. 19 | } 20 | \description{ 21 | Replace quoted targets in the body of a function with quoted replacements. 22 | } 23 | \examples{ 24 | fun <- function(x) { 25 | x^exp 26 | } 27 | body_replace(body(fun), quote(exp), quote(!!exp)) 28 | } 29 | -------------------------------------------------------------------------------- /man/build_factory.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/build_factory.R 3 | \name{build_factory} 4 | \alias{build_factory} 5 | \title{Easily Build Function Factories} 6 | \usage{ 7 | build_factory(fun, ..., .pass_dots = FALSE, .internal_variables = NULL) 8 | } 9 | \arguments{ 10 | \item{fun}{A function to turn into a factory.} 11 | 12 | \item{...}{Arguments for the factory function. Things on the RHS will be 13 | evaluated before building your factory unless explicitly quoted with 14 | \code{quote}. See examples.} 15 | 16 | \item{.pass_dots}{A logical indicating whether the factory should accept 17 | additional arguments (...) to pass on to methods. In order for this to 18 | work, the manufactured function *must* also include dots, and the input 19 | \code{fun} must indicate where those dots are used.} 20 | 21 | \item{.internal_variables}{A named list of additional code to run to create 22 | additional variables used by the factory.} 23 | } 24 | \value{ 25 | A function factory. 26 | } 27 | \description{ 28 | Easily Build Function Factories 29 | } 30 | \examples{ 31 | y <- 2 32 | power <- build_factory( 33 | fun = function(x) { 34 | x^exponent 35 | }, 36 | exponent 37 | ) 38 | square <- power(y) 39 | square(2) 40 | y <- 7 41 | square(2) 42 | 43 | base_bins <- build_factory( 44 | .internal_variables = list( 45 | nclass_fun = switch( 46 | type, 47 | Sturges = nclass.Sturges, 48 | scott = nclass.scott, 49 | FD = nclass.FD, 50 | stop("Unknown type", call. = FALSE) 51 | ) 52 | ), 53 | fun = function(x) { 54 | (max(x) - min(x) / nclass_fun(x)) 55 | }, 56 | type 57 | ) 58 | base_bins("Sturges") 59 | } 60 | -------------------------------------------------------------------------------- /man/digested_is.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils-tidy-eval.R 3 | \name{:=} 4 | \alias{:=} 5 | \title{Digested is} 6 | \arguments{ 7 | \item{lhs}{An expression that evaluates to a character or a symbol (used as a 8 | function parameter).} 9 | 10 | \item{rhs}{The thing to assign to that parameter.} 11 | } 12 | \description{ 13 | Tidy evaluation uses a special parameter assignment operator, \code{:=}. See 14 | \code{\link[rlang]{quasiquotation}} for more information. 15 | } 16 | \keyword{internal} 17 | -------------------------------------------------------------------------------- /man/factory-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/factory-package.R 3 | \docType{package} 4 | \name{factory-package} 5 | \alias{factory} 6 | \alias{factory-package} 7 | \title{factory: Build Function Factories} 8 | \description{ 9 | Function factories are functions that make functions. They can be 10 | confusing to construct. Straightforward techniques can produce functions 11 | that are fragile or hard to understand. While more robust techniques exist 12 | to construct function factories, those techniques can be confusing. This 13 | package is designed to make it easier to construct function factories. 14 | } 15 | \seealso{ 16 | Useful links: 17 | \itemize{ 18 | \item \url{https://github.com/jonthegeek/factory} 19 | \item Report bugs at \url{https://github.com/jonthegeek/factory/issues} 20 | } 21 | 22 | } 23 | \author{ 24 | \strong{Maintainer}: Jon Harmon \email{jonthegeek@gmail.com} (\href{https://orcid.org/0000-0003-4781-4346}{ORCID}) 25 | 26 | Other contributors: 27 | \itemize{ 28 | \item Tyler Grant Smith [contributor] 29 | } 30 | 31 | } 32 | \keyword{internal} 33 | -------------------------------------------------------------------------------- /man/figures/factory.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jonthegeek/factory/07d9a555d3402f4dfc2abce9c42b886134e40abb/man/figures/factory.png -------------------------------------------------------------------------------- /man/figures/factory.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | image/svg+xmlfactoryJon HarmonCC0 52 | 62 | 68 | factory 70 | 78 | 82 | 86 | 90 | 91 | 97 | 103 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 129 | 133 | 138 | 143 | actory 154 | -------------------------------------------------------------------------------- /man/pipe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils-pipe.R 3 | \name{\%>\%} 4 | \alias{\%>\%} 5 | \title{Pipe operator} 6 | \usage{ 7 | lhs \%>\% rhs 8 | } 9 | \description{ 10 | See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. 11 | } 12 | \keyword{internal} 13 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(factory) 3 | 4 | test_check("factory") 5 | -------------------------------------------------------------------------------- /tests/testthat/test-build_factory.R: -------------------------------------------------------------------------------- 1 | test_that("factory basics work", { 2 | y <- 2 3 | power <- build_factory( 4 | fun = function(x) { 5 | x^exponent 6 | }, 7 | exponent = 8 | ) 9 | square <- power(y) 10 | expect_identical(square(2), 4) 11 | y <- 7 12 | expect_identical(square(2), 4) 13 | }) 14 | 15 | test_that("factory errors", { 16 | expect_error( 17 | build_factory( 18 | fun = function(x) { 19 | x^exponent 20 | } 21 | ), 22 | "You must provide at least one argument to your factory" 23 | ) 24 | 25 | power <- build_factory( 26 | fun = function(x) { 27 | x^exponent 28 | }, 29 | exponent = 30 | ) 31 | expect_error( 32 | power(), 33 | "argument \"exponent\" is missing, with no default" 34 | ) 35 | 36 | power <- build_factory( 37 | fun = function(x) { 38 | x^exponent 39 | }, 40 | exponent = 2 41 | ) 42 | expect_error( 43 | power(), 44 | NA 45 | ) 46 | }) 47 | 48 | test_that("Equals unnecessary for arguments.", { 49 | overpower <- build_factory( 50 | fun = function(x) { 51 | x^exponent^other 52 | }, 53 | exponent, 54 | other = 55 | ) 56 | square_cube <- overpower(2, 3) 57 | expect_identical(square_cube(2), 2^2^3) 58 | }) 59 | 60 | test_that("NULL default arguments work.", { 61 | null_ok <- build_factory( 62 | fun = function(x) { 63 | c(x, to_add) 64 | }, 65 | to_add = NULL 66 | ) 67 | add_null <- null_ok() 68 | expect_identical(add_null("a"), "a") 69 | add_a <- null_ok("a") 70 | expect_identical(add_a("b"), c("b", "a")) 71 | }) 72 | 73 | test_that("dots [...] as arguments work.", { 74 | dots_ok <- build_factory( 75 | fun = function(x, ...) { 76 | x + y + sum(...) 77 | }, 78 | y 79 | ) 80 | 81 | add_one <- dots_ok(1) 82 | expect_identical(add_one(2, 3, 4), 10) 83 | expect_setequal(formalArgs(add_one), c("x", "...")) 84 | expect_identical(as.character(body(add_one)[-1]), "x + 1 + sum(...)") 85 | }) 86 | 87 | test_that("Factories can pass dots.", { 88 | number_format <- build_factory( 89 | fun = function(x, ...) { 90 | scales::number( 91 | x, 92 | accuracy = accuracy, scale = scale, prefix = prefix, 93 | suffix = suffix, big.mark = big.mark, decimal.mark = decimal.mark, 94 | trim = trim, ... 95 | ) 96 | }, 97 | accuracy = NULL, 98 | scale = 1, 99 | prefix = "", 100 | suffix = "", 101 | big.mark = " ", 102 | decimal.mark = ".", 103 | trim = TRUE, 104 | .pass_dots = TRUE 105 | ) 106 | 107 | expect_identical( 108 | scales::number_format(width = 8)(1:10 * 10000), 109 | number_format(width = 8)(1:10 * 10000) 110 | ) 111 | 112 | expect_error( 113 | build_factory( 114 | fun = function(x) { 115 | mean(x * multiple) 116 | }, 117 | multiple, 118 | .pass_dots = TRUE 119 | ), 120 | regexp = "fun must contain" 121 | ) 122 | 123 | number_format2 <- factory::build_factory( 124 | fun = function(x) { 125 | scales::number( 126 | x, 127 | accuracy = accuracy, scale = scale, prefix = prefix, suffix = suffix, 128 | big.mark = big.mark, decimal.mark = decimal.mark, trim = trim, ... 129 | ) 130 | }, 131 | accuracy = NULL, 132 | scale = 1, 133 | prefix = "", 134 | suffix = "", 135 | big.mark = " ", 136 | decimal.mark = ".", 137 | trim = TRUE, 138 | .pass_dots = TRUE 139 | ) 140 | 141 | expect_identical( 142 | scales::number_format(width = 8)(1:10 * 10000), 143 | number_format2(width = 8)(1:10 * 10000) 144 | ) 145 | expect_identical( 146 | formals(number_format2(width = 8)), 147 | as.pairlist(alist(x = )) 148 | ) 149 | }) 150 | 151 | test_that("Can build factories that branch into functions by variable.", { 152 | base_bins <- build_factory( 153 | .internal_variables = list( 154 | nclass_fun = switch( 155 | type, 156 | Sturges = grDevices::nclass.Sturges, 157 | scott = grDevices::nclass.scott, 158 | FD = grDevices::nclass.FD, 159 | stop("Unknown type", call. = FALSE) 160 | ) 161 | ), 162 | fun = function(x) { 163 | (max(x) - min(x)) / nclass_fun(x) 164 | }, 165 | type 166 | ) 167 | x <- rnorm(3 * 100, sd = c(1, 5, 15)) 168 | expect_identical( 169 | base_bins("Sturges")(x), 170 | (max(x) - min(x)) / nclass.Sturges(x) 171 | ) 172 | 173 | expect_error( 174 | build_factory( 175 | .internal_variables = c(nclass_fun = "this"), 176 | fun = function(x) { 177 | (max(x) - min(x)) / nclass_fun(x) 178 | }, 179 | type 180 | ), 181 | regexp = "internal_variables must be a named list" 182 | ) 183 | 184 | # I have not finished this test but don't want to delete it. 185 | # plot_dev <- build_factory( 186 | # fun = list( 187 | # ext = list( 188 | # ps = function(path, ...) { 189 | # grDevices::postscript( 190 | # file = filename, ..., onefile = FALSE, horizontal = FALSE, 191 | # paper = "special" 192 | # ) 193 | # }, 194 | # png = function(...) { 195 | # grDevices::png(..., res = dpi, units = "in") 196 | # } 197 | # ) 198 | # ), 199 | # ext, 200 | # dpi = 96 201 | # ) 202 | }) 203 | -------------------------------------------------------------------------------- /tests/testthat/test-utils.R: -------------------------------------------------------------------------------- 1 | test_that("body_replace replaces bits of bodies", { 2 | test_fun <- function(x) { 3 | x^exp 4 | } 5 | body(test_fun) <- body_replace(body(test_fun), quote(exp), quote(!!exp)) 6 | expected_fun <- function(x) { 7 | x^!!exp 8 | } 9 | expect_identical(test_fun, expected_fun) 10 | }) 11 | 12 | test_that("body_insert errors appropriately.", { 13 | fun <- function(x) x + 1 14 | expect_error( 15 | body_insert( 16 | fn_body = body(fun), 17 | insertion = quote("Should not matter") 18 | ), 19 | regexp = "Please wrap your function" 20 | ) 21 | }) 22 | 23 | test_that("body_replace doesn't freak out with NULL.", { 24 | test_fun <- function(x_vector) { 25 | matrix(x_vector, ncol = 1, dimnames = list(NULL, "x")) 26 | } 27 | test_body <- body(test_fun) 28 | expect_error( 29 | body_replace( 30 | fn_body = test_body, 31 | target = quote(x_vector), 32 | replacement = quote("got it!") 33 | ), 34 | NA 35 | ) 36 | }) -------------------------------------------------------------------------------- /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /vignettes/building_a_factory.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Building a Factory" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Building a Factory} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r, include = FALSE} 11 | knitr::opts_chunk$set( 12 | collapse = TRUE, 13 | comment = "#>" 14 | ) 15 | ``` 16 | 17 | ```{r setup} 18 | library(factory) 19 | ``` 20 | 21 | To build a function factory, begin by writing the function that you want to generalize (like a normal function). Here we'll generalize a function to add a color scale to a ggplot using a custom palette. 22 | 23 | ```{r function to generalize} 24 | my_scale_color <- function(discrete = TRUE, reverse = FALSE, ...) { 25 | my_palette <- c( 26 | "#772277", "#333388", "#1144aa", "#55aa11", 27 | "#f40000", "#f47a00", "#ffe314" 28 | ) 29 | if (reverse) { 30 | my_palette <- rev(my_palette) 31 | } 32 | pal <- colorRampPalette(my_palette, ...) 33 | 34 | if (discrete) { 35 | ggplot2::discrete_scale( 36 | aesthetics = "colour", 37 | scale_name = "my_color_scale", 38 | palette = pal, 39 | ... 40 | ) 41 | } else { 42 | ggplot2::scale_color_gradientn(colors = pal(256),) 43 | } 44 | } 45 | 46 | ggplot2::ggplot(mtcars) + 47 | ggplot2::aes(x = mpg, y = cyl, color = factor(gear)) + 48 | ggplot2::geom_point() + 49 | my_scale_color() 50 | ``` 51 | 52 | We could conceivably want to generalize this function to create a similar function, given a palette and (optionally) the name of the scale. 53 | 54 | ```{r genericized function} 55 | my_scale_color_generic <- function(discrete = TRUE, reverse = FALSE, ...) { 56 | my_palette <- this_palette 57 | if (reverse) { 58 | my_palette <- rev(my_palette) 59 | } 60 | pal <- colorRampPalette(my_palette, ...) 61 | 62 | if (discrete) { 63 | ggplot2::discrete_scale( 64 | aesthetics = "colour", 65 | scale_name = this_scale_name, 66 | palette = pal, 67 | ... 68 | ) 69 | } else { 70 | ggplot2::scale_color_gradientn(colors = pal(256),) 71 | } 72 | } 73 | ``` 74 | 75 | We can use `factory::build_factory` to turn that function into a factory. 76 | 77 | ```{r sample factory} 78 | my_scale_color_factory <- build_factory( 79 | fun = my_scale_color_generic, 80 | this_palette, 81 | this_scale_name = "my_color_scale" 82 | ) 83 | ``` 84 | 85 | Using our factory with the values we started with should reproduce the original function. 86 | 87 | ```{r using the factor} 88 | my_scale_color_factory( 89 | this_palette = c( 90 | "#772277", "#333388", "#1144aa", "#55aa11", 91 | "#f40000", "#f47a00", "#ffe314" 92 | ) 93 | ) 94 | ``` 95 | 96 | Note: If you use `factory` to build a factory in a package, we recommend that you copy/paste the resulting function definition into your package, rather than using the `factory::build_factory` call directly in your package. This will allow you to better comment your code, and will avoid [build errors](https://r6.r-lib.org/articles/Portable.html#potential-pitfalls-with-cross-package-inheritance). 97 | -------------------------------------------------------------------------------- /vignettes/examples.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Examples" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Examples} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r, include = FALSE} 11 | knitr::opts_chunk$set( 12 | collapse = TRUE, 13 | comment = "#>" 14 | ) 15 | ``` 16 | 17 | ```{r setup} 18 | library(factory) 19 | ``` 20 | 21 | Most of these examples are adapted from [Advanced R by Hadley Wickham (2nd Edition), Chapter 10: Function Factories](https://adv-r.hadley.nz/function-factories.html). 22 | 23 | ## 10.2.6 Exercises 24 | 25 | In the exercises for section 10.2.6, we're asked to produce a `pick` factory that basically acts like `[[`, such that `pick(1)(x)` is equivalent to `x[[1]]`. 26 | We can relatively easily create this simple factory in {factory}. 27 | 28 | ```{r pick} 29 | pick <- build_factory( 30 | function(x) x[[i]], 31 | i 32 | ) 33 | 34 | identical(pick(1)(mtcars), mtcars[[1]]) 35 | identical(pick(2)(mtcars), mtcars[[2]]) 36 | identical(pick(3)(mtcars$disp), mtcars$disp[[3]]) 37 | identical( 38 | lapply(mtcars, pick(5)), 39 | lapply(mtcars, function(x) x[[5]]) 40 | ) 41 | ``` 42 | 43 | We're also asked to create another factory, this time for finding the i^th^ central moment. 44 | We first create a two-argument function to calculate the central moment. 45 | 46 | ```{r central-moment-2-arg} 47 | moment2 <- function(x, i) { 48 | 1/length(x) * 49 | sum( 50 | (x - mean(x))^i 51 | ) 52 | } 53 | 54 | x <- runif(100) 55 | all.equal(moment2(x, 1), 0) 56 | all.equal(moment2(x, 2), var(x) * 99/100) 57 | ``` 58 | 59 | Since this works, we can pull `i` out to make our factory. 60 | 61 | ```{r central-moment-factory} 62 | moment1 <- function(x) { 63 | 1/length(x) * 64 | sum( 65 | (x - mean(x))^i 66 | ) 67 | } 68 | 69 | moment <- build_factory( 70 | moment1, 71 | i 72 | ) 73 | 74 | m1 <- moment(1) 75 | m2 <- moment(2) 76 | 77 | all.equal(m1(x), 0) 78 | all.equal(m2(x), var(x) * 99/100) 79 | ``` 80 | 81 | ## Scales 82 | 83 | The {scales} package contains a number of function factories. 84 | These factories are written in the traditional format, and thus produce confusing functions. 85 | Let's see if we can make them easier to work with. 86 | 87 | One of the workhorse functions of {scales} is `number_format`. 88 | 89 | ```{r number-format} 90 | scales::number_format 91 | ``` 92 | 93 | This factory takes several arguments, and returns a function that is simply a call to the `number` function. 94 | Let's see if we can recreate this factory. 95 | I'm naming the rebuilt versions with a `format_` prefix instead of suffix, to "fix" the "unfortunate accident of history" mentioned by Hadley Wickham while discussing these examples. 96 | 97 | ```{r number-format-redux} 98 | format_number <- build_factory( 99 | function(x, ...) { 100 | scales::number( 101 | x, 102 | accuracy = accuracy, scale = scale, prefix = prefix, suffix = suffix, 103 | big.mark = big.mark, decimal.mark = decimal.mark, trim = trim, ... 104 | ) 105 | }, 106 | accuracy = NULL, 107 | scale = 1, 108 | prefix = "", 109 | suffix = "", 110 | big.mark = " ", 111 | decimal.mark = ".", 112 | trim = TRUE, 113 | .pass_dots = TRUE 114 | ) 115 | 116 | identical( 117 | scales::number_format(width = 8)(1:10 * 10000), 118 | format_number(width = 8)(1:10 * 10000) 119 | ) 120 | ``` 121 | 122 | We had to do a couple special things to get our factory to behave like the {scales} version: 123 | 124 | * The version in scales passes the `...` from the factory without officially declaring dots as an argument to the manufactured function. We more formally include the dots. 125 | * We have to tell `build_factory` that we want to `pass_dots` from the factory to its constructed functions. 126 | 127 | Our factory also works to define our own version of `comma_format`. 128 | 129 | ```{r comma-format} 130 | scales::comma_format 131 | 132 | format_comma <- function(accuracy = NULL, scale = 1, prefix = "", 133 | suffix = "", big.mark = ",", decimal.mark = ".", 134 | trim = TRUE, digits, ...) { 135 | if (!missing(digits)) { 136 | warning("`digits` argument is deprecated, use `accuracy` instead.", 137 | .call = FALSE) 138 | } 139 | format_number( 140 | accuracy = accuracy, scale = scale, prefix = prefix, suffix = suffix, 141 | big.mark = big.mark, decimal.mark = decimal.mark, trim = trim, ... 142 | ) 143 | } 144 | 145 | identical( 146 | scales::comma_format(width = 8)(1:10 * 10000), 147 | format_comma(width = 8)(1:10 * 10000) 148 | ) 149 | ``` 150 | 151 | ## binwidth 152 | 153 | The `binwidth` argument of `ggplot2::geom_histogram` can be a function. 154 | Let's recreate examples of binwidth function factories. 155 | 156 | ```{r binwidth-bins} 157 | binwidth_bins <- build_factory( 158 | function(x) { 159 | (max(x) - min(x)) / n 160 | }, 161 | n 162 | ) 163 | 164 | sd <- c(1, 5, 15) 165 | m <- 100 166 | df <- data.frame( 167 | x = rnorm(3 * m, sd = sd), 168 | sd = rep(sd, m) 169 | ) 170 | 171 | df %>% 172 | ggplot2::ggplot() + 173 | ggplot2::aes(x) + 174 | ggplot2::geom_histogram(binwidth = 2) + 175 | ggplot2::facet_wrap(~ sd, scales = "free_x") + 176 | ggplot2::labs(x = NULL) 177 | 178 | df %>% 179 | ggplot2::ggplot() + 180 | ggplot2::aes(x) + 181 | ggplot2::geom_histogram(binwidth = binwidth_bins(20)) + 182 | ggplot2::facet_wrap(~ sd, scales = "free_x") + 183 | ggplot2::labs(x = NULL) 184 | 185 | ``` 186 | 187 | We can also wrap functions from {grDevices} that automatically find "optimal" binwidth. 188 | 189 | ```{r base-optimal-binwidth} 190 | base_bins <- build_factory( 191 | .internal_variables = list( 192 | nclass_fun = switch( 193 | type, 194 | Sturges = grDevices::nclass.Sturges, 195 | scott = grDevices::nclass.scott, 196 | FD = grDevices::nclass.FD, 197 | stop("Unknown type", call. = FALSE) 198 | ) 199 | ), 200 | fun = function(x) { 201 | (max(x) - min(x)) / nclass_fun(x) 202 | }, 203 | type 204 | ) 205 | 206 | df %>% 207 | ggplot2::ggplot() + 208 | ggplot2::aes(x) + 209 | ggplot2::geom_histogram(binwidth = base_bins("FD")) + 210 | ggplot2::facet_wrap(~ sd, scales = "free_x") + 211 | ggplot2::labs(x = NULL) 212 | ``` 213 | 214 | ## Bootstrap generator 215 | 216 | Function factories can also be used to create bootstrap generators. 217 | 218 | ```{r boot-permute} 219 | boot_permute <- build_factory( 220 | .internal_variables = list( 221 | n = nrow(df) 222 | ), 223 | fun = function() { 224 | col <- df[[var]] 225 | col[sample(n, replace = TRUE)] 226 | }, 227 | df, 228 | var 229 | ) 230 | 231 | boot_mtcars1 <- boot_permute(mtcars, "mpg") 232 | head(boot_mtcars1()) 233 | head(boot_mtcars1()) 234 | ``` 235 | 236 | This is particularly useful when the bootstrap depends on a model. 237 | 238 | ```{r boot-model} 239 | boot_model <- build_factory( 240 | .internal_variables = list( 241 | mod = lm(formula, data = df), 242 | fitted_vals = unname(fitted(mod)), 243 | resid_vals = unname(resid(mod)) 244 | ), 245 | fun = function() { 246 | fitted_vals + sample(resid_vals) 247 | }, 248 | df, 249 | formula 250 | ) 251 | 252 | boot_mtcars2 <- boot_model(mtcars, mpg ~ wt) 253 | head(boot_mtcars2()) 254 | head(boot_mtcars2()) 255 | ``` 256 | 257 | ## Maximum likelihood estimation 258 | 259 | Function factories are also useful for maximum likelihood estimation (MLE). 260 | Here we'll compute lambda for a Poisson distribution. 261 | 262 | ```{r ll-poisson} 263 | ll_poisson <- build_factory( 264 | .internal_variables = list( 265 | n = length(x), 266 | sum_x = sum(x), 267 | c_var = sum(lfactorial(x)) 268 | ), 269 | fun = function(lambda) { 270 | log(lambda) * sum_x - n * lambda - c_var 271 | }, 272 | x 273 | ) 274 | 275 | # Say we have this vector of observations. 276 | x1 <- c(41, 30, 31, 38, 29, 24, 30, 29, 31, 38) 277 | 278 | ll1 <- ll_poisson(x1) 279 | 280 | ll1(10) 281 | ll1(20) 282 | ll1(30) 283 | optimize(ll1, c(0, 100), maximum = TRUE) 284 | ``` 285 | 286 | We can see that this is a more efficient process than *not* using a function factory. 287 | 288 | ```{r optim-optim} 289 | # Slightly change the dataset to prove that the factory version isn't 290 | # pre-computed. We also need a reasonably large x2 for the efficiency to pay off 291 | # (it starts to pay off around size = 30, but size = 100 is clearer and closer 292 | # to a real dataset). 293 | x2 <- sample(20:50, size = 100, replace = TRUE) 294 | 295 | # I'm defining both the factory and the non-factory function outside of optim. 296 | lprob_poisson <- function(lambda, x) { 297 | n <- length(x) 298 | (log(lambda) * sum(x)) - (n * lambda) - sum(lfactorial(x)) 299 | } 300 | 301 | bench::mark( 302 | with_factory = { 303 | ll2 <- ll_poisson(x2) 304 | optimize( 305 | ll2, 306 | c(0, 100), 307 | maximum = TRUE 308 | ) 309 | }, 310 | without_factory = { 311 | optimize( 312 | lprob_poisson, 313 | c(0, 100), 314 | x = x2, 315 | maximum = TRUE 316 | ) 317 | } 318 | ) 319 | ``` 320 | --------------------------------------------------------------------------------