├── Functional-Programming ├── 01_functions_in_R.R ├── 02_pure_functional_programming.R ├── 03_scope_and_closures.R ├── 04_higher_order_functions.R ├── 05_filter_map_and_reduce.R └── 06_point_free_programming.R ├── LICENSE.txt ├── README.md └── contributing.md /Functional-Programming/01_functions_in_R.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | square <- function(x) x**2 3 | 4 | ## ------------------------------------------------------------------------ 5 | square(1:5) 6 | 7 | ## ------------------------------------------------------------------------ 8 | rescale <- function(x) { 9 | m <- mean(x) 10 | s <- sd(x) 11 | (x - m) / s 12 | } 13 | 14 | ## ------------------------------------------------------------------------ 15 | (x <- 1:5) 16 | 17 | ## ---- echo=FALSE--------------------------------------------------------- 18 | rm(x) 19 | 20 | ## ------------------------------------------------------------------------ 21 | rescale <- function(x, only_translate) { 22 | m <- mean(x) 23 | translated <- x - m 24 | if (only_translate) return(translated) 25 | s <- sd(x) 26 | translated / s 27 | } 28 | rescale(1:4, TRUE) 29 | rescale(1:4, FALSE) 30 | 31 | ## ---- results="hide"----------------------------------------------------- 32 | rescale(x = 1:4, only_translate = TRUE) 33 | rescale(x = 1:4, only_translate = FALSE) 34 | 35 | ## ---- results="hide"----------------------------------------------------- 36 | rescale(only_translate = TRUE, x = 1:4) 37 | rescale(only_translate = FALSE, x = 1:4) 38 | 39 | ## ---- results="hide"----------------------------------------------------- 40 | rescale(1:4, only_translate = TRUE) 41 | rescale(only_translate = TRUE, 1:4) 42 | rescale(x = 1:4, TRUE) 43 | rescale(TRUE, x = 1:4) 44 | 45 | ## ---- results="hide"----------------------------------------------------- 46 | rescale(1:4, o = TRUE) 47 | rescale(o = TRUE, 1:4) 48 | 49 | ## ------------------------------------------------------------------------ 50 | rescale <- function(x, only_translate = FALSE) { 51 | m <- mean(x) 52 | translated <- x - m 53 | if (only_translate) return(translated) 54 | s <- sd(x) 55 | translated / s 56 | } 57 | 58 | ## ---- result="hide"------------------------------------------------------ 59 | rescale(1:4) 60 | 61 | ## ------------------------------------------------------------------------ 62 | rescale <- function(x, ...) { 63 | m <- mean(x, ...) 64 | s <- sd(x, ...) 65 | (x - m) / s 66 | } 67 | 68 | ## ------------------------------------------------------------------------ 69 | x <- c(NA, 1:3) 70 | rescale(x) 71 | 72 | ## ------------------------------------------------------------------------ 73 | rescale(x, na.rm = TRUE) 74 | 75 | ## ------------------------------------------------------------------------ 76 | f <- function(x) x 77 | g <- function(x, ...) x 78 | f(1:4, foo = "bar") 79 | g(1:4, foo = "bar") 80 | 81 | ## ------------------------------------------------------------------------ 82 | f <- function(...) list(...) 83 | g <- function(x, y, ...) f(...) 84 | g(x = 1, y = 2, z = 3, w = 4) 85 | 86 | ## ------------------------------------------------------------------------ 87 | f <- function(w) w 88 | g <- function(x, y, ...) f(...) 89 | g(x = 1, y = 2, z = 3, w = 4) 90 | 91 | ## ------------------------------------------------------------------------ 92 | parameters <- function(...) eval(substitute(alist(...))) 93 | parameters(a = 4, b = a**2) 94 | 95 | ## ------------------------------------------------------------------------ 96 | alist(a = 4, b = a**2) 97 | 98 | ## ------------------------------------------------------------------------ 99 | list(a = 4, b = a**2) 100 | 101 | ## ------------------------------------------------------------------------ 102 | parameters <- function(...) alist(...) 103 | parameters(a = 4, b = x**2) 104 | 105 | ## ------------------------------------------------------------------------ 106 | (function(x) x**2)(2) 107 | 108 | ## ------------------------------------------------------------------------ 109 | f <- function(a, b) a 110 | f(2, stop("error if evaluated")) 111 | f(stop("error if evaluated"), 2) 112 | 113 | ## ------------------------------------------------------------------------ 114 | f <- function(a, b = a) a + b 115 | f(a = 2) 116 | 117 | ## ------------------------------------------------------------------------ 118 | a <- 4 119 | f <- function(x) { 120 | a <- 2 121 | x 122 | } 123 | f(1 + a) 124 | 125 | ## ---- echo=FALSE--------------------------------------------------------- 126 | rm(a) 127 | 128 | ## ------------------------------------------------------------------------ 129 | f <- function(a) function(b) a + b 130 | 131 | ## ------------------------------------------------------------------------ 132 | f(2)(2) 133 | 134 | ## ------------------------------------------------------------------------ 135 | ff <- vector("list", 4) 136 | for (i in 1:4) { 137 | ff[[i]] <- f(i) 138 | } 139 | ff 140 | 141 | ## ------------------------------------------------------------------------ 142 | ff[[1]](1) 143 | 144 | ## ------------------------------------------------------------------------ 145 | i <- 1 146 | ff[[2]](1) 147 | 148 | ## ------------------------------------------------------------------------ 149 | i <- 2 150 | ff[[2]](1) 151 | 152 | ## ------------------------------------------------------------------------ 153 | results <- vector("numeric", 4) 154 | for (i in 1:4) { 155 | results[i] <- ff[[i]](1) 156 | } 157 | results 158 | 159 | ## ------------------------------------------------------------------------ 160 | f <- function(a) { 161 | force(a) 162 | function(b) a + b 163 | } 164 | 165 | ff <- vector("list", 4) 166 | for (i in 1:4) { 167 | ff[[i]] <- f(i) 168 | } 169 | 170 | ff[[1]](1) 171 | i <- 1 172 | ff[[2]](1) 173 | 174 | ## ------------------------------------------------------------------------ 175 | parameters <- function(...) eval(substitute(alist(...))) 176 | 177 | p <- parameters(x = 2) 178 | class(p$x) 179 | 180 | ## ------------------------------------------------------------------------ 181 | a <- 2 182 | p <- parameters(x = a) 183 | class(p$x) 184 | 185 | ## ------------------------------------------------------------------------ 186 | eval(p$x) 187 | 188 | ## ------------------------------------------------------------------------ 189 | a <- 4 190 | eval(p$x) 191 | 192 | ## ---- echo=FALSE--------------------------------------------------------- 193 | rm(a) 194 | 195 | ## ------------------------------------------------------------------------ 196 | p <- parameters(x = 2 * y) 197 | class(p$x) 198 | 199 | ## ------------------------------------------------------------------------ 200 | eval(p$x) 201 | 202 | ## ------------------------------------------------------------------------ 203 | parameters2 <- function(...) { 204 | y <- 2 205 | eval(substitute(alist(...))) 206 | } 207 | p2 <- parameters(x = 2 * y) 208 | eval(p2$x) 209 | 210 | ## ------------------------------------------------------------------------ 211 | y <- 2 212 | eval(p$x) 213 | 214 | ## ------------------------------------------------------------------------ 215 | eval(p$x, list(y = 4)) 216 | 217 | ## ---- echo=FALSE--------------------------------------------------------- 218 | rm(y) 219 | 220 | ## ------------------------------------------------------------------------ 221 | x <- 1:5 222 | y <- 6:10 223 | x - y 224 | 225 | ## ------------------------------------------------------------------------ 226 | 2 * x 227 | 228 | ## ------------------------------------------------------------------------ 229 | x <- 1:6 230 | y <- 1:3 231 | x - y 232 | 233 | ## ------------------------------------------------------------------------ 234 | log(1:3) - sqrt(1:3) 235 | 236 | ## ------------------------------------------------------------------------ 237 | f <- function(a, b) log(a) - sqrt(b) 238 | f(1:3, 1:3) 239 | 240 | ## ------------------------------------------------------------------------ 241 | compare <- function(x, y) { 242 | if (x < y) { 243 | -1 244 | } else if (y < x) { 245 | 1 246 | } else { 247 | 0 248 | } 249 | } 250 | 251 | ## ------------------------------------------------------------------------ 252 | compare <- function(x, y) { 253 | ifelse(x < y, -1, ifelse(y < x, 1, 0)) 254 | } 255 | compare(1:6, 1:3) 256 | 257 | ## ------------------------------------------------------------------------ 258 | compare <- function(x, y) { 259 | if (x < y) { 260 | -1 261 | } else if (y < x) { 262 | 1 263 | } else { 264 | 0 265 | } 266 | } 267 | compare <- Vectorize(compare) 268 | compare(1:6, 1:3) 269 | 270 | ## ------------------------------------------------------------------------ 271 | scale_with <- function(x, y) { 272 | (x - mean(y)) / sd(y) 273 | } 274 | 275 | ## ------------------------------------------------------------------------ 276 | scale_with(1:6, 1:3) 277 | scale_with <- Vectorize(scale_with) 278 | scale_with(1:6, 1:3) 279 | 280 | ## ------------------------------------------------------------------------ 281 | scale_with <- function(x, y) { 282 | (x - mean(y)) / sd(y) 283 | } 284 | scale_with <- Vectorize(scale_with, vectorize.args="x") 285 | scale_with(1:6, 1:3) 286 | 287 | ## ------------------------------------------------------------------------ 288 | make_node <- function(name, left = NULL, right = NULL) 289 | list(name = name, left = left, right = right) 290 | 291 | tree <- make_node("root", 292 | make_node("C", make_node("A"), 293 | make_node("B")), 294 | make_node("D")) 295 | 296 | ## ------------------------------------------------------------------------ 297 | node_depth <- function(tree, name, depth = 0) { 298 | if (is.null(tree)) return(NA) 299 | if (tree$name == name) return(depth) 300 | 301 | left <- node_depth(tree$left, name, depth + 1) 302 | if (!is.na(left)) return(left) 303 | right <- node_depth(tree$right, name, depth + 1) 304 | return(right) 305 | } 306 | 307 | ## ------------------------------------------------------------------------ 308 | node_depth(tree, "D") 309 | node_depth(tree, "A") 310 | 311 | ## ------------------------------------------------------------------------ 312 | node_depth <- Vectorize(node_depth, vectorize.args = "name", 313 | USE.NAMES = FALSE) 314 | node_depth(tree, c("A", "B", "C", "D")) 315 | 316 | ## ------------------------------------------------------------------------ 317 | `+`(2, 2) 318 | 319 | ## ------------------------------------------------------------------------ 320 | `if`(2 > 3, "true", "false") 321 | 322 | ## ------------------------------------------------------------------------ 323 | `%x%` <- `*` 324 | 3 %x% 2 325 | 326 | ## ------------------------------------------------------------------------ 327 | `%x%` <- function(expr, num) replicate(num, expr) 328 | 3 %x% 5 329 | cat("This is ", "very " %x% 3, "much fun") 330 | 331 | ## ------------------------------------------------------------------------ 332 | rnorm(1) %x% 4 333 | 334 | ## ------------------------------------------------------------------------ 335 | `%x%` <- function(expr, num) { 336 | m <- match.call() 337 | replicate(num, eval.parent(m$expr)) 338 | } 339 | rnorm(1) %x% 4 340 | 341 | ## ------------------------------------------------------------------------ 342 | x <- y <- 1:5 343 | x 344 | y 345 | x[1] <- 6 346 | x 347 | y 348 | 349 | ## ------------------------------------------------------------------------ 350 | rm(x) ; rm(y) 351 | mem_change(x <- 1:10000000) 352 | address(x) 353 | mem_change(x[1] <- 6) 354 | address(x) 355 | 356 | ## ------------------------------------------------------------------------ 357 | class(6) 358 | class(6L) 359 | 360 | ## ------------------------------------------------------------------------ 361 | z <- 1:5 362 | class(z) 363 | z[1] <- 6 364 | class(z) 365 | 366 | ## ---- echo=FALSE--------------------------------------------------------- 367 | rm(z) 368 | 369 | ## ------------------------------------------------------------------------ 370 | mem_change(x[3] <- 8) 371 | address(x) 372 | 373 | ## ------------------------------------------------------------------------ 374 | mem_change(y <- x) 375 | address(x) 376 | address(y) 377 | 378 | ## ------------------------------------------------------------------------ 379 | mem_change(x[3] <- 8) 380 | address(x) 381 | address(y) 382 | 383 | ## ------------------------------------------------------------------------ 384 | mem_change(x[4] <- 9) 385 | address(x) 386 | 387 | ## ---- echo=FALSE--------------------------------------------------------- 388 | rm(x) ; rm(y) 389 | 390 | ## ------------------------------------------------------------------------ 391 | x <- 1:4 392 | x 393 | names(x) <- letters[1:4] 394 | x 395 | names(x) 396 | 397 | ## ------------------------------------------------------------------------ 398 | names(x) <- letters[1:4] 399 | 400 | ## ------------------------------------------------------------------------ 401 | x <- `names<-`(x, letters[1:4]) 402 | 403 | ## ------------------------------------------------------------------------ 404 | x <- 1:4 405 | attributes(x) 406 | attributes(x) <- list(foo = "bar") 407 | attributes(x) 408 | attr(x, "baz") <- "qux" 409 | attributes(x) 410 | 411 | ## ------------------------------------------------------------------------ 412 | tree <- make_node("root", 413 | make_node("C", make_node("A"), 414 | make_node("B")), 415 | make_node("D")) 416 | 417 | ## ------------------------------------------------------------------------ 418 | `left<-` <- function(node, value) { 419 | node$left = value 420 | node 421 | } 422 | `right<-` <- function(node, value) { 423 | node$right = value 424 | node 425 | } 426 | 427 | ## ------------------------------------------------------------------------ 428 | A <- make_node("A") 429 | B <- make_node("B") 430 | C <- make_node("C") 431 | D <- make_node("D") 432 | root <- make_node("root") 433 | left(C) <- A 434 | right(C) <- B 435 | left(root) <- C 436 | right(root) <- D 437 | tree <- root 438 | 439 | ## ------------------------------------------------------------------------ 440 | print_tree <- function(tree) { 441 | build_string <- function(node) { 442 | if (is.null(node$left) && is.null(node$right)) { 443 | node$name 444 | } else { 445 | left <- build_string(node$left) 446 | right <- build_string(node$right) 447 | paste0("(", left, ",", right, ")") 448 | } 449 | } 450 | build_string(tree) 451 | } 452 | print_tree(tree) 453 | 454 | ## ------------------------------------------------------------------------ 455 | A <- make_node("A") 456 | B <- make_node("B") 457 | C <- make_node("C") 458 | D <- make_node("D") 459 | root <- make_node("root") 460 | left(root) <- C 461 | right(root) <- D 462 | left(C) <- A 463 | right(C) <- B 464 | tree <- root 465 | print_tree(tree) 466 | 467 | -------------------------------------------------------------------------------- /Functional-Programming/02_pure_functional_programming.R: -------------------------------------------------------------------------------- 1 | ## ---- echo=FALSE--------------------------------------------------------- 2 | is_empty <- function(x) length(x) == 0 3 | first <- function(x) x[1] 4 | rest <- function(x) { 5 | if (length(x) == 1) NULL 6 | else x[2:length(x)] 7 | } 8 | 9 | ## ------------------------------------------------------------------------ 10 | lin_search <- function(element, sequence) { 11 | if (is_empty(sequence)) FALSE 12 | else if (first(sequence) == element) TRUE 13 | else lin_search(element, rest(sequence)) 14 | } 15 | 16 | x <- 1:5 17 | lin_search(0, x) 18 | lin_search(1, x) 19 | lin_search(5, x) 20 | lin_search(6, x) 21 | 22 | ## ------------------------------------------------------------------------ 23 | is_empty <- function(x) length(x) == 0 24 | first <- function(x) x[1] 25 | rest <- function(x) { 26 | if (length(x) == 1) NULL else x[2:length(x)] 27 | } 28 | 29 | ## ------------------------------------------------------------------------ 30 | next_list <- function(element, rest = NULL) 31 | list(element = element, rest = rest) 32 | 33 | ## ------------------------------------------------------------------------ 34 | x <- next_list(1, 35 | next_list(2, 36 | next_list(3, 37 | next_list(4)))) 38 | 39 | 40 | ## ------------------------------------------------------------------------ 41 | nl_is_empty <- function(nl) is.null(nl) 42 | nl_first <- function(nl) nl$element 43 | nl_rest <- function(nl) nl$rest 44 | 45 | ## ------------------------------------------------------------------------ 46 | nl_lin_search <- function(element, sequence) { 47 | if (nl_is_empty(sequence)) FALSE 48 | else if (nl_first(sequence) == element) TRUE 49 | else nl_lin_search(element, nl_rest(sequence)) 50 | } 51 | 52 | ## ------------------------------------------------------------------------ 53 | vector_to_next_list <- function(x) { 54 | if (is_empty(x)) NULL 55 | else next_list(first(x), vector_to_next_list(rest(x))) 56 | } 57 | 58 | ## ------------------------------------------------------------------------ 59 | i_is_empty <- function(x, i) i > length(x) 60 | i_first <- function(x, i) x[i] 61 | 62 | ## ------------------------------------------------------------------------ 63 | i_vector_to_next_list <- function(x, i = 1) { 64 | if (i_is_empty(x, i)) NULL 65 | else next_list(i_first(x, i), i_vector_to_next_list(x, i + 1)) 66 | } 67 | 68 | ## ------------------------------------------------------------------------ 69 | i_lin_search <- function(element, sequence, i = 1) { 70 | if (i_is_empty(sequence, i)) FALSE 71 | else if (i_first(sequence, i) == element) TRUE 72 | else i_lin_search(element, sequence, i + 1) 73 | } 74 | 75 | ## ------------------------------------------------------------------------ 76 | lin_search <- function(element, sequence, i = 1) { 77 | if (i > length(sequence)) FALSE 78 | else if (sequence[i] == element) TRUE 79 | else lin_search(element, sequence, i + 1) 80 | } 81 | 82 | ## ---- echo=FALSE--------------------------------------------------------- 83 | assert(lin_search(0, 1:5) == FALSE) 84 | assert(lin_search(1, 1:5) == TRUE) 85 | 86 | ## ------------------------------------------------------------------------ 87 | binary_search <- function(element, x, 88 | first = 1, last = length(x)) { 89 | 90 | if (last < first) return(FALSE) # empty sequence 91 | 92 | middle <- (last - first) %/% 2 + first 93 | if (element == x[middle]) { 94 | TRUE 95 | } else if (element < x[middle]) { 96 | binary_search(element, x, first, middle) 97 | } else { 98 | binary_search(element, x, middle, last) 99 | } 100 | } 101 | 102 | ## ------------------------------------------------------------------------ 103 | binary_search <- function(element, x, 104 | first = 1, last = length(x)) { 105 | 106 | if (last < first) return(FALSE) # empty sequence 107 | 108 | middle <- (last - first) %/% 2 + first 109 | if (element == x[middle]) { 110 | TRUE 111 | } else if (element < x[middle]) { 112 | binary_search(element, x, first, middle - 1) 113 | } else { 114 | binary_search(element, x, middle + 1, last) 115 | } 116 | } 117 | 118 | ## ---- echo=FALSE--------------------------------------------------------- 119 | assert(binary_search(0, 1:5) == FALSE) 120 | assert(binary_search(1, 1:5) == TRUE) 121 | assert(binary_search(2, 1:5) == TRUE) 122 | assert(binary_search(3, 1:5) == TRUE) 123 | assert(binary_search(4, 1:5) == TRUE) 124 | assert(binary_search(5, 1:5) == TRUE) 125 | assert(binary_search(6, 1:5) == FALSE) 126 | 127 | ## ------------------------------------------------------------------------ 128 | node_depth <- function(tree, name, depth = 0) { 129 | if (is.null(tree)) return(NA) 130 | if (tree$name == name) return(depth) 131 | 132 | left <- node_depth(tree$left, name, depth + 1) 133 | if (!is.na(left)) return(left) 134 | right <- node_depth(tree$right, name, depth + 1) 135 | return(right) 136 | } 137 | 138 | ## ------------------------------------------------------------------------ 139 | factorial <- function(n) { 140 | if (n == 1) 1 141 | else n * factorial(n - 1) 142 | } 143 | 144 | ## ------------------------------------------------------------------------ 145 | nl_rm_duplicates <- function(x) { 146 | if (is.null(x)) return(NULL) 147 | else if (is.null(x$rest)) return(x) 148 | 149 | rest <- nl_rm_duplicates(x$rest) 150 | if (x$element == rest$element) rest 151 | else next_list(x$element, rest) 152 | } 153 | 154 | (x <- next_list(1, next_list(1, next_list(2, next_list(2))))) 155 | nl_rm_duplicates(x) 156 | 157 | ## ---- echo=FALSE--------------------------------------------------------- 158 | find_duplicates <- which %.% duplicated 159 | 160 | ## ------------------------------------------------------------------------ 161 | vector_rm_duplicates <- function(x) { 162 | dup <- find_duplicates(x) 163 | x[-dup] 164 | } 165 | vector_rm_duplicates(c(1, 1, 2, 2)) 166 | 167 | ## ---- echo=FALSE--------------------------------------------------------- 168 | builtin_find_duplicates <- which %.% duplicated 169 | 170 | ## ------------------------------------------------------------------------ 171 | find_duplicates <- function(x, i = 1) { 172 | if (i >= length(x)) return(c()) 173 | 174 | rest <- find_duplicates(x, i + 1) 175 | if (x[i] == x[i + 1]) c(i, rest) 176 | else rest 177 | } 178 | 179 | ## ---- echo=FALSE--------------------------------------------------------- 180 | x <- c(1,1,2,3,4,4) 181 | assert(all(builtin_find_duplicates(x)-1 == find_duplicates(x))) 182 | 183 | ## ------------------------------------------------------------------------ 184 | size_of_tree <- function(node) { 185 | if (is.null(node$left) && is.null(node$right)) { 186 | size <- 1 187 | } else { 188 | left_size <- size_of_tree(node$left) 189 | right_size <- size_of_tree(node$right) 190 | size <- left_size + right_size + 1 191 | } 192 | size 193 | } 194 | 195 | ## ---- echo=FALSE--------------------------------------------------------- 196 | make_node <- function(name, left = NULL, right = NULL) 197 | list(name = name, left = left, right = right) 198 | 199 | ## ------------------------------------------------------------------------ 200 | tree <- make_node("root", 201 | make_node("C", make_node("A"), 202 | make_node("B")), 203 | make_node("D")) 204 | 205 | size_of_tree(tree) 206 | 207 | ## ------------------------------------------------------------------------ 208 | set_size_of_subtrees <- function(node) { 209 | if (is.null(node$left) && is.null(node$right)) { 210 | node$size <- 1 211 | } else { 212 | left_size <- set_size_of_subtrees(node$left) 213 | right_size <- set_size_of_subtrees(node$right) 214 | node$size <- left_size + right_size + 1 215 | } 216 | node$size 217 | } 218 | 219 | ## ------------------------------------------------------------------------ 220 | set_size_of_subtrees(tree) 221 | tree$size 222 | 223 | ## ------------------------------------------------------------------------ 224 | set_size_of_subtrees <- function(node) { 225 | if (is.null(node$left) && is.null(node$right)) { 226 | node$size <- 1 227 | } else { 228 | left <- set_size_of_subtrees(node$left) 229 | right <- set_size_of_subtrees(node$right) 230 | node$size <- left$size + right$size + 1 231 | } 232 | node 233 | } 234 | 235 | tree <- set_size_of_subtrees(tree) 236 | tree$size 237 | 238 | ## ------------------------------------------------------------------------ 239 | depth_first_numbers <- function(node, dfn = 1) { 240 | if (is.null(node$left) && is.null(node$right)) { 241 | node$range <- c(dfn, dfn) 242 | new_table <- table 243 | table <- c() 244 | table[node$name] <- dfn 245 | list(node = node, new_dfn = dfn + 1, table = table) 246 | 247 | } else { 248 | left <- depth_first_numbers(node$left, dfn) 249 | right <- depth_first_numbers(node$right, left$new_dfn) 250 | 251 | new_dfn <- right$new_dfn 252 | new_node <- make_node(node$name, left$node, right$node) 253 | new_node$range <- c(left$node$range[1], new_dfn) 254 | table <- c(left$table, right$table) 255 | table[node$name] <- new_dfn 256 | list(node = new_node, new_dfn = new_dfn + 1, table = table) 257 | } 258 | } 259 | 260 | ## ------------------------------------------------------------------------ 261 | df <- depth_first_numbers(tree) 262 | df$node$range 263 | df$table 264 | 265 | ## ------------------------------------------------------------------------ 266 | in_df_range <- function(i, df_range) 267 | df_range[1] <= i && i <= df_range[2] 268 | 269 | ## ------------------------------------------------------------------------ 270 | node_depth <- function(tree, name, dfn_table, depth = 0) { 271 | dfn <- dfn_table[name] 272 | 273 | if (is.null(tree) || !in_df_range(dfn, tree$range)) { 274 | return(NA) 275 | } 276 | if (tree$name == name) { 277 | return(depth) 278 | } 279 | 280 | if (in_df_range(dfn, tree$left$range)) { 281 | node_depth(tree$left, name, dfn_table, depth + 1) 282 | } else if (in_df_range(dfn, tree$right$range)) { 283 | node_depth(tree$right, name, dfn_table, depth + 1) 284 | } else { 285 | NA 286 | } 287 | } 288 | 289 | node_depth <- Vectorize(node_depth, 290 | vectorize.args = "name", 291 | USE.NAMES = FALSE) 292 | node_depth(df$node, LETTERS[1:4], df$table) 293 | 294 | ## ------------------------------------------------------------------------ 295 | factorial <- function(n) { 296 | if (n == 1) 1 297 | else n * factorial(n - 1) 298 | } 299 | 300 | ## ------------------------------------------------------------------------ 301 | factorial <- function(n, acc = 1) { 302 | if (n == 1) acc 303 | else factorial(n - 1, acc * n) 304 | } 305 | 306 | ## ---- echo=FALSE--------------------------------------------------------- 307 | assert(factorial(3) == 3*2) 308 | 309 | ## ------------------------------------------------------------------------ 310 | find_duplicates <- function(x, i = 1) { 311 | if (i >= length(x)) return(c()) 312 | rest <- find_duplicates(x, i + 1) 313 | if (x[i] == x[i + 1]) c(i, rest) else rest 314 | } 315 | 316 | ## ------------------------------------------------------------------------ 317 | find_duplicates <- function(x, i = 1, acc = c()) { 318 | if (i >= length(x)) return(acc) 319 | if (x[i] == x[i + 1]) find_duplicates(x, i + 1, c(acc, i)) 320 | else find_duplicates(x, i + 1, acc) 321 | } 322 | 323 | ## ---- echo=FALSE--------------------------------------------------------- 324 | assert(all(find_duplicates(c(1,1,2,2)) == c(1,3))) 325 | 326 | ## ------------------------------------------------------------------------ 327 | r_lin_search <- function(element, sequence, i = 1) { 328 | if (i > length(sequence)) FALSE 329 | else if (sequence[i] == element) TRUE 330 | else r_lin_search(element, sequence, i + 1) 331 | } 332 | 333 | ## ------------------------------------------------------------------------ 334 | l_lin_search <- function(element, sequence) { 335 | for (e in sequence) { 336 | if (e == element) return(TRUE) 337 | } 338 | return(FALSE) 339 | } 340 | 341 | ## ----lin_search_comparison, cache=TRUE----------------------------------- 342 | x <- 1:1000 343 | microbenchmark(r_lin_search(-1, x), 344 | l_lin_search(-1, x)) 345 | 346 | 347 | ## ------------------------------------------------------------------------ 348 | r_binary_search <- function(element, x, 349 | first = 1, last = length(x)) { 350 | if (last < first) return(FALSE) # empty sequence 351 | 352 | middle <- (last - first) %/% 2 + first 353 | if (element == x[middle]) TRUE 354 | else if (element < x[middle]) { 355 | r_binary_search(element, x, first, middle - 1) 356 | } else { 357 | r_binary_search(element, x, middle + 1, last) 358 | } 359 | } 360 | 361 | ## ------------------------------------------------------------------------ 362 | l_binary_search <- function(element, x, 363 | first = 1, last = length(x)) { 364 | repeat { 365 | if (last < first) return(FALSE) # empty sequence 366 | 367 | middle <- (last - first) %/% 2 + first 368 | if (element == x[middle]) return(TRUE) 369 | 370 | else if (element < x[middle]) { 371 | last <- middle - 1 372 | } else { 373 | first <- middle + 1 374 | } 375 | } 376 | } 377 | 378 | ## ----bin_search_benchmark, cache=TRUE------------------------------------ 379 | x <- 1:10000000 380 | microbenchmark(r_binary_search(-1, x), 381 | l_binary_search(-1, x)) 382 | 383 | -------------------------------------------------------------------------------- /Functional-Programming/03_scope_and_closures.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | x <- 2 ; y <- 2 3 | x + y 4 | 5 | ## ------------------------------------------------------------------------ 6 | quote(x + y) 7 | 8 | ## ------------------------------------------------------------------------ 9 | eval(x + y) 10 | 11 | ## ------------------------------------------------------------------------ 12 | eval(quote(x + y)) 13 | 14 | ## ------------------------------------------------------------------------ 15 | env <- new.env() 16 | env$x <- 4 17 | 18 | ## ------------------------------------------------------------------------ 19 | env <- list2env(list(x = 4)) 20 | 21 | ## ------------------------------------------------------------------------ 22 | eval(x + y, env) 23 | 24 | ## ------------------------------------------------------------------------ 25 | eval(quote(x + y), env) 26 | 27 | ## ---- echo=FALSE--------------------------------------------------------- 28 | rm(x) ; rm(y) ; rm(env) 29 | 30 | ## ------------------------------------------------------------------------ 31 | y <- 2 32 | f <- function(x) { 33 | result <- x + y 34 | y <- 3 35 | return(result) 36 | } 37 | f(2) 38 | 39 | ## ------------------------------------------------------------------------ 40 | f <- function(condx, x, dondy, y) { 41 | if (condx) x <- 2 42 | if (condy) y <- 2 43 | x + y 44 | } 45 | 46 | ## ------------------------------------------------------------------------ 47 | f <- function(x, y = 2 * x) x + y 48 | 49 | ## ------------------------------------------------------------------------ 50 | f(x = 2) 51 | 52 | ## ------------------------------------------------------------------------ 53 | f <- function(x) { 54 | g <- function(y) x + y 55 | g(x) 56 | } 57 | f(2) 58 | 59 | ## ------------------------------------------------------------------------ 60 | f <- function(x) { 61 | g <- function(y) x + y 62 | g 63 | } 64 | h <- f(2) 65 | h(2) 66 | 67 | ## ------------------------------------------------------------------------ 68 | h1 <- f(1) 69 | h2 <- f(2) 70 | 71 | ## ------------------------------------------------------------------------ 72 | gg <- function(ff) ff(1) 73 | gg(h1) 74 | gg(h2) 75 | 76 | ## ------------------------------------------------------------------------ 77 | make_adder <- function(x) { 78 | add_y <- function(y) x + y 79 | add_y 80 | } 81 | add1 <- make_adder(1) 82 | add2 <- make_adder(2) 83 | 84 | ## ------------------------------------------------------------------------ 85 | make_counter <- function() { 86 | x <- 0 87 | count <- function() { 88 | x <- x + 1 89 | x 90 | } 91 | } 92 | counter <- make_counter() 93 | 94 | ## ------------------------------------------------------------------------ 95 | counter() 96 | counter() 97 | counter() 98 | 99 | ## ------------------------------------------------------------------------ 100 | make_counter <- function() { 101 | x <- 0 102 | count <- function() { 103 | x <<- x + 1 104 | x 105 | } 106 | } 107 | counter <- make_counter() 108 | counter() 109 | counter() 110 | counter() 111 | 112 | ## ------------------------------------------------------------------------ 113 | depth_first_numbers <- function(tree) { 114 | table <- c() 115 | counter <- make_counter() 116 | 117 | traverse_tree <- function(node) { 118 | if (is.null(node$left) && is.null(node$right)) { 119 | dfn <- counter() 120 | node$range <- c(dfn, dfn) 121 | table[node$name] <<- dfn 122 | node 123 | 124 | } else { 125 | left <- traverse_tree(node$left) 126 | right <- traverse_tree(node$right) 127 | new_node <- make_node(node$name, left, right) 128 | new_node$range <- c(left$range[1], right$range[2]) 129 | new_node 130 | } 131 | } 132 | 133 | new_tree <- traverse_tree(tree) 134 | list(tree = new_tree, table = table) 135 | } 136 | 137 | ## ---- echo=FALSE--------------------------------------------------------- 138 | make_node <- function(name, left = NULL, right = NULL) 139 | list(name = name, left = left, right = right) 140 | 141 | print_tree <- function(tree) { 142 | build_string <- function(node) { 143 | if (is.null(node$left) && is.null(node$right)) { 144 | node$name 145 | } else { 146 | left <- build_string(node$left) 147 | right <- build_string(node$right) 148 | paste0("(", left, ",", right, ")") 149 | } 150 | } 151 | build_string(tree) 152 | } 153 | 154 | tree <- make_node("root", 155 | make_node("C", make_node("A"), 156 | make_node("B")), 157 | make_node("D")) 158 | 159 | ## ------------------------------------------------------------------------ 160 | result <- depth_first_numbers(tree) 161 | print_tree(result$tree) 162 | result$table 163 | 164 | ## ------------------------------------------------------------------------ 165 | x <- 2; y <- 2 166 | eval(quote(x + y)) 167 | 168 | ## ------------------------------------------------------------------------ 169 | rm(x); rm(y) 170 | f <- function() { 171 | x <- 2; y <- 2 172 | eval(quote(x + y)) 173 | } 174 | f() 175 | 176 | ## ------------------------------------------------------------------------ 177 | f <- function(x) { 178 | x <- x 179 | g <- function(y) { 180 | y 181 | eval(quote(x + y)) 182 | } 183 | g(2) 184 | } 185 | f(2) 186 | 187 | -------------------------------------------------------------------------------- /Functional-Programming/04_higher_order_functions.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | sapply(1:4, sqrt) 3 | 4 | ## ------------------------------------------------------------------------ 5 | myapply <- function(x, f) { 6 | result <- x 7 | for (i in seq_along(x)) result[i] <- f(x[i]) 8 | result 9 | } 10 | 11 | myapply(1:4, sqrt) 12 | 13 | ## ------------------------------------------------------------------------ 14 | rescale <- function(x) { 15 | m <- mean(x) 16 | s <- sd(x) 17 | (x - m) / s 18 | } 19 | rescale(1:4) 20 | 21 | ## ------------------------------------------------------------------------ 22 | rescale <- function(x) { 23 | m <- mean(x) 24 | s <- sd(x) 25 | f <- function(y) (y - m) / s 26 | myapply(x, f) 27 | } 28 | rescale(1:4) 29 | 30 | ## ------------------------------------------------------------------------ 31 | rescale <- function(x) { 32 | m <- mean(x) 33 | s <- sd(x) 34 | myapply(x, function(y) (y - m) / s) 35 | } 36 | rescale(1:4) 37 | 38 | ## ------------------------------------------------------------------------ 39 | f <- function(x, y) x + y 40 | 41 | ## ------------------------------------------------------------------------ 42 | g <- function(y) f(2, y) 43 | myapply(1:4, g) 44 | 45 | ## ------------------------------------------------------------------------ 46 | h <- function(x) function(y) f(x, y) 47 | myapply(1:4, h(2)) 48 | 49 | ## ------------------------------------------------------------------------ 50 | f(2, 2) 51 | h(2)(2) 52 | 53 | ## ------------------------------------------------------------------------ 54 | curry2 <- function(f) 55 | function(x) function(y) f(x, y) 56 | 57 | ## ------------------------------------------------------------------------ 58 | h <- curry2(f) 59 | f(2, 3) 60 | h(2)(3) 61 | 62 | ## ------------------------------------------------------------------------ 63 | h <- curry2(`+`) 64 | h(2)(3) 65 | 66 | ## ------------------------------------------------------------------------ 67 | myapply(1:4, curry2(`+`)(2)) 68 | 69 | ## ------------------------------------------------------------------------ 70 | curry <- function(f) { 71 | n <- length(formals(f)) 72 | if (n == 1) return(f) # no currying needed 73 | 74 | arguments <- vector("list", length = n) 75 | last <- function(x) { 76 | arguments[n] <<- x 77 | do.call(f, arguments) 78 | } 79 | make_i <- function(i, continuation) { 80 | force(i) ; force(continuation) 81 | function(x) { 82 | arguments[i] <<- x 83 | continuation 84 | } 85 | } 86 | 87 | continuation <- last 88 | for (i in seq(n-1, 1)) { 89 | continuation <- make_i(i, continuation) 90 | } 91 | continuation 92 | } 93 | 94 | ## ------------------------------------------------------------------------ 95 | f <- function(x, y, z) x + 2*y + 3*z 96 | f(1, 2, 3) 97 | curry(f)(1)(2)(3) 98 | 99 | ## ------------------------------------------------------------------------ 100 | bind_parameters <- function(f, ...) { 101 | remembered <- list(...) 102 | function(...) { 103 | new <- list(...) 104 | do.call(f, c(remembered, new)) 105 | } 106 | } 107 | 108 | f <- function(x, y, z, w = 4) x + 2*y + 3*z + 4*w 109 | 110 | f(1, 2, 3, 4) 111 | g <- bind_parameters(f, y = 2) 112 | g(x = 1, z = 3) 113 | 114 | h <- bind_parameters(f, y = 1, w = 1) 115 | f(2, 1, 3, 1) 116 | h(x = 2, z = 3) 117 | 118 | ## ------------------------------------------------------------------------ 119 | my_sum_direct <- function(lst) { 120 | if (is_empty(lst)) 0 121 | else first(lst) + my_sum_direct(rest(lst)) 122 | } 123 | my_sum_acc <- function(lst, acc = 0) { 124 | if (is_empty(lst)) acc 125 | else my_sum_acc(rest(lst), first(lst) + acc) 126 | } 127 | my_sum_cont <- function(lst, cont = identity) { 128 | if (is_empty(lst)) cont(0) 129 | else my_sum_cont(rest(lst), 130 | function(acc) cont(first(lst) + acc)) 131 | } 132 | 133 | ## ---- echo=FALSE--------------------------------------------------------- 134 | make_node <- function(name, left = NULL, right = NULL) 135 | list(name = name, left = left, right = right) 136 | 137 | tree <- make_node("root", 138 | make_node("C", make_node("A"), 139 | make_node("B")), 140 | make_node("D")) 141 | 142 | ## ------------------------------------------------------------------------ 143 | size_of_tree <- function(node, continuation = identity) { 144 | if (is.null(node$left) && is.null(node$right)) { 145 | continuation(1) 146 | } else { 147 | new_continuation <- function(left_result) { 148 | continuation(left_result + size_of_tree(node$right) + 1) 149 | } 150 | size_of_tree(node$left, new_continuation) 151 | } 152 | } 153 | 154 | size_of_tree(tree) 155 | 156 | ## ------------------------------------------------------------------------ 157 | size_of_tree <- function(node) { 158 | continuation <- identity # function(x) x 159 | repeat { 160 | if (is.null(node$left) && is.null(node$right)) { 161 | return(continuation(1)) 162 | } 163 | new_continuation <- function(continuation) { 164 | force(continuation) 165 | function(left_result) { 166 | continuation(left_result + size_of_tree(node$right) + 1) 167 | } 168 | } 169 | # simulated recursive call 170 | node <- node$left 171 | continuation <- new_continuation(continuation) 172 | } 173 | } 174 | 175 | size_of_tree(tree) 176 | 177 | ## ------------------------------------------------------------------------ 178 | make_thunk <- function(f, ...) { 179 | force(f) 180 | params <- list(...) 181 | function() do.call(f, params) 182 | } 183 | 184 | ## ------------------------------------------------------------------------ 185 | f <- function(x, y) x + y 186 | thunk <- make_thunk(f, 2, 2) 187 | thunk() 188 | 189 | ## ------------------------------------------------------------------------ 190 | trampoline <- function(thunk) { 191 | while (is.function(thunk)) thunk <- thunk() 192 | thunk 193 | } 194 | 195 | ## ------------------------------------------------------------------------ 196 | factorial <- function(n, acc = 1) { 197 | if (n == 1) acc 198 | else factorial(n - 1, acc * n) 199 | } 200 | 201 | ## ----cp_factorial, cache=TRUE-------------------------------------------- 202 | cp_factorial <- function(n, continuation = identity) { 203 | if (n == 1) { 204 | continuation(1) 205 | } else { 206 | new_continuation <- function(result) { 207 | continuation(result * n) 208 | } 209 | cp_factorial(n - 1, new_continuation) 210 | } 211 | } 212 | 213 | factorial(10) 214 | cp_factorial(10) 215 | 216 | ## ------------------------------------------------------------------------ 217 | thunk_factorial <- function(n, continuation = identity) { 218 | if (n == 1) { 219 | continuation(1) 220 | } else { 221 | new_continuation <- function(result) { 222 | make_thunk(continuation, n * result) 223 | } 224 | make_thunk(thunk_factorial, n - 1, new_continuation) 225 | } 226 | } 227 | 228 | ## ------------------------------------------------------------------------ 229 | thunk_factorial(1) 230 | 231 | ## ------------------------------------------------------------------------ 232 | thunk_factorial(2)()() 233 | 234 | ## ----thunk_factorial_explicit, cache=TRUE-------------------------------- 235 | thunk_factorial(3)()()()() 236 | thunk_factorial(4)()()()()()() 237 | thunk_factorial(5)()()()()()()()() 238 | 239 | ## ----trampoline_thunk, cache=TRUE---------------------------------------- 240 | trampoline(thunk_factorial(100)) 241 | 242 | ## ----trampoline_thunk_function, cache=TRUE------------------------------- 243 | make_trampoline <- function(f) function(...) trampoline(f(...)) 244 | factorial <- make_trampoline(thunk_factorial) 245 | factorial(100) 246 | 247 | ## ------------------------------------------------------------------------ 248 | thunk_size <- function(node, continuation = identity) { 249 | if (is.null(node$left) && is.null(node$right)) { 250 | continuation(1) 251 | } else { 252 | new_continuation <- function(left_result) 253 | make_thunk(continuation, 254 | left_result + thunk_size(node$right) + 1) 255 | make_thunk(thunk_size, node$left, new_continuation) 256 | } 257 | } 258 | 259 | size_of_tree <- make_trampoline(thunk_size) 260 | size_of_tree(tree) 261 | 262 | -------------------------------------------------------------------------------- /Functional-Programming/05_filter_map_and_reduce.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | list(1, 2, 3, 4) 3 | 4 | ## ------------------------------------------------------------------------ 5 | 1:4 6 | 7 | ## ------------------------------------------------------------------------ 8 | as.list(1:4) 9 | 10 | ## ------------------------------------------------------------------------ 11 | list(1:4) 12 | 13 | ## ------------------------------------------------------------------------ 14 | is_even <- function(x) x %% 2 == 0 15 | unlist(Filter(is_even, 1:10)) 16 | 17 | ## ------------------------------------------------------------------------ 18 | larger_than <- function(x) function(y) y > x 19 | unlist(Filter(larger_than(5), 1:10)) 20 | 21 | ## ---- echo=FALSE--------------------------------------------------------- 22 | curry2 <- function(f) function(x) function(y) f(x, y) 23 | 24 | ## ------------------------------------------------------------------------ 25 | unlist(Filter(curry2(`<`)(5), 1:10)) 26 | unlist(Filter(curry2(`>=`)(5), 1:10)) 27 | 28 | ## ------------------------------------------------------------------------ 29 | rcurry2 <- function(f) function(y) function(x) f(x, y) 30 | unlist(Filter(rcurry2(`>=`)(5), 1:10)) 31 | unlist(Filter(rcurry2(`<`)(5), 1:10)) 32 | 33 | ## ------------------------------------------------------------------------ 34 | s <- list(a = 1:10, b = list(1,2,3,4,5,6), 35 | c = y ~ x1 + x2 + x3, d = vector("numeric")) 36 | Filter(function(x) length(x) > 5, s) 37 | 38 | ## ------------------------------------------------------------------------ 39 | unlist(Map(is_even, 1:5)) 40 | 41 | ## ------------------------------------------------------------------------ 42 | add <- function(x) function(y) x + y 43 | unlist(Map(add(2), 1:5)) 44 | unlist(Map(add(3), 1:5)) 45 | 46 | ## ------------------------------------------------------------------------ 47 | s <- list(a = 1:10, b = list(1,2,3,4,5,6), 48 | c = y ~ x1 + x2 + x3, d = vector("numeric")) 49 | unlist(Map(length, s)) 50 | 51 | ## ------------------------------------------------------------------------ 52 | unlist(Map(`+`, 1:5, 1:5)) 53 | 54 | ## ------------------------------------------------------------------------ 55 | x <- 1:10 56 | y <- c(NA, x) 57 | s <- list(x = x, y = y) 58 | unlist(Map(mean, s)) 59 | unlist(Map(mean, s, na.rm = TRUE)) 60 | 61 | ## ------------------------------------------------------------------------ 62 | unlist(Map(mean, s, MoreArgs = list(na.rm = TRUE))) 63 | 64 | ## ------------------------------------------------------------------------ 65 | scale <- function(x, y) (x - mean(y))/sd(y) 66 | 67 | ## ------------------------------------------------------------------------ 68 | unlist(Map(scale, 1:10, 1:5)) 69 | 70 | ## ------------------------------------------------------------------------ 71 | unlist(Map(scale, 1:10, y = 1:5)) 72 | 73 | ## ------------------------------------------------------------------------ 74 | unlist(Map(scale, 1:10, MoreArgs = list(y = 1:5))) 75 | 76 | ## ------------------------------------------------------------------------ 77 | s <- list(a = 1:10, b = list(1,2,3,4,5,6), 78 | c = y ~ x1 + x2 + x3, d = vector("numeric")) 79 | unlist(Map(length, s)) 80 | 81 | ## ------------------------------------------------------------------------ 82 | Reduce(`+`, 1:5) 83 | 84 | ## ------------------------------------------------------------------------ 85 | Reduce(`+`, 1:5, accumulate = TRUE) 86 | 87 | ## ------------------------------------------------------------------------ 88 | Reduce(`+`, 1:5, right = TRUE, accumulate = TRUE) 89 | 90 | ## ------------------------------------------------------------------------ 91 | Reduce(`+`, 1:5, init = 10, accumulate = TRUE) 92 | 93 | ## ------------------------------------------------------------------------ 94 | Reduce(`*`, 1:5) 95 | Reduce(`*`, 1:5, accumulate = TRUE) 96 | Reduce(`*`, 1:5, right = TRUE, accumulate = TRUE) 97 | 98 | ## ------------------------------------------------------------------------ 99 | samples <- replicate(3, sample(1:10, replace = TRUE), 100 | simplify = FALSE) 101 | str(samples) 102 | Reduce(intersect, samples) 103 | 104 | ## ---- echo=FALSE--------------------------------------------------------- 105 | make_node <- function(name, left = NULL, right = NULL) 106 | list(name = name, left = left, right = right) 107 | 108 | print_tree <- function(tree) { 109 | build_string <- function(node) { 110 | if (is.null(node$left) && is.null(node$right)) { 111 | node$name 112 | } else { 113 | left <- build_string(node$left) 114 | right <- build_string(node$right) 115 | paste0("(", left, ",", right, ")") 116 | } 117 | } 118 | build_string(tree) 119 | } 120 | 121 | size_of_tree <- function(node) { 122 | if (is.null(node$left) && is.null(node$right)) { 123 | size <- 1 124 | } else { 125 | left_size <- size_of_tree(node$left) 126 | right_size <- size_of_tree(node$right) 127 | size <- left_size + right_size + 1 128 | } 129 | size 130 | } 131 | 132 | ## ------------------------------------------------------------------------ 133 | A <- make_node("A") 134 | C <- make_node("C", make_node("A"), 135 | make_node("B")) 136 | E <- make_node("E", 137 | make_node("C", make_node("A"), make_node("B")), 138 | make_node("D")) 139 | 140 | trees <- list(A = A, C = C, E = E) 141 | 142 | ## ------------------------------------------------------------------------ 143 | trees[[2]] 144 | unlist(trees[[2]]) 145 | print_tree(trees[[2]]) 146 | 147 | ## ------------------------------------------------------------------------ 148 | Map(print_tree, trees) 149 | unlist(Map(print_tree, trees)) 150 | 151 | ## ------------------------------------------------------------------------ 152 | unlist(Map(print_tree, 153 | Filter(function(tree) size_of_tree(tree) > 1, trees))) 154 | 155 | ## ------------------------------------------------------------------------ 156 | unlist(Map(size_of_tree, trees)) 157 | Reduce(`+`, Map(size_of_tree, trees), 0) 158 | 159 | ## ---- echo=FALSE--------------------------------------------------------- 160 | node_depth <- function(tree, name, depth = 0) { 161 | if (is.null(tree)) return(NA) 162 | if (tree$name == name) return(depth) 163 | 164 | left <- node_depth(tree$left, name, depth + 1) 165 | if (!is.na(left)) return(left) 166 | right <- node_depth(tree$right, name, depth + 1) 167 | return(right) 168 | } 169 | 170 | ## ------------------------------------------------------------------------ 171 | node_depth_B <- function(tree) node_depth(tree, "B") 172 | unlist(Map(node_depth_B, trees)) 173 | 174 | ## ------------------------------------------------------------------------ 175 | unlist(Map(node_depth_B, trees), use.names = FALSE) 176 | 177 | ## ------------------------------------------------------------------------ 178 | Filter(function(x) !is.na(x), 179 | unlist(Map(node_depth_B, trees), use.names = FALSE)) 180 | 181 | ## ------------------------------------------------------------------------ 182 | has_B <- function(node) { 183 | if (node$name == "B") return(TRUE) 184 | if (is.null(node$left) && is.null(node$right)) return(FALSE) 185 | has_B(node$left) || has_B(node$right) 186 | } 187 | unlist(Map(node_depth_B, Filter(has_B, trees)), use.names = FALSE) 188 | 189 | ## ------------------------------------------------------------------------ 190 | sapply(trees, size_of_tree) 191 | sapply(trees, identity) 192 | 193 | ## ------------------------------------------------------------------------ 194 | vapply(trees, size_of_tree, 1) 195 | 196 | ## ------------------------------------------------------------------------ 197 | lapply(trees, size_of_tree) 198 | 199 | ## ------------------------------------------------------------------------ 200 | (m <- matrix(1:6, nrow=2, byrow=TRUE)) 201 | 202 | ## ------------------------------------------------------------------------ 203 | collaps_input <- function(x) paste(x, collapse = ":") 204 | 205 | ## ------------------------------------------------------------------------ 206 | apply(m, 1, collaps_input) 207 | 208 | ## ------------------------------------------------------------------------ 209 | apply(m, 2, collaps_input) 210 | 211 | ## ------------------------------------------------------------------------ 212 | apply(m, c(1, 2), collaps_input) 213 | 214 | ## ------------------------------------------------------------------------ 215 | (x <- rnorm(10)) 216 | (categories <- sample(c("A", "B", "C"), size = 10, replace = TRUE)) 217 | tapply(x, categories, mean) 218 | 219 | ## ------------------------------------------------------------------------ 220 | (categories2 <- sample(c("X", "Y"), size = 10, replace = TRUE)) 221 | tapply(x, list(categories, categories2), mean) 222 | 223 | ## ------------------------------------------------------------------------ 224 | library(purrr) 225 | 226 | ## ------------------------------------------------------------------------ 227 | keep(1:5, rcurry2(`>`)(3)) 228 | discard(1:5, rcurry2(`>`)(3)) 229 | 230 | ## ------------------------------------------------------------------------ 231 | keep(as.list(1:5), rcurry2(`>`)(3)) 232 | 233 | ## ------------------------------------------------------------------------ 234 | every(1:5, rcurry2(`>`)(0)) 235 | every(1:5, rcurry2(`>`)(3)) 236 | some(1:5, rcurry2(`>`)(3)) 237 | some(1:5, rcurry2(`>`)(6)) 238 | 239 | ## ------------------------------------------------------------------------ 240 | keep(1:5, ~ .x > 3) 241 | discard(1:5, ~ .x > 3) 242 | 243 | ## ------------------------------------------------------------------------ 244 | map(1:5, ~ .x + 2) 245 | map_dbl(1:5, ~ .x + 2) 246 | 247 | ## ------------------------------------------------------------------------ 248 | map2(1:5, 6:10, ~ 2 * .x + .y) 249 | map2_dbl(1:5, 6:10, ~ 2 * .x + .y) 250 | 251 | ## ------------------------------------------------------------------------ 252 | pmap(list(1:5, 6:10, 11:15), 253 | function(x, y, z) x + y + z) 254 | pmap_dbl(list(1:5, 6:10, 11:15), 255 | function(x, y, z) x + y + z) 256 | 257 | ## ------------------------------------------------------------------------ 258 | unlist(map_if(1:5, ~ .x %% 2 == 1, ~ 2*.x)) 259 | 260 | ## ------------------------------------------------------------------------ 261 | map_chr(map(keep(trees, ~ size_of_tree(.x) > 1), "left"), 262 | print_tree) 263 | 264 | ## ------------------------------------------------------------------------ 265 | reduce(1:5, `+`) 266 | reduce_right(1:5, `*`) 267 | 268 | -------------------------------------------------------------------------------- /Functional-Programming/06_point_free_programming.R: -------------------------------------------------------------------------------- 1 | ## ------------------------------------------------------------------------ 2 | compose <- function(g, f) function(...) g(f(...)) 3 | 4 | ## ---- echo=FALSE--------------------------------------------------------- 5 | curry2 <- function(f) function(x) function(y) f(x, y) 6 | 7 | ## ------------------------------------------------------------------------ 8 | umap <- compose(unlist, Map) 9 | umap(curry2(`+`)(2), 1:4) 10 | 11 | ## ------------------------------------------------------------------------ 12 | library(pryr) 13 | umap <- unlist %.% Map 14 | umap(curry2(`+`)(2), 1:4) 15 | 16 | ## ------------------------------------------------------------------------ 17 | rmse <- sqrt %.% mean %.% function(x, y) (x - y)**2 18 | rmse(1:4, 2:5) 19 | 20 | ## ------------------------------------------------------------------------ 21 | `%;%` <- function(f, g) function(...) g(f(...)) 22 | rmse <- (function(x, y) (x - y)**2) %;% mean %;% sqrt 23 | rmse(1:4, 2:5) 24 | 25 | ## ------------------------------------------------------------------------ 26 | library(magrittr) 27 | 1:4 %>% mean %>% sqrt 28 | 29 | ## ------------------------------------------------------------------------ 30 | rnorm(4) %>% data.frame(x = ., y = cos(.)) 31 | 32 | ## ------------------------------------------------------------------------ 33 | rnorm(4) %>% data.frame(x = sin(.), y = cos(.)) 34 | 35 | ## ------------------------------------------------------------------------ 36 | mean_sqrt <- 1:4 %>% mean %>% sqrt 37 | mean_sqrt 38 | 39 | ## ------------------------------------------------------------------------ 40 | mean_sqrt <- . %>% mean %>% sqrt 41 | mean_sqrt(1:4) 42 | 43 | ## ------------------------------------------------------------------------ 44 | 1:4 %>% mean_sqrt 45 | 46 | ## ------------------------------------------------------------------------ 47 | rmse <- . %>% { (.$x - .$y)**2 } %>% mean %>% sqrt 48 | data.frame(x = 1:4, y = 2:5) %>% rmse 49 | 50 | ## ------------------------------------------------------------------------ 51 | rnorm(4) %>% { data.frame(x = sin(.), y = cos(.)) } 52 | 53 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Apress/functional-prog-in-r/4e3e67dde06d15eb6729835553986fbfe07b1498/LICENSE.txt -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Apress Source Code 2 | 3 | This repository accompanies [*Functional Programming in R*](http://www.apress.com/9781484227459) by Thomas Mailund (Apress, 2017). 4 | 5 | [comment]: #cover 6 | 7 | 8 | Download the files as a zip using the green button, or clone the repository to your machine using Git. 9 | 10 | ## Releases 11 | 12 | Release v1.0 corresponds to the code in the published book, without corrections or updates. 13 | 14 | ## Contributions 15 | 16 | See the file Contributing.md for more information on how you can contribute to this repository. 17 | -------------------------------------------------------------------------------- /contributing.md: -------------------------------------------------------------------------------- 1 | # Contributing to Apress Source Code 2 | 3 | Copyright for Apress source code belongs to the author(s). However, under fair use you are encouraged to fork and contribute minor corrections and updates for the benefit of the author(s) and other readers. 4 | 5 | ## How to Contribute 6 | 7 | 1. Make sure you have a GitHub account. 8 | 2. Fork the repository for the relevant book. 9 | 3. Create a new branch on which to make your change, e.g. 10 | `git checkout -b my_code_contribution` 11 | 4. Commit your change. Include a commit message describing the correction. Please note that if your commit message is not clear, the correction will not be accepted. 12 | 5. Submit a pull request. 13 | 14 | Thank you for your contribution! --------------------------------------------------------------------------------