├── .Rbuildignore ├── .gitignore ├── utils.R ├── keep-and-helpers.R ├── include-in-pkgs.Rproj ├── CODE_OF_CONDUCT.md ├── README.md ├── README.Rmd ├── safely.R └── map.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^README\.Rmd$ 2 | ^CODE_OF_CONDUCT\.md$ 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /utils.R: -------------------------------------------------------------------------------- 1 | `%l0%` <- function(x, y) if (length(x) == 0) y else x 2 | `%||%` <- function(x, y) if (is.null(x)) y else x 3 | `%@%` <- function (x, name) attr(x, name, exact = TRUE) 4 | -------------------------------------------------------------------------------- /keep-and-helpers.R: -------------------------------------------------------------------------------- 1 | is_empty <- function(x) length(x) == 0 2 | 3 | keep <- function(.x, .p, ...) { 4 | .x[map_lgl(.x, .p, ...)] 5 | } 6 | 7 | discard <- function(.x, .p, ...) { 8 | .x[!map_lgl(.x, .p, ...)] 9 | } 10 | 11 | compact <- function(.x, .p=identity) { 12 | discard(.x, function(x) is_empty(.p(x))) 13 | } 14 | 15 | -------------------------------------------------------------------------------- /include-in-pkgs.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 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | -------------------------------------------------------------------------------- /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 4 | contribute through reporting issues, posting feature requests, updating documentation, 5 | submitting pull requests or patches, and other activities. 6 | 7 | We are committed to making participation in this project a harassment-free experience for 8 | everyone, regardless of level of experience, gender, gender identity and expression, 9 | sexual orientation, disability, personal appearance, body size, race, ethnicity, age, or religion. 10 | 11 | Examples of unacceptable behavior by participants include the use of sexual language or 12 | imagery, derogatory comments or personal attacks, trolling, public or private harassment, 13 | insults, or other unprofessional conduct. 14 | 15 | Project maintainers have the right and responsibility to remove, edit, or reject comments, 16 | commits, code, wiki edits, issues, and other contributions that are not aligned to this 17 | Code of Conduct. Project maintainers who do not follow the Code of Conduct may be removed 18 | from the project team. 19 | 20 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by 21 | opening an issue or contacting one or more of the project maintainers. 22 | 23 | This Code of Conduct is adapted from the Contributor Covenant 24 | (http://contributor-covenant.org), version 1.0.0, available at 25 | http://contributor-covenant.org/version/1/0/0/ 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # include-in-pkgs 5 | 6 | R code/files that are meant to be *copied into new packages* (i.e. this 7 | repo is not a pkg just files with code) to both reduce dependencies in 8 | general but also reduce dependencies on compiled code. 9 | 10 | Unless otherwise noted in a comment near a function, these are all 11 | implemented in base R. 12 | 13 | The compiled code equivalents are (generally) faster than these and most 14 | of them also have more robust features. Basically: use these components 15 | if they cover your use-cases *and* if the benefits of a thinner 16 | dependency stack outweigh the performance penalty costs. 17 | 18 | Contributions can be made via PR or issues. 19 | 20 | # IF YOU WANT EASIER ACCESS TO THESE IN A PACKAGE 21 | 22 | Try [`freebase`ing](https://github.com/hrbrmstr/freebase). 23 | 24 | ## Available things 25 | 26 | - `is_empty()` 27 | - `%l0%` 28 | - `%||%` 29 | - `%@%` 30 | - `safely()` 31 | - `quietly()` 32 | - `possibly()` 33 | - `keep()` 34 | - `discard()` 35 | - `compact()` 36 | - `bind_rows()` 37 | - `map()` 38 | - `map_chr()` 39 | - `map_dbl()` 40 | - `map_df()` 41 | - `map_int()` 42 | - `map_lgl()` 43 | - `map2()` 44 | - `map2_chr()` 45 | - `map2_dbl()` 46 | - `map2_df()` 47 | - `map2_int()` 48 | - `map2_lgl()` 49 | 50 | ## Code of Conduct 51 | 52 | Please note that this project is released with a [Contributor Code of 53 | Conduct](CODE_OF_CONDUCT.md). By participating in this project you agree 54 | to abide by its terms. 55 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r setup, include = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>" 11 | ) 12 | ``` 13 | # include-in-pkgs 14 | 15 | R code/files that are meant to be _copied into new packages_ (i.e. this repo is not a pkg just files with code) to both reduce dependencies in general but also reduce dependencies on compiled code. 16 | 17 | Unless otherwise noted in a comment near a function, these are all implemented in base R. 18 | 19 | The compiled code equivalents are (generally) faster than these and most of them also have more robust features. Basically: use these components if they cover your use-cases _and_ if the benefits of a thinner dependency stack outweigh the performance penalty costs. 20 | 21 | Contributions can be made via PR or issues. 22 | 23 | # IF YOU WANT EASIER ACCESS TO THESE IN A PACKAGE 24 | 25 | Try [`freebase`ing](https://github.com/hrbrmstr/freebase). 26 | 27 | ## Available things 28 | 29 | - `is_empty()` 30 | - `%l0%` 31 | - `%||%` 32 | - `%@%` 33 | - `safely()` 34 | - `quietly()` 35 | - `possibly()` 36 | - `keep()` 37 | - `discard()` 38 | - `compact()` 39 | - `bind_rows()` 40 | - `map()` 41 | - `map_chr()` 42 | - `map_dbl()` 43 | - `map_df()` 44 | - `map_int()` 45 | - `map_lgl()` 46 | - `map2()` 47 | - `map2_chr()` 48 | - `map2_dbl()` 49 | - `map2_df()` 50 | - `map2_int()` 51 | - `map2_lgl()` 52 | 53 | ## Code of Conduct 54 | 55 | Please note that this project is released with a [Contributor Code of Conduct](CODE_OF_CONDUCT.md). 56 | By participating in this project you agree to abide by its terms. 57 | -------------------------------------------------------------------------------- /safely.R: -------------------------------------------------------------------------------- 1 | # Less cool counterparts to purrr's side-effect capture-rs 2 | # 3 | # Most of the helper functions are 100% from output.R in purrr repo 4 | # 5 | # @param quiet Hide errors (`TRUE`, the default), or display them 6 | # as they occur? 7 | # @param otherwise Default value to use when an error occurs. 8 | # 9 | # @return `safely`: wrapped function instead returns a list with 10 | # components `result` and `error`. One value is always `NULL`. 11 | # 12 | # `quietly`: wrapped function instead returns a list with components 13 | # `result`, `output`, `messages` and `warnings`. 14 | # 15 | # `possibly`: wrapped function uses a default value (`otherwise`) 16 | # whenever an error occurs. 17 | safely <- function(.f, otherwise = NULL, quiet = TRUE) { 18 | function(...) capture_error(.f(...), otherwise, quiet) 19 | } 20 | 21 | quietly <- function(.f) { 22 | function(...) capture_output(.f(...)) 23 | } 24 | 25 | possibly <- function(.f, otherwise, quiet = TRUE) { 26 | force(otherwise) 27 | function(...) { 28 | tryCatch(.f(...), 29 | error = function(e) { 30 | if (!quiet) 31 | message("Error: ", e$message) 32 | otherwise 33 | }, 34 | interrupt = function(e) { 35 | stop("Terminated by user", call. = FALSE) 36 | } 37 | ) 38 | } 39 | } 40 | 41 | capture_error <- function(code, otherwise = NULL, quiet = TRUE) { 42 | tryCatch( 43 | list(result = code, error = NULL), 44 | error = function(e) { 45 | if (!quiet) 46 | message("Error: ", e$message) 47 | 48 | list(result = otherwise, error = e) 49 | }, 50 | interrupt = function(e) { 51 | stop("Terminated by user", call. = FALSE) 52 | } 53 | ) 54 | } 55 | 56 | capture_output <- function(code) { 57 | warnings <- character() 58 | wHandler <- function(w) { 59 | warnings <<- c(warnings, w$message) 60 | invokeRestart("muffleWarning") 61 | } 62 | 63 | messages <- character() 64 | mHandler <- function(m) { 65 | messages <<- c(messages, m$message) 66 | invokeRestart("muffleMessage") 67 | } 68 | 69 | temp <- file() 70 | sink(temp) 71 | on.exit({ 72 | sink() 73 | close(temp) 74 | }) 75 | 76 | result <- withCallingHandlers( 77 | code, 78 | warning = wHandler, 79 | message = mHandler 80 | ) 81 | 82 | output <- paste0(readLines(temp, warn = FALSE), collapse = "\n") 83 | 84 | list( 85 | result = result, 86 | output = output, 87 | warnings = warnings, 88 | messages = messages 89 | ) 90 | } 91 | -------------------------------------------------------------------------------- /map.R: -------------------------------------------------------------------------------- 1 | # NOTE these aren't 100% equivalent to the purrr mappers but cover very common use-cases 2 | map <- function(.x, .f, ...) { 3 | 4 | if (inherits(.f, "formula")) { 5 | .body <- dimnames(attr(terms(.f), "factors"))[[1]] 6 | .f <- function(.x, .=.x) {} 7 | body(.f) <- as.expression(parse(text=.body)) 8 | } 9 | 10 | if (inherits(.f, "function")) { 11 | lapply(.x, .f, ...) 12 | } else if (is.numeric(.f)) { 13 | lapply(.x, `[`, .f) 14 | } 15 | 16 | } 17 | 18 | map2 <- function(.x, .y, .f, ...) { 19 | 20 | if (inherits(.f, "formula")) { 21 | .body <- dimnames(attr(terms(.f), "factors"))[[1]] 22 | .f <- function(.x, .y, .=.x) {} 23 | body(.f) <- as.expression(parse(text=.body)) 24 | } 25 | 26 | if (inherits(.f, "function")) { 27 | mapply(.f, .x, .y, ..., SIMPLIFY=FALSE, USE.NAMES=FALSE) 28 | } 29 | 30 | } 31 | 32 | map_chr <- function(.x, .f, ...) { 33 | as.character(unlist(map(.x, .f, ...), use.names = FALSE)) 34 | } 35 | 36 | map2_chr <- function(.x, .y, .f, ...) { 37 | as.character(unlist(map2(.x, .y, .f, ...), use.names = FALSE)) 38 | } 39 | 40 | map_lgl <- function(.x, .f, ...) { 41 | as.logical(unlist(map(.x, .f, ...), use.names = FALSE)) 42 | } 43 | 44 | map2_lgl <- function(.x, .y, .f, ...) { 45 | as.logical(unlist(map2(.x, .y, .f, ...), use.names = FALSE)) 46 | } 47 | 48 | map_dbl <- function(.x, .f, ...) { 49 | as.double(unlist(map(.x, .f, ...), use.names = FALSE)) 50 | } 51 | 52 | map2_dbl <- function(.x, .y, .f, ...) { 53 | as.double(unlist(map2(.x, .y, .f, ...), use.names = FALSE)) 54 | } 55 | 56 | map_int <- function(.x, .f, ...) { 57 | as.integer(unlist(map(.x, .f, ...), use.names = FALSE)) 58 | } 59 | 60 | map2_int <- function(.x, .y, .f, ...) { 61 | as.integer(unlist(map2(.x, .y, .f, ...), use.names = FALSE)) 62 | } 63 | 64 | 65 | map_df <- function(.x, .f, ..., .id=NULL) { 66 | 67 | res <- map(.x, .f, ...) 68 | out <- bind_rows(res, .id=.id) 69 | out 70 | 71 | } 72 | 73 | map2_df <- function(.x, .y, .f, ..., .id=NULL) { 74 | 75 | res <- map(.x, .y, .f, ...) 76 | out <- bind_rows(res, .id=.id) 77 | out 78 | 79 | } 80 | 81 | # this has limitations and is more like 75% of dplyr::bind_rows() 82 | # this is also orders of magnitude slower than dplyr::bind_rows() 83 | bind_rows <- function(..., .id = NULL) { 84 | 85 | res <- list(...) 86 | 87 | if (length(res) == 1) res <- res[[1]] 88 | 89 | cols <- unique(unlist(lapply(res, names), use.names = FALSE)) 90 | 91 | if (!is.null(.id)) { 92 | inthere <- cols[.id %in% cols] 93 | if (length(inthere) > 0) { 94 | .id <- make.unique(c(inthere, .id))[2] 95 | } 96 | } 97 | 98 | id_vals <- if (is.null(names(res))) 1:length(res) else names(res) 99 | 100 | saf <- default.stringsAsFactors() 101 | options(stringsAsFactors = FALSE) 102 | on.exit(options(stringsAsFactors = saf)) 103 | 104 | idx <- 1 105 | do.call( 106 | rbind.data.frame, 107 | lapply(res, function(.x) { 108 | x_names <- names(.x) 109 | moar_names <- setdiff(cols, x_names) 110 | if (length(moar_names) > 0) { 111 | for (i in 1:length(moar_names)) { 112 | .x[[moar_names[i]]] <- rep(NA, length(.x[[1]])) 113 | } 114 | } 115 | if (!is.null(.id)) { 116 | .x[[.id]] <- id_vals[idx] 117 | idx <<- idx + 1 118 | } 119 | .x 120 | }) 121 | ) -> out 122 | 123 | rownames(out) <- NULL 124 | 125 | class(out) <- c("tbl_df", "tbl", "data.frame") 126 | 127 | out 128 | 129 | } 130 | --------------------------------------------------------------------------------