├── .Rbuildignore ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── R ├── extract_lines.R ├── get.R ├── get_ns.R ├── methods.R ├── relationship.R ├── repack.R ├── scan_for_content.R ├── split_lines.R ├── unbox.R └── unpack.R ├── README.Rmd ├── README.md ├── foreman.Rproj └── man ├── figures ├── README-unnamed-chunk-12-1.png ├── README-unnamed-chunk-14-1.png ├── README-unnamed-chunk-16-1.png ├── README-unnamed-chunk-19-1.png ├── README-unnamed-chunk-7-1.png ├── README-unnamed-chunk-8-1.png └── README-unnamed-chunk-9-1.png ├── get.Rd ├── relationship.Rd ├── repack.Rd └── unpack.Rd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^README\.Rmd$ 4 | ^LICENSE\.md$ 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: foreman 2 | Type: Package 3 | Title: Unpacking, Interrogating and Subsetting R packages 4 | Version: 0.0.2 5 | Authors@R: person(given = "Jonathan", family = "Sidi", role = c("aut", "cre"), 6 | email = "yonicd@gmail.com") 7 | Description: Unpacking, Interrogating and Subsetting R packages. 8 | Depends: R (>= 3.2.0) 9 | Imports: utils,glue 10 | License: MIT + file LICENSE 11 | Encoding: UTF-8 12 | LazyData: true 13 | RoxygenNote: 6.1.1 14 | Roxygen: list(markdown = TRUE) 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2019 2 | COPYRIGHT HOLDER: Jonathan Sidi 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2019 Jonathan Sidi 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 | S3method(as.data.frame,relationship) 4 | S3method(print,box) 5 | S3method(subset,boxes) 6 | export(get_lines) 7 | export(get_text) 8 | export(relationship) 9 | export(repack) 10 | export(unpack) 11 | importFrom(utils,capture.output) 12 | importFrom(utils,getParseData) 13 | -------------------------------------------------------------------------------- /R/extract_lines.R: -------------------------------------------------------------------------------- 1 | #' @importFrom utils capture.output 2 | extract_lines <- function(fun, ns, td){ 3 | 4 | if(!dir.exists(td)) 5 | dir.create(td) 6 | 7 | 8 | script <- get(fun,envir = ns) 9 | 10 | if(grepl('^[[:punct:]]',fun)){ 11 | 12 | file <- file.path(td,'other.R') 13 | file_temp <- file.path(td,'other_temp.R') 14 | 15 | }else{ 16 | 17 | file <- file.path(td,sprintf('%s.R',fun)) 18 | file_temp <- file.path(td,sprintf('%s_temp.R',fun)) 19 | 20 | } 21 | 22 | on.exit(unlink(file_temp),add = TRUE) 23 | 24 | utils::capture.output(print.function(script), file = file_temp) 25 | 26 | check.file <- readLines(file_temp) 27 | 28 | body <- check.file[-c(which(grepl("^<", check.file))[1]:length(check.file))] 29 | 30 | if(grepl('^[[:punct:]]',fun)){ 31 | 32 | body[1] <- sprintf('`%s` <- %s',fun,body[1]) 33 | 34 | }else{ 35 | 36 | body[1] <- sprintf('%s <- %s',fun,body[1]) 37 | 38 | } 39 | 40 | cat(body, file = file, sep = "\n",append = TRUE) 41 | 42 | } 43 | -------------------------------------------------------------------------------- /R/get.R: -------------------------------------------------------------------------------- 1 | #' @title FUNCTION_TITLE 2 | #' @description FUNCTION_DESCRIPTION 3 | #' @param x PARAM_DESCRIPTION 4 | #' @return OUTPUT_DESCRIPTION 5 | #' @details DETAILS 6 | #' @examples 7 | #' \dontrun{ 8 | #' if(interactive()){ 9 | #' #EXAMPLE1 10 | #' } 11 | #' } 12 | #' @rdname get 13 | #' @export 14 | 15 | get_lines <- function(x){ 16 | 17 | x$lines 18 | 19 | } 20 | 21 | #' @rdname get 22 | #' @export 23 | get_text <- function(x){ 24 | 25 | x$text 26 | 27 | } 28 | -------------------------------------------------------------------------------- /R/get_ns.R: -------------------------------------------------------------------------------- 1 | get_ns <- function(ns, td = NULL ){ 2 | 3 | if(is.null(td)){ 4 | 5 | if(inherits(ns,'character')){ 6 | ns_name <- ns 7 | ns <- asNamespace(ns) 8 | 9 | } 10 | 11 | if(inherits(ns,'environment')){ 12 | 13 | ns_name <- gsub('^(.*?)namespace:|>$','',capture.output(print(ns))) 14 | 15 | } 16 | 17 | td <- file.path(tempdir(),sprintf('package_clone_%s',ns_name)) 18 | 19 | } 20 | 21 | 22 | lsx <- ls(envir = ns) 23 | 24 | lsx_cl <- sapply(lsx,function(x) inherits(get(x,envir = ns),'function'),USE.NAMES = FALSE) 25 | 26 | lsx_f <- lsx[lsx_cl] 27 | 28 | invisible(lapply(lsx_f,extract_lines,ns = ns, td = td)) 29 | 30 | return(td) 31 | 32 | } 33 | -------------------------------------------------------------------------------- /R/methods.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | subset.boxes <- function(x,...){ 3 | 4 | y <- c(...) 5 | xx <- as.data.frame(relationship(x)) 6 | x1 <- xx[xx$parent%in%y,] 7 | z <- do.call('rbind',lapply(names(x),function(z) { 8 | data.frame(file = z, funs = names(x[[z]]),stringsAsFactors = FALSE) 9 | })) 10 | 11 | z1 <- z[z$funs%in%unique(c(x1$parent,x1$child)),] 12 | 13 | ret <- mapply(function(f,fun,x){x[[f]][[fun]]}, 14 | f = z1$file, 15 | fun = z1$funs,MoreArgs = list(x=x), 16 | SIMPLIFY = FALSE 17 | ) 18 | 19 | class(ret) <- c('boxes','list') 20 | 21 | ret 22 | 23 | } 24 | 25 | #' @export 26 | print.box <- function(x,...){ 27 | cat(get_text(x),sep='\n') 28 | } 29 | 30 | #' @export 31 | as.data.frame.relationship <- function(x, row.names = NULL, optional = FALSE, ...){ 32 | 33 | do.call('rbind',lapply(names(x),function(nmx){ 34 | 35 | xx <- x[[nmx]] 36 | 37 | ret <- lapply(names(xx),function(nm,file){ 38 | data.frame(child = xx[[nm]], parent = nm, file = file, stringsAsFactors = FALSE) 39 | },file = nmx) 40 | 41 | ret[[1]] 42 | })) 43 | } 44 | -------------------------------------------------------------------------------- /R/relationship.R: -------------------------------------------------------------------------------- 1 | #' @title FUNCTION_TITLE 2 | #' @description FUNCTION_DESCRIPTION 3 | #' @param x PARAM_DESCRIPTION 4 | #' @param parent PARAM_DESCRIPTION, Default: NULL 5 | #' @param child PARAM_DESCRIPTION, Default: NULL 6 | #' @return OUTPUT_DESCRIPTION 7 | #' @details DETAILS 8 | #' @examples 9 | #' \dontrun{ 10 | #' if(interactive()){ 11 | #' #EXAMPLE1 12 | #' } 13 | #' } 14 | #' @rdname relationship 15 | #' @export 16 | relationship <- function(x, parent = NULL, child = NULL){ 17 | 18 | fn_names <- unlist(lapply(x,function(xx) names(xx)),use.names = FALSE) 19 | 20 | if(!is.null(child)){ 21 | 22 | fn_names <- intersect(fn_names,child) 23 | 24 | } 25 | 26 | out <- lapply(x,find_relatives, 27 | parent = parent, fn_names = fn_names) 28 | 29 | out <- out[!sapply(out,is.null)] 30 | 31 | structure(out,class=c('relationship','list')) 32 | 33 | } 34 | 35 | find_relatives <- function(y,parent,fn_names) { 36 | 37 | if(!is.null(parent)){ 38 | 39 | if(!any(names(y)%in%parent)) 40 | return(NULL) 41 | 42 | } 43 | 44 | ret_up <- lapply(y,function(xx) { 45 | 46 | ret <- fn_names[fn_names %in% attr(xx,'SYMBOL_FUNCTION_CALL')] 47 | if(!length(ret)) 48 | ret <- NULL 49 | 50 | ret 51 | }) 52 | 53 | ret_up <- ret_up[!sapply(ret_up,is.null)] 54 | 55 | if(!length(ret_up)) 56 | ret_up <- NULL 57 | 58 | if(!is.null(parent)){ 59 | 60 | ret_up <- ret_up[intersect(parent,names(ret_up))] 61 | 62 | } 63 | 64 | ret_up 65 | 66 | } 67 | -------------------------------------------------------------------------------- /R/repack.R: -------------------------------------------------------------------------------- 1 | #' @title FUNCTION_TITLE 2 | #' @description FUNCTION_DESCRIPTION 3 | #' @param x PARAM_DESCRIPTION 4 | #' @param dir_out PARAM_DESCRIPTION, Default: NULL 5 | #' @param single_file PARAM_DESCRIPTION, Default: TRUE 6 | #' @return OUTPUT_DESCRIPTION 7 | #' @details DETAILS 8 | #' @examples 9 | #' \dontrun{ 10 | #' if(interactive()){ 11 | #' #EXAMPLE1 12 | #' } 13 | #' } 14 | #' @rdname repack 15 | #' @export 16 | 17 | repack <- function(x, dir_out = NULL, single_file = TRUE){ 18 | 19 | if(is.null(dir_out)){ 20 | 21 | dir_out <- file.path(tempdir(),'foreman') 22 | 23 | } 24 | 25 | dir_out <- normalizePath(dir_out,mustWork = FALSE) 26 | 27 | if(!dir.exists(dir_out)) 28 | dir.create(dir_out,recursive = TRUE,showWarnings = FALSE) 29 | 30 | if(single_file){ 31 | 32 | tf <- file.path(dir_out,'unpacked.R') 33 | 34 | scratch_file(tf) 35 | 36 | invisible({ 37 | lapply(x, function(y){ 38 | cat(y$text,file = tf,append = TRUE,sep = '\n') 39 | }) 40 | }) 41 | 42 | message(sprintf('Functions packed to %s',tf)) 43 | 44 | }else{ 45 | 46 | invisible({ 47 | lapply(names(x),function(nm){ 48 | 49 | scratch_file(file.path(dir_out,nm)) 50 | 51 | }) 52 | 53 | }) 54 | 55 | invisible({ 56 | lapply(names(x),function(nm){ 57 | 58 | tf <- file.path(dir_out,nm) 59 | 60 | cat(x[[nm]]$text,file = tf, sep = '\n',append = TRUE) 61 | 62 | }) 63 | }) 64 | 65 | message(sprintf('Functions packed to %s',dir_out)) 66 | 67 | } 68 | 69 | return(invisible(dir_out)) 70 | 71 | } 72 | 73 | scratch_file <- function(file){ 74 | 75 | cat('#Generated by foreman:\n', 76 | file = file, 77 | sep='\n', 78 | append = FALSE) 79 | 80 | } 81 | -------------------------------------------------------------------------------- /R/scan_for_content.R: -------------------------------------------------------------------------------- 1 | scan_for_content <- function(FILE, warn = TRUE){ 2 | 3 | lines <- readLines(FILE, warn = FALSE) 4 | 5 | lines <- lines[!grepl("^\\s*#'", lines)] 6 | 7 | objs <- gsub( 8 | "\\s*([[:alnum:]._]+).*", 9 | "\\1", grep("^\\s*[[:alnum:]._]+\\s*(<-|=)", lines, value = TRUE) 10 | ) 11 | 12 | res <- length(objs) == 0L 13 | 14 | if(warn & res) 15 | warning("No functions found in\n", normalizePath(FILE), call. = FALSE) 16 | 17 | return(!res) 18 | } 19 | -------------------------------------------------------------------------------- /R/split_lines.R: -------------------------------------------------------------------------------- 1 | split_lines <- function(x, lines, parse_data, parse_lines) { 2 | 3 | y <- parse_lines[x == parse_lines$root, c("line1", "line2")] 4 | y <- seq(y[, 1], y[, 2]) 5 | fn_lines <- c(parse_data$line1[parse_data$parent %in% (-x)], y) 6 | lout <- lines[fn_lines] 7 | fn_name <- parse_data$text[which(parse_data$id == x) + 1] 8 | 9 | if (!nzchar(fn_name)) 10 | fn_name <- NULL 11 | 12 | ret <- data.frame( 13 | text = lines[fn_lines], 14 | lines = fn_lines, 15 | stringsAsFactors = FALSE 16 | ) 17 | 18 | attr(ret,'name') <- fn_name 19 | 20 | attr(ret,'parse') <- parse_data[parse_data$line1%in%fn_lines,] 21 | 22 | attr(ret,'SYMBOL_FUNCTION_CALL') <- parse_data$text[parse_data$line1%in%fn_lines&parse_data$token=='SYMBOL_FUNCTION_CALL'] 23 | 24 | class(ret) <- c('box','data.frame') 25 | 26 | ret 27 | 28 | } 29 | -------------------------------------------------------------------------------- /R/unbox.R: -------------------------------------------------------------------------------- 1 | #' @importFrom utils getParseData 2 | unbox <- function(file = "", text = NULL) { 3 | 4 | if (!is.null(text) & length(text) == 1) { 5 | text <- strsplit(text, "\n")[[1]] 6 | } 7 | 8 | if (nzchar(file)) { 9 | text <- readLines(file, warn = FALSE) 10 | } 11 | 12 | if (is.null(text)||length(text)==0) 13 | return(NULL) 14 | 15 | parse_text <- parse(text = text,keep.source = TRUE) 16 | parse_data <- utils::getParseData(parse_text) 17 | parse_data_filter <- parse_data$parent[with(parse_data, text == "function" & terminal == TRUE)] 18 | 19 | if(!length(parse_data_filter)) 20 | return(NULL) 21 | 22 | parse_lines <- parse_data[parse_data$id %in% (parse_data_filter + 1), ] 23 | parse_lines$root <- as.numeric(rownames(parse_lines)) 24 | 25 | parse_split <- lapply(parse_lines$root, split_lines, lines = text, parse_data = parse_data, parse_lines = parse_lines) 26 | 27 | if(length(sapply(parse_split,attr,'name'))!=length(parse_split)) 28 | browser() 29 | 30 | names(parse_split) <- sapply(parse_split,attr,'name') 31 | 32 | parse_split 33 | 34 | } 35 | -------------------------------------------------------------------------------- /R/unpack.R: -------------------------------------------------------------------------------- 1 | #' @title FUNCTION_TITLE 2 | #' @description FUNCTION_DESCRIPTION 3 | #' @param path PARAM_DESCRIPTION, Default: 'R' 4 | #' @param ns PARAM_DESCRIPTION, Default: NULL 5 | #' @param warn PARAM_DESCRIPTION, Default: TRUE 6 | #' @return OUTPUT_DESCRIPTION 7 | #' @details DETAILS 8 | #' @examples 9 | #' \dontrun{ 10 | #' if(interactive()){ 11 | #' #EXAMPLE1 12 | #' } 13 | #' } 14 | #' @rdname unpack 15 | #' @export 16 | unpack <- function(path = 'R', ns = NULL, warn = TRUE){ 17 | 18 | if(!is.null(ns)){ 19 | 20 | path <- get_ns(asNamespace(ns)) 21 | 22 | on.exit(unlink(path,recursive = TRUE,force = TRUE),add = TRUE) 23 | 24 | } 25 | 26 | if (length(path) == 1L && file.info(path)$isdir) { 27 | 28 | files <- list.files(path = path, pattern = ".+\\.[rR]$", full.names = TRUE) 29 | 30 | } else { 31 | 32 | files <- path 33 | 34 | } 35 | 36 | if (!all(grepl("\\.[rR]$", basename(files)))) { 37 | stop("Supplied file(s) is not an .R file!", call. = FALSE) 38 | } 39 | 40 | files <- files[sapply(files,scan_for_content,warn = warn)] 41 | 42 | if(length(files)==0){ 43 | return(invisible(NULL)) 44 | } 45 | 46 | names(files) <- basename(files) 47 | 48 | ret <- lapply(files,unbox) 49 | 50 | class(ret) <- c('boxes','list') 51 | 52 | ret 53 | } 54 | -------------------------------------------------------------------------------- /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 | 16 | # foreman 17 | 18 | 19 | [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) 20 | 21 | 22 | The goals of foreman are to: 23 | 24 | - [Unpack](#unpacking) a package's functions to interrogate [relationships](#relationships) of the functions within it. 25 | - [Isolate](#subset) function scripts within a package (including the documentation for local paths) 26 | - [Consolidate](#consolidation) a subset of self contained functions in a file(s) to allow for focused learning on a specific package functionality. 27 | 28 | > Given these goals it is important to state that this package is not meant to replace any parent package. 29 | 30 | The package supports both [local packages](#local-packages) and [compiled](#compiled-library) libraries. 31 | 32 | ## Installation 33 | 34 | ``` r 35 | remotes::install_github("yonicd/foreman") 36 | ``` 37 | 38 | ## Local Packages 39 | 40 | This example will use a local fork of `purrr`. 41 | 42 | ```{r example,message=FALSE,warning=FALSE} 43 | library(foreman) 44 | library(ggraph) 45 | library(igraph) 46 | ``` 47 | 48 | ### Unpacking 49 | 50 | Unpack a pacakge into a list 51 | 52 | ```{r} 53 | x <- unpack(path = '../forks/purrr/R', warn = FALSE) 54 | ``` 55 | 56 | Click the triangle to view the contents found in `arrays.R` 57 | 58 | ```{r,results='asis'} 59 | details::details(lapply(x$arrays.R,get_text),summary = 'arrays.R') 60 | ``` 61 | 62 | ### Relationships 63 | 64 | ```{r} 65 | x_rel <- relationship(x) 66 | ``` 67 | 68 | Relationships contained in `arrays.R` 69 | 70 | ```{r} 71 | x_rel$arrays.R 72 | ``` 73 | 74 | Functions that `compose` calls 75 | 76 | ```{r} 77 | relationship(x,parent = 'compose') 78 | ``` 79 | 80 | Functions who call `flatten` 81 | 82 | ```{r} 83 | relationship(x,child = 'flatten') 84 | ``` 85 | 86 | ### Convert relationships to a data.frame 87 | 88 | ```{r} 89 | x_rel_df <- as.data.frame(x_rel) 90 | ``` 91 | 92 | Click the triangle to view the data.frame 93 | 94 | ```{r,results='asis'} 95 | details::details(x_rel_df,summary = 'Relatives') 96 | ``` 97 | 98 | ### Plotting the relationships 99 | 100 | ```{r} 101 | 102 | graph <- igraph::graph_from_data_frame(x_rel_df,directed = TRUE) 103 | 104 | ``` 105 | 106 | ```{r} 107 | igraph::V(graph)$parents <- names(igraph::V(graph)) 108 | ``` 109 | 110 | ```{r,fig.dim=c(7,7)} 111 | ggraph(graph) + 112 | geom_edge_link( 113 | aes(colour = file), 114 | arrow = grid::arrow(length = unit(0.05, "inches"))) + 115 | geom_node_text(aes(label = parents),size = 3) + 116 | labs(title = 'purrr function map', colour = 'Exported') + 117 | ggplot2::theme(legend.position = 'bottom') 118 | 119 | ``` 120 | 121 | 122 | ### Subset 123 | 124 | Subsetting Package Functions 125 | 126 | ```{r} 127 | sub_x <- subset(x,'compose') 128 | ``` 129 | 130 | Click the triangle to view the contents found in the subset containing `compose` and the functions the it calls. 131 | 132 | 133 | ```{r,results='asis'} 134 | details::details(lapply(sub_x,get_text),summary = 'Package subset') 135 | ``` 136 | 137 | ### Consolidation 138 | 139 | Consolidating Subsetted Functions into a File 140 | 141 | ```{r} 142 | pack_path <- repack(sub_x) 143 | ``` 144 | 145 | Click the triangle to view the contents found in the file containing the consolidated functions. 146 | 147 | ```{r,results='asis'} 148 | details::details(file.path(pack_path,'unpacked.R'),summary = 'Consolidated Script') 149 | ``` 150 | 151 | ### Compiled Library 152 | 153 | This example will use the installed library `future`. 154 | 155 | Using foreman with an compiled libraries is also simple 156 | 157 | ```{r} 158 | library(future) 159 | 160 | unpacked_future <- unpack(ns = 'future')%>% 161 | relationship()%>% 162 | as.data.frame() 163 | 164 | ``` 165 | 166 | ```{r} 167 | 168 | graph <- igraph::graph_from_data_frame(unpacked_future,directed = TRUE) 169 | igraph::V(graph)$parents <- names(igraph::V(graph)) 170 | igraph::V(graph)$exported <- names(igraph::V(graph))%in%ls('package:future') 171 | 172 | ``` 173 | 174 | ```{r,fig.dim=c(7,7)} 175 | ggraph(graph) + 176 | geom_edge_link( 177 | arrow = grid::arrow(length = unit(0.05, "inches")),alpha = 0.05) + 178 | geom_node_text(aes(colour = exported,label = parents),size = 2) + 179 | labs(title = 'future function map', colour = 'Exported') + 180 | ggplot2::theme(legend.position = 'bottom') 181 | ``` 182 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # foreman 5 | 6 | 7 | 8 | [![Lifecycle: 9 | experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) 10 | 11 | 12 | The goals of foreman are to: 13 | 14 | - [Unpack](#unpacking) a package’s functions to interrogate 15 | [relationships](#relationships) of the functions within it. 16 | - [Isolate](#subset) function scripts within a package (including the 17 | documentation for local paths) 18 | - [Consolidate](#consolidation) a subset of self contained functions 19 | in a file(s) to allow for focused learning on a specific package 20 | functionality. 21 | 22 | > Given these goals it is important to state that this package is not 23 | > meant to replace any parent package. 24 | 25 | The package supports both [local packages](#local-packages) and 26 | [compiled](#compiled-library) libraries. 27 | 28 | ## Installation 29 | 30 | ``` r 31 | remotes::install_github("yonicd/foreman") 32 | ``` 33 | 34 | ## Local Packages 35 | 36 | This example will use a local fork of `purrr`. 37 | 38 | ``` r 39 | library(foreman) 40 | library(ggraph) 41 | library(igraph) 42 | ``` 43 | 44 | ### Unpacking 45 | 46 | Unpack a pacakge into a list 47 | 48 | ``` r 49 | x <- unpack(path = '../forks/purrr/R', warn = FALSE) 50 | ``` 51 | 52 | Click the triangle to view the contents found in `arrays.R` 53 | 54 | ``` r 55 | details::details(lapply(x$arrays.R,get_text),summary = 'arrays.R') 56 | ``` 57 | 58 |
59 | 60 | arrays.R 61 | 62 | ``` r 63 | 64 | $array_branch 65 | [1] "#' Coerce array to list" 66 | [2] "#'" 67 | [3] "#' `array_branch()` and `array_tree()` enable arrays to be" 68 | [4] "#' used with purrr's functionals by turning them into lists. The" 69 | [5] "#' details of the coercion are controlled by the `margin`" 70 | [6] "#' argument. `array_tree()` creates an hierarchical list (a tree)" 71 | [7] "#' that has as many levels as dimensions specified in `margin`," 72 | [8] "#' while `array_branch()` creates a flat list (by analogy, a" 73 | [9] "#' branch) along all mentioned dimensions." 74 | [10] "#'" 75 | [11] "#' When no margin is specified, all dimensions are used by" 76 | [12] "#' default. When `margin` is a numeric vector of length zero, the" 77 | [13] "#' whole array is wrapped in a list." 78 | [14] "#' @param array An array to coerce into a list." 79 | [15] "#' @param margin A numeric vector indicating the positions of the" 80 | [16] "#' indices to be to be enlisted. If `NULL`, a full margin is" 81 | [17] "#' used. If `numeric(0)`, the array as a whole is wrapped in a" 82 | [18] "#' list." 83 | [19] "#' @name array-coercion" 84 | [20] "#' @export" 85 | [21] "#' @examples" 86 | [22] "#' # We create an array with 3 dimensions" 87 | [23] "#' x <- array(1:12, c(2, 2, 3))" 88 | [24] "#'" 89 | [25] "#' # A full margin for such an array would be the vector 1:3. This is" 90 | [26] "#' # the default if you don't specify a margin" 91 | [27] "#'" 92 | [28] "#' # Creating a branch along the full margin is equivalent to" 93 | [29] "#' # as.list(array) and produces a list of size length(x):" 94 | [30] "#' array_branch(x) %>% str()" 95 | [31] "#'" 96 | [32] "#' # A branch along the first dimension yields a list of length 2" 97 | [33] "#' # with each element containing a 2x3 array:" 98 | [34] "#' array_branch(x, 1) %>% str()" 99 | [35] "#'" 100 | [36] "#' # A branch along the first and third dimensions yields a list of" 101 | [37] "#' # length 2x3 whose elements contain a vector of length 2:" 102 | [38] "#' array_branch(x, c(1, 3)) %>% str()" 103 | [39] "#'" 104 | [40] "#' # Creating a tree from the full margin creates a list of lists of" 105 | [41] "#' # lists:" 106 | [42] "#' array_tree(x) %>% str()" 107 | [43] "#'" 108 | [44] "#' # The ordering and the depth of the tree are controlled by the" 109 | [45] "#' # margin argument:" 110 | [46] "#' array_tree(x, c(3, 1)) %>% str()" 111 | [47] "array_branch <- function(array, margin = NULL) {" 112 | [48] " dims <- dim(array) %||% length(array)" 113 | [49] " margin <- margin %||% seq_along(dims)" 114 | [50] "" 115 | [51] " if (length(margin) == 0) {" 116 | [52] " list(array)" 117 | [53] " } else if (is.null(dim(array))) {" 118 | [54] " if (!identical(as.integer(margin), 1L)) {" 119 | [55] " abort(sprintf(" 120 | [56] " \"`margin` must be `NULL` or `1` with 1D arrays, not `%s`\"," 121 | [57] " toString(margin)" 122 | [58] " ))" 123 | [59] " }" 124 | [60] " as.list(array)" 125 | [61] " } else {" 126 | [62] " flatten(apply(array, margin, list))" 127 | [63] " }" 128 | [64] "}" 129 | 130 | $array_tree 131 | [1] "#' @rdname array-coercion" 132 | [2] "#' @export" 133 | [3] "array_tree <- function(array, margin = NULL) {" 134 | [4] " dims <- dim(array) %||% length(array)" 135 | [5] " margin <- margin %||% seq_along(dims)" 136 | [6] "" 137 | [7] " if (length(margin) > 1) {" 138 | [8] " new_margin <- ifelse(margin[-1] > margin[[1]], margin[-1] - 1, margin[-1])" 139 | [9] " apply(array, margin[[1]], array_tree, new_margin)" 140 | [10] " } else {" 141 | [11] " array_branch(array, margin)" 142 | [12] " }" 143 | [13] "}" 144 | ``` 145 | 146 |
147 | 148 |
149 | 150 | ### Relationships 151 | 152 | ``` r 153 | x_rel <- relationship(x) 154 | ``` 155 | 156 | Relationships contained in `arrays.R` 157 | 158 | ``` r 159 | x_rel$arrays.R 160 | #> $array_branch 161 | #> [1] "flatten" 162 | #> 163 | #> $array_tree 164 | #> [1] "array_branch" 165 | ``` 166 | 167 | Functions that `compose` calls 168 | 169 | ``` r 170 | relationship(x,parent = 'compose') 171 | #> $compose.R 172 | #> $compose.R$compose 173 | #> [1] "compose" "map" "fn" 174 | #> 175 | #> 176 | #> attr(,"class") 177 | #> [1] "relationship" "list" 178 | ``` 179 | 180 | Functions who call `flatten` 181 | 182 | ``` r 183 | relationship(x,child = 'flatten') 184 | #> $arrays.R 185 | #> $arrays.R$array_branch 186 | #> [1] "flatten" 187 | #> 188 | #> 189 | #> $lmap.R 190 | #> $lmap.R$lmap_at 191 | #> [1] "flatten" 192 | #> 193 | #> 194 | #> $splice.R 195 | #> $splice.R$splice_if 196 | #> [1] "flatten" 197 | #> 198 | #> 199 | #> attr(,"class") 200 | #> [1] "relationship" "list" 201 | ``` 202 | 203 | ### Convert relationships to a data.frame 204 | 205 | ``` r 206 | x_rel_df <- as.data.frame(x_rel) 207 | ``` 208 | 209 | Click the triangle to view the data.frame 210 | 211 | ``` r 212 | details::details(x_rel_df,summary = 'Relatives') 213 | ``` 214 | 215 |
216 | 217 | Relatives 218 | 219 | ``` r 220 | 221 | child parent file 222 | 1 flatten array_branch arrays.R 223 | 2 as_mapper as_function as_mapper.R 224 | 3 stop_defunct as_function as_mapper.R 225 | 4 paste_line as_function as_mapper.R 226 | 5 coerce coerce_lgl coerce.R 227 | 6 can_simplify as_vector coercion.R 228 | 7 warn_deprecated signal_soft_deprecated compat-lifecycle.R 229 | 8 compose compose compose.R 230 | 9 map compose compose.R 231 | 10 fn compose compose.R 232 | 11 as_vector lift_vl composition.R 233 | 12 what_bad_object stop_bad_type conditions.R 234 | 13 friendly_type_of stop_bad_type conditions.R 235 | 14 as_mapper cross cross.R 236 | 15 as_predicate_friendly_type_of cross cross.R 237 | 16 compact cross cross.R 238 | 17 is_bool cross cross.R 239 | 18 map_int vec_depth depth.R 240 | 19 as_predicate detect detect.R 241 | 20 index detect detect.R 242 | 21 as_predicate every every-some.R 243 | 22 detect_index head_while head-tail.R 244 | 23 negate head_while head-tail.R 245 | 24 as_mapper imap imap.R 246 | 25 vec_index imap imap.R 247 | 26 map2 imap imap.R 248 | 27 probe keep keep.R 249 | 28 list_recurse list_modify list-modify.R 250 | 29 lmap_at lmap lmap.R 251 | 30 as_mapper map map.R 252 | 31 as_mapper map2 map2-pmap.R 253 | 32 as_mapper modify.default modify.R 254 | 33 as_mapper negate negate.R 255 | 34 as_mapper safely output.R 256 | 35 capture_error safely output.R 257 | 36 signal_soft_deprecated partial partial.R 258 | 37 stop_defunct partial partial.R 259 | 38 map partial partial.R 260 | 39 paste_line partial partial.R 261 | 40 friendly_type_of partial partial.R 262 | 41 assign_in `pluck<-` pluck.R 263 | 42 as_mapper insistently rate.R 264 | 43 stop_bad_type insistently rate.R 265 | 44 capture_error insistently rate.R 266 | 45 rate_backoff insistently rate.R 267 | 46 is_rate insistently rate.R 268 | 47 rate_sleep insistently rate.R 269 | 48 rate_reset insistently rate.R 270 | 49 f insistently rate.R 271 | 50 reduce_impl reduce reduce.R 272 | 51 eval_dots rerun rerun.R 273 | 52 has_names rerun rerun.R 274 | 53 map2 invoke_map retired-invoke.R 275 | 54 as_invoke_function invoke_map retired-invoke.R 276 | 55 splice_if splice splice.R 277 | 56 check_tibble maybe_as_data_frame utils.R 278 | ``` 279 | 280 |
281 | 282 |
283 | 284 | ### Plotting the relationships 285 | 286 | ``` r 287 | 288 | graph <- igraph::graph_from_data_frame(x_rel_df,directed = TRUE) 289 | ``` 290 | 291 | ``` r 292 | igraph::V(graph)$parents <- names(igraph::V(graph)) 293 | ``` 294 | 295 | ``` r 296 | ggraph(graph) + 297 | geom_edge_link( 298 | aes(colour = file), 299 | arrow = grid::arrow(length = unit(0.05, "inches"))) + 300 | geom_node_text(aes(label = parents),size = 3) + 301 | labs(title = 'purrr function map', colour = 'Exported') + 302 | ggplot2::theme(legend.position = 'bottom') 303 | #> Using `nicely` as default layout 304 | ``` 305 | 306 | 307 | 308 | ### Subset 309 | 310 | Subsetting Package Functions 311 | 312 | ``` r 313 | sub_x <- subset(x,'compose') 314 | ``` 315 | 316 | Click the triangle to view the contents found in the subset containing 317 | `compose` and the functions the it calls. 318 | 319 | ``` r 320 | details::details(lapply(sub_x,get_text),summary = 'Package subset') 321 | ``` 322 | 323 |
324 | 325 | Package subset 326 | 327 | 328 | ``` r 329 | 330 | $compose.R 331 | [1] "#' Compose multiple functions" 332 | [2] "#'" 333 | [3] "#' @param ... Functions to apply in order (from right to left by" 334 | [4] "#' default). Formulas are converted to functions in the usual way." 335 | [5] "#'" 336 | [6] "#' These dots support [tidy dots][rlang::list2] features. In" 337 | [7] "#' particular, if your functions are stored in a list, you can" 338 | [8] "#' splice that in with `!!!`." 339 | [9] "#' @param .dir If `\"backward\"` (the default), the functions are called" 340 | [10] "#' in the reverse order, from right to left, as is conventional in" 341 | [11] "#' mathematics. If `\"forward\"`, they are called from left to right." 342 | [12] "#' @return A function" 343 | [13] "#' @export" 344 | [14] "#' @examples" 345 | [15] "#' not_null <- compose(`!`, is.null)" 346 | [16] "#' not_null(4)" 347 | [17] "#' not_null(NULL)" 348 | [18] "#'" 349 | [19] "#' add1 <- function(x) x + 1" 350 | [20] "#' compose(add1, add1)(8)" 351 | [21] "#'" 352 | [22] "#' # You can use the formula shortcut for functions:" 353 | [23] "#' fn <- compose(~ paste(.x, \"foo\"), ~ paste(.x, \"bar\"))" 354 | [24] "#' fn(\"input\")" 355 | [25] "#'" 356 | [26] "#' # Lists of functions can be spliced with !!!" 357 | [27] "#' fns <- list(" 358 | [28] "#' function(x) paste(x, \"foo\")," 359 | [29] "#' ~ paste(.x, \"bar\")" 360 | [30] "#' )" 361 | [31] "#' fn <- compose(!!!fns)" 362 | [32] "#' fn(\"input\")" 363 | [33] "compose <- function(..., .dir = c(\"backward\", \"forward\")) {" 364 | [34] " .dir <- arg_match(.dir, c(\"backward\", \"forward\"))" 365 | [35] "" 366 | [36] " fns <- map(list2(...), rlang::as_closure, env = caller_env())" 367 | [37] " if (!length(fns)) {" 368 | [38] " # Return the identity function" 369 | [39] " return(compose(function(x, ...) x))" 370 | [40] " }" 371 | [41] "" 372 | [42] " if (.dir == \"backward\") {" 373 | [43] " n <- length(fns)" 374 | [44] " first_fn <- fns[[n]]" 375 | [45] " fns <- rev(fns[-n])" 376 | [46] " } else {" 377 | [47] " first_fn <- fns[[1]]" 378 | [48] " fns <- fns[-1]" 379 | [49] " }" 380 | [50] "" 381 | [51] " body <- expr({" 382 | [52] " out <- !!fn_body(first_fn)" 383 | [53] "" 384 | [54] " fns <- !!fns" 385 | [55] " for (fn in fns) {" 386 | [56] " out <- fn(out)" 387 | [57] " }" 388 | [58] "" 389 | [59] " out" 390 | [60] " })" 391 | [61] "" 392 | [62] " structure(" 393 | [63] " new_function(formals(first_fn), body, fn_env(first_fn))," 394 | [64] " class = c(\"purrr_function_compose\", \"function\")," 395 | [65] " first_fn = first_fn," 396 | [66] " fns = fns" 397 | [67] " )" 398 | [68] "}" 399 | 400 | $map.R 401 | [1] "#' Apply a function to each element of a vector" 402 | [2] "#'" 403 | [3] "#' @description" 404 | [4] "#'" 405 | [5] "#' The map functions transform their input by applying a function to" 406 | [6] "#' each element and returning a vector the same length as the input." 407 | [7] "#'" 408 | [8] "#' * `map()`, `map_if()` and `map_at()` always return a list. See the" 409 | [9] "#' [modify()] family for versions that return an object of the same" 410 | [10] "#' type as the input." 411 | [11] "#'" 412 | [12] "#' The `_if` and `_at` variants take a predicate function `.p` that" 413 | [13] "#' determines which elements of `.x` are transformed with `.f`." 414 | [14] "#'" 415 | [15] "#' * `map_lgl()`, `map_int()`, `map_dbl()` and `map_chr()` each return" 416 | [16] "#' an atomic vector of the indicated type (or die trying)." 417 | [17] "#'" 418 | [18] "#' The return value of `.f` must be of length one for each element of" 419 | [19] "#' `.x`. If `.f` uses an extractor function shortcut, `.default`" 420 | [20] "#' can be specified to handle values that are absent or empty. See" 421 | [21] "#' [as_mapper()] for more on `.default`." 422 | [22] "#'" 423 | [23] "#' * `map_dfr()` and `map_dfc()` return data frames created by" 424 | [24] "#' row-binding and column-binding respectively. They require dplyr" 425 | [25] "#' to be installed." 426 | [26] "#'" 427 | [27] "#' * `walk()` calls `.f` for its side-effect and returns the input `.x`." 428 | [28] "#'" 429 | [29] "#' @inheritParams as_mapper" 430 | [30] "#' @param .x A list or atomic vector." 431 | [31] "#' @param .p A single predicate function, a formula describing such a" 432 | [32] "#' predicate function, or a logical vector of the same length as `.x`." 433 | [33] "#' Alternatively, if the elements of `.x` are themselves lists of" 434 | [34] "#' objects, a string indicating the name of a logical element in the" 435 | [35] "#' inner lists. Only those elements where `.p` evaluates to" 436 | [36] "#' `TRUE` will be modified." 437 | [37] "#' @param .at A character vector of names, positive numeric vector of" 438 | [38] "#' positions to include, or a negative numeric vector of positions to" 439 | [39] "#' exlude. Only those elements corresponding to `.at` will be modified." 440 | [40] "#' @param ... Additional arguments passed on to the mapped function." 441 | [41] "#' @return All functions return a vector the same length as `.x`." 442 | [42] "#'" 443 | [43] "#' `map()` returns a list, `map_lgl()` a logical vector, `map_int()` an" 444 | [44] "#' integer vector, `map_dbl()` a double vector, and `map_chr()` a character" 445 | [45] "#' vector. The output of `.f` will be automatically typed upwards," 446 | [46] "#' e.g. logical -> integer -> double -> character." 447 | [47] "#'" 448 | [48] "#' If `.x` has `names()`, the return value preserves those names." 449 | [49] "#'" 450 | [50] "#' `walk()` returns the input `.x` (invisibly). This makes it easy to" 451 | [51] "#' use in pipe." 452 | [52] "#' @export" 453 | [53] "#' @family map variants" 454 | [54] "#' @examples" 455 | [55] "#' 1:10 %>%" 456 | [56] "#' map(rnorm, n = 10) %>%" 457 | [57] "#' map_dbl(mean)" 458 | [58] "#'" 459 | [59] "#' # Or use an anonymous function" 460 | [60] "#' 1:10 %>%" 461 | [61] "#' map(function(x) rnorm(10, x))" 462 | [62] "#'" 463 | [63] "#' # Or a formula" 464 | [64] "#' 1:10 %>%" 465 | [65] "#' map(~ rnorm(10, .x))" 466 | [66] "#'" 467 | [67] "#' # The names of the input are preserved in the output:" 468 | [68] "#' list(foo = 1, bar = 2) %>% map(`+`, 10)" 469 | [69] "#'" 470 | [70] "#' # Using set_names() with character vectors is handy to keep track" 471 | [71] "#' # of the original inputs:" 472 | [72] "#' set_names(c(\"foo\", \"bar\")) %>% map_chr(paste0, \":suffix\")" 473 | [73] "#'" 474 | [74] "#' # Extract by name or position" 475 | [75] "#' # .default specifies value for elements that are missing or NULL" 476 | [76] "#' l1 <- list(list(a = 1L), list(a = NULL, b = 2L), list(b = 3L))" 477 | [77] "#' l1 %>% map(\"a\", .default = \"???\")" 478 | [78] "#' l1 %>% map_int(\"b\", .default = NA)" 479 | [79] "#' l1 %>% map_int(2, .default = NA)" 480 | [80] "#'" 481 | [81] "#' # Supply multiple values to index deeply into a list" 482 | [82] "#' l2 <- list(" 483 | [83] "#' list(num = 1:3, letters[1:3])," 484 | [84] "#' list(num = 101:103, letters[4:6])," 485 | [85] "#' list()" 486 | [86] "#' )" 487 | [87] "#' l2 %>% map(c(2, 2))" 488 | [88] "#'" 489 | [89] "#' # Use a list to build an extractor that mixes numeric indices and names," 490 | [90] "#' # and .default to provide a default value if the element does not exist" 491 | [91] "#' l2 %>% map(list(\"num\", 3))" 492 | [92] "#' l2 %>% map_int(list(\"num\", 3), .default = NA)" 493 | [93] "#'" 494 | [94] "#'" 495 | [95] "#' # Use a predicate function to decide whether to map a function:" 496 | [96] "#' map_if(iris, is.factor, as.character)" 497 | [97] "#'" 498 | [98] "#' # Specify an alternative with the `.else` argument:" 499 | [99] "#' map_if(iris, is.factor, as.character, .else = as.integer)" 500 | [100] "#'" 501 | [101] "#' # A more realistic example: split a data frame into pieces, fit a" 502 | [102] "#' # model to each piece, summarise and extract R^2" 503 | [103] "#' mtcars %>%" 504 | [104] "#' split(.$cyl) %>%" 505 | [105] "#' map(~ lm(mpg ~ wt, data = .x)) %>%" 506 | [106] "#' map(summary) %>%" 507 | [107] "#' map_dbl(\"r.squared\")" 508 | [108] "#'" 509 | [109] "#' # Use map_lgl(), map_dbl(), etc to reduce to a vector." 510 | [110] "#' # * list" 511 | [111] "#' mtcars %>% map(sum)" 512 | [112] "#' # * vector" 513 | [113] "#' mtcars %>% map_dbl(sum)" 514 | [114] "#'" 515 | [115] "#' # If each element of the output is a data frame, use" 516 | [116] "#' # map_dfr to row-bind them together:" 517 | [117] "#' mtcars %>%" 518 | [118] "#' split(.$cyl) %>%" 519 | [119] "#' map(~ lm(mpg ~ wt, data = .x)) %>%" 520 | [120] "#' map_dfr(~ as.data.frame(t(as.matrix(coef(.)))))" 521 | [121] "#' # (if you also want to preserve the variable names see" 522 | [122] "#' # the broom package)" 523 | [123] "#'" 524 | [124] "#' # Use `map_depth()` to recursively traverse nested vectors and map" 525 | [125] "#' # a function at a certain depth:" 526 | [126] "#' x <- list(a = list(foo = 1:2, bar = 3:4), b = list(baz = 5:6))" 527 | [127] "#' str(x)" 528 | [128] "#' map_depth(x, 2, paste, collapse = \"/\")" 529 | [129] "#'" 530 | [130] "#' # Equivalent to:" 531 | [131] "#' map(x, map, paste, collapse = \"/\")" 532 | [132] "map <- function(.x, .f, ...) {" 533 | [133] " .f <- as_mapper(.f, ...)" 534 | [134] " .Call(map_impl, environment(), \".x\", \".f\", \"list\")" 535 | [135] "}" 536 | 537 | $reduce.R 538 | [1] " fn <- function(x, y, ...) .f(y, x, ...)" 539 | ``` 540 | 541 |
542 | 543 |
544 | 545 | ### Consolidation 546 | 547 | Consolidating Subsetted Functions into a File 548 | 549 | ``` r 550 | pack_path <- repack(sub_x) 551 | #> Functions packed to /var/folders/kx/t4h_mm1910sb7vhm_gnfnx2c0000gn/T//Rtmpgg7cm0/foreman/unpacked.R 552 | ``` 553 | 554 | Click the triangle to view the contents found in the file containing the 555 | consolidated 556 | functions. 557 | 558 | ``` r 559 | details::details(file.path(pack_path,'unpacked.R'),summary = 'Consolidated Script') 560 | ``` 561 | 562 |
563 | 564 | Consolidated Script 565 | 566 | 567 | ``` r 568 | 569 | #Generated by foreman: 570 | 571 | #' Compose multiple functions 572 | #' 573 | #' @param ... Functions to apply in order (from right to left by 574 | #' default). Formulas are converted to functions in the usual way. 575 | #' 576 | #' These dots support [tidy dots][rlang::list2] features. In 577 | #' particular, if your functions are stored in a list, you can 578 | #' splice that in with `!!!`. 579 | #' @param .dir If `"backward"` (the default), the functions are called 580 | #' in the reverse order, from right to left, as is conventional in 581 | #' mathematics. If `"forward"`, they are called from left to right. 582 | #' @return A function 583 | #' @export 584 | #' @examples 585 | #' not_null <- compose(`!`, is.null) 586 | #' not_null(4) 587 | #' not_null(NULL) 588 | #' 589 | #' add1 <- function(x) x + 1 590 | #' compose(add1, add1)(8) 591 | #' 592 | #' # You can use the formula shortcut for functions: 593 | #' fn <- compose(~ paste(.x, "foo"), ~ paste(.x, "bar")) 594 | #' fn("input") 595 | #' 596 | #' # Lists of functions can be spliced with !!! 597 | #' fns <- list( 598 | #' function(x) paste(x, "foo"), 599 | #' ~ paste(.x, "bar") 600 | #' ) 601 | #' fn <- compose(!!!fns) 602 | #' fn("input") 603 | compose <- function(..., .dir = c("backward", "forward")) { 604 | .dir <- arg_match(.dir, c("backward", "forward")) 605 | 606 | fns <- map(list2(...), rlang::as_closure, env = caller_env()) 607 | if (!length(fns)) { 608 | # Return the identity function 609 | return(compose(function(x, ...) x)) 610 | } 611 | 612 | if (.dir == "backward") { 613 | n <- length(fns) 614 | first_fn <- fns[[n]] 615 | fns <- rev(fns[-n]) 616 | } else { 617 | first_fn <- fns[[1]] 618 | fns <- fns[-1] 619 | } 620 | 621 | body <- expr({ 622 | out <- !!fn_body(first_fn) 623 | 624 | fns <- !!fns 625 | for (fn in fns) { 626 | out <- fn(out) 627 | } 628 | 629 | out 630 | }) 631 | 632 | structure( 633 | new_function(formals(first_fn), body, fn_env(first_fn)), 634 | class = c("purrr_function_compose", "function"), 635 | first_fn = first_fn, 636 | fns = fns 637 | ) 638 | } 639 | #' Apply a function to each element of a vector 640 | #' 641 | #' @description 642 | #' 643 | #' The map functions transform their input by applying a function to 644 | #' each element and returning a vector the same length as the input. 645 | #' 646 | #' * `map()`, `map_if()` and `map_at()` always return a list. See the 647 | #' [modify()] family for versions that return an object of the same 648 | #' type as the input. 649 | #' 650 | #' The `_if` and `_at` variants take a predicate function `.p` that 651 | #' determines which elements of `.x` are transformed with `.f`. 652 | #' 653 | #' * `map_lgl()`, `map_int()`, `map_dbl()` and `map_chr()` each return 654 | #' an atomic vector of the indicated type (or die trying). 655 | #' 656 | #' The return value of `.f` must be of length one for each element of 657 | #' `.x`. If `.f` uses an extractor function shortcut, `.default` 658 | #' can be specified to handle values that are absent or empty. See 659 | #' [as_mapper()] for more on `.default`. 660 | #' 661 | #' * `map_dfr()` and `map_dfc()` return data frames created by 662 | #' row-binding and column-binding respectively. They require dplyr 663 | #' to be installed. 664 | #' 665 | #' * `walk()` calls `.f` for its side-effect and returns the input `.x`. 666 | #' 667 | #' @inheritParams as_mapper 668 | #' @param .x A list or atomic vector. 669 | #' @param .p A single predicate function, a formula describing such a 670 | #' predicate function, or a logical vector of the same length as `.x`. 671 | #' Alternatively, if the elements of `.x` are themselves lists of 672 | #' objects, a string indicating the name of a logical element in the 673 | #' inner lists. Only those elements where `.p` evaluates to 674 | #' `TRUE` will be modified. 675 | #' @param .at A character vector of names, positive numeric vector of 676 | #' positions to include, or a negative numeric vector of positions to 677 | #' exlude. Only those elements corresponding to `.at` will be modified. 678 | #' @param ... Additional arguments passed on to the mapped function. 679 | #' @return All functions return a vector the same length as `.x`. 680 | #' 681 | #' `map()` returns a list, `map_lgl()` a logical vector, `map_int()` an 682 | #' integer vector, `map_dbl()` a double vector, and `map_chr()` a character 683 | #' vector. The output of `.f` will be automatically typed upwards, 684 | #' e.g. logical -> integer -> double -> character. 685 | #' 686 | #' If `.x` has `names()`, the return value preserves those names. 687 | #' 688 | #' `walk()` returns the input `.x` (invisibly). This makes it easy to 689 | #' use in pipe. 690 | #' @export 691 | #' @family map variants 692 | #' @examples 693 | #' 1:10 %>% 694 | #' map(rnorm, n = 10) %>% 695 | #' map_dbl(mean) 696 | #' 697 | #' # Or use an anonymous function 698 | #' 1:10 %>% 699 | #' map(function(x) rnorm(10, x)) 700 | #' 701 | #' # Or a formula 702 | #' 1:10 %>% 703 | #' map(~ rnorm(10, .x)) 704 | #' 705 | #' # The names of the input are preserved in the output: 706 | #' list(foo = 1, bar = 2) %>% map(`+`, 10) 707 | #' 708 | #' # Using set_names() with character vectors is handy to keep track 709 | #' # of the original inputs: 710 | #' set_names(c("foo", "bar")) %>% map_chr(paste0, ":suffix") 711 | #' 712 | #' # Extract by name or position 713 | #' # .default specifies value for elements that are missing or NULL 714 | #' l1 <- list(list(a = 1L), list(a = NULL, b = 2L), list(b = 3L)) 715 | #' l1 %>% map("a", .default = "???") 716 | #' l1 %>% map_int("b", .default = NA) 717 | #' l1 %>% map_int(2, .default = NA) 718 | #' 719 | #' # Supply multiple values to index deeply into a list 720 | #' l2 <- list( 721 | #' list(num = 1:3, letters[1:3]), 722 | #' list(num = 101:103, letters[4:6]), 723 | #' list() 724 | #' ) 725 | #' l2 %>% map(c(2, 2)) 726 | #' 727 | #' # Use a list to build an extractor that mixes numeric indices and names, 728 | #' # and .default to provide a default value if the element does not exist 729 | #' l2 %>% map(list("num", 3)) 730 | #' l2 %>% map_int(list("num", 3), .default = NA) 731 | #' 732 | #' 733 | #' # Use a predicate function to decide whether to map a function: 734 | #' map_if(iris, is.factor, as.character) 735 | #' 736 | #' # Specify an alternative with the `.else` argument: 737 | #' map_if(iris, is.factor, as.character, .else = as.integer) 738 | #' 739 | #' # A more realistic example: split a data frame into pieces, fit a 740 | #' # model to each piece, summarise and extract R^2 741 | #' mtcars %>% 742 | #' split(.$cyl) %>% 743 | #' map(~ lm(mpg ~ wt, data = .x)) %>% 744 | #' map(summary) %>% 745 | #' map_dbl("r.squared") 746 | #' 747 | #' # Use map_lgl(), map_dbl(), etc to reduce to a vector. 748 | #' # * list 749 | #' mtcars %>% map(sum) 750 | #' # * vector 751 | #' mtcars %>% map_dbl(sum) 752 | #' 753 | #' # If each element of the output is a data frame, use 754 | #' # map_dfr to row-bind them together: 755 | #' mtcars %>% 756 | #' split(.$cyl) %>% 757 | #' map(~ lm(mpg ~ wt, data = .x)) %>% 758 | #' map_dfr(~ as.data.frame(t(as.matrix(coef(.))))) 759 | #' # (if you also want to preserve the variable names see 760 | #' # the broom package) 761 | #' 762 | #' # Use `map_depth()` to recursively traverse nested vectors and map 763 | #' # a function at a certain depth: 764 | #' x <- list(a = list(foo = 1:2, bar = 3:4), b = list(baz = 5:6)) 765 | #' str(x) 766 | #' map_depth(x, 2, paste, collapse = "/") 767 | #' 768 | #' # Equivalent to: 769 | #' map(x, map, paste, collapse = "/") 770 | map <- function(.x, .f, ...) { 771 | .f <- as_mapper(.f, ...) 772 | .Call(map_impl, environment(), ".x", ".f", "list") 773 | } 774 | fn <- function(x, y, ...) .f(y, x, ...) 775 | ``` 776 | 777 |
778 | 779 |
780 | 781 | ### Compiled Library 782 | 783 | This example will use the installed library `future`. 784 | 785 | Using foreman with an compiled libraries is also simple 786 | 787 | ``` r 788 | library(future) 789 | #> 790 | #> Attaching package: 'future' 791 | #> The following objects are masked from 'package:igraph': 792 | #> 793 | #> %->%, %<-% 794 | 795 | unpacked_future <- unpack(ns = 'future')%>% 796 | relationship()%>% 797 | as.data.frame() 798 | ``` 799 | 800 | ``` r 801 | 802 | graph <- igraph::graph_from_data_frame(unpacked_future,directed = TRUE) 803 | igraph::V(graph)$parents <- names(igraph::V(graph)) 804 | igraph::V(graph)$exported <- names(igraph::V(graph))%in%ls('package:future') 805 | ``` 806 | 807 | ``` r 808 | ggraph(graph) + 809 | geom_edge_link( 810 | arrow = grid::arrow(length = unit(0.05, "inches")),alpha = 0.05) + 811 | geom_node_text(aes(colour = exported,label = parents),size = 2) + 812 | labs(title = 'future function map', colour = 'Exported') + 813 | ggplot2::theme(legend.position = 'bottom') 814 | #> Using `nicely` as default layout 815 | ``` 816 | 817 | 818 | -------------------------------------------------------------------------------- /foreman.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 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace,vignette 22 | -------------------------------------------------------------------------------- /man/figures/README-unnamed-chunk-12-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yonicd/foreman/f9aeae3caa35b51fc949b15cace31dfb0ef4fc87/man/figures/README-unnamed-chunk-12-1.png -------------------------------------------------------------------------------- /man/figures/README-unnamed-chunk-14-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yonicd/foreman/f9aeae3caa35b51fc949b15cace31dfb0ef4fc87/man/figures/README-unnamed-chunk-14-1.png -------------------------------------------------------------------------------- /man/figures/README-unnamed-chunk-16-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yonicd/foreman/f9aeae3caa35b51fc949b15cace31dfb0ef4fc87/man/figures/README-unnamed-chunk-16-1.png -------------------------------------------------------------------------------- /man/figures/README-unnamed-chunk-19-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yonicd/foreman/f9aeae3caa35b51fc949b15cace31dfb0ef4fc87/man/figures/README-unnamed-chunk-19-1.png -------------------------------------------------------------------------------- /man/figures/README-unnamed-chunk-7-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yonicd/foreman/f9aeae3caa35b51fc949b15cace31dfb0ef4fc87/man/figures/README-unnamed-chunk-7-1.png -------------------------------------------------------------------------------- /man/figures/README-unnamed-chunk-8-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yonicd/foreman/f9aeae3caa35b51fc949b15cace31dfb0ef4fc87/man/figures/README-unnamed-chunk-8-1.png -------------------------------------------------------------------------------- /man/figures/README-unnamed-chunk-9-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yonicd/foreman/f9aeae3caa35b51fc949b15cace31dfb0ef4fc87/man/figures/README-unnamed-chunk-9-1.png -------------------------------------------------------------------------------- /man/get.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/get.R 3 | \name{get_lines} 4 | \alias{get_lines} 5 | \alias{get_text} 6 | \title{FUNCTION_TITLE} 7 | \usage{ 8 | get_lines(x) 9 | 10 | get_text(x) 11 | } 12 | \arguments{ 13 | \item{x}{PARAM_DESCRIPTION} 14 | } 15 | \value{ 16 | OUTPUT_DESCRIPTION 17 | } 18 | \description{ 19 | FUNCTION_DESCRIPTION 20 | } 21 | \details{ 22 | DETAILS 23 | } 24 | \examples{ 25 | \dontrun{ 26 | if(interactive()){ 27 | #EXAMPLE1 28 | } 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /man/relationship.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/relationship.R 3 | \name{relationship} 4 | \alias{relationship} 5 | \title{FUNCTION_TITLE} 6 | \usage{ 7 | relationship(x, parent = NULL, child = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{PARAM_DESCRIPTION} 11 | 12 | \item{parent}{PARAM_DESCRIPTION, Default: NULL} 13 | 14 | \item{child}{PARAM_DESCRIPTION, Default: NULL} 15 | } 16 | \value{ 17 | OUTPUT_DESCRIPTION 18 | } 19 | \description{ 20 | FUNCTION_DESCRIPTION 21 | } 22 | \details{ 23 | DETAILS 24 | } 25 | \examples{ 26 | \dontrun{ 27 | if(interactive()){ 28 | #EXAMPLE1 29 | } 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /man/repack.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/repack.R 3 | \name{repack} 4 | \alias{repack} 5 | \title{FUNCTION_TITLE} 6 | \usage{ 7 | repack(x, dir_out = NULL, single_file = TRUE) 8 | } 9 | \arguments{ 10 | \item{x}{PARAM_DESCRIPTION} 11 | 12 | \item{dir_out}{PARAM_DESCRIPTION, Default: NULL} 13 | 14 | \item{single_file}{PARAM_DESCRIPTION, Default: TRUE} 15 | } 16 | \value{ 17 | OUTPUT_DESCRIPTION 18 | } 19 | \description{ 20 | FUNCTION_DESCRIPTION 21 | } 22 | \details{ 23 | DETAILS 24 | } 25 | \examples{ 26 | \dontrun{ 27 | if(interactive()){ 28 | #EXAMPLE1 29 | } 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /man/unpack.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/unpack.R 3 | \name{unpack} 4 | \alias{unpack} 5 | \title{FUNCTION_TITLE} 6 | \usage{ 7 | unpack(path = "R", ns = NULL, warn = TRUE) 8 | } 9 | \arguments{ 10 | \item{path}{PARAM_DESCRIPTION, Default: 'R'} 11 | 12 | \item{ns}{PARAM_DESCRIPTION, Default: NULL} 13 | 14 | \item{warn}{PARAM_DESCRIPTION, Default: TRUE} 15 | } 16 | \value{ 17 | OUTPUT_DESCRIPTION 18 | } 19 | \description{ 20 | FUNCTION_DESCRIPTION 21 | } 22 | \details{ 23 | DETAILS 24 | } 25 | \examples{ 26 | \dontrun{ 27 | if(interactive()){ 28 | #EXAMPLE1 29 | } 30 | } 31 | } 32 | --------------------------------------------------------------------------------