Skip to content

Instantly share code, notes, and snippets.

@jmbarbone

jmbarbone/lambda-functions-2.R

Last active June 3, 2024 03:23
Show Gist options
  • Save jmbarbone/431dc8130f4c7960973aa36a38b8041d to your computer and use it in GitHub Desktop.
Save jmbarbone/431dc8130f4c7960973aa36a38b8041d to your computer and use it in GitHub Desktop.
Download ZIP
base 'map()`-like functions
Raw
lambda-functions-2.md 
lambda <- function(expr, args = ".i") {
  fun <- function() { }
  formals(fun) <- structure(
    rep(list(substitute()), length(args)),
    class = "alist",
    names = args
  )

  if (is.function(expr)) {
    body(fun) <- substitute({
      expr()
    })
  } else {
    expr <- as.formula(expr)[[2]]
    body(fun) <- substitute({
      expr
    })
  }
  fun
}


lambda(function(x) x + 1)
#> function (.i) 
#> {
#>     (function(x) x + 1)()
#> }
#> <environment: 0x56d7fed1a638>
lambda(~.i + 1 + .j, args = c(".i", ".j"))
#> function (.i, .j) 
#> {
#>     .i + 1 + .j
#> }
#> <environment: 0x56d7fd436e10>
lambda(~.i + 1 + .j, args = c(".i", ".j"))(1, 2)
#> [1] 4
apply_lambda <- function(x, expr, fun, ...) {
  force(fun)
  ..call <- sys.call(sys.parent())
  withCallingHandlers(
    set_names2(do.call(fun, c(list(x, expr), list(...))), names(x)),
    error = function(e) {
      e$call <- ..call
      stop(e)
    }
  )
}

apply_each <- function(x, fun) {
  lapply(x, function(.i) do.call(fun, as.list(.i)))
}

set_names <- fuj::set_names
set_names2 <- function(x, names = x) {
  if (is.matrix(x)) {
    dimnames(x) <-  list(seq_len(NROW(x)), names)
  } else {
    names(x) <- names
  }

  x
}

each <- function(x, expr, args = ".i") {
  apply_lambda(x, lambda(expr, args), apply_each)
}

each_ <- function(type) {
  fun <- function(x, expr, args = ".i", n = 1L) {  }
  body(fun) <- substitute({
    res <- apply_lambda(
      x,
      lambda(expr, args),
      vapply,
      FUN.VALUE = type(n),
      USE.NAMES = FALSE
    )
    if (is.matrix(res)) {
      apply(res, 2L, as.vector, simplify = FALSE)
    } else {
      res
    }
  })
  fun
}

date <- function(n = 0L) {
  rep(as.Date(0L), n)
}

datetime <- function(n = 0L) {
  rep(as.POSIXct(0L), n)
}

each_int <- each_(integer)
each_dbl <- each_(double)
each_chr <- each_(character)
each_lgl <- each_(logical)
each_raw <- each_(raw)
each_dte <- function(x, expr, args = ".i", n = 1L) {
  res <- each_dbl(x, expr, args, n)
  res[] <- as.Date.numeric(res)
  res
}
each_dtm <- function(x, expr, args = ".i", n = 1L) {
  res <- each_dbl(x, expr, args, n)
  res[] <- as.POSIXct.numeric(res)
  res
}

each(state.name, ~nchar(.i) + 1)
#> [[1]]
#> [1] 8
#> 
#> [[2]]
#> [1] 7
#> 
#> [[3]]
#> [1] 8
#> 
#> [[4]]
#> [1] 9
#> 
#> [[5]]
#> [1] 11
#> 
#> [[6]]
#> [1] 9
#> 
#> [[7]]
#> [1] 12
#> 
#> [[8]]
#> [1] 9
#> 
#> [[9]]
#> [1] 8
#> 
#> [[10]]
#> [1] 8
#> 
#> [[11]]
#> [1] 7
#> 
#> [[12]]
#> [1] 6
#> 
#> [[13]]
#> [1] 9
#> 
#> [[14]]
#> [1] 8
#> 
#> [[15]]
#> [1] 5
#> 
#> [[16]]
#> [1] 7
#> 
#> [[17]]
#> [1] 9
#> 
#> [[18]]
#> [1] 10
#> 
#> [[19]]
#> [1] 6
#> 
#> [[20]]
#> [1] 9
#> 
#> [[21]]
#> [1] 14
#> 
#> [[22]]
#> [1] 9
#> 
#> [[23]]
#> [1] 10
#> 
#> [[24]]
#> [1] 12
#> 
#> [[25]]
#> [1] 9
#> 
#> [[26]]
#> [1] 8
#> 
#> [[27]]
#> [1] 9
#> 
#> [[28]]
#> [1] 7
#> 
#> [[29]]
#> [1] 14
#> 
#> [[30]]
#> [1] 11
#> 
#> [[31]]
#> [1] 11
#> 
#> [[32]]
#> [1] 9
#> 
#> [[33]]
#> [1] 15
#> 
#> [[34]]
#> [1] 13
#> 
#> [[35]]
#> [1] 5
#> 
#> [[36]]
#> [1] 9
#> 
#> [[37]]
#> [1] 7
#> 
#> [[38]]
#> [1] 13
#> 
#> [[39]]
#> [1] 13
#> 
#> [[40]]
#> [1] 15
#> 
#> [[41]]
#> [1] 13
#> 
#> [[42]]
#> [1] 10
#> 
#> [[43]]
#> [1] 6
#> 
#> [[44]]
#> [1] 5
#> 
#> [[45]]
#> [1] 8
#> 
#> [[46]]
#> [1] 9
#> 
#> [[47]]
#> [1] 11
#> 
#> [[48]]
#> [1] 14
#> 
#> [[49]]
#> [1] 10
#> 
#> [[50]]
#> [1] 8
each(list(1:2, 2:3, 3:4), ~a^b, c("a", "b"))
#> [[1]]
#> [1] 1
#> 
#> [[2]]
#> [1] 8
#> 
#> [[3]]
#> [1] 81
each_int(state.name, ~nchar(.i))
#>  [1]  7  6  7  8 10  8 11  8  7  7  6  5  8  7  4  6  8  9  5  8 13  8  9 11  8
#> [26]  7  8  6 13 10 10  8 14 12  4  8  6 12 12 14 12  9  5  4  7  8 10 13  9  7
try(each_int(state.name, ~nchar(.i) + 2.5))
#> Error in each_int(state.name, ~nchar(.i) + 2.5) : 
#>   values must be type 'integer',
#>  but FUN(X[[1]]) result is type 'double'
try(each(1:3, ~.i + Sys.date()))
#> Error in each(1:3, ~.i + Sys.date()) : could not find function "Sys.date"
each(1:3, ~.i + Sys.Date())
#> [[1]]
#> [1] "2024-06-03"
#> 
#> [[2]]
#> [1] "2024-06-04"
#> 
#> [[3]]
#> [1] "2024-06-05"
1:3 |>
  set_names(letters[1:3]) |>
  each(~.i + 1)
#> $a
#> [1] 2
#> 
#> $b
#> [1] 3
#> 
#> $c
#> [1] 4
lambda(~.i + Sys.date())
#> function (.i) 
#> {
#>     .i + Sys.date()
#> }
#> <environment: 0x56d802825700>
try(each_dte(1:3, ~.i + Sys.date()))
#> Error in each_dbl(x, expr, args, n) : could not find function "Sys.date"
each_dte(1:3, ~.i + Sys.Date())
#> [1] 19877 19878 19879
1:3 |>
  set_names() |>
  each_dte(~.i + Sys.Date())
#>     1     2     3 
#> 19877 19878 19879
bench::mark(
  each(1:4, ~.i + 1),
  purrr::map(1:4, ~.x + 1)
)
#> # A tibble: 2 × 6
#>   expression                    min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>               <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 each(1:4, ~.i + 1)         55.8µs     64µs    13443.        0B     14.7
#> 2 purrr::map(1:4, ~.x + 1)   46.8µs   55.1µs    15846.    59.8KB     12.5
# doesn't work
bench::mark(
  each(list(1:2, 2:3, 3:4), ~.i + .j, c(".i", ".j")),
  try(purrr::pmap(list(1:2, 2:3, 3:4), ~.x + .y)),
  try(purrr::pmap(list(1:2, 2:3, 3:4), ~..1 + ..2)),
  check = FALSE
)
#> # A tibble: 3 × 6
#>   expression                            min  median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                        <bch:t> <bch:t>     <dbl> <bch:byt>    <dbl>
#> 1 "each(list(1:2, 2:3, 3:4), ~.i +…  55.8µs  62.8µs    13805.        0B     14.7
#> 2 "try(purrr::pmap(list(1:2, 2:3, … 107.2µs 126.3µs     6975.   46.75KB     12.5
#> 3 "try(purrr::pmap(list(1:2, 2:3, … 115.1µs 127.2µs     6754.    6.11KB     14.8
bench::mark(
  each_int(state.abb, ~nchar(.i) + 1L),
  purrr::map_int(state.abb, ~nchar(.x) + 1L)
)
#> # A tibble: 2 × 6
#>   expression                             min median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                           <bch> <bch:>     <dbl> <bch:byt>    <dbl>
#> 1 each_int(state.abb, ~nchar(.i) + 1L) 122µs  132µs     6752.    3.09KB     19.0
#> 2 purrr::map_int(state.abb, ~nchar(.x… 107µs  120µs     6934.  100.48KB     16.9
state.name |>
  set_names() |>
  each_int(~c(nchar(.i), 1L), n = 2)
#> $Alabama
#> [1] 7 1
#> 
#> $Alaska
#> [1] 6 1
#> 
#> $Arizona
#> [1] 7 1
#> 
#> $Arkansas
#> [1] 8 1
#> 
#> $California
#> [1] 10  1
#> 
#> $Colorado
#> [1] 8 1
#> 
#> $Connecticut
#> [1] 11  1
#> 
#> $Delaware
#> [1] 8 1
#> 
#> $Florida
#> [1] 7 1
#> 
#> $Georgia
#> [1] 7 1
#> 
#> $Hawaii
#> [1] 6 1
#> 
#> $Idaho
#> [1] 5 1
#> 
#> $Illinois
#> [1] 8 1
#> 
#> $Indiana
#> [1] 7 1
#> 
#> $Iowa
#> [1] 4 1
#> 
#> $Kansas
#> [1] 6 1
#> 
#> $Kentucky
#> [1] 8 1
#> 
#> $Louisiana
#> [1] 9 1
#> 
#> $Maine
#> [1] 5 1
#> 
#> $Maryland
#> [1] 8 1
#> 
#> $Massachusetts
#> [1] 13  1
#> 
#> $Michigan
#> [1] 8 1
#> 
#> $Minnesota
#> [1] 9 1
#> 
#> $Mississippi
#> [1] 11  1
#> 
#> $Missouri
#> [1] 8 1
#> 
#> $Montana
#> [1] 7 1
#> 
#> $Nebraska
#> [1] 8 1
#> 
#> $Nevada
#> [1] 6 1
#> 
#> $`New Hampshire`
#> [1] 13  1
#> 
#> $`New Jersey`
#> [1] 10  1
#> 
#> $`New Mexico`
#> [1] 10  1
#> 
#> $`New York`
#> [1] 8 1
#> 
#> $`North Carolina`
#> [1] 14  1
#> 
#> $`North Dakota`
#> [1] 12  1
#> 
#> $Ohio
#> [1] 4 1
#> 
#> $Oklahoma
#> [1] 8 1
#> 
#> $Oregon
#> [1] 6 1
#> 
#> $Pennsylvania
#> [1] 12  1
#> 
#> $`Rhode Island`
#> [1] 12  1
#> 
#> $`South Carolina`
#> [1] 14  1
#> 
#> $`South Dakota`
#> [1] 12  1
#> 
#> $Tennessee
#> [1] 9 1
#> 
#> $Texas
#> [1] 5 1
#> 
#> $Utah
#> [1] 4 1
#> 
#> $Vermont
#> [1] 7 1
#> 
#> $Virginia
#> [1] 8 1
#> 
#> $Washington
#> [1] 10  1
#> 
#> $`West Virginia`
#> [1] 13  1
#> 
#> $Wisconsin
#> [1] 9 1
#> 
#> $Wyoming
#> [1] 7 1
1:3 |>
  set_names() |>
  each_dte(~Sys.Date() + c(.i, -.i), n = 2)
#> $`1`
#> [1] 19877 19875
#> 
#> $`2`
#> [1] 19878 19874
#> 
#> $`3`
#> [1] 19879 19873
state.abb |>
  set_names() |>
  each_int(~c(nchar(.i), 1L), n = 2)
#> $AL
#> [1] 2 1
#> 
#> $AK
#> [1] 2 1
#> 
#> $AZ
#> [1] 2 1
#> 
#> $AR
#> [1] 2 1
#> 
#> $CA
#> [1] 2 1
#> 
#> $CO
#> [1] 2 1
#> 
#> $CT
#> [1] 2 1
#> 
#> $DE
#> [1] 2 1
#> 
#> $FL
#> [1] 2 1
#> 
#> $GA
#> [1] 2 1
#> 
#> $HI
#> [1] 2 1
#> 
#> $ID
#> [1] 2 1
#> 
#> $IL
#> [1] 2 1
#> 
#> $IN
#> [1] 2 1
#> 
#> $IA
#> [1] 2 1
#> 
#> $KS
#> [1] 2 1
#> 
#> $KY
#> [1] 2 1
#> 
#> $LA
#> [1] 2 1
#> 
#> $ME
#> [1] 2 1
#> 
#> $MD
#> [1] 2 1
#> 
#> $MA
#> [1] 2 1
#> 
#> $MI
#> [1] 2 1
#> 
#> $MN
#> [1] 2 1
#> 
#> $MS
#> [1] 2 1
#> 
#> $MO
#> [1] 2 1
#> 
#> $MT
#> [1] 2 1
#> 
#> $NE
#> [1] 2 1
#> 
#> $NV
#> [1] 2 1
#> 
#> $NH
#> [1] 2 1
#> 
#> $NJ
#> [1] 2 1
#> 
#> $NM
#> [1] 2 1
#> 
#> $NY
#> [1] 2 1
#> 
#> $NC
#> [1] 2 1
#> 
#> $ND
#> [1] 2 1
#> 
#> $OH
#> [1] 2 1
#> 
#> $OK
#> [1] 2 1
#> 
#> $OR
#> [1] 2 1
#> 
#> $PA
#> [1] 2 1
#> 
#> $RI
#> [1] 2 1
#> 
#> $SC
#> [1] 2 1
#> 
#> $SD
#> [1] 2 1
#> 
#> $TN
#> [1] 2 1
#> 
#> $TX
#> [1] 2 1
#> 
#> $UT
#> [1] 2 1
#> 
#> $VT
#> [1] 2 1
#> 
#> $VA
#> [1] 2 1
#> 
#> $WA
#> [1] 2 1
#> 
#> $WV
#> [1] 2 1
#> 
#> $WI
#> [1] 2 1
#> 
#> $WY
#> [1] 2 1
bench::mark(
  each_int(state.abb, ~c(nchar(.i), 1L), n = 2),
)
#> # A tibble: 1 × 6
#>   expression                             min median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                           <bch> <bch:>     <dbl> <bch:byt>    <dbl>
#> 1 each_int(state.abb, ~c(nchar(.i), 1… 226µs  296µs     2799.    1.31KB     14.7

Created on 2024-06-02 with reprex v2.1.0

Raw
lambda-functions-2.R
lambda <- function(expr, args = ".i") {
fun <- function() { }
formals(fun) <- structure(
rep(list(substitute()), length(args)),
class = "alist",
names = args
)
if (is.function(expr)) {
body(fun) <- substitute({
expr()
})
} else {
expr <- as.formula(expr)[[2]]
body(fun) <- substitute({
expr
})
}
fun
}
lambda(function(x) x + 1)
lambda(~.i + 1 + .j, args = c(".i", ".j"))
lambda(~.i + 1 + .j, args = c(".i", ".j"))(1, 2)
apply_lambda <- function(x, expr, fun, ...) {
force(fun)
..call <- sys.call(sys.parent())
withCallingHandlers(
set_names2(do.call(fun, c(list(x, expr), list(...))), names(x)),
error = function(e) {
e$call <- ..call
stop(e)
}
)
}
apply_each <- function(x, fun) {
lapply(x, function(.i) do.call(fun, as.list(.i)))
}
set_names <- fuj::set_names
set_names2 <- function(x, names = x) {
if (is.matrix(x)) {
dimnames(x) <- list(seq_len(NROW(x)), names)
} else {
names(x) <- names
}
x
}
each <- function(x, expr, args = ".i") {
apply_lambda(x, lambda(expr, args), apply_each)
}
each_ <- function(type) {
fun <- function(x, expr, args = ".i", n = 1L) { }
body(fun) <- substitute({
res <- apply_lambda(
x,
lambda(expr, args),
vapply,
FUN.VALUE = type(n),
USE.NAMES = FALSE
)
if (is.matrix(res)) {
apply(res, 2L, as.vector, simplify = FALSE)
} else {
res
}
})
fun
}
date <- function(n = 0L) {
rep(as.Date(0L), n)
}
datetime <- function(n = 0L) {
rep(as.POSIXct(0L), n)
}
each_int <- each_(integer)
each_dbl <- each_(double)
each_chr <- each_(character)
each_lgl <- each_(logical)
each_raw <- each_(raw)
each_dte <- function(x, expr, args = ".i", n = 1L) {
res <- each_dbl(x, expr, args, n)
res[] <- as.Date.numeric(res)
res
}
each_dtm <- function(x, expr, args = ".i", n = 1L) {
res <- each_dbl(x, expr, args, n)
res[] <- as.POSIXct.numeric(res)
res
}
each(state.name, ~nchar(.i) + 1)
each(list(1:2, 2:3, 3:4), ~a^b, c("a", "b"))
each_int(state.name, ~nchar(.i))
try(each_int(state.name, ~nchar(.i) + 2.5))
try(each(1:3, ~.i + Sys.date()))
each(1:3, ~.i + Sys.Date())
1:3 |>
set_names(letters[1:3]) |>
each(~.i + 1)
lambda(~.i + Sys.date())
try(each_dte(1:3, ~.i + Sys.date()))
each_dte(1:3, ~.i + Sys.Date())
1:3 |>
set_names() |>
each_dte(~.i + Sys.Date())
bench::mark(
each(1:4, ~.i + 1),
purrr::map(1:4, ~.x + 1)
)
# doesn't work
bench::mark(
each(list(1:2, 2:3, 3:4), ~.i + .j, c(".i", ".j")),
try(purrr::pmap(list(1:2, 2:3, 3:4), ~.x + .y)),
try(purrr::pmap(list(1:2, 2:3, 3:4), ~..1 + ..2)),
check = FALSE
)
bench::mark(
each_int(state.abb, ~nchar(.i) + 1L),
purrr::map_int(state.abb, ~nchar(.x) + 1L)
)
state.name |>
set_names() |>
each_int(~c(nchar(.i), 1L), n = 2)
1:3 |>
set_names() |>
each_dte(~Sys.Date() + c(.i, -.i), n = 2)
state.abb |>
set_names() |>
each_int(~c(nchar(.i), 1L), n = 2)
bench::mark(
each_int(state.abb, ~c(nchar(.i), 1L), n = 2),
)
Raw
lambda-functions.md 
lambda <- function(x, expr) {
  fun <- function(.i) { }
  if (is.function(expr)) {
    body(fun) <- substitute(expr(.i))
  } else {
    expr <- as.formula(expr)[[2L]]
    body(fun) <- substitute(expr)
  }
  list(x, fun)
}

lambda(1:10, force)
#> [[1]]
#>  [1]  1  2  3  4  5  6  7  8  9 10
#> 
#> [[2]]
#> function (.i) 
#> force(.i)
#> <environment: 0x63926b526740>
lambda(1:10, ~force(.i))
#> [[1]]
#>  [1]  1  2  3  4  5  6  7  8  9 10
#> 
#> [[2]]
#> function (.i) 
#> force(.i)
#> <environment: 0x63926b3a05b0>
set_names <- function(x, nms = x) {
  names(x) <- nms
  x
}

apply_lambda <- function(fun, lambda, ...) {
  set_names(do.call(fun, c(lambda, ...)), names(lambda[[1L]]))
}

each <- function(x, expr) {
  apply_lambda(lapply, lambda(x, expr))
}

each_int <- function(x, expr) {
  apply_lambda(vapply, lambda(x, expr), FUN.VALUE = 0L, USE.NAMES = FALSE)
}

each_chr <- function(x, expr) {
  apply_lambda(vapply, lambda(x, expr), FUN.VALUE = "", USE.NAMES = FALSE)
}

lambda(state.abb, ~nchar(.i) + 1L)
#> [[1]]
#>  [1] "AL" "AK" "AZ" "AR" "CA" "CO" "CT" "DE" "FL" "GA" "HI" "ID" "IL" "IN" "IA"
#> [16] "KS" "KY" "LA" "ME" "MD" "MA" "MI" "MN" "MS" "MO" "MT" "NE" "NV" "NH" "NJ"
#> [31] "NM" "NY" "NC" "ND" "OH" "OK" "OR" "PA" "RI" "SC" "SD" "TN" "TX" "UT" "VT"
#> [46] "VA" "WA" "WV" "WI" "WY"
#> 
#> [[2]]
#> function (.i) 
#> nchar(.i) + 1L
#> <environment: 0x63926c76c570>
each(state.abb, ~nchar(.i) + 1L)
#> [[1]]
#> [1] 3
#> 
#> [[2]]
#> [1] 3
#> 
#> [[3]]
#> [1] 3
#> 
#> [[4]]
#> [1] 3
#> 
#> [[5]]
#> [1] 3
#> 
#> [[6]]
#> [1] 3
#> 
#> [[7]]
#> [1] 3
#> 
#> [[8]]
#> [1] 3
#> 
#> [[9]]
#> [1] 3
#> 
#> [[10]]
#> [1] 3
#> 
#> [[11]]
#> [1] 3
#> 
#> [[12]]
#> [1] 3
#> 
#> [[13]]
#> [1] 3
#> 
#> [[14]]
#> [1] 3
#> 
#> [[15]]
#> [1] 3
#> 
#> [[16]]
#> [1] 3
#> 
#> [[17]]
#> [1] 3
#> 
#> [[18]]
#> [1] 3
#> 
#> [[19]]
#> [1] 3
#> 
#> [[20]]
#> [1] 3
#> 
#> [[21]]
#> [1] 3
#> 
#> [[22]]
#> [1] 3
#> 
#> [[23]]
#> [1] 3
#> 
#> [[24]]
#> [1] 3
#> 
#> [[25]]
#> [1] 3
#> 
#> [[26]]
#> [1] 3
#> 
#> [[27]]
#> [1] 3
#> 
#> [[28]]
#> [1] 3
#> 
#> [[29]]
#> [1] 3
#> 
#> [[30]]
#> [1] 3
#> 
#> [[31]]
#> [1] 3
#> 
#> [[32]]
#> [1] 3
#> 
#> [[33]]
#> [1] 3
#> 
#> [[34]]
#> [1] 3
#> 
#> [[35]]
#> [1] 3
#> 
#> [[36]]
#> [1] 3
#> 
#> [[37]]
#> [1] 3
#> 
#> [[38]]
#> [1] 3
#> 
#> [[39]]
#> [1] 3
#> 
#> [[40]]
#> [1] 3
#> 
#> [[41]]
#> [1] 3
#> 
#> [[42]]
#> [1] 3
#> 
#> [[43]]
#> [1] 3
#> 
#> [[44]]
#> [1] 3
#> 
#> [[45]]
#> [1] 3
#> 
#> [[46]]
#> [1] 3
#> 
#> [[47]]
#> [1] 3
#> 
#> [[48]]
#> [1] 3
#> 
#> [[49]]
#> [1] 3
#> 
#> [[50]]
#> [1] 3
each(state.abb, ~nchar(.i) + 1L)
#> [[1]]
#> [1] 3
#> 
#> [[2]]
#> [1] 3
#> 
#> [[3]]
#> [1] 3
#> 
#> [[4]]
#> [1] 3
#> 
#> [[5]]
#> [1] 3
#> 
#> [[6]]
#> [1] 3
#> 
#> [[7]]
#> [1] 3
#> 
#> [[8]]
#> [1] 3
#> 
#> [[9]]
#> [1] 3
#> 
#> [[10]]
#> [1] 3
#> 
#> [[11]]
#> [1] 3
#> 
#> [[12]]
#> [1] 3
#> 
#> [[13]]
#> [1] 3
#> 
#> [[14]]
#> [1] 3
#> 
#> [[15]]
#> [1] 3
#> 
#> [[16]]
#> [1] 3
#> 
#> [[17]]
#> [1] 3
#> 
#> [[18]]
#> [1] 3
#> 
#> [[19]]
#> [1] 3
#> 
#> [[20]]
#> [1] 3
#> 
#> [[21]]
#> [1] 3
#> 
#> [[22]]
#> [1] 3
#> 
#> [[23]]
#> [1] 3
#> 
#> [[24]]
#> [1] 3
#> 
#> [[25]]
#> [1] 3
#> 
#> [[26]]
#> [1] 3
#> 
#> [[27]]
#> [1] 3
#> 
#> [[28]]
#> [1] 3
#> 
#> [[29]]
#> [1] 3
#> 
#> [[30]]
#> [1] 3
#> 
#> [[31]]
#> [1] 3
#> 
#> [[32]]
#> [1] 3
#> 
#> [[33]]
#> [1] 3
#> 
#> [[34]]
#> [1] 3
#> 
#> [[35]]
#> [1] 3
#> 
#> [[36]]
#> [1] 3
#> 
#> [[37]]
#> [1] 3
#> 
#> [[38]]
#> [1] 3
#> 
#> [[39]]
#> [1] 3
#> 
#> [[40]]
#> [1] 3
#> 
#> [[41]]
#> [1] 3
#> 
#> [[42]]
#> [1] 3
#> 
#> [[43]]
#> [1] 3
#> 
#> [[44]]
#> [1] 3
#> 
#> [[45]]
#> [1] 3
#> 
#> [[46]]
#> [1] 3
#> 
#> [[47]]
#> [1] 3
#> 
#> [[48]]
#> [1] 3
#> 
#> [[49]]
#> [1] 3
#> 
#> [[50]]
#> [1] 3
each(set_names(state.abb), ~nchar(.i) + 1L)
#> $AL
#> [1] 3
#> 
#> $AK
#> [1] 3
#> 
#> $AZ
#> [1] 3
#> 
#> $AR
#> [1] 3
#> 
#> $CA
#> [1] 3
#> 
#> $CO
#> [1] 3
#> 
#> $CT
#> [1] 3
#> 
#> $DE
#> [1] 3
#> 
#> $FL
#> [1] 3
#> 
#> $GA
#> [1] 3
#> 
#> $HI
#> [1] 3
#> 
#> $ID
#> [1] 3
#> 
#> $IL
#> [1] 3
#> 
#> $IN
#> [1] 3
#> 
#> $IA
#> [1] 3
#> 
#> $KS
#> [1] 3
#> 
#> $KY
#> [1] 3
#> 
#> $LA
#> [1] 3
#> 
#> $ME
#> [1] 3
#> 
#> $MD
#> [1] 3
#> 
#> $MA
#> [1] 3
#> 
#> $MI
#> [1] 3
#> 
#> $MN
#> [1] 3
#> 
#> $MS
#> [1] 3
#> 
#> $MO
#> [1] 3
#> 
#> $MT
#> [1] 3
#> 
#> $NE
#> [1] 3
#> 
#> $NV
#> [1] 3
#> 
#> $NH
#> [1] 3
#> 
#> $NJ
#> [1] 3
#> 
#> $NM
#> [1] 3
#> 
#> $NY
#> [1] 3
#> 
#> $NC
#> [1] 3
#> 
#> $ND
#> [1] 3
#> 
#> $OH
#> [1] 3
#> 
#> $OK
#> [1] 3
#> 
#> $OR
#> [1] 3
#> 
#> $PA
#> [1] 3
#> 
#> $RI
#> [1] 3
#> 
#> $SC
#> [1] 3
#> 
#> $SD
#> [1] 3
#> 
#> $TN
#> [1] 3
#> 
#> $TX
#> [1] 3
#> 
#> $UT
#> [1] 3
#> 
#> $VT
#> [1] 3
#> 
#> $VA
#> [1] 3
#> 
#> $WA
#> [1] 3
#> 
#> $WV
#> [1] 3
#> 
#> $WI
#> [1] 3
#> 
#> $WY
#> [1] 3
each_int(state.abb, ~nchar(.i) + 1L)
#>  [1] 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3
#> [39] 3 3 3 3 3 3 3 3 3 3 3 3
bench::mark(
  each(state.abb, ~nchar(.i) + 1L),
  purrr::map(state.abb, ~nchar(.x) + 1L)
)
#> # A tibble: 2 × 6
#>   expression                             min median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                         <bch:t> <bch:>     <dbl> <bch:byt>    <dbl>
#> 1 each(state.abb, ~nchar(.i) + 1L)    94.8µs  106µs     7604.      448B     16.9
#> 2 purrr::map(state.abb, ~nchar(.x) … 109.3µs  119µs     7407.     165KB     17.1
bench::mark(
  each_int(state.abb, ~nchar(.i) + 1L),
  purrr::map_int(state.abb, ~nchar(.x) + 1L)
)
#> # A tibble: 2 × 6
#>   expression                             min median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                          <bch:> <bch:>     <dbl> <bch:byt>    <dbl>
#> 1 each_int(state.abb, ~nchar(.i) + 1… 90.5µs  109µs     7590.    9.97KB     17.0
#> 2 purrr::map_int(state.abb, ~nchar(.… 92.8µs  115µs     7532.    3.85KB     19.2
bench::mark(
  each_chr(state.abb, ~substr(.i, 1, 3)),
  purrr::map_chr(state.abb, ~substr(.x, 1, 3))
)
#> # A tibble: 2 × 6
#>   expression                             min median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                           <bch> <bch:>     <dbl> <bch:byt>    <dbl>
#> 1 each_chr(state.abb, ~substr(.i, 1, … 106µs  245µs     4252.      448B    10.4 
#> 2 purrr::map_chr(state.abb, ~substr(.… 144µs  246µs     2565.    22.9KB     8.35
bench::mark(
  each_chr(state.abb, paste),
  purrr::map_chr(state.abb, paste)
)
#> # A tibble: 2 × 6
#>   expression                            min  median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>                       <bch:tm> <bch:t>     <dbl> <bch:byt>    <dbl>
#> 1 each_chr(state.abb, paste)          105µs   135µs     6356.      448B     16.9
#> 2 purrr::map_chr(state.abb, paste)    109µs   144µs     5471.      448B     12.4

Created on 2024-06-02 with reprex v2.1.0

Raw
lambda-functions.R
lambda <- function(x, expr) {
fun <- function(.i) { }
if (is.function(expr)) {
body(fun) <- substitute(expr(.i))
} else {
expr <- as.formula(expr)[[2L]]
body(fun) <- substitute(expr)
}
list(x, fun)
}
lambda(1:10, force)
lambda(1:10, ~force(.i))
set_names <- function(x, nms = x) {
names(x) <- nms
x
}
apply_lambda <- function(fun, lambda, ...) {
set_names(do.call(fun, c(lambda, ...)), names(lambda[[1L]]))
}
each <- function(x, expr) {
apply_lambda(lapply, lambda(x, expr))
}
each_int <- function(x, expr) {
apply_lambda(vapply, lambda(x, expr), FUN.VALUE = 0L, USE.NAMES = FALSE)
}
each_chr <- function(x, expr) {
apply_lambda(vapply, lambda(x, expr), FUN.VALUE = "", USE.NAMES = FALSE)
}
lambda(state.abb, ~nchar(.i) + 1L)
each(state.abb, ~nchar(.i) + 1L)
each(state.abb, ~nchar(.i) + 1L)
each(set_names(state.abb), ~nchar(.i) + 1L)
each_int(state.abb, ~nchar(.i) + 1L)
bench::mark(
each(state.abb, ~nchar(.i) + 1L),
purrr::map(state.abb, ~nchar(.x) + 1L)
)
bench::mark(
each_int(state.abb, ~nchar(.i) + 1L),
purrr::map_int(state.abb, ~nchar(.x) + 1L)
)
bench::mark(
each_chr(state.abb, ~substr(.i, 1, 3)),
purrr::map_chr(state.abb, ~substr(.x, 1, 3))
)
bench::mark(
each_chr(state.abb, paste),
purrr::map_chr(state.abb, paste)
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment