├── _pkgdown.yml ├── .github ├── .gitignore └── workflows │ └── pkgdown.yaml ├── .gitignore ├── docs ├── reference │ ├── mySOreputation-1.png │ ├── readClip.html │ └── shuffler.html ├── pkgdown.yml ├── link.svg ├── bootstrap-toc.css ├── docsearch.js ├── pkgdown.js ├── bootstrap-toc.js ├── 404.html ├── authors.html └── index.html ├── man ├── readClip.Rd ├── dist2df.Rd ├── shuffler.Rd ├── Diag.Rd ├── adjCombos.Rd ├── letterRep.Rd ├── clc.Rd ├── TrueSeq.Rd ├── replace_portion.Rd ├── lengthener.Rd ├── vectorBind.Rd ├── needleInHaystack.Rd ├── writeClip.Rd ├── vec2symmat.Rd ├── ReshapeLong.Rd ├── sortEnds.Rd ├── unlist_by_row.Rd ├── mc_tribble.Rd ├── findFirst.Rd ├── shifter.Rd ├── completeVecs.Rd ├── CharNumSplit.Rd ├── this_by_n.Rd ├── TabulateInt.Rd ├── TriIndex.Rd ├── tidyHTML.Rd ├── dupe_thresh.Rd ├── SOfun-package.Rd ├── grouped_stem.Rd ├── word_value.Rd ├── col_flatten.Rd ├── fwf2csv.Rd ├── dailyCalendar.Rd ├── toColClasses.Rd ├── naLast.Rd ├── arrayExtractor.Rd ├── SampleToSum.Rd ├── list_unlister.Rd ├── ragged.Rd ├── Riffle.Rd ├── melt_wide.Rd ├── read.mtable.Rd ├── moveMe.Rd ├── ftable2dt.Rd ├── Factor.Rd ├── write.Hmisc.SPSS.Rd ├── getMyRows.Rd ├── mySOreputation.Rd ├── helpExtract.Rd ├── list_reduction.Rd ├── GroupedMedian.Rd ├── makemeNA.Rd └── almostComplete.Rd ├── README.md ├── R ├── clc.R ├── shuffler.R ├── Diag.R ├── adjCombos.R ├── letterRep.R ├── TrueSeq.R ├── dist2df.R ├── shifter.R ├── lengthener.R ├── CharNumSplit.R ├── vectorBind.R ├── findFirst.R ├── replace_portion.R ├── sortEnds.R ├── completeVecs.R ├── this_by_n.R ├── tidyHTML.R ├── needleInHaystack.R ├── TabulateInt.R ├── SOfun-package.R ├── TriIndex.R ├── ReshapeLong.R ├── mc_tribble.R ├── word_value.R ├── vec2symmat.R ├── dupe_thresh.R ├── unlist_by_row.R ├── arrayExtractor.R ├── SampleToSum.R ├── fwf2csv.R ├── melt_wide.R ├── toColClasses.R ├── col_flatten.R ├── list_unlister.R ├── read.mtable.R ├── ragged.R ├── getMyRows.R ├── naLast.R ├── list_reduction.R ├── Factor.R ├── dailyCalendar.R ├── moveMe.R ├── makemeNA.R ├── helpExtract.R ├── GroupedMedian.R ├── utils.R ├── almostComplete.R ├── Riffle.R ├── mySOreputation.R ├── grouped_stem.R ├── write.Hmisc.SPSS.R └── ftable2dt.R ├── DESCRIPTION ├── NEWS.md └── NAMESPACE /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | SOfun.Rproj 5 | .Rbuildignore 6 | 7 | -------------------------------------------------------------------------------- /docs/reference/mySOreputation-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrdwab/SOfun/HEAD/docs/reference/mySOreputation-1.png -------------------------------------------------------------------------------- /docs/pkgdown.yml: -------------------------------------------------------------------------------- 1 | pandoc: '2.5' 2 | pkgdown: 1.5.1.9000 3 | pkgdown_sha: caf7cc74e008e8d0d6e53eeda93cd3cad3545bf2 4 | articles: [] 5 | last_built: 2020-06-19T22:09Z 6 | 7 | -------------------------------------------------------------------------------- /man/readClip.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{readClip} 4 | \alias{readClip} 5 | \title{Read Clipboard Regardless of OS} 6 | \usage{ 7 | readClip() 8 | } 9 | \value{ 10 | character string containing text on the clipboard. 11 | } 12 | \description{ 13 | Different operating systems have different ways of handling the clipboard. 14 | Given the frequency with which text is copied to the clipboard to place in 15 | an answer on StackOverflow, this utility is provided. 16 | } 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # SOfun 2 | 3 | Functions I've written as answers to R questions on Stack Overflow. Destined to be the most important R package you have ever loaded in your R session. 4 | 5 | ## Installation 6 | 7 | ``` 8 | source("http://news.mrdwab.com/install_github.R") 9 | install_github("mrdwab/SOfun") 10 | ``` 11 | 12 | ## Contents 13 | 14 | The "SOfun" package is filled with a very strongly cohesive set of functions. 15 | 16 | Visit the [Reference page](http://mrdwab.github.io/SOfun/reference/index.html) for an overview of the functions in this package. 17 | 18 | Don't ask me why I did this. 19 | -------------------------------------------------------------------------------- /R/clc.R: -------------------------------------------------------------------------------- 1 | #' Clear your workspace 2 | #' 3 | #' A slightly more elaborate version of `rm(list = ls())` to clear your workspace. 4 | #' 5 | #' @param all Logical. Should hidden objects also be removed? Defaults to `FALSE`. 6 | #' @return Nothing 7 | #' @author Ananda Mahto 8 | #' @references 9 | #' @examples 10 | #' 11 | #' \dontrun{ 12 | #' clc() # Will not affect hidden files 13 | #' clc(TRUE) # Will affect hidden files 14 | #' } 15 | #' 16 | #' @export clc 17 | clc <- function(all = FALSE) { 18 | rm(list = ls(.GlobalEnv, all.names = all), envir = .GlobalEnv) 19 | } 20 | -------------------------------------------------------------------------------- /R/shuffler.R: -------------------------------------------------------------------------------- 1 | #' Shuffle the Elements of a Vector 2 | #' 3 | #' Shuffles the elements of a vector such that no single element is in the same 4 | #' place it was before. 5 | #' 6 | #' @param inVec The input vector 7 | #' @return A shuffled version of the input vector 8 | #' @author Ananda Mahto 9 | #' @references \url{http://stackoverflow.com/a/19898689/1270695} 10 | #' @examples 11 | #' 12 | #' shuffler(letters[1:10]) 13 | #' 14 | #' @export shuffler 15 | shuffler <- function(inVec) { 16 | Res <- vector() 17 | while ( TRUE ) { 18 | Res <- sample(inVec) 19 | if ( !any(Res == inVec) ) { break } 20 | } 21 | Res 22 | } 23 | NULL 24 | -------------------------------------------------------------------------------- /man/dist2df.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dist2df.R 3 | \name{dist2df} 4 | \alias{dist2df} 5 | \title{Converts a Distance Matrix to a data.frame} 6 | \usage{ 7 | dist2df(inDist) 8 | } 9 | \arguments{ 10 | \item{inDist}{The input distance object.} 11 | } 12 | \value{ 13 | A \code{data.frame}. 14 | } 15 | \description{ 16 | Converts a distance matrix to a \code{data.frame}. 17 | } 18 | \examples{ 19 | 20 | dd <- as.dist((1 - cor(USJudgeRatings)[1:5, 1:5])/2) 21 | dist2df(dd) 22 | 23 | } 24 | \references{ 25 | \url{http://stackoverflow.com/q/23474729/1270695} 26 | } 27 | \author{ 28 | Ananda Mahto 29 | } 30 | -------------------------------------------------------------------------------- /man/shuffler.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/shuffler.R 3 | \name{shuffler} 4 | \alias{shuffler} 5 | \title{Shuffle the Elements of a Vector} 6 | \usage{ 7 | shuffler(inVec) 8 | } 9 | \arguments{ 10 | \item{inVec}{The input vector} 11 | } 12 | \value{ 13 | A shuffled version of the input vector 14 | } 15 | \description{ 16 | Shuffles the elements of a vector such that no single element is in the same 17 | place it was before. 18 | } 19 | \examples{ 20 | 21 | shuffler(letters[1:10]) 22 | 23 | } 24 | \references{ 25 | \url{http://stackoverflow.com/a/19898689/1270695} 26 | } 27 | \author{ 28 | Ananda Mahto 29 | } 30 | -------------------------------------------------------------------------------- /R/Diag.R: -------------------------------------------------------------------------------- 1 | #' Extract the Values at the Diagonal of a Matrix 2 | #' 3 | #' A faster version of [base::diag()] (on larger matrices). 4 | #' 5 | #' 6 | #' @param inMatrix The input matrix 7 | #' @return A vector 8 | #' @author Ananda Mahto 9 | #' @references 10 | #' @examples 11 | #' 12 | #' set.seed(1) 13 | #' m <- matrix(rnorm(100), ncol = 10) 14 | #' 15 | #' Diag(m) 16 | #' diag(m) 17 | #' 18 | #' @export Diag 19 | Diag <- function(inMatrix) { 20 | A <- sequence(ncol(inMatrix))[sequence(min(nrow(inMatrix), 21 | ncol(inMatrix)))] 22 | inMatrix[cbind(A, A)] 23 | } 24 | 25 | -------------------------------------------------------------------------------- /man/Diag.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Diag.R 3 | \name{Diag} 4 | \alias{Diag} 5 | \title{Extract the Values at the Diagonal of a Matrix} 6 | \usage{ 7 | Diag(inMatrix) 8 | } 9 | \arguments{ 10 | \item{inMatrix}{The input matrix} 11 | } 12 | \value{ 13 | A vector 14 | } 15 | \description{ 16 | A faster version of \code{\link[base:diag]{base::diag()}} (on larger matrices). 17 | } 18 | \examples{ 19 | 20 | set.seed(1) 21 | m <- matrix(rnorm(100), ncol = 10) 22 | 23 | Diag(m) 24 | diag(m) 25 | 26 | } 27 | \references{ 28 | \url{http://stackoverflow.com/a/20489737/1270695} 29 | } 30 | \author{ 31 | Ananda Mahto 32 | } 33 | -------------------------------------------------------------------------------- /man/adjCombos.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/adjCombos.R 3 | \name{adjCombos} 4 | \alias{adjCombos} 5 | \title{Create Adjacent Combinations, Varying Length} 6 | \usage{ 7 | adjCombos(invec) 8 | } 9 | \arguments{ 10 | \item{invec}{The input vector} 11 | } 12 | \value{ 13 | A \code{list} of vectors 14 | } 15 | \description{ 16 | Create adjacent combinations of the elements of a vector, varying the length 17 | with each iteration. 18 | } 19 | \examples{ 20 | 21 | adjCombos(letters[1:5]) 22 | 23 | } 24 | \references{ 25 | \url{http://stackoverflow.com/a/20157957/1270695} 26 | } 27 | \author{ 28 | Ananda Mahto 29 | } 30 | -------------------------------------------------------------------------------- /man/letterRep.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/letterRep.R 3 | \name{letterRep} 4 | \alias{letterRep} 5 | \title{"Wrap" the \code{letters} Constant} 6 | \usage{ 7 | letterRep(inRange) 8 | } 9 | \arguments{ 10 | \item{inRange}{The (numeric) input range.} 11 | } 12 | \value{ 13 | A character vector. 14 | } 15 | \description{ 16 | The \code{letterRep} function "wraps" the \code{letters} constant, making 17 | repeated letters unique by pasting characters together. 18 | } 19 | \examples{ 20 | 21 | letterRep(60) 22 | letterRep(20:40) 23 | 24 | } 25 | \references{ 26 | \url{http://stackoverflow.com/a/21681824/1270695} 27 | } 28 | \author{ 29 | Ananda Mahto 30 | } 31 | -------------------------------------------------------------------------------- /man/clc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/clc.R 3 | \name{clc} 4 | \alias{clc} 5 | \title{Clear your workspace} 6 | \usage{ 7 | clc(all = FALSE) 8 | } 9 | \arguments{ 10 | \item{all}{Logical. Should hidden objects also be removed? Defaults to \code{FALSE}.} 11 | } 12 | \value{ 13 | Nothing 14 | } 15 | \description{ 16 | A slightly more elaborate version of \code{rm(list = ls())} to clear your workspace. 17 | } 18 | \examples{ 19 | 20 | \dontrun{ 21 | clc() # Will not affect hidden files 22 | clc(TRUE) # Will affect hidden files 23 | } 24 | 25 | } 26 | \references{ 27 | \url{http://stackoverflow.com/a/20389913/1270695} 28 | } 29 | \author{ 30 | Ananda Mahto 31 | } 32 | -------------------------------------------------------------------------------- /R/adjCombos.R: -------------------------------------------------------------------------------- 1 | #' Create Adjacent Combinations, Varying Length 2 | #' 3 | #' Create adjacent combinations of the elements of a vector, varying the length 4 | #' with each iteration. 5 | #' 6 | #' @param invec The input vector 7 | #' @return A `list` of vectors 8 | #' @author Ananda Mahto 9 | #' @references 10 | #' @examples 11 | #' 12 | #' adjCombos(letters[1:5]) 13 | #' 14 | #' @export adjCombos 15 | adjCombos <- function(invec) { 16 | A <- lapply(2:(length(invec)-1L), sequence) 17 | B <- lapply(rev(lengths(A))-1L, function(x) c(0, sequence(x))) 18 | unlist(lapply(seq_along(A), function(x) { 19 | lapply(B[[x]], function(y) invec[A[[x]]+y]) 20 | }), recursive = FALSE, use.names = FALSE) 21 | } 22 | NULL 23 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: SOfun 2 | Type: Package 3 | Title: Functions From Answers to R Questions on Stack Overflow 4 | Version: 1.76 5 | Date: 2020-06-19 6 | Authors@R: c(person("Ananda", "Mahto", email = "ananda@mahto.info", 7 | role = c("aut", "cre")), 8 | person("Jota", role = "aut"), 9 | person("Ed", "Morton", role = "aut")) 10 | Description: Nothing special. A very incohesive collection of functions, that's 11 | all. If a function disappears, I might have moved it to another package. 12 | URL: http://mrdwab.github.io/SOfun, https://github.com/mrdwab/SOfun 13 | License: CC0 14 | RoxygenNote: 7.1.0 15 | Roxygen: list(markdown = TRUE) 16 | Imports: Hmisc, 17 | data.table, 18 | stringr, 19 | XML, 20 | utils 21 | Suggests: reshape2, 22 | ggplot2 23 | Encoding: UTF-8 24 | -------------------------------------------------------------------------------- /man/TrueSeq.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/TrueSeq.R 3 | \name{TrueSeq} 4 | \alias{TrueSeq} 5 | \title{Convert TRUE Values in a Vector to a Grouped Sequence} 6 | \usage{ 7 | TrueSeq(inLogi, zero2NA = FALSE) 8 | } 9 | \arguments{ 10 | \item{inLogi}{The input logical vector.} 11 | 12 | \item{zero2NA}{Logical. Should the zeroes in the result be converted to 13 | \code{NA}. Defaults to \code{FALSE}.} 14 | } 15 | \value{ 16 | A numeric vector 17 | } 18 | \description{ 19 | Convert the \code{TRUE} values in a vector into a sequence by groups of 20 | values. 21 | } 22 | \examples{ 23 | 24 | set.seed(1) 25 | x <- sample(c(TRUE, FALSE), 100, TRUE) 26 | 27 | TrueSeq(x) 28 | 29 | } 30 | \references{ 31 | \url{http://stackoverflow.com/a/21328046/1270695} 32 | } 33 | \author{ 34 | Ananda Mahto 35 | } 36 | -------------------------------------------------------------------------------- /man/replace_portion.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/replace_portion.R 3 | \name{replace_portion} 4 | \alias{replace_portion} 5 | \title{Find and Replace a Portion of a Vector} 6 | \usage{ 7 | replace_portion(invec, find, replace) 8 | } 9 | \arguments{ 10 | \item{invec}{The input vector.} 11 | 12 | \item{find}{What is the sequence that you're looking for?} 13 | 14 | \item{replace}{What do you want to replace the values with?} 15 | } 16 | \value{ 17 | A vector the same length as the input vector. 18 | } 19 | \description{ 20 | Searches for a pattern in a vector and replaces it with a provided replacement pattern. 21 | } 22 | \examples{ 23 | 24 | x <- c(1, 2, 3, 1, 0, 1, 0, 1, 2, 3, 4, 1, 0, 1) 25 | replace_portion(x, c(1, 0, 1), c(9, 9, 9)) 26 | 27 | } 28 | \author{ 29 | Ananda Mahto 30 | } 31 | -------------------------------------------------------------------------------- /man/lengthener.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lengthener.R 3 | \name{lengthener} 4 | \alias{lengthener} 5 | \title{Lengthens a Dataset by Combination of Columns} 6 | \usage{ 7 | lengthener(indt, n = 2) 8 | } 9 | \arguments{ 10 | \item{indt}{The input dataset.} 11 | 12 | \item{n}{The number of columns expected. Passed on to \code{combn}.} 13 | } 14 | \value{ 15 | A \code{data.table}. 16 | } 17 | \description{ 18 | Creates a long dataset of "n" columns comprising the combinations of values 19 | from different columns. 20 | } 21 | \examples{ 22 | 23 | mydf <- as.data.frame(matrix(c(1,2,3,4,0,0,1,1), byrow = TRUE, nrow = 2)) 24 | lengthener(mydf, 2) 25 | lengthener(mydf, 3) 26 | 27 | } 28 | \references{ 29 | \url{http://stackoverflow.com/q/35690478/1270695} 30 | } 31 | \author{ 32 | Ananda Mahto 33 | } 34 | -------------------------------------------------------------------------------- /R/letterRep.R: -------------------------------------------------------------------------------- 1 | #' "Wrap" the \code{letters} Constant 2 | #' 3 | #' The \code{letterRep} function "wraps" the \code{letters} constant, making 4 | #' repeated letters unique by pasting characters together. 5 | #' 6 | #' 7 | #' @param inRange The (numeric) input range. 8 | #' @return A character vector. 9 | #' @author Ananda Mahto 10 | #' @references \url{http://stackoverflow.com/a/21681824/1270695} 11 | #' @examples 12 | #' 13 | #' letterRep(60) 14 | #' letterRep(20:40) 15 | #' 16 | #' @export letterRep 17 | letterRep <- function(inRange) { 18 | if (length(inRange) == 1) inRange <- sequence(inRange) 19 | temp <- (inRange - 1) %% 26 + 1 20 | vals <- letters[temp] 21 | grp <- cumsum(c(1, temp[-length(temp)] %/% 26)) 22 | vapply(seq_along(vals), 23 | function(x) paste(rep(vals[x], grp[x]), collapse = ""), 24 | character(1L)) 25 | } 26 | -------------------------------------------------------------------------------- /docs/link.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 8 | 12 | 13 | -------------------------------------------------------------------------------- /man/vectorBind.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vectorBind.R 3 | \name{vectorBind} 4 | \alias{vectorBind} 5 | \title{Bind Vectors Column-Wise According to Name} 6 | \usage{ 7 | vectorBind(...) 8 | } 9 | \arguments{ 10 | \item{\dots}{The objects that need to be combined.} 11 | } 12 | \value{ 13 | A matrix. 14 | } 15 | \description{ 16 | Combines named vectors into a matrix with the rows being the names of the 17 | vector elements, and the columns being the name of the source vector. 18 | } 19 | \examples{ 20 | 21 | set.seed(1) 22 | t1 <- table(sample(LETTERS[c(1, 2, 4)], 20, TRUE)) 23 | t2 <- table(sample(LETTERS[c(1, 2, 3)], 20, TRUE)) 24 | t3 <- table(sample(LETTERS[c(2, 4, 5)], 20, TRUE)) 25 | 26 | vectorBind(t1, t2, t3) 27 | 28 | } 29 | \references{ 30 | \url{http://stackoverflow.com/q/25639223/1270695} 31 | } 32 | \author{ 33 | Ananda Mahto 34 | } 35 | -------------------------------------------------------------------------------- /R/TrueSeq.R: -------------------------------------------------------------------------------- 1 | #' Convert TRUE Values in a Vector to a Grouped Sequence 2 | #' 3 | #' Convert the \code{TRUE} values in a vector into a sequence by groups of 4 | #' values. 5 | #' 6 | #' 7 | #' @param inLogi The input logical vector. 8 | #' @param zero2NA Logical. Should the zeroes in the result be converted to 9 | #' \code{NA}. Defaults to \code{FALSE}. 10 | #' @return A numeric vector 11 | #' @author Ananda Mahto 12 | #' @references \url{http://stackoverflow.com/a/21328046/1270695} 13 | #' @examples 14 | #' 15 | #' set.seed(1) 16 | #' x <- sample(c(TRUE, FALSE), 100, TRUE) 17 | #' 18 | #' TrueSeq(x) 19 | #' 20 | #' @export TrueSeq 21 | TrueSeq <- function(inLogi, zero2NA = FALSE) { 22 | if (!is.logical(inLogi)) stop("Your input must be a logical vector") 23 | x <- rle(cumsum(!inLogi)[inLogi])$lengths 24 | inLogi[inLogi] <- rep(seq_along(x), x) 25 | if (isTRUE(zero2NA)) inLogi[inLogi == 0] <- NA 26 | inLogi 27 | } 28 | -------------------------------------------------------------------------------- /man/needleInHaystack.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/needleInHaystack.R 3 | \name{needleInHaystack} 4 | \alias{needleInHaystack} 5 | \title{Find a Needle in a Haystack...} 6 | \usage{ 7 | needleInHaystack(findMe, findIn) 8 | } 9 | \arguments{ 10 | \item{findMe}{What are you looking for? A character vector.} 11 | 12 | \item{findIn}{Where are you looking for it? A character vector.} 13 | } 14 | \value{ 15 | A matrix with 1 indicating presence and 0 indicating absence. 16 | } 17 | \description{ 18 | Find specified search patterns (in any order, not necessarily joined) in 19 | another vector of strings. 20 | } 21 | \examples{ 22 | 23 | x <- c("cat", "dog", "rat", "far", "f*n", "god", "g*dn") 24 | y <- c("ar", "n*", "a", "zo") 25 | 26 | needleInHaystack(y, x) 27 | 28 | } 29 | \references{ 30 | \url{http://stackoverflow.com/q/22129542/1270695} 31 | } 32 | \author{ 33 | Ananda Mahto 34 | } 35 | -------------------------------------------------------------------------------- /man/writeClip.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{writeClip} 4 | \alias{writeClip} 5 | \title{Write to Clipboard on Multiple OSes} 6 | \usage{ 7 | writeClip(object) 8 | } 9 | \arguments{ 10 | \item{object}{character. Character to be copied to the clipboard} 11 | } 12 | \value{ 13 | Returns nothing to R. Returns character string to the clipboard 14 | } 15 | \description{ 16 | This function works on Windows, Mac and Linux. It copies a 17 | character string or vector of characters to the clipboard and interprets 18 | a vector of characters as one character with each element being newline 19 | separated. If using Linux, xclip is used as the clipboard. So for the 20 | function to work, xclip must be installed. 21 | } 22 | \details{ 23 | If using Linux, xclip will be used as the clipboard. To paste from 24 | xclip, either use middle click or the command \code{xclip -o} in the shell. 25 | } 26 | -------------------------------------------------------------------------------- /man/vec2symmat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/vec2symmat.R 3 | \name{vec2symmat} 4 | \alias{vec2symmat} 5 | \title{Creates a Symmetric Matrix from a Vector} 6 | \usage{ 7 | vec2symmat(invec, diag = 1, byrow = TRUE) 8 | } 9 | \arguments{ 10 | \item{invec}{The input vector} 11 | 12 | \item{diag}{The value for the diagonal} 13 | 14 | \item{byrow}{Logical. Whether the upper-triangle should be filled in by row} 15 | } 16 | \value{ 17 | A matrix 18 | } 19 | \description{ 20 | Takes a vector and, if the vector is of the correct lenght to be made into a 21 | symmetric matrix, performs the conversion. 22 | } 23 | \examples{ 24 | 25 | myvec <- c(-.55, -.48, .66, .47, -.38, -.46) 26 | vec2symmat(myvec) 27 | 28 | vec2symmat(1:15, diag = 0) 29 | vec2symmat(1:15, diag = 0, byrow = FALSE) 30 | 31 | } 32 | \references{ 33 | \url{http://stackoverflow.com/a/18598933/1270695} 34 | } 35 | \author{ 36 | Ananda Mahto 37 | } 38 | -------------------------------------------------------------------------------- /R/dist2df.R: -------------------------------------------------------------------------------- 1 | #' Converts a Distance Matrix to a data.frame 2 | #' 3 | #' Converts a distance matrix to a `data.frame`. 4 | #' 5 | #' @param inDist The input distance object. 6 | #' @return A `data.frame`. 7 | #' @author Ananda Mahto 8 | #' @references 9 | #' @examples 10 | #' 11 | #' dd <- as.dist((1 - cor(USJudgeRatings)[1:5, 1:5])/2) 12 | #' dist2df(dd) 13 | #' 14 | #' @export dist2df 15 | dist2df <- function(inDist) { 16 | if (class(inDist) != "dist") stop("wrong input type") 17 | A <- attr(inDist, "Size") 18 | B <- if (is.null(attr(inDist, "Labels"))) sequence(A) else attr(inDist, "Labels") 19 | if (isTRUE(attr(inDist, "Diag"))) attr(inDist, "Diag") <- FALSE 20 | if (isTRUE(attr(inDist, "Upper"))) attr(inDist, "Upper") <- FALSE 21 | data.frame( 22 | row = B[unlist(lapply(sequence(A)[-1], function(x) x:A))], 23 | col = rep(B[-length(B)], (length(B)-1):1), 24 | value = as.vector(inDist)) 25 | } 26 | NULL 27 | -------------------------------------------------------------------------------- /R/shifter.R: -------------------------------------------------------------------------------- 1 | #' "Shift" the Values of a Vector Ahead or Behind by a Specified Amount 2 | #' 3 | #' This function "shifts" the values of a vector by a specified amount. For 4 | #' instance, if you are starting with a vector, "x", where the range of values 5 | #' is between 1 and 10, and you want 10 to be replaced by 9, 9 to be replaced 6 | #' by 8, and so on, with 1 being ultimately replaced by 10, this funciton 7 | #' should be of use. 8 | #' 9 | #' @param x The range that you are shifting 10 | #' @param n How much of a shift you want 11 | #' @return A vector of shifted values 12 | #' @author Ananda Mahto 13 | #' @references \url{http://stackoverflow.com/a/20825012/1270695} 14 | #' @examples 15 | #' 16 | #' set.seed(1) 17 | #' X <- sample(10, 20, replace = TRUE) 18 | #' X 19 | #' 20 | #' shifter()[X] 21 | #' shifter(n = -2)[X] 22 | #' 23 | #' @export shifter 24 | shifter <- function(x = 1:10, n = 1) { 25 | if (n == 0) x <- x 26 | else x <- c(tail(x, -n), head(x, n)) 27 | x 28 | } 29 | -------------------------------------------------------------------------------- /R/lengthener.R: -------------------------------------------------------------------------------- 1 | #' Lengthens a Dataset by Combination of Columns 2 | #' 3 | #' Creates a long dataset of "n" columns comprising the combinations of values 4 | #' from different columns. 5 | #' 6 | #' @param indt The input dataset. 7 | #' @param n The number of columns expected. Passed on to \code{combn}. 8 | #' @return A \code{data.table}. 9 | #' @author Ananda Mahto 10 | #' @references \url{http://stackoverflow.com/q/35690478/1270695} 11 | #' @examples 12 | #' 13 | #' mydf <- as.data.frame(matrix(c(1,2,3,4,0,0,1,1), byrow = TRUE, nrow = 2)) 14 | #' lengthener(mydf, 2) 15 | #' lengthener(mydf, 3) 16 | #' 17 | #' @export lengthener 18 | lengthener <- function(indt, n = 2) { 19 | if (!is.data.table(indt)) indt <- as.data.table(indt) 20 | temp <- rbindlist( 21 | combn(names(indt), n, FUN = function(x) { 22 | indt[, x, with = FALSE] 23 | }, simplify = FALSE), 24 | use.names = FALSE, idcol = TRUE) 25 | setorder(temp[, .id := sequence(.N), by = .id], .id)[, .id := NULL][] 26 | } 27 | NULL 28 | -------------------------------------------------------------------------------- /man/ReshapeLong.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ReshapeLong.R 3 | \name{ReshapeLong} 4 | \alias{ReshapeLong} 5 | \title{Reshape Data into a Semi-Long Format} 6 | \usage{ 7 | ReshapeLong(indt, stubs, sep = NULL) 8 | } 9 | \arguments{ 10 | \item{indt}{The input \code{data.table}.} 11 | 12 | \item{stubs}{Character vector containing the uniquely identifying stub 13 | portion of the variable names.} 14 | 15 | \item{sep}{Not presently used.} 16 | } 17 | \value{ 18 | A \code{data.table}. 19 | } 20 | \description{ 21 | Reshapes data with multiple measurements in a wide format into 22 | a long format with one column per measurement type. 23 | } 24 | \examples{ 25 | 26 | \dontrun{ 27 | library(foreign) 28 | dadmom <- read.dta("http://www.ats.ucla.edu/stat/stata/modules/dadmomw.dta") 29 | ReshapeLong(dadmom, c("name", "inc")) 30 | } 31 | 32 | } 33 | \references{ 34 | \url{http://stackoverflow.com/q/10468969/1270695} 35 | } 36 | \author{ 37 | Ananda Mahto 38 | } 39 | -------------------------------------------------------------------------------- /man/sortEnds.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sortEnds.R 3 | \name{sortEnds} 4 | \alias{sortEnds} 5 | \title{Select the Top-n Highest or Lowest Values in a Vector} 6 | \usage{ 7 | sortEnds(invec, n, where = "head") 8 | } 9 | \arguments{ 10 | \item{invec}{The input vector} 11 | 12 | \item{n}{The number of values desired} 13 | 14 | \item{where}{Either \code{"head"} or \code{"tail"}.} 15 | } 16 | \value{ 17 | A sorted vector of length = n 18 | } 19 | \description{ 20 | Takes "n" values from the head or tail of a sorted vector. Utilizes the 21 | "partial" argument from \code{sort} for increased efficiency. 22 | } 23 | \note{ 24 | The \code{"tail"} approach may not be consideraby faster than 25 | the standard approach. 26 | } 27 | \examples{ 28 | 29 | set.seed(1) 30 | x <- sample(300, 45, TRUE) 31 | sortEnds(x, 3) 32 | sortEnds(x, 3, "tail") 33 | 34 | ## Compare with 35 | head(sort(x), 3) 36 | tail(sort(x), 3) 37 | 38 | } 39 | \author{ 40 | Ananda Mahto 41 | } 42 | -------------------------------------------------------------------------------- /man/unlist_by_row.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/unlist_by_row.R 3 | \name{unlist_by_row} 4 | \alias{unlist_by_row} 5 | \alias{unlist_by_col} 6 | \title{Unlists the Values in a Rectangular Dataset by Row or Column} 7 | \usage{ 8 | unlist_by_row(indt, source = TRUE) 9 | 10 | unlist_by_col(indt, source = TRUE) 11 | } 12 | \arguments{ 13 | \item{indt}{The input dataset.} 14 | 15 | \item{source}{Logical. Should columns indicating the original row and column 16 | positions be returned. Defaults to \code{TRUE}.} 17 | } 18 | \value{ 19 | A \code{data.table} if \code{source = TRUE} or a vector. 20 | } 21 | \description{ 22 | Unlists the values in a rectangular dataset (like a \code{matrix}, 23 | \code{data.frame}, or \code{data.table}) by row. 24 | } 25 | \examples{ 26 | 27 | unlist_by_row(mtcars) 28 | 29 | 30 | unlist_by_col(mtcars) 31 | 32 | } 33 | \references{ 34 | \url{http://stackoverflow.com/q/36073947/1270695} 35 | } 36 | \author{ 37 | Ananda Mahto 38 | } 39 | -------------------------------------------------------------------------------- /R/CharNumSplit.R: -------------------------------------------------------------------------------- 1 | #' Split Vectors in the Form of Numbers+Characters or Characters+Numbers into Respective Parts 2 | #' 3 | #' A convenience function for the `perl = TRUE` patterns for 4 | #' `"(?<=[a-zA-Z])(?=[0-9])"` and `"(?<=[0-9])(?=[a-zA-Z])"`. That's it. Really. 5 | #' 6 | #' @param string The string to be split. 7 | #' @param alphaFirst Logical. Characters first (`TRUE`)? Or numbers (`FALSE`)? 8 | #' @return A `list` with the split values. 9 | #' @author Ananda Mahto 10 | #' @references 11 | #' @examples 12 | #' 13 | #' STR1 <- c("ABC123", "BCD234", "CDE345", "DEF456") 14 | #' STR2 <- c("123ABC", "234BCD", "345CDE", "456DEF") 15 | #' 16 | #' CharNumSplit(STR1, alphaFirst = TRUE) 17 | #' CharNumSplit(STR2, alphaFirst = FALSE) 18 | #' 19 | #' @export CharNumSplit 20 | CharNumSplit <- function(string, alphaFirst = TRUE) { 21 | Pattern <- ifelse(isTRUE(alphaFirst), "(?<=[a-zA-Z])(?=[0-9])", "(?<=[0-9])(?=[a-zA-Z])") 22 | strsplit(string, split = Pattern, perl = T) 23 | } 24 | -------------------------------------------------------------------------------- /R/vectorBind.R: -------------------------------------------------------------------------------- 1 | #' Bind Vectors Column-Wise According to Name 2 | #' 3 | #' Combines named vectors into a matrix with the rows being the names of the 4 | #' vector elements, and the columns being the name of the source vector. 5 | #' 6 | #' @param \dots The objects that need to be combined. 7 | #' @return A matrix. 8 | #' @author Ananda Mahto 9 | #' @references \url{http://stackoverflow.com/q/25639223/1270695} 10 | #' @examples 11 | #' 12 | #' set.seed(1) 13 | #' t1 <- table(sample(LETTERS[c(1, 2, 4)], 20, TRUE)) 14 | #' t2 <- table(sample(LETTERS[c(1, 2, 3)], 20, TRUE)) 15 | #' t3 <- table(sample(LETTERS[c(2, 4, 5)], 20, TRUE)) 16 | #' 17 | #' vectorBind(t1, t2, t3) 18 | #' 19 | #' @export vectorBind 20 | vectorBind <- function(...) { 21 | tbs <- list(...) 22 | names(tbs) <- getDots(...) 23 | nm <- unique(names(unlist(unname(tbs)))) 24 | vapply(tbs, function(x) { 25 | length(x) <- length(nm) 26 | x <- x[match(nm, names(x))] 27 | setNames(x, nm) 28 | }, numeric(length = length(nm))) 29 | } 30 | NULL 31 | -------------------------------------------------------------------------------- /man/mc_tribble.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mc_tribble.R 3 | \name{mc_tribble} 4 | \alias{mc_tribble} 5 | \title{Like \code{dput} for Those Confined to the Tidyverse} 6 | \usage{ 7 | mc_tribble(indf, indents = 4, mdformat = TRUE) 8 | } 9 | \arguments{ 10 | \item{indf}{The input \code{data.frame}.} 11 | 12 | \item{indents}{The number of spaces to indent each line of output. Defaults 13 | to \code{4}.} 14 | 15 | \item{mdformat}{Logical. Whether or not to add 4 spaces before every line in 16 | order to format as a code block. Defaults to \code{TRUE}.} 17 | } 18 | \description{ 19 | Creates a \code{dput}-like pasteable format that can be used to create small tables. 20 | } 21 | \examples{ 22 | 23 | \dontrun{ 24 | short_iris <- head(iris) 25 | mc_tribble(short_iris) 26 | } 27 | 28 | } 29 | \references{ 30 | \url{http://stackoverflow.com/q/42839626/1270695} 31 | } 32 | \author{ 33 | Ananda Mahto. Name courtesy of \href{https://stackoverflow.com/users/1191259/frank}{Frank}. 34 | } 35 | -------------------------------------------------------------------------------- /R/findFirst.R: -------------------------------------------------------------------------------- 1 | #' Find the First, Second, n Non-sequential Position of a Value in a Vector 2 | #' 3 | #' This function returns the location of the first, second, third (and so on) 4 | #' occurrence of a specified non-sequential value in a vector. 5 | #' 6 | #' @param invec The input vector. 7 | #' @param value The value you are looking for. 8 | #' @param event The desired position to be returned. 9 | #' @return A vector of length 1. 10 | #' @author Ananda Mahto 11 | #' @references 12 | #' @examples 13 | #' 14 | #' set.seed(1) 15 | #' a <- sample(LETTERS[1:5], 20, TRUE) 16 | #' a 17 | #' 18 | #' ## Note the difference between the following. 19 | #' ## The value "2" is skipped because it is sequential. 20 | #' which(a == "B") 21 | #' 22 | #' findFirst(a, "B", 2) 23 | #' 24 | #' @export findFirst 25 | findFirst <- function(invec, value, event) { 26 | x <- which(invec == value) 27 | if (event == 1) out <- x[1] 28 | else out <- x[which(diff(x) != 1)[event-1] + 1] 29 | out 30 | } 31 | 32 | -------------------------------------------------------------------------------- /R/replace_portion.R: -------------------------------------------------------------------------------- 1 | #' Find and Replace a Portion of a Vector 2 | #' 3 | #' Searches for a pattern in a vector and replaces it with a provided replacement pattern. 4 | #' 5 | #' @param invec The input vector. 6 | #' @param find What is the sequence that you're looking for? 7 | #' @param replace What do you want to replace the values with? 8 | #' @return A vector the same length as the input vector. 9 | #' @author Ananda Mahto 10 | #' @examples 11 | #' 12 | #' x <- c(1, 2, 3, 1, 0, 1, 0, 1, 2, 3, 4, 1, 0, 1) 13 | #' replace_portion(x, c(1, 0, 1), c(9, 9, 9)) 14 | #' 15 | #' @export replace_portion 16 | replace_portion <- function(invec, find, replace) { 17 | if (length(find) != length(replace)) stop("incompatible find/replace") 18 | if (all(find %in% invec)) { 19 | pos <- which(invec == find[1]) 20 | for (i in seq_along(pos)) { 21 | ind <- pos[i]:(pos[i]+length(find)-1) 22 | if (identical(invec[ind], find)) invec[ind] <- replace 23 | } 24 | } else { 25 | message("nothing changed") 26 | } 27 | invec 28 | } 29 | NULL 30 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # SOfun 1.76 2 | 3 | Added `list_reduction` function. 4 | 5 | # SOfun 1.75 6 | 7 | Not really sure whether this package warrants a NEWS section, so maybe I'll just use this for any major changes. 8 | 9 | ## Functions that have disappeared 10 | 11 | Sometimes functoins disappear for a good reason. Here are some that have gone missing. 12 | 13 | 1. `appendMe`: Like `rbind()` but adds the source in the process. Just use `rbindlist` from "data.table" with the `idcol` argument instead. Much better.... 14 | 1. `concat.split.DT`: Work in progress on an `fread()` approach to `concat.split()` from "splitstackshape". Now part of "splitstackshape" (since V1.4.0 and above). 15 | 1. `expandRows`: Expand the rows of a `data.frame` by a column in the `data.frame` or by a specified vector. Now a part of "splitstackshape". 16 | 17 | ## Functions that aren't really missing 18 | 19 | 1. [`ftable2df` `ftable2dt`](../reference/ftable2dt.html): Converts the output of `ftable()` to a `data.table`. *NOTE: Changed from `data.frame` to `data.table`.* -------------------------------------------------------------------------------- /man/findFirst.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/findFirst.R 3 | \name{findFirst} 4 | \alias{findFirst} 5 | \title{Find the First, Second, n Non-sequential Position of a Value in a Vector} 6 | \usage{ 7 | findFirst(invec, value, event) 8 | } 9 | \arguments{ 10 | \item{invec}{The input vector.} 11 | 12 | \item{value}{The value you are looking for.} 13 | 14 | \item{event}{The desired position to be returned.} 15 | } 16 | \value{ 17 | A vector of length 1. 18 | } 19 | \description{ 20 | This function returns the location of the first, second, third (and so on) 21 | occurrence of a specified non-sequential value in a vector. 22 | } 23 | \examples{ 24 | 25 | set.seed(1) 26 | a <- sample(LETTERS[1:5], 20, TRUE) 27 | a 28 | 29 | ## Note the difference between the following. 30 | ## The value "2" is skipped because it is sequential. 31 | which(a == "B") 32 | 33 | findFirst(a, "B", 2) 34 | 35 | } 36 | \references{ 37 | \url{http://stackoverflow.com/q/22049035/1270695} 38 | } 39 | \author{ 40 | Ananda Mahto 41 | } 42 | -------------------------------------------------------------------------------- /man/shifter.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/shifter.R 3 | \name{shifter} 4 | \alias{shifter} 5 | \title{"Shift" the Values of a Vector Ahead or Behind by a Specified Amount} 6 | \usage{ 7 | shifter(x = 1:10, n = 1) 8 | } 9 | \arguments{ 10 | \item{x}{The range that you are shifting} 11 | 12 | \item{n}{How much of a shift you want} 13 | } 14 | \value{ 15 | A vector of shifted values 16 | } 17 | \description{ 18 | This function "shifts" the values of a vector by a specified amount. For 19 | instance, if you are starting with a vector, "x", where the range of values 20 | is between 1 and 10, and you want 10 to be replaced by 9, 9 to be replaced 21 | by 8, and so on, with 1 being ultimately replaced by 10, this funciton 22 | should be of use. 23 | } 24 | \examples{ 25 | 26 | set.seed(1) 27 | X <- sample(10, 20, replace = TRUE) 28 | X 29 | 30 | shifter()[X] 31 | shifter(n = -2)[X] 32 | 33 | } 34 | \references{ 35 | \url{http://stackoverflow.com/a/20825012/1270695} 36 | } 37 | \author{ 38 | Ananda Mahto 39 | } 40 | -------------------------------------------------------------------------------- /man/completeVecs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/completeVecs.R 3 | \name{completeVecs} 4 | \alias{completeVecs} 5 | \title{Extract the \code{complete.cases} for a Set of Vectors} 6 | \usage{ 7 | completeVecs(...) 8 | } 9 | \arguments{ 10 | \item{\dots}{The vectors that need to be combined.} 11 | } 12 | \value{ 13 | A matrix with the same number of columns as there are input vectors. 14 | } 15 | \description{ 16 | Takes vectors as input and outputs a matrix of the complete cases across 17 | these vectors. 18 | } 19 | \note{ 20 | Short vectors are recycled without warnings. If your vectors are 21 | different lengths, you should decide whether this is a desirable behavior or 22 | not before using this function. 23 | } 24 | \examples{ 25 | 26 | A <- c(12, 8, 11, 9, NA, NA, NA) 27 | B <- c(NA, 7, NA, 10, NA, 11, 9) 28 | 29 | completeVecs(A, B) 30 | 31 | C <- c(1, 2, NA) 32 | 33 | completeVecs(A, B, C) 34 | 35 | } 36 | \references{ 37 | \url{http://stackoverflow.com/a/20146003/1270695} 38 | } 39 | \author{ 40 | Ananda Mahto 41 | } 42 | -------------------------------------------------------------------------------- /man/CharNumSplit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/CharNumSplit.R 3 | \name{CharNumSplit} 4 | \alias{CharNumSplit} 5 | \title{Split Vectors in the Form of Numbers+Characters or Characters+Numbers into Respective Parts} 6 | \usage{ 7 | CharNumSplit(string, alphaFirst = TRUE) 8 | } 9 | \arguments{ 10 | \item{string}{The string to be split.} 11 | 12 | \item{alphaFirst}{Logical. Characters first (\code{TRUE})? Or numbers (\code{FALSE})?} 13 | } 14 | \value{ 15 | A \code{list} with the split values. 16 | } 17 | \description{ 18 | A convenience function for the \code{perl = TRUE} patterns for 19 | \code{"(?<=[a-zA-Z])(?=[0-9])"} and \code{"(?<=[0-9])(?=[a-zA-Z])"}. That's it. Really. 20 | } 21 | \examples{ 22 | 23 | STR1 <- c("ABC123", "BCD234", "CDE345", "DEF456") 24 | STR2 <- c("123ABC", "234BCD", "345CDE", "456DEF") 25 | 26 | CharNumSplit(STR1, alphaFirst = TRUE) 27 | CharNumSplit(STR2, alphaFirst = FALSE) 28 | 29 | } 30 | \references{ 31 | \url{http://stackoverflow.com/a/23052016/1270695} 32 | } 33 | \author{ 34 | Ananda Mahto 35 | } 36 | -------------------------------------------------------------------------------- /man/this_by_n.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/this_by_n.R 3 | \name{this_by_n} 4 | \alias{this_by_n} 5 | \title{Apply This By Every n Values} 6 | \usage{ 7 | this_by_n(invec, n = 3, FUN = sum, fill = NA, include_first = TRUE) 8 | } 9 | \arguments{ 10 | \item{invec}{The input vector.} 11 | 12 | \item{n}{By how many values?} 13 | 14 | \item{FUN}{The function to apply to each set of n values.} 15 | 16 | \item{fill}{The value to padd the resulting vector with. Defaults to \code{NA}.} 17 | 18 | \item{include_first}{Logical. Should the first value be included. Defaults to \code{TRUE}.} 19 | } 20 | \value{ 21 | A vector the same length as the input vector. 22 | } 23 | \description{ 24 | Applies a function by every n values to a vector. 25 | } 26 | \examples{ 27 | 28 | x <- c(1, 2, 3, 4, 7, 9, 2, 4) 29 | this_by_n(x, 3, mean) 30 | this_by_n(x, 2, max) 31 | this_by_n(x, 4, min) 32 | this_by_n(letters[1:10], 5, toString) 33 | 34 | } 35 | \references{ 36 | \url{http://stackoverflow.com/q/34563693/1270695} 37 | } 38 | \author{ 39 | Ananda Mahto 40 | } 41 | -------------------------------------------------------------------------------- /R/sortEnds.R: -------------------------------------------------------------------------------- 1 | #' Select the Top-n Highest or Lowest Values in a Vector 2 | #' 3 | #' Takes "n" values from the head or tail of a sorted vector. Utilizes the 4 | #' "partial" argument from `sort` for increased efficiency. 5 | #' 6 | #' @param invec The input vector 7 | #' @param n The number of values desired 8 | #' @param where Either \code{"head"} or \code{"tail"}. 9 | #' @return A sorted vector of length = n 10 | #' @author Ananda Mahto 11 | #' @note The \code{"tail"} approach may not be consideraby faster than 12 | #' the standard approach. 13 | #' 14 | #' @examples 15 | #' 16 | #' set.seed(1) 17 | #' x <- sample(300, 45, TRUE) 18 | #' sortEnds(x, 3) 19 | #' sortEnds(x, 3, "tail") 20 | #' 21 | #' ## Compare with 22 | #' head(sort(x), 3) 23 | #' tail(sort(x), 3) 24 | #' 25 | #' @export sortEnds 26 | sortEnds <- function(invec, n, where = "head") { 27 | invec <- switch(where, head = invec, tail = -invec, 28 | stop("where must be 'head' or 'tail'")) 29 | out <- sort(invec, partial = seq_len(n))[seq_len(n)] 30 | switch(where, head = out, tail = sort(-out)) 31 | } 32 | NULL 33 | -------------------------------------------------------------------------------- /man/TabulateInt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/TabulateInt.R 3 | \name{TabulateInt} 4 | \alias{TabulateInt} 5 | \title{Allows Tabulate to Be Used with Negative Integers Too} 6 | \usage{ 7 | TabulateInt(vec) 8 | } 9 | \arguments{ 10 | \item{vec}{The input vector} 11 | } 12 | \value{ 13 | A named integer vector. There is a bin for each of the values 1, ..., nbins. 14 | } 15 | \description{ 16 | Modifies tabulate to work with non-positive integers too. 17 | } 18 | \note{ 19 | The behavior on non-integers might be somewhat unpredictable, but should 20 | be somewhat like using \code{table(cut(...))} with breaks being from the minimum 21 | to the maximum + 1. See the "Examples" section. 22 | } 23 | \examples{ 24 | 25 | x <- c(-5, -5, 3, 1, 0, 2, 5, -4, 0, 0, 1) 26 | TabulateInt(x) 27 | 28 | ## Compare 29 | tabulate(x) 30 | table(x) 31 | table(factor(x, min(x):max(x))) 32 | 33 | ## Non-integers 34 | set.seed(1) 35 | x <- rnorm(20) 36 | TabulateInt(x) 37 | table(cut(x, seq(min(x), max(x)+1, 1), include.lowest = TRUE)) 38 | 39 | } 40 | \author{ 41 | Ananda Mahto 42 | } 43 | -------------------------------------------------------------------------------- /man/TriIndex.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/TriIndex.R 3 | \name{TriIndex} 4 | \alias{TriIndex} 5 | \title{Get the row and column indices of upper and lower trianges of a matrix} 6 | \usage{ 7 | TriIndex(Nrow, which = "lower") 8 | } 9 | \arguments{ 10 | \item{Nrow}{The number of rows} 11 | 12 | \item{which}{Specify \code{which = "lower"} or \code{which = "upper"}. 13 | Defaults to \code{"lower"}.} 14 | } 15 | \value{ 16 | A two-column matrix. 17 | } 18 | \description{ 19 | Given the number of rows in a symmetric matrix, calculate the row and column 20 | indices of the upper or lower triangles. 21 | } 22 | \note{ 23 | A straightforward way to do this is to use 24 | \code{which(lower.tri(YourMatrix), arr.ind = TRUE)}, however, this can be 25 | quite slow as the number of rows increases. 26 | } 27 | \examples{ 28 | 29 | TriIndex(4) 30 | TriIndex(4, "upper") 31 | 32 | m <- matrix(0, nrow = 4, ncol = 4) 33 | which(lower.tri(m), arr.ind = TRUE) 34 | 35 | } 36 | \references{ 37 | \url{http://stackoverflow.com/a/20899060/1270695} 38 | } 39 | \author{ 40 | Ananda Mahto 41 | } 42 | -------------------------------------------------------------------------------- /R/completeVecs.R: -------------------------------------------------------------------------------- 1 | #' Extract the `complete.cases` for a Set of Vectors 2 | #' 3 | #' Takes vectors as input and outputs a matrix of the complete cases across 4 | #' these vectors. 5 | #' 6 | #' 7 | #' @param \dots The vectors that need to be combined. 8 | #' @return A matrix with the same number of columns as there are input vectors. 9 | #' @note Short vectors are recycled without warnings. If your vectors are 10 | #' different lengths, you should decide whether this is a desirable behavior or 11 | #' not before using this function. 12 | #' @author Ananda Mahto 13 | #' @references 14 | #' @examples 15 | #' 16 | #' A <- c(12, 8, 11, 9, NA, NA, NA) 17 | #' B <- c(NA, 7, NA, 10, NA, 11, 9) 18 | #' 19 | #' completeVecs(A, B) 20 | #' 21 | #' C <- c(1, 2, NA) 22 | #' 23 | #' completeVecs(A, B, C) 24 | #' 25 | #' @export completeVecs 26 | completeVecs <- function(...) { 27 | myList <- list(...) 28 | Names <- sapply(substitute(list(...)), deparse)[-1] 29 | out <- suppressWarnings( 30 | do.call(cbind, myList)[!is.na(Reduce("+", myList)), ]) 31 | colnames(out) <- Names 32 | out 33 | } 34 | -------------------------------------------------------------------------------- /man/tidyHTML.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tidyHTML.R 3 | \name{tidyHTML} 4 | \alias{tidyHTML} 5 | \title{Try to "Tidy" Untidy HTML Pages} 6 | \usage{ 7 | tidyHTML(URL) 8 | } 9 | \arguments{ 10 | \item{URL}{The problematic URL} 11 | } 12 | \value{ 13 | A parsed URL, ready to be used with \code{readHTMLTable} from the 14 | \code{XML} package. 15 | } 16 | \description{ 17 | Sometimes, web pages need a little "HTML Tidy" treatment before they can be 18 | successfully used by the parsers in the XML package. This function tries to 19 | tidy them using the online web service for HTML Tidy before parsing it. 20 | } 21 | \note{ 22 | Still no guarantee it will work! \code{:-)} 23 | } 24 | \examples{ 25 | 26 | \dontrun{ 27 | ## Can't find an actual example. The URL from the 28 | ## question is no longer online to test it with. 29 | 30 | Page <- "http://en.wikipedia.org/wiki/List_of_countries_by_population" 31 | u <- tidyHTML(Page) 32 | tables <- readHTMLTable(u) 33 | str(tables) 34 | } 35 | 36 | } 37 | \references{ 38 | \url{http://stackoverflow.com/a/12761741/1270695} 39 | } 40 | \author{ 41 | Ananda Mahto 42 | } 43 | -------------------------------------------------------------------------------- /R/this_by_n.R: -------------------------------------------------------------------------------- 1 | #' Apply This By Every n Values 2 | #' 3 | #' Applies a function by every n values to a vector. 4 | #' 5 | #' @param invec The input vector. 6 | #' @param n By how many values? 7 | #' @param FUN The function to apply to each set of n values. 8 | #' @param fill The value to padd the resulting vector with. Defaults to \code{NA}. 9 | #' @param include_first Logical. Should the first value be included. Defaults to `TRUE`. 10 | #' @return A vector the same length as the input vector. 11 | #' @author Ananda Mahto 12 | #' @references \url{http://stackoverflow.com/q/34563693/1270695} 13 | #' @examples 14 | #' 15 | #' x <- c(1, 2, 3, 4, 7, 9, 2, 4) 16 | #' this_by_n(x, 3, mean) 17 | #' this_by_n(x, 2, max) 18 | #' this_by_n(x, 4, min) 19 | #' this_by_n(letters[1:10], 5, toString) 20 | #' 21 | #' @export this_by_n 22 | this_by_n <- function(invec, n = 3, FUN = sum, fill = NA, include_first = TRUE) { 23 | FUN <- match.fun(FUN) 24 | n <- if (include_first) seq_len(n)-1 else seq_len(n) 25 | temp <- data.table::transpose(data.table::shift(invec, n = n, fill = fill, type = "lead")) 26 | sapply(temp, function(x) if (all(is.na(x))) NA else FUN(x[!is.na(x)])) 27 | } 28 | NULL 29 | -------------------------------------------------------------------------------- /R/tidyHTML.R: -------------------------------------------------------------------------------- 1 | #' Try to "Tidy" Untidy HTML Pages 2 | #' 3 | #' Sometimes, web pages need a little "HTML Tidy" treatment before they can be 4 | #' successfully used by the parsers in the XML package. This function tries to 5 | #' tidy them using the online web service for HTML Tidy before parsing it. 6 | #' 7 | #' @param URL The problematic URL 8 | #' @return A parsed URL, ready to be used with \code{readHTMLTable} from the 9 | #' \code{XML} package. 10 | #' @note Still no guarantee it will work! \code{:-)} 11 | #' @author Ananda Mahto 12 | #' @references \url{http://stackoverflow.com/a/12761741/1270695} 13 | #' @examples 14 | #' 15 | #' \dontrun{ 16 | #' ## Can't find an actual example. The URL from the 17 | #' ## question is no longer online to test it with. 18 | #' 19 | #' Page <- "http://en.wikipedia.org/wiki/List_of_countries_by_population" 20 | #' u <- tidyHTML(Page) 21 | #' tables <- readHTMLTable(u) 22 | #' str(tables) 23 | #' } 24 | #' 25 | #' @export tidyHTML 26 | tidyHTML <- function(URL) { 27 | URL = gsub("/", "%2F", URL) 28 | URL <- gsub(":", "%3A", URL) 29 | URL <- paste("http://services.w3.org/tidy/tidy?docAddr=", URL, sep = "") 30 | XML::htmlParse(URL) 31 | } 32 | -------------------------------------------------------------------------------- /R/needleInHaystack.R: -------------------------------------------------------------------------------- 1 | #' Find a Needle in a Haystack... 2 | #' 3 | #' Find specified search patterns (in any order, not necessarily joined) in 4 | #' another vector of strings. 5 | #' 6 | #' @param findMe What are you looking for? A character vector. 7 | #' @param findIn Where are you looking for it? A character vector. 8 | #' @return A matrix with 1 indicating presence and 0 indicating absence. 9 | #' @author Ananda Mahto 10 | #' @references \url{http://stackoverflow.com/q/22129542/1270695} 11 | #' @examples 12 | #' 13 | #' x <- c("cat", "dog", "rat", "far", "f*n", "god", "g*dn") 14 | #' y <- c("ar", "n*", "a", "zo") 15 | #' 16 | #' needleInHaystack(y, x) 17 | #' 18 | #' @export needleInHaystack 19 | needleInHaystack <- function(findMe, findIn) { 20 | Specials <- c(".", "|", "(", ")", "[", "{", "^", "$", "*", "+", "?") 21 | Patterns <- strsplit(findMe, "", fixed=TRUE) 22 | out <- vapply(vapply(Patterns, function(x) { 23 | x <- ifelse(x %in% Specials, paste0("\\", x), x) 24 | paste0("^", paste0("(?=.*", x, ")", collapse="")) 25 | }, character(1L)), grepl, logical(length(findIn)), 26 | findIn, perl = TRUE) * 1 27 | dimnames(out) <- list(findIn, findMe) 28 | out 29 | } 30 | NULL 31 | 32 | -------------------------------------------------------------------------------- /R/TabulateInt.R: -------------------------------------------------------------------------------- 1 | #' Allows Tabulate to Be Used with Negative Integers Too 2 | #' 3 | #' Modifies tabulate to work with non-positive integers too. 4 | #' 5 | #' @param vec The input vector 6 | #' @return A named integer vector. There is a bin for each of the values 1, ..., nbins. 7 | #' @author Ananda Mahto 8 | #' @note The behavior on non-integers might be somewhat unpredictable, but should 9 | #' be somewhat like using `table(cut(...))` with breaks being from the minimum 10 | #' to the maximum + 1. See the "Examples" section. 11 | #' @examples 12 | #' 13 | #' x <- c(-5, -5, 3, 1, 0, 2, 5, -4, 0, 0, 1) 14 | #' TabulateInt(x) 15 | #' 16 | #' ## Compare 17 | #' tabulate(x) 18 | #' table(x) 19 | #' table(factor(x, min(x):max(x))) 20 | #' 21 | #' ## Non-integers 22 | #' set.seed(1) 23 | #' x <- rnorm(20) 24 | #' TabulateInt(x) 25 | #' table(cut(x, seq(min(x), max(x)+1, 1), include.lowest = TRUE)) 26 | #' 27 | #' @export TabulateInt 28 | TabulateInt <- function(vec) { 29 | RANGE <- max(vec) 30 | x <- c(1, RANGE) 31 | if (any(vec <= 0)) { 32 | x <- range(vec) 33 | RANGE <- diff(x) + 1 34 | vec <- vec + abs(min(x)) + 1 35 | } 36 | `names<-`(tabulate(vec, nbins = RANGE), x[1]:x[2]) 37 | } 38 | NULL -------------------------------------------------------------------------------- /R/SOfun-package.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | #' Functions written while answering Stack Overflow questions 4 | #' 5 | #' A collection of functions I've written while answering questions on Stack 6 | #' Overflow. 7 | #' 8 | #' \tabular{ll}{ Package: \tab SOfun\cr Type: \tab Package\cr Version: \tab 9 | #' 1.76\cr Date: \tab 2020-06-19\cr License: \tab CC0\cr } 10 | #' 11 | #' @name SOfun-package 12 | #' @aliases SOfun SOfun-package 13 | #' @docType package 14 | #' @author Ananda Mahto 15 | #' 16 | #' Maintainer: Ananda Mahto 17 | #' @keywords package 18 | #' @examples 19 | #' 20 | #' adjCombos(letters[1:5]) 21 | #' 22 | #' cvA <- c(12, 8, 11, 9); cvB <- c(NA, 7, NA, 10) 23 | #' completeVecs(cvA, cvB) 24 | #' 25 | #' fx <- c("Y", "Y", "Yes", "N", "No", "H") 26 | #' Factor(fx, list(Yes = c("Yes", "Y"), No = c("No", "N"))) 27 | #' 28 | #' moveA <- letters[1:10] 29 | #' moveMe(moveA, "a last; b, e, g before d; c first; h after j") 30 | #' 31 | #' letterRep(20:40) 32 | #' 33 | #' Riffle(1:6, "x") 34 | #' Riffle(1:6, c("x", "y")) 35 | #' 36 | #' set.seed(1) 37 | #' SampleToSum() 38 | #' 39 | #' shiftX <- c(1, 4, 5, 2, 3, 6, 7, 8, 10, 9) 40 | #' shifter()[shiftX] 41 | #' 42 | #' shuffler(letters[1:10]) 43 | #' 44 | NULL 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /man/dupe_thresh.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dupe_thresh.R 3 | \name{dupe_thresh} 4 | \alias{dupe_thresh} 5 | \title{Filters a Vector According to Number of Duplicates} 6 | \usage{ 7 | dupe_thresh(invec, count) 8 | } 9 | \arguments{ 10 | \item{invec}{The input vector.} 11 | 12 | \item{count}{The threshold for duplicates. See "Details".} 13 | } 14 | \value{ 15 | A vector. 16 | } 17 | \description{ 18 | Filters a vector according to the number of duplicates in the vector, where 19 | the conditions for the acceptable number of duplicate values are specified. 20 | } 21 | \details{ 22 | The \code{"count"} parameter can be either a single digit or a character 23 | vector showing the desired comparison to be used as the threshold (for 24 | example \code{"> 5"}). If no binary relational operator is specified, the 25 | relational operator used is \code{>=}. 26 | } 27 | \examples{ 28 | 29 | set.seed(1) 30 | x <- sample(letters[1:10], 35, TRUE) 31 | sort(table(x)) 32 | 33 | table(dupe_thresh(x, 3)) 34 | table(dupe_thresh(x, "<3")) 35 | table(dupe_thresh(x, "== 3")) 36 | table(dupe_thresh(x, "!=3")) 37 | 38 | } 39 | \references{ 40 | \url{http://stackoverflow.com/q/29973061/1270695} 41 | } 42 | \author{ 43 | Ananda Mahto 44 | } 45 | -------------------------------------------------------------------------------- /man/SOfun-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SOfun-package.R 3 | \docType{package} 4 | \name{SOfun-package} 5 | \alias{SOfun-package} 6 | \alias{SOfun} 7 | \title{Functions written while answering Stack Overflow questions} 8 | \description{ 9 | A collection of functions I've written while answering questions on Stack 10 | Overflow. 11 | } 12 | \details{ 13 | \tabular{ll}{ Package: \tab SOfun\cr Type: \tab Package\cr Version: \tab 14 | 1.76\cr Date: \tab 2020-06-19\cr License: \tab CC0\cr } 15 | } 16 | \examples{ 17 | 18 | adjCombos(letters[1:5]) 19 | 20 | cvA <- c(12, 8, 11, 9); cvB <- c(NA, 7, NA, 10) 21 | completeVecs(cvA, cvB) 22 | 23 | fx <- c("Y", "Y", "Yes", "N", "No", "H") 24 | Factor(fx, list(Yes = c("Yes", "Y"), No = c("No", "N"))) 25 | 26 | moveA <- letters[1:10] 27 | moveMe(moveA, "a last; b, e, g before d; c first; h after j") 28 | 29 | letterRep(20:40) 30 | 31 | Riffle(1:6, "x") 32 | Riffle(1:6, c("x", "y")) 33 | 34 | set.seed(1) 35 | SampleToSum() 36 | 37 | shiftX <- c(1, 4, 5, 2, 3, 6, 7, 8, 10, 9) 38 | shifter()[shiftX] 39 | 40 | shuffler(letters[1:10]) 41 | 42 | } 43 | \author{ 44 | Ananda Mahto 45 | 46 | Maintainer: \href{mailto:ananda@mahto.info}{ananda@mahto.info} Ananda Mahto 47 | } 48 | \keyword{package} 49 | -------------------------------------------------------------------------------- /man/grouped_stem.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/grouped_stem.R 3 | \name{grouped_stem} 4 | \alias{grouped_stem} 5 | \alias{print.grouped_stem} 6 | \title{Create a Grouped Stem-and-Leaf Plot} 7 | \usage{ 8 | grouped_stem(invec, n = 2) 9 | 10 | \method{print}{grouped_stem}(x, ...) 11 | } 12 | \arguments{ 13 | \item{invec}{The input vector. This function only works with integers.} 14 | 15 | \item{n}{The number of stem values to be grouped} 16 | 17 | \item{x}{The object to be printed.} 18 | 19 | \item{\dots}{Not used.} 20 | } 21 | \value{ 22 | A \code{list} printed with stem-and-leaf formatting 23 | } 24 | \description{ 25 | Create a stem-and-leaf plot where the stems can be grouped by multiple values 26 | and the leaves indicate where the values are split 27 | } 28 | \examples{ 29 | 30 | set.seed(1) 31 | data_pos <- sample(0:50, 100, TRUE) 32 | grouped_stem(data_pos, 2) 33 | 34 | data_neg <- sample(-50:-1, 100, TRUE) 35 | grouped_stem(data_neg, 2) 36 | 37 | data_pos_neg <- c(0, sample(-50:50, 100, TRUE)) 38 | grouped_stem(data_pos_neg, 3) 39 | 40 | } 41 | \references{ 42 | \url{https://stackoverflow.com/q/62044245/1270695} 43 | } 44 | \seealso{ 45 | \code{\link[graphics:stem]{graphics::stem()}} 46 | } 47 | \author{ 48 | Ananda Mahto 49 | } 50 | -------------------------------------------------------------------------------- /man/word_value.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/word_value.R 3 | \name{word_value} 4 | \alias{word_value} 5 | \title{Converts a Vector of Words to Numeric Values Based on Letter Positions} 6 | \usage{ 7 | word_value(words, dtOut = FALSE) 8 | } 9 | \arguments{ 10 | \item{words}{The input vector of words.} 11 | 12 | \item{dtOut}{Logical. Should the output be a \code{data.table} comprising 13 | the words and the values. Defaults to \code{FALSE}.} 14 | } 15 | \value{ 16 | A named numeric vector or a \code{data.table}. 17 | } 18 | \description{ 19 | Uses the numeric position of the letters in a word to create a numeric value 20 | for a word. 21 | } 22 | \details{ 23 | The function converts the input to lowercase, removes anything that 24 | is not between the letters "a" and "z", and transliterates accented characters 25 | to their ASCII equivalent before converting the word to a numeric value. 26 | } 27 | \examples{ 28 | 29 | myvec <- c("and", "dad", "cat", "fox", "mom", 30 | "add", "dan", "naive", "non-descript") 31 | word_value(myvec) 32 | word_value(myvec, TRUE) 33 | 34 | } 35 | \references{ 36 | \url{http://stackoverflow.com/q/36097446/1270695} 37 | } 38 | \author{ 39 | Ananda Mahto and \href{http://stackoverflow.com/users/640595/jota}{Jota}. 40 | } 41 | -------------------------------------------------------------------------------- /man/col_flatten.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/col_flatten.R 3 | \name{col_flatten} 4 | \alias{col_flatten} 5 | \alias{col_flattenLong} 6 | \title{Flatten List Columns into a Wide or Long Form} 7 | \usage{ 8 | col_flatten(indt, cols, drop = FALSE) 9 | 10 | col_flattenLong(indt, cols) 11 | } 12 | \arguments{ 13 | \item{indt}{The input \code{data.table}.} 14 | 15 | \item{cols}{Character vector containing the names of list columns} 16 | 17 | \item{drop}{Logical. Should the list columns be dropped from the original 18 | \code{data.table}?} 19 | } 20 | \value{ 21 | A \code{data.table}. 22 | } 23 | \description{ 24 | Converts list columns into separate columns or into a long form. 25 | } 26 | \examples{ 27 | 28 | df <- structure( 29 | list(CAT = structure(1:2, .Label = c("A", "B"), class = "factor"), 30 | COUNT = list(1:3, 4:5), TREAT = list(c("Treat-a", "Treat-b"), 31 | c("Treat-c", "Treat-d", "Treat-e"))), 32 | .Names = c("CAT", "COUNT", "TREAT"), 33 | row.names = c(NA, -2L), class = "data.frame") 34 | 35 | col_flatten(df, c("COUNT", "TREAT"), TRUE) 36 | 37 | 38 | col_flattenLong(df, c("COUNT", "TREAT")) 39 | 40 | } 41 | \references{ 42 | \url{http://stackoverflow.com/q/34206003/1270695} 43 | } 44 | \author{ 45 | Ananda Mahto 46 | } 47 | -------------------------------------------------------------------------------- /man/fwf2csv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fwf2csv.R 3 | \name{fwf2csv} 4 | \alias{fwf2csv} 5 | \title{Creates a CSV Representation of Data Accoding to Stacks of Whitespace} 6 | \usage{ 7 | fwf2csv(infile, toDF = FALSE, ...) 8 | } 9 | \arguments{ 10 | \item{infile}{The input file. Can also be \code{"clipboard"} to read directly 11 | from the clipboard.} 12 | 13 | \item{toDF}{Logical. Should the file be read in while we are at it? Defaults 14 | to \code{FALSE}.} 15 | 16 | \item{\dots}{Other arguments to be passed to \code{read.table}.} 17 | } 18 | \value{ 19 | A vector or a \code{data.frame}, depending on the value in \code{toDF}. 20 | } 21 | \description{ 22 | Uses awk to convert a fixed-width file to a CSV based on stacks of whitespace. 23 | } 24 | \note{ 25 | Only tested on Linux. 26 | } 27 | \examples{ 28 | 29 | myfile <- tempfile(fileext = ".txt") 30 | Lines <- c("aaa b b ccc 345", "ddd fgt f u 3456", "e r der der 5 674") 31 | cat(Lines, sep = "\n") 32 | cat(Lines, sep = "\n", file = myfile) 33 | fwf2csv(myfile) 34 | fwf2csv(myfile, TRUE, header = FALSE) 35 | 36 | } 37 | \references{ 38 | \url{http://stackoverflow.com/q/30868600/1270695} 39 | } 40 | \author{ 41 | Ananda Mahto and \href{http://stackoverflow.com/users/1745001/ed-morton}{Ed Morton}. 42 | } 43 | -------------------------------------------------------------------------------- /R/TriIndex.R: -------------------------------------------------------------------------------- 1 | #' Get the row and column indices of upper and lower trianges of a matrix 2 | #' 3 | #' Given the number of rows in a symmetric matrix, calculate the row and column 4 | #' indices of the upper or lower triangles. 5 | #' 6 | #' @param Nrow The number of rows 7 | #' @param which Specify \code{which = "lower"} or \code{which = "upper"}. 8 | #' Defaults to \code{"lower"}. 9 | #' @return A two-column matrix. 10 | #' @note A straightforward way to do this is to use 11 | #' \code{which(lower.tri(YourMatrix), arr.ind = TRUE)}, however, this can be 12 | #' quite slow as the number of rows increases. 13 | #' @author Ananda Mahto 14 | #' @references \url{http://stackoverflow.com/a/20899060/1270695} 15 | #' @examples 16 | #' 17 | #' TriIndex(4) 18 | #' TriIndex(4, "upper") 19 | #' 20 | #' m <- matrix(0, nrow = 4, ncol = 4) 21 | #' which(lower.tri(m), arr.ind = TRUE) 22 | #' 23 | #' @export TriIndex 24 | TriIndex <- function(Nrow, which = "lower") { 25 | z <- sequence(Nrow) 26 | lower <- cbind( 27 | row = unlist(lapply(2:Nrow, function(x) x:Nrow), use.names = FALSE), 28 | col = rep(z[-length(z)], times = rev(tail(z, -1))-1)) 29 | out <- switch( 30 | which, 31 | lower = lower, 32 | upper = abs(lower - (Nrow + 1))[nrow(lower):1, ], 33 | stop("which should be 'upper' or 'lower'")) 34 | out 35 | } 36 | NULL 37 | 38 | -------------------------------------------------------------------------------- /R/ReshapeLong.R: -------------------------------------------------------------------------------- 1 | #' @name ReshapeLong 2 | #' @rdname ReshapeLong 3 | #' @title Reshape Data into a Semi-Long Format 4 | #' 5 | #' @description Reshapes data with multiple measurements in a wide format into 6 | #' a long format with one column per measurement type. 7 | #' 8 | #' @param indt The input \code{data.table}. 9 | #' @param stubs Character vector containing the uniquely identifying stub 10 | #' portion of the variable names. 11 | #' @param sep Not presently used. 12 | #' @return A \code{data.table}. 13 | #' @author Ananda Mahto 14 | #' @references \url{http://stackoverflow.com/q/10468969/1270695} 15 | #' @examples 16 | #' 17 | #' \dontrun{ 18 | #' library(foreign) 19 | #' dadmom <- read.dta("http://www.ats.ucla.edu/stat/stata/modules/dadmomw.dta") 20 | #' ReshapeLong(dadmom, c("name", "inc")) 21 | #' } 22 | #' 23 | #' @export 24 | ReshapeLong <- function(indt, stubs, sep = NULL) { 25 | if (!data.table::is.data.table(indt)) indt <- data.table::as.data.table(indt) 26 | variable <- NULL 27 | mv <- lapply(stubs, function(y) grep(sprintf("^%s", y), names(indt))) 28 | levs <- unique(gsub(paste(stubs, collapse="|"), "", names(indt)[unlist(mv)])) 29 | if (!is.null(sep)) levs <- gsub(sprintf("^%s", sep), "", levs, fixed = TRUE) 30 | data.table::melt(indt, measure = mv, value.name = stubs)[ 31 | , variable := factor(variable, labels = levs)][] 32 | } 33 | NULL 34 | -------------------------------------------------------------------------------- /R/mc_tribble.R: -------------------------------------------------------------------------------- 1 | #' Like `dput` for Those Confined to the Tidyverse 2 | #' 3 | #' Creates a `dput`-like pasteable format that can be used to create small tables. 4 | #' 5 | #' @param indf The input `data.frame`. 6 | #' @param indents The number of spaces to indent each line of output. Defaults 7 | #' to `4`. 8 | #' @param mdformat Logical. Whether or not to add 4 spaces before every line in 9 | #' order to format as a code block. Defaults to `TRUE`. 10 | #' @author Ananda Mahto. Name courtesy of [Frank](https://stackoverflow.com/users/1191259/frank). 11 | #' @references 12 | #' @examples 13 | #' 14 | #' \dontrun{ 15 | #' short_iris <- head(iris) 16 | #' mc_tribble(short_iris) 17 | #' } 18 | #' 19 | #' @export mc_tribble 20 | mc_tribble <- function(indf, indents = 4, mdformat = TRUE) { 21 | name <- as.character(substitute(indf)) 22 | name <- name[length(name)] 23 | cols <- paste0("~", names(indf), collapse = ", ") 24 | 25 | meat <- paste0( 26 | paste(rep(" ", indents), collapse = ""), 27 | c(cols, capture.output( 28 | data.table::fwrite(indf, quote = TRUE, col.names = FALSE, sep = ",")))) 29 | 30 | if (mdformat) meat <- paste0(" ", meat) 31 | obj <- paste(name, " <- tribble(\n", paste(meat, collapse = ",\n"), ")", sep = "") 32 | if (mdformat) obj <- paste0(" ", obj) 33 | writeClip(obj) 34 | cat(obj) 35 | } -------------------------------------------------------------------------------- /man/dailyCalendar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dailyCalendar.R 3 | \name{dailyCalendar} 4 | \alias{dailyCalendar} 5 | \alias{WeekDays} 6 | \title{Creates a Calendar in R} 7 | \usage{ 8 | WeekDays(startOn = "Monday", abbreviate = FALSE) 9 | 10 | dailyCalendar( 11 | startDate = Sys.Date(), 12 | days = 30, 13 | startOn = "Monday", 14 | fancy = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{startOn}{The day of the week to start on. Defaults to \code{"Monday"}.} 19 | 20 | \item{abbreviate}{Logical. Should the result be the abbreviated weekday name? 21 | Defaults to \code{FALSE}.} 22 | 23 | \item{startDate}{What should be the first date in the calendar? Defaults to 24 | \code{Sys.Date()}.} 25 | 26 | \item{days}{How many days do you want in your calendar? Defaults to \code{30}.} 27 | 28 | \item{fancy}{Logical. Should a more nicely formatted version of the calendar 29 | be displayed? Defaults to \code{FALSE}.} 30 | } 31 | \value{ 32 | A vector, a \code{data.frame}, or a \code{list}, depending on which function is 33 | called with what arguments. 34 | } 35 | \description{ 36 | Creates a daily calendar in R. 37 | } 38 | \examples{ 39 | WeekDays() 40 | WeekDays("Thursday", TRUE) 41 | dailyCalendar(startDate = "2013-12-27", days = 10) 42 | dailyCalendar(startDate = "2013-12-27", days = 10, startOn = "Friday") 43 | dailyCalendar(days = 40, fancy = TRUE) 44 | } 45 | \author{ 46 | Ananda Mahto 47 | } 48 | -------------------------------------------------------------------------------- /R/word_value.R: -------------------------------------------------------------------------------- 1 | #' Converts a Vector of Words to Numeric Values Based on Letter Positions 2 | #' 3 | #' Uses the numeric position of the letters in a word to create a numeric value 4 | #' for a word. 5 | #' 6 | #' @param words The input vector of words. 7 | #' @param dtOut Logical. Should the output be a \code{data.table} comprising 8 | #' the words and the values. Defaults to \code{FALSE}. 9 | #' @return A named numeric vector or a \code{data.table}. 10 | #' @author Ananda Mahto and \href{http://stackoverflow.com/users/640595/jota}{Jota}. 11 | #' @references \url{http://stackoverflow.com/q/36097446/1270695} 12 | #' @details The function converts the input to lowercase, removes anything that 13 | #' is not between the letters "a" and "z", and transliterates accented characters 14 | #' to their ASCII equivalent before converting the word to a numeric value. 15 | #' @examples 16 | #' 17 | #' myvec <- c("and", "dad", "cat", "fox", "mom", 18 | #' "add", "dan", "naive", "non-descript") 19 | #' word_value(myvec) 20 | #' word_value(myvec, TRUE) 21 | #' 22 | #' @export word_value 23 | word_value <- function(words, dtOut = FALSE) { 24 | offset <- utf8ToInt("a") - 1 25 | stripped <- iconv(tolower(gsub("[^a-z]", "", words)), to = "ASCII//TRANSLIT") 26 | out <- vapply(stripped, function(ii) 27 | sum(utf8ToInt(ii) - offset), numeric(1L)) 28 | if (isTRUE(dtOut)) setnames(data.table(as.table(out)), c("word", "value"))[] 29 | else out 30 | } 31 | NULL 32 | -------------------------------------------------------------------------------- /R/vec2symmat.R: -------------------------------------------------------------------------------- 1 | #' Creates a Symmetric Matrix from a Vector 2 | #' 3 | #' Takes a vector and, if the vector is of the correct lenght to be made into a 4 | #' symmetric matrix, performs the conversion. 5 | #' 6 | #' 7 | #' @param invec The input vector 8 | #' @param diag The value for the diagonal 9 | #' @param byrow Logical. Whether the upper-triangle should be filled in by row 10 | #' @return A matrix 11 | #' @author Ananda Mahto 12 | #' @references \url{http://stackoverflow.com/a/18598933/1270695} 13 | #' @examples 14 | #' 15 | #' myvec <- c(-.55, -.48, .66, .47, -.38, -.46) 16 | #' vec2symmat(myvec) 17 | #' 18 | #' vec2symmat(1:15, diag = 0) 19 | #' vec2symmat(1:15, diag = 0, byrow = FALSE) 20 | #' 21 | #' @export vec2symmat 22 | vec2symmat <- function(invec, diag = 1, byrow = TRUE) { 23 | Nrow <- ceiling(sqrt(2*length(invec))) 24 | 25 | if (!sqrt(length(invec)*2 + Nrow) %% 1 == 0) { 26 | stop("invec is wrong length to create a square symmetrical matrix") 27 | } 28 | 29 | mempty <- matrix(0, nrow = Nrow, ncol = Nrow) 30 | mindex <- matrix(sequence(Nrow^2), nrow = Nrow, ncol = Nrow, byrow = byrow) 31 | if (isTRUE(byrow)) { 32 | mempty[mindex[lower.tri(mindex)]] <- invec 33 | mempty[lower.tri(mempty)] <- t(mempty)[lower.tri(t(mempty))] 34 | } else { 35 | mempty[mindex[upper.tri(mindex)]] <- invec 36 | mempty[lower.tri(mempty)] <- t(mempty)[lower.tri(t(mempty))] 37 | } 38 | 39 | diag(mempty) <- diag 40 | mempty 41 | } 42 | -------------------------------------------------------------------------------- /R/dupe_thresh.R: -------------------------------------------------------------------------------- 1 | #' Filters a Vector According to Number of Duplicates 2 | #' 3 | #' Filters a vector according to the number of duplicates in the vector, where 4 | #' the conditions for the acceptable number of duplicate values are specified. 5 | #' 6 | #' @param invec The input vector. 7 | #' @param count The threshold for duplicates. See "Details". 8 | #' @return A vector. 9 | #' @author Ananda Mahto 10 | #' @references 11 | #' @details The `"count"` parameter can be either a single digit or a character 12 | #' vector showing the desired comparison to be used as the threshold (for 13 | #' example `"> 5"`). If no binary relational operator is specified, the 14 | #' relational operator used is `>=`. 15 | #' @examples 16 | #' 17 | #' set.seed(1) 18 | #' x <- sample(letters[1:10], 35, TRUE) 19 | #' sort(table(x)) 20 | #' 21 | #' table(dupe_thresh(x, 3)) 22 | #' table(dupe_thresh(x, "<3")) 23 | #' table(dupe_thresh(x, "== 3")) 24 | #' table(dupe_thresh(x, "!=3")) 25 | #' 26 | #' @export dupe_thresh 27 | dupe_thresh <- function(invec, count) { 28 | x <- trimws(strsplit(as.character(count), "(?<=[<>=!])", perl = TRUE)[[1]]) 29 | y <- if (length(x) == 1) { 30 | list(">=", x) 31 | } else if (length(x) == 2) { 32 | list(x[1], x[2]) 33 | } else if (length(x) == 3) { 34 | list(paste0(x[1], x[2]), x[3]) 35 | } 36 | ind <- ave(rep(1L, length(invec)), invec, FUN = length) 37 | invec[match.fun(y[[1]])(ind, as.numeric(y[[2]]))] 38 | } 39 | NULL -------------------------------------------------------------------------------- /man/toColClasses.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/toColClasses.R 3 | \name{toColClasses} 4 | \alias{toColClasses} 5 | \title{Change the Column Classes of Variables in a \code{data.frame}} 6 | \usage{ 7 | toColClasses(inDF, colClasses) 8 | } 9 | \arguments{ 10 | \item{inDF}{The source \code{data.frame}.} 11 | 12 | \item{colClasses}{A character vector of the desired column classes. This 13 | should be the same length as the number of columns in the \code{data.frame}. 14 | If no change is desired, use \code{""}.} 15 | } 16 | \value{ 17 | A \code{data.frame}. 18 | } 19 | \description{ 20 | Change the column classes of variables in a \code{data.frame} that has 21 | already been read into your workspace. 22 | } 23 | \note{ 24 | This function has only been tested with a very small set of the 25 | \code{as.*} functions. 26 | } 27 | \examples{ 28 | 29 | mydf <- data.frame( 30 | a = c(" 1"," 2", " 3"), 31 | b = c("a","b","c"), 32 | c = c(" 1.0", "NA", " 2.0"), 33 | d = c(" 1", "B", "2"), 34 | e = c(1, 0, 1)) 35 | 36 | mydf 37 | str(mydf) 38 | 39 | x <- toColClasses(mydf, c("as.integer", "", "as.numeric", 40 | "as.factor", "as.logical")) 41 | x 42 | str(x) 43 | 44 | y <- toColClasses(mydf, c("as.integer", "", "as.numeric", 45 | "as.character", "as.logical")) 46 | y 47 | str(y) 48 | 49 | } 50 | \references{ 51 | \url{http://stackoverflow.com/a/18893672/1270695} 52 | } 53 | \author{ 54 | Ananda Mahto 55 | } 56 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: master 4 | 5 | name: pkgdown 6 | 7 | jobs: 8 | pkgdown: 9 | runs-on: macOS-latest 10 | env: 11 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 12 | steps: 13 | - uses: actions/checkout@v2 14 | 15 | - uses: r-lib/actions/setup-r@master 16 | 17 | - uses: r-lib/actions/setup-pandoc@master 18 | 19 | - name: Query dependencies 20 | run: | 21 | install.packages('remotes') 22 | saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) 23 | writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") 24 | shell: Rscript {0} 25 | 26 | - name: Cache R packages 27 | uses: actions/cache@v1 28 | with: 29 | path: ${{ env.R_LIBS_USER }} 30 | key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} 31 | restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- 32 | 33 | - name: Install dependencies 34 | run: | 35 | install.packages("remotes") 36 | remotes::install_deps(dependencies = TRUE) 37 | remotes::install_dev("pkgdown") 38 | shell: Rscript {0} 39 | 40 | - name: Install package 41 | run: R CMD INSTALL . 42 | 43 | - name: Deploy package 44 | run: pkgdown::deploy_to_branch(new_process = FALSE) 45 | shell: Rscript {0} 46 | -------------------------------------------------------------------------------- /man/naLast.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/naLast.R 3 | \name{naLast} 4 | \alias{naLast} 5 | \title{Move All \code{NA} Values to the End of the Rows or Columns of a Matrix} 6 | \usage{ 7 | naLast(inmat, by = "row", outList = FALSE, fill = NA) 8 | } 9 | \arguments{ 10 | \item{inmat}{The input matrix.} 11 | 12 | \item{by}{Should be either \code{"row"} or \code{"col"}, depending on if you 13 | want to shift non-\code{NA} values left or up.} 14 | 15 | \item{outList}{Logical. Do you just want a \code{list} of the non-\code{NA} 16 | values? Defaults to \code{FALSE}.} 17 | 18 | \item{fill}{While you're at it, do you want to replace \code{NA} with some 19 | other value?} 20 | } 21 | \value{ 22 | Either a \code{matrix} with the same dimensions as the input matrix 23 | or a \code{list} with the same number of rows or columns as the input matrix 24 | (depending on the choice made in \code{by}). 25 | } 26 | \description{ 27 | Moves all of the \code{NA} values in the rows or columns of a matrix to the 28 | end of the respective rows or columns. 29 | } 30 | \examples{ 31 | 32 | set.seed(1) 33 | m <- matrix(sample(25, 20, TRUE), ncol = 4, 34 | dimnames = list(letters[1:5], LETTERS[1:4])) 35 | m[sample(prod(dim(m)), prod(dim(m)) * .6)] <- NA 36 | 37 | m 38 | 39 | naLast(m, by = "row") 40 | naLast(m, by = "col") 41 | naLast(m, by = "col", outList = TRUE) 42 | 43 | } 44 | \references{ 45 | \url{http://stackoverflow.com/q/23008142/1270695} 46 | } 47 | \author{ 48 | Ananda Mahto 49 | } 50 | -------------------------------------------------------------------------------- /man/arrayExtractor.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/arrayExtractor.R 3 | \name{arrayExtractor} 4 | \alias{arrayExtractor} 5 | \title{Extracting Information from an Array} 6 | \usage{ 7 | arrayExtractor(inarray, valslist) 8 | } 9 | \arguments{ 10 | \item{inarray}{The input array.} 11 | 12 | \item{valslist}{A list of vectors to use to extract data. A value of \code{NULL} 13 | for any of the list elements will return all values for that dimension.} 14 | } 15 | \value{ 16 | An array. 17 | } 18 | \description{ 19 | Uses a \code{list} of the same length as the dimensions of an array to extract 20 | information, similar to using matrix indexing. 21 | } 22 | \note{ 23 | The \code{list} used for \code{valslist} must be the same length as the number of 24 | dimensions in the array. It must also be specified in the same order as you 25 | would normally reference the dimensions of an array. For instance, in the 26 | example, the array has row dimensions, column dimensions, and a third 27 | dimension. 28 | } 29 | \examples{ 30 | 31 | my_array <- structure(1:12, .Dim = c(2L, 3L, 2L), 32 | .Dimnames = list(c("D_11", "D_12"), 33 | c("D_21", "D_22", "D_23"), c("D_31", "D_32"))) 34 | my_array 35 | 36 | arrayExtractor(my_array, list("D_11", NULL, NULL)) 37 | arrayExtractor(my_array, list(NULL, "D_21", "D_32")) 38 | arrayExtractor(my_array, list(NULL, c("D_21", "D_22"), NULL)) 39 | 40 | } 41 | \references{ 42 | \url{http://stackoverflow.com/q/34795331/1270695} 43 | } 44 | \author{ 45 | Ananda Mahto 46 | } 47 | -------------------------------------------------------------------------------- /R/unlist_by_row.R: -------------------------------------------------------------------------------- 1 | #' @name unlist_by_row 2 | #' @rdname unlist_by_row 3 | #' @title Unlists the Values in a Rectangular Dataset by Row or Column 4 | #' 5 | #' @description Unlists the values in a rectangular dataset (like a \code{matrix}, 6 | #' \code{data.frame}, or \code{data.table}) by row. 7 | #' 8 | #' @param indt The input dataset. 9 | #' @param source Logical. Should columns indicating the original row and column 10 | #' positions be returned. Defaults to \code{TRUE}. 11 | #' @return A \code{data.table} if \code{source = TRUE} or a vector. 12 | #' @author Ananda Mahto 13 | #' @references \url{http://stackoverflow.com/q/36073947/1270695} 14 | NULL 15 | 16 | #' @rdname unlist_by_row 17 | #' @examples 18 | #' 19 | #' unlist_by_row(mtcars) 20 | #' 21 | #' @export 22 | #' @aliases unlist_by_row 23 | unlist_by_row <- function(indt, source = TRUE) { 24 | if (!is.data.table(indt)) indt <- as.data.table(indt) 25 | temp <- c(t(indt)) 26 | if (isTRUE(source)) { 27 | setnames(do.call(CJ, lapply(dim(indt), seq_len)), 28 | c("row", "col"))[, value := temp][] 29 | } else { 30 | temp 31 | } 32 | } 33 | NULL 34 | 35 | #' @rdname unlist_by_row 36 | #' @examples 37 | #' 38 | #' unlist_by_col(mtcars) 39 | #' 40 | #' @export 41 | #' @aliases unlist_by_col 42 | unlist_by_col <- function(indt, source = TRUE) { 43 | if (!is.data.table(indt)) indt <- as.data.table(indt) 44 | if (isTRUE(source)) { 45 | setorder(unlist_by_row(indt, TRUE), col, row)[] 46 | } else { 47 | unlist(indt, use.names = FALSE) 48 | } 49 | } 50 | NULL 51 | -------------------------------------------------------------------------------- /man/SampleToSum.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/SampleToSum.R 3 | \name{SampleToSum} 4 | \alias{SampleToSum} 5 | \title{Sample from a Specific Range with a Target Vector Sum} 6 | \usage{ 7 | SampleToSum( 8 | Target = 100, 9 | VecLen = 10, 10 | InRange = 1:100, 11 | Tolerance = 2, 12 | showSum = TRUE 13 | ) 14 | } 15 | \arguments{ 16 | \item{Target}{The value that the vector should \code{sum} to} 17 | 18 | \item{VecLen}{The required vector length} 19 | 20 | \item{InRange}{The input range that values can be sampled from} 21 | 22 | \item{Tolerance}{A "buffer" for the \code{Target} argument, allowing the 23 | resulting sum to be slightly higher or slightly lower than specified.} 24 | 25 | \item{showSum}{Logical. Should the resulting total be shown?} 26 | } 27 | \value{ 28 | A vector 29 | } 30 | \description{ 31 | Takes a sample from a given range (for example, 1 to 100), and a specified 32 | resulting vector length (for example, 10), which add up to a specified 33 | value. 34 | } 35 | \note{ 36 | There is a good chance that with certain settings, this will be VERY 37 | SLOW! 38 | } 39 | \examples{ 40 | 41 | set.seed(1) 42 | SampleToSum() 43 | 44 | SampleToSum() 45 | 46 | SampleToSum(Tolerance = 0) 47 | 48 | SampleToSum(Tolerance = 0) 49 | 50 | set.seed(123) 51 | ## You'll have to wait a few seconds here 52 | SampleToSum(Target = 1163, VecLen = 15, InRange = 50:150) 53 | 54 | } 55 | \references{ 56 | \url{http://stackoverflow.com/a/14687223/1270695} 57 | } 58 | \author{ 59 | Ananda Mahto 60 | } 61 | -------------------------------------------------------------------------------- /man/list_unlister.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/list_unlister.R 3 | \name{list_unlister} 4 | \alias{list_unlister} 5 | \title{Unlists Columns of Lists by Combinations of Values} 6 | \usage{ 7 | list_unlister(indt, addRN = TRUE) 8 | } 9 | \arguments{ 10 | \item{indt}{The input \code{data.table}. The input can also be a \code{list}, 11 | possibly with elements of different lengths.} 12 | 13 | \item{addRN}{Logical. Should a column named "rn" be added to the 14 | \code{data.table}? Such a column is required, so if it does not already exist, 15 | it is suggested to keep this set to \code{TRUE}, the default.} 16 | } 17 | \value{ 18 | A \code{data.table}. 19 | } 20 | \description{ 21 | Unlists columns of lists by row creating combinations of values in the process. 22 | } 23 | \examples{ 24 | 25 | L1 <- list(list("A", c("B", "C")), list(1:2, 1:3)) 26 | list_unlister(L1) 27 | 28 | ## Note the NULLs and the shorter length of the first list item 29 | L2 <- list(V1 = list("A", c("A", "B"), "X", NULL), 30 | V2 = list(1, c(1, 2, 3), c(1, 2), c(1, 2, 3, 4), 1), 31 | V3 = list(c("a", "b"), "c", "d", c("e", "f"), c("g", "h", "i"))) 32 | list_unlister(L2) 33 | 34 | DT <- data.table::data.table( 35 | x1 = list("A", c("A", "B"), "X", NULL, c("Z", "W")), 36 | x2 = list(1, c(1, 2, 3), c(1, 2), c(1, 2, 3, 4), 1), 37 | x3 = list(c("a", "b"), "c", "d", c("e", "f"), c("g", "h", "i"))) 38 | list_unlister(DT) 39 | 40 | } 41 | \references{ 42 | \url{http://stackoverflow.com/q/23217958/1270695} 43 | } 44 | \author{ 45 | Ananda Mahto 46 | } 47 | -------------------------------------------------------------------------------- /R/arrayExtractor.R: -------------------------------------------------------------------------------- 1 | #' Extracting Information from an Array 2 | #' 3 | #' Uses a `list` of the same length as the dimensions of an array to extract 4 | #' information, similar to using matrix indexing. 5 | #' 6 | #' @param inarray The input array. 7 | #' @param valslist A list of vectors to use to extract data. A value of `NULL` 8 | #' for any of the list elements will return all values for that dimension. 9 | #' @return An array. 10 | #' @author Ananda Mahto 11 | #' @references 12 | #' @note The `list` used for `valslist` must be the same length as the number of 13 | #' dimensions in the array. It must also be specified in the same order as you 14 | #' would normally reference the dimensions of an array. For instance, in the 15 | #' example, the array has row dimensions, column dimensions, and a third 16 | #' dimension. 17 | #' @examples 18 | #' 19 | #' my_array <- structure(1:12, .Dim = c(2L, 3L, 2L), 20 | #' .Dimnames = list(c("D_11", "D_12"), 21 | #' c("D_21", "D_22", "D_23"), c("D_31", "D_32"))) 22 | #' my_array 23 | #' 24 | #' arrayExtractor(my_array, list("D_11", NULL, NULL)) 25 | #' arrayExtractor(my_array, list(NULL, "D_21", "D_32")) 26 | #' arrayExtractor(my_array, list(NULL, c("D_21", "D_22"), NULL)) 27 | #' 28 | #' @export arrayExtractor 29 | arrayExtractor <- function(inarray, valslist) { 30 | x <- sapply(valslist, is.null) 31 | valslist[x] <- dimnames(inarray)[x] 32 | temp <- as.matrix(expand.grid(valslist)) 33 | `dimnames<-`(`dim<-`(inarray[temp], lengths(valslist)), valslist) 34 | } 35 | NULL 36 | -------------------------------------------------------------------------------- /man/ragged.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ragged.R 3 | \name{ragged} 4 | \alias{ragged} 5 | \alias{print.ragged} 6 | \title{Display a \code{data.frame} with "ragged" keys} 7 | \usage{ 8 | ragged(indt, keys, blank = "") 9 | 10 | \method{print}{ragged}(x, ...) 11 | } 12 | \arguments{ 13 | \item{indt}{The input \code{data.frame} or \code{data.table}} 14 | 15 | \item{keys}{The variables to be used as keys or grouping variables} 16 | 17 | \item{blank}{The character to print to show nesting. Defaults to "".} 18 | 19 | \item{x}{The object to be printed.} 20 | 21 | \item{\dots}{Not used.} 22 | } 23 | \value{ 24 | A \code{list} with a "ragged" object and the sorted \code{data.table}. The custom 25 | \code{print} method displays the "ragged" result, but allows further use of \code{data.table}. 26 | } 27 | \description{ 28 | This is a display method for \code{data.frame}s to show ragged key/grouping variables, 29 | similar to \code{ftable} 30 | } 31 | \examples{ 32 | 33 | before= data.frame(C1= c(rep("A", 5), rep("L", 2)), 34 | C2= c("B", rep("E", 3), rep("K", 2), "L"), 35 | C3= c("C", "F", rep("H", 5)), 36 | C4= c("D", "G", "I", rep("J", 4)), 37 | stringsAsFactors = FALSE) 38 | 39 | ragged(before, c("C1", "C2")) 40 | ragged(before, names(before), ":") 41 | ragged(head(ggplot2::diamonds, 30), c("cut", "color"), ":")[, mean(price), .(cut, color)] 42 | 43 | } 44 | \references{ 45 | \url{https://stackoverflow.com/q/41324110/1270695} 46 | } 47 | \seealso{ 48 | \code{\link[stats:ftable]{stats::ftable()}} 49 | } 50 | \author{ 51 | Ananda Mahto 52 | } 53 | -------------------------------------------------------------------------------- /man/Riffle.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Riffle.R 3 | \name{Riffle} 4 | \alias{Riffle} 5 | \title{Interleaves Values Within Matrices or Vectors} 6 | \usage{ 7 | Riffle(...) 8 | } 9 | \arguments{ 10 | \item{\dots}{The objects or values that need to be interleaved.} 11 | } 12 | \value{ 13 | A vector or a matrix depending on the input. If one or more input 14 | objects is a matrix, the result will also be a matrix. 15 | } 16 | \description{ 17 | Mimics some of the behavior of the \code{Riffle} function 18 | (\url{http://reference.wolfram.com/mathematica/ref/Riffle.html}) in 19 | Mathematica. For matrices, it interleaves the columns. For vectors, it 20 | interleaves differently according to whether the subsequent values are 21 | presented as separate values or whether they are grouped with \code{c()}. 22 | } 23 | \details{ 24 | It is expected that all matrices to be interleaved would have the same 25 | number of rows, though they may have differing numbers of columns. If they 26 | have differing numbers of columns, they are all made to conform to the same 27 | dimension before proceeding by recycling the existing columns. 28 | } 29 | \examples{ 30 | 31 | m1 <- matrix(1:9, nrow = 3, ncol = 3) 32 | m2 <- matrix(letters[1:9], nrow = 3, ncol = 3) 33 | 34 | Riffle(m1, m2) 35 | Riffle(m1, "||", m2) 36 | 37 | m3 <- matrix(LETTERS[1:6], nrow = 3, ncol = 2) 38 | 39 | Riffle(m1, m2, m3) 40 | 41 | ## Just vectors 42 | 43 | Riffle(1:6, "x") 44 | Riffle(1:6, "x", "y") 45 | Riffle(1:6, c("x", "y")) 46 | 47 | } 48 | \references{ 49 | \url{http://stackoverflow.com/q/21347207/1270695} 50 | } 51 | \author{ 52 | Ananda Mahto 53 | } 54 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("[",ragged) 4 | S3method(print,Factor) 5 | S3method(print,grouped_stem) 6 | S3method(print,ragged) 7 | export(CharNumSplit) 8 | export(Diag) 9 | export(Factor) 10 | export(GroupedMedian) 11 | export(ReshapeLong) 12 | export(RestoreFactor) 13 | export(Riffle) 14 | export(SampleToSum) 15 | export(TabulateInt) 16 | export(TriIndex) 17 | export(TrueSeq) 18 | export(WeekDays) 19 | export(adjCombos) 20 | export(almostComplete) 21 | export(arrayExtractor) 22 | export(clc) 23 | export(col_flatten) 24 | export(col_flattenLong) 25 | export(completeVecs) 26 | export(dailyCalendar) 27 | export(dist2df) 28 | export(dupe_thresh) 29 | export(findFirst) 30 | export(ftable2dt) 31 | export(fwf2csv) 32 | export(getMyRows) 33 | export(grouped_stem) 34 | export(helpExtract) 35 | export(lengthener) 36 | export(letterRep) 37 | export(list_reduction) 38 | export(list_unlister) 39 | export(makemeNA) 40 | export(mc_tribble) 41 | export(melt_wide) 42 | export(moveMe) 43 | export(mySOreputation) 44 | export(naLast) 45 | export(needleInHaystack) 46 | export(ragged) 47 | export(read.mtable) 48 | export(replace_portion) 49 | export(shifter) 50 | export(shuffler) 51 | export(sortEnds) 52 | export(this_by_n) 53 | export(tidyHTML) 54 | export(toColClasses) 55 | export(unlist_by_col) 56 | export(unlist_by_row) 57 | export(vec2symmat) 58 | export(vectorBind) 59 | export(word_value) 60 | export(write.Hmisc.SPSS) 61 | import(Hmisc) 62 | import(data.table) 63 | import(stringr) 64 | import(utils) 65 | importFrom(stats,ave) 66 | importFrom(stats,embed) 67 | importFrom(stats,ftable) 68 | importFrom(stats,runif) 69 | importFrom(stats,setNames) 70 | importFrom(stats,ts) 71 | -------------------------------------------------------------------------------- /R/SampleToSum.R: -------------------------------------------------------------------------------- 1 | #' Sample from a Specific Range with a Target Vector Sum 2 | #' 3 | #' Takes a sample from a given range (for example, 1 to 100), and a specified 4 | #' resulting vector length (for example, 10), which add up to a specified 5 | #' value. 6 | #' 7 | #' @param Target The value that the vector should \code{sum} to 8 | #' @param VecLen The required vector length 9 | #' @param InRange The input range that values can be sampled from 10 | #' @param Tolerance A "buffer" for the \code{Target} argument, allowing the 11 | #' resulting sum to be slightly higher or slightly lower than specified. 12 | #' @param showSum Logical. Should the resulting total be shown? 13 | #' @return A vector 14 | #' @note There is a good chance that with certain settings, this will be VERY 15 | #' SLOW! 16 | #' @author Ananda Mahto 17 | #' @references \url{http://stackoverflow.com/a/14687223/1270695} 18 | #' @examples 19 | #' 20 | #' set.seed(1) 21 | #' SampleToSum() 22 | #' 23 | #' SampleToSum() 24 | #' 25 | #' SampleToSum(Tolerance = 0) 26 | #' 27 | #' SampleToSum(Tolerance = 0) 28 | #' 29 | #' set.seed(123) 30 | #' ## You'll have to wait a few seconds here 31 | #' SampleToSum(Target = 1163, VecLen = 15, InRange = 50:150) 32 | #' 33 | #' @export SampleToSum 34 | SampleToSum <- function(Target = 100, VecLen = 10, 35 | InRange = 1:100, Tolerance = 2, 36 | showSum = TRUE) { 37 | Res <- vector() 38 | while ( TRUE ) { 39 | Res <- round(diff(c(0, sort(runif(VecLen - 1)), 1)) * Target) 40 | if ( all(Res > 0) & 41 | all(Res >= min(InRange)) & 42 | all(Res <= max(InRange)) & 43 | abs((sum(Res) - Target)) <= Tolerance ) { break } 44 | } 45 | if (isTRUE(showSum)) cat("Total = ", sum(Res), "\n") 46 | Res 47 | } 48 | NULL 49 | 50 | -------------------------------------------------------------------------------- /man/melt_wide.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/melt_wide.R 3 | \name{melt_wide} 4 | \alias{melt_wide} 5 | \title{Melt Wide data.tables into Long data.tables} 6 | \usage{ 7 | melt_wide(data, id.vars, new.names) 8 | } 9 | \arguments{ 10 | \item{data}{The input \code{data.frame}} 11 | 12 | \item{id.vars}{ID variables} 13 | 14 | \item{new.names}{The new names for the resulting columns} 15 | } 16 | \value{ 17 | A long \code{data.table} 18 | } 19 | \description{ 20 | Reshapes double and tripple wide \code{data.table}s to long 21 | \code{data.table}s 22 | } 23 | \examples{ 24 | 25 | triplewide <- structure(list(ID = 1:4, 26 | w1d1t1 = c(4L, 3L, 2L, 2L), 27 | w1d1t2 = c(5L, 4L, 3L, 3L), 28 | w1d2t1 = c(6L, 5L, 5L, 4L), 29 | w1d2t2 = c(5L, 4L, 5L, 2L), 30 | w2d1t1 = c(6L, 5L, 4L, 3L), 31 | w2d1t2 = c(5L, 4L, 5L, 5L), 32 | w2d2t1 = c(6L, 3L, 6L, 3L), 33 | w2d2t2 = c(7L, 4L, 3L, 2L)), 34 | .Names = c("ID", "w1d1t1", "w1d1t2", 35 | "w1d2t1", "w1d2t2", "w2d1t1", "w2d1t2", 36 | "w2d2t1", "w2d2t2"), 37 | class = "data.frame", 38 | row.names = c(NA, -4L)) 39 | triplewide 40 | triplewide.long <- melt_wide(triplewide, id.vars="ID", 41 | new.names=c("week", "day", "trial")) 42 | triplewide.long 43 | data.table::dcast(triplewide.long, ID + week + day ~ trial) 44 | 45 | } 46 | \references{ 47 | \url{http://stackoverflow.com/a/10170630/1270695} 48 | } 49 | \author{ 50 | Ananda Mahto 51 | } 52 | -------------------------------------------------------------------------------- /man/read.mtable.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/read.mtable.R 3 | \name{read.mtable} 4 | \alias{read.mtable} 5 | \title{Read Data from a File Containing Multiple Datasets} 6 | \usage{ 7 | read.mtable(inFile, chunkId, ...) 8 | } 9 | \arguments{ 10 | \item{inFile}{The path to the input file} 11 | 12 | \item{chunkId}{A pattern in the text that identifies the "header" that 13 | indicates the start of a new dataset} 14 | 15 | \item{\dots}{Other arguments to be passed to \code{read.table}} 16 | } 17 | \value{ 18 | A \code{list} of \code{data.frame}s 19 | } 20 | \description{ 21 | Sometimes, a single file might have multiple datasets, each separated with a 22 | "header" of some sort. This function attempts to read the most basic of 23 | those types of files. 24 | } 25 | \note{ 26 | \code{names} are added to the resulting \code{list}, but these are not 27 | likely to be syntactically valid R names. 28 | } 29 | \examples{ 30 | 31 | x <- tempfile() 32 | cat("'Experiment Name: Here Be',,", "1,2,3", "4,5,6", "7,8,9", 33 | "'Experiment Name: The Dragons',,", "10,11,12", "13,14,15", 34 | "16,17,18", file = x, sep = "\n") 35 | 36 | read.mtable(x, "Experi", sep = ",") 37 | 38 | cat("Header: Boston city data", 39 | "Month Data1 Data2 Data3", 40 | "1 1.5 9.1342 8.1231", 41 | "2 12.3 12.31 1.129", 42 | "", "", "Header: Chicago city data", 43 | "Month Data1 Data2 Data3", 44 | "1 1.5 9.1342 8.1231", 45 | "2 12.3 12.31 1.129", 46 | file = x, sep = "\n") 47 | 48 | read.mtable(x, "Header", header = TRUE) 49 | 50 | } 51 | \references{ 52 | \url{http://stackoverflow.com/a/11530036/1270695}, 53 | \url{http://stackoverflow.com/a/11555316/1270695} 54 | } 55 | \author{ 56 | Ananda Mahto 57 | } 58 | -------------------------------------------------------------------------------- /man/moveMe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moveMe.R 3 | \name{moveMe} 4 | \alias{moveMe} 5 | \title{Reorders the Contents of a Vector} 6 | \usage{ 7 | moveMe(invec, movecommand) 8 | } 9 | \arguments{ 10 | \item{invec}{The input vector} 11 | 12 | \item{movecommand}{The command that describes how you want to shuffle the 13 | vector. See \emph{Details}.} 14 | } 15 | \value{ 16 | A vector. 17 | } 18 | \description{ 19 | Shuffle the order of a vector around using natural language statements. 20 | } 21 | \details{ 22 | This can be a useful function for reordering the columns of a 23 | \code{data.frame} or \code{data.table} in a convenient manner. In such 24 | cases, the \code{invec} would be \code{names(your_data_frame)}. When using 25 | \code{data.table}s, remember to use \code{setcolorder} to avoid copying. 26 | 27 | The \code{movecommand} argument is specified in the form of \code{"a, b 28 | before f"}. The positions to move are: \itemize{ \item \strong{first}: move 29 | the specified items to the first postion. \item \strong{last}: move the 30 | specified items to the last position. \item \strong{before}: move the 31 | specified items before the value mentioned. \item \strong{after}: move the 32 | specified items after the value mentioned. } Multiples are allowed: 33 | \itemize{ \item Specify multiple values to be moved by separating them with 34 | a comma. \item Chain multiple move commands by separating them with a 35 | semicolon. } 36 | } 37 | \examples{ 38 | 39 | myvec <- letters[1:10] 40 | myvec 41 | moveMe(myvec, "a last; b, e, g before d; c first; h after j") 42 | 43 | x <- names(mtcars) 44 | x 45 | moveMe(x, "hp first; cyl after drat; vs, am, gear before mpg; wt last") 46 | 47 | } 48 | \references{ 49 | \url{http://stackoverflow.com/a/18420673/1270695} 50 | } 51 | \author{ 52 | Ananda Mahto 53 | } 54 | -------------------------------------------------------------------------------- /R/fwf2csv.R: -------------------------------------------------------------------------------- 1 | #' Creates a CSV Representation of Data Accoding to Stacks of Whitespace 2 | #' 3 | #' Uses awk to convert a fixed-width file to a CSV based on stacks of whitespace. 4 | #' 5 | #' @param infile The input file. Can also be `"clipboard"` to read directly 6 | #' from the clipboard. 7 | #' @param toDF Logical. Should the file be read in while we are at it? Defaults 8 | #' to `FALSE`. 9 | #' @param \dots Other arguments to be passed to `read.table`. 10 | #' @return A vector or a `data.frame`, depending on the value in `toDF`. 11 | #' @author Ananda Mahto and [Ed Morton](http://stackoverflow.com/users/1745001/ed-morton). 12 | #' @references 13 | #' @note Only tested on Linux. 14 | #' @examples 15 | #' 16 | #' myfile <- tempfile(fileext = ".txt") 17 | #' Lines <- c("aaa b b ccc 345", "ddd fgt f u 3456", "e r der der 5 674") 18 | #' cat(Lines, sep = "\n") 19 | #' cat(Lines, sep = "\n", file = myfile) 20 | #' fwf2csv(myfile) 21 | #' fwf2csv(myfile, TRUE, header = FALSE) 22 | #' 23 | #' @export fwf2csv 24 | fwf2csv <- function(infile, toDF = FALSE, ...) { 25 | if (infile == "clipboard") { 26 | infile <- tempfile() 27 | writeLines(readClip(), infile) 28 | } 29 | 30 | a <- tempfile() 31 | text <- 'BEGIN{ FS=OFS=""; ARGV[ARGC]=ARGV[ARGC-1]; ARGC++ } 32 | NR==FNR { 33 | for (i=1;i<=NF;i++) { 34 | if ($i == " ") { 35 | space[i] 36 | } 37 | else { 38 | nonSpace[i] 39 | } 40 | } 41 | next 42 | } 43 | FNR==1 { 44 | for (i in nonSpace) { 45 | delete space[i] 46 | } 47 | } 48 | { 49 | for (i in space) { 50 | $i = "," 51 | } 52 | gsub(/,+/,",") 53 | print 54 | }' 55 | writeLines(text, a) 56 | command <- sprintf("awk -f %s %s", a, infile) 57 | if (isTRUE(toDF)) read.csv(text = system(command, intern = TRUE), ...) 58 | else system(command, intern = TRUE) 59 | } 60 | NULL -------------------------------------------------------------------------------- /R/melt_wide.R: -------------------------------------------------------------------------------- 1 | #' Melt Wide data.tables into Long data.tables 2 | #' 3 | #' Reshapes double and tripple wide \code{data.table}s to long 4 | #' \code{data.table}s 5 | #' 6 | #' 7 | #' @param data The input \code{data.frame} 8 | #' @param id.vars ID variables 9 | #' @param new.names The new names for the resulting columns 10 | #' @return A long \code{data.table} 11 | #' @author Ananda Mahto 12 | #' @references \url{http://stackoverflow.com/a/10170630/1270695} 13 | #' @examples 14 | #' 15 | #' triplewide <- structure(list(ID = 1:4, 16 | #' w1d1t1 = c(4L, 3L, 2L, 2L), 17 | #' w1d1t2 = c(5L, 4L, 3L, 3L), 18 | #' w1d2t1 = c(6L, 5L, 5L, 4L), 19 | #' w1d2t2 = c(5L, 4L, 5L, 2L), 20 | #' w2d1t1 = c(6L, 5L, 4L, 3L), 21 | #' w2d1t2 = c(5L, 4L, 5L, 5L), 22 | #' w2d2t1 = c(6L, 3L, 6L, 3L), 23 | #' w2d2t2 = c(7L, 4L, 3L, 2L)), 24 | #' .Names = c("ID", "w1d1t1", "w1d1t2", 25 | #' "w1d2t1", "w1d2t2", "w2d1t1", "w2d1t2", 26 | #' "w2d2t1", "w2d2t2"), 27 | #' class = "data.frame", 28 | #' row.names = c(NA, -4L)) 29 | #' triplewide 30 | #' triplewide.long <- melt_wide(triplewide, id.vars="ID", 31 | #' new.names=c("week", "day", "trial")) 32 | #' triplewide.long 33 | #' data.table::dcast(triplewide.long, ID + week + day ~ trial) 34 | #' 35 | #' @export 36 | melt_wide = function(data, id.vars, new.names) { 37 | if (!data.table::is.data.table(data)) data <- data.table::as.data.table(data) 38 | variable <- NULL 39 | data.table::melt(data, id.vars=id.vars)[ 40 | , (new.names) := data.table::transpose( 41 | stringr::str_extract_all(variable, "[0-9]+"))][] 42 | } 43 | -------------------------------------------------------------------------------- /R/toColClasses.R: -------------------------------------------------------------------------------- 1 | #' Change the Column Classes of Variables in a \code{data.frame} 2 | #' 3 | #' Change the column classes of variables in a \code{data.frame} that has 4 | #' already been read into your workspace. 5 | #' 6 | #' @param inDF The source \code{data.frame}. 7 | #' @param colClasses A character vector of the desired column classes. This 8 | #' should be the same length as the number of columns in the \code{data.frame}. 9 | #' If no change is desired, use \code{""}. 10 | #' @return A \code{data.frame}. 11 | #' @note This function has only been tested with a very small set of the 12 | #' \code{as.*} functions. 13 | #' @author Ananda Mahto 14 | #' @references \url{http://stackoverflow.com/a/18893672/1270695} 15 | #' @examples 16 | #' 17 | #' mydf <- data.frame( 18 | #' a = c(" 1"," 2", " 3"), 19 | #' b = c("a","b","c"), 20 | #' c = c(" 1.0", "NA", " 2.0"), 21 | #' d = c(" 1", "B", "2"), 22 | #' e = c(1, 0, 1)) 23 | #' 24 | #' mydf 25 | #' str(mydf) 26 | #' 27 | #' x <- toColClasses(mydf, c("as.integer", "", "as.numeric", 28 | #' "as.factor", "as.logical")) 29 | #' x 30 | #' str(x) 31 | #' 32 | #' y <- toColClasses(mydf, c("as.integer", "", "as.numeric", 33 | #' "as.character", "as.logical")) 34 | #' y 35 | #' str(y) 36 | #' 37 | #' @export toColClasses 38 | toColClasses <- function(inDF, colClasses) { 39 | if (length(colClasses) != length(inDF)) stop("Please specify colClasses for each column") 40 | inDF[] <- lapply(seq_along(colClasses), function(y) { 41 | if (colClasses[y] == "") { 42 | inDF[y] <- inDF[[y]] 43 | } else if (colClasses[y] == "as.logical") { 44 | FUN <- match.fun(colClasses[y]) 45 | inDF[y] <- suppressWarnings(FUN(as.numeric(as.character(inDF[[y]])))) 46 | } 47 | else { 48 | FUN <- match.fun(colClasses[y]) 49 | inDF[y] <- suppressWarnings(FUN(as.character(inDF[[y]]))) 50 | } 51 | }) 52 | inDF 53 | } 54 | NULL 55 | -------------------------------------------------------------------------------- /man/ftable2dt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ftable2dt.R 3 | \name{ftable2dt} 4 | \alias{ftable2dt} 5 | \title{Convert an \code{ftable} or an \code{array} Object to a \code{data.table}} 6 | \usage{ 7 | ftable2dt(inarray, direction = "wide") 8 | } 9 | \arguments{ 10 | \item{inarray}{The input \code{ftable} or \code{array}.} 11 | 12 | \item{direction}{Should the reslut be "wide" (with multiple measurement. 13 | columns) or "long" (with a single measurement column)? Defaults to \code{"wide"}.} 14 | } 15 | \value{ 16 | A \code{data.table} 17 | } 18 | \description{ 19 | While convenient methods exist for converting \code{table}s and other 20 | objects to \code{data.tables}s, such methods do not exist for converting an 21 | \code{ftable} to a \code{data.table}. An \code{ftable} is essentially a \code{matrix} with 22 | \code{attributes} for the rows and columns, which can be nested. 23 | } 24 | \note{ 25 | If the array has no \code{dimnames}, names would be added using the 26 | \code{provideDimnames} function. Defaults to \code{\link[reshape2:melt]{reshape2::melt()}} if the input is a 27 | simple matrix and not a multidimensional array. 28 | } 29 | \examples{ 30 | 31 | x <- ftable(Titanic, row.vars = 1:3) 32 | x 33 | ftable2dt(x) 34 | ftable2dt(x, direction = "long") 35 | 36 | \dontrun{ 37 | dims <- c(2, 1, 2, 3, 2) 38 | set.seed(1) 39 | M <- `dim<-`(sample(100, prod(dims), TRUE), dims) 40 | N <- O <- `dimnames<-`(M, lapply(dims, function(x) 41 | c(letters, LETTERS)[seq_len(x)])) 42 | names(attributes(O)$dimnames) <- c("first", "second", "third", 43 | "fourth", "fifth") 44 | 45 | ftable2dt(M) 46 | ftable2dt(N) 47 | ftable2dt(O) 48 | ftable2dt(M, "long") 49 | ftable2dt(N, "long") 50 | ftable2dt(O, "long") 51 | } 52 | 53 | } 54 | \references{ 55 | \url{http://stackoverflow.com/a/11143126/1270695} 56 | } 57 | \author{ 58 | Ananda Mahto 59 | } 60 | -------------------------------------------------------------------------------- /R/col_flatten.R: -------------------------------------------------------------------------------- 1 | #' @name col_flatten 2 | #' @rdname col_flatten 3 | #' @title Flatten List Columns into a Wide or Long Form 4 | #' 5 | #' @description Converts list columns into separate columns or into a long form. 6 | #' 7 | #' @param indt The input `data.table`. 8 | #' @param cols Character vector containing the names of list columns 9 | #' @param drop Logical. Should the list columns be dropped from the original 10 | #' `data.table`? 11 | #' @return A `data.table`. 12 | #' @author Ananda Mahto 13 | #' @references 14 | NULL 15 | 16 | #' @rdname col_flatten 17 | #' @examples 18 | #' 19 | #' df <- structure( 20 | #' list(CAT = structure(1:2, .Label = c("A", "B"), class = "factor"), 21 | #' COUNT = list(1:3, 4:5), TREAT = list(c("Treat-a", "Treat-b"), 22 | #' c("Treat-c", "Treat-d", "Treat-e"))), 23 | #' .Names = c("CAT", "COUNT", "TREAT"), 24 | #' row.names = c(NA, -2L), class = "data.frame") 25 | #' 26 | #' col_flatten(df, c("COUNT", "TREAT"), TRUE) 27 | #' 28 | #' @export 29 | #' @aliases col_flatten 30 | col_flatten <- function(indt, cols, drop = FALSE) { 31 | if (!data.table::is.data.table(indt)) indt <- data.table::as.data.table(indt) 32 | x <- unlist(indt[, lapply(.SD, function(x) max(lengths(x))), .SDcols = cols]) 33 | nams <- paste(rep(cols, x), sequence(x), sep = "_") 34 | indt[, (nams) := unlist(lapply(.SD, transpose), recursive = FALSE), .SDcols = (cols)] 35 | if (isTRUE(drop)) indt[, (cols) := NULL] 36 | indt[] 37 | } 38 | NULL 39 | 40 | #' @rdname col_flatten 41 | #' @examples 42 | #' 43 | #' col_flattenLong(df, c("COUNT", "TREAT")) 44 | #' 45 | #' @export 46 | #' @aliases col_flattenLong 47 | col_flattenLong <- function(indt, cols) { 48 | ob <- setdiff(names(indt), cols) 49 | x <- col_flatten(indt, cols, TRUE) 50 | mv <- lapply(cols, function(y) grep(sprintf("^%s_", y), names(x))) 51 | data.table::setorderv(melt(x, measure.vars = mv, value.name = cols), ob)[] 52 | } 53 | NULL -------------------------------------------------------------------------------- /R/list_unlister.R: -------------------------------------------------------------------------------- 1 | #' Unlists Columns of Lists by Combinations of Values 2 | #' 3 | #' Unlists columns of lists by row creating combinations of values in the process. 4 | #' 5 | #' @param indt The input \code{data.table}. The input can also be a \code{list}, 6 | #' possibly with elements of different lengths. 7 | #' @param addRN Logical. Should a column named "rn" be added to the 8 | #' \code{data.table}? Such a column is required, so if it does not already exist, 9 | #' it is suggested to keep this set to \code{TRUE}, the default. 10 | #' @return A \code{data.table}. 11 | #' @author Ananda Mahto 12 | #' @references \url{http://stackoverflow.com/q/23217958/1270695} 13 | #' @examples 14 | #' 15 | #' L1 <- list(list("A", c("B", "C")), list(1:2, 1:3)) 16 | #' list_unlister(L1) 17 | #' 18 | #' ## Note the NULLs and the shorter length of the first list item 19 | #' L2 <- list(V1 = list("A", c("A", "B"), "X", NULL), 20 | #' V2 = list(1, c(1, 2, 3), c(1, 2), c(1, 2, 3, 4), 1), 21 | #' V3 = list(c("a", "b"), "c", "d", c("e", "f"), c("g", "h", "i"))) 22 | #' list_unlister(L2) 23 | #' 24 | #' DT <- data.table::data.table( 25 | #' x1 = list("A", c("A", "B"), "X", NULL, c("Z", "W")), 26 | #' x2 = list(1, c(1, 2, 3), c(1, 2), c(1, 2, 3, 4), 1), 27 | #' x3 = list(c("a", "b"), "c", "d", c("e", "f"), c("g", "h", "i"))) 28 | #' list_unlister(DT) 29 | #' 30 | #' @export list_unlister 31 | list_unlister <- function(indt, addRN = TRUE) { 32 | LEN <- lengths(indt) 33 | MLen <- max(LEN) 34 | if (any(LEN != MLen)) indt <- lapply(indt, `length<-`, MLen) 35 | if (!is.data.table(indt)) indt <- as.data.table(indt) 36 | if (isTRUE(addRN)) indt <- copy(indt)[, rn := seq_len(nrow(indt))] 37 | setkey(indt, rn) 38 | setcolorder(indt, c("rn", names(indt)[-length(indt)])) 39 | out <- Reduce(function(x, y) x[y, allow.cartesian = TRUE], 40 | lapply(setdiff(names(indt), "rn"), function(x) 41 | indt[, list(unlist(get(x))), by = rn])) 42 | setnames(out, names(indt))[] 43 | } 44 | NULL -------------------------------------------------------------------------------- /man/Factor.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Factor.R 3 | \name{Factor} 4 | \alias{Factor} 5 | \alias{print.Factor} 6 | \alias{RestoreFactor} 7 | \title{Factor Vectors with Multiple Levels} 8 | \usage{ 9 | Factor(invec, levels = list(), store = TRUE, ...) 10 | 11 | \method{print}{Factor}(x, ...) 12 | 13 | RestoreFactor(invec) 14 | } 15 | \arguments{ 16 | \item{invec}{A \code{vector} that needs to be factored.} 17 | 18 | \item{levels}{A named \code{list} of the levels. The \code{name} is the 19 | level and the values are what should be mapped to those levels.} 20 | 21 | \item{store}{Logical. Should the input values be stored as an attribute?} 22 | 23 | \item{\dots}{Additional arguments to \code{factor}.} 24 | 25 | \item{x}{The object to be printed.} 26 | } 27 | \value{ 28 | A factored variable with \code{class} of \code{factor} and \code{Factor}, optionally 29 | with an \code{attribute} of \code{"Input"} which stores the original input values. 30 | } 31 | \description{ 32 | \code{\link[base:factor]{base::factor()}} does not let you use duplicated levels nicely. 33 | It results in an ugly warning message and you need to use \code{\link[base:droplevels]{base::droplevels()}} 34 | to get the desired output. The "solution" is to first factor the vector, and 35 | then use a named \code{list} with the \code{\link[base:levels]{base::levels()}} function. This function is 36 | a wrapper around those steps. 37 | } 38 | \examples{ 39 | 40 | x <- c("Y", "Y", "Yes", "N", "No", "H") 41 | Factor(x, list(Yes = c("Yes", "Y"), No = c("No", "N"))) 42 | Factor(x, list(Yes = c("Yes", "Y"), No = c("No", "N")), FALSE) 43 | y <- Factor(x, list(No = c("No", "N"), Yes = c("Yes", "Y")), ordered = TRUE) 44 | y 45 | 46 | RestoreFactor(y) 47 | 48 | } 49 | \references{ 50 | \url{http://stackoverflow.com/a/19410249/1270695} 51 | } 52 | \seealso{ 53 | \code{\link[base:factor]{base::factor()}}, \code{\link[base:levels]{base::levels()}} 54 | } 55 | \author{ 56 | Ananda Mahto 57 | } 58 | -------------------------------------------------------------------------------- /man/write.Hmisc.SPSS.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/write.Hmisc.SPSS.R 3 | \name{write.Hmisc.SPSS} 4 | \alias{write.Hmisc.SPSS} 5 | \title{Write an Hmisc data.frame with labels to SPSS} 6 | \usage{ 7 | write.Hmisc.SPSS(data, datafile, codefile) 8 | } 9 | \arguments{ 10 | \item{data}{The input data.frame} 11 | 12 | \item{datafile}{The name for the resulting SPSS data file} 13 | 14 | \item{codefile}{The name for the resulting SPSS code file} 15 | } 16 | \value{ 17 | Two files will be created in your working directory: a script file 18 | and a data file that can be used with SPSS 19 | } 20 | \description{ 21 | The Hmisc package lets you assign labels to data. This information is not 22 | included when using write.spss from the "foreign" package. This function 23 | tries to address that. 24 | } 25 | \examples{ 26 | 27 | df <- data.frame(id = c(1:6), 28 | p.code = c(1, 5, 4, NA, 0, 5), 29 | p.label = c('Optometrists', 'Nurses', 30 | 'Financial analysts', '', 31 | '0', 'Nurses'), 32 | foo = LETTERS[1:6]) 33 | # Add some variable labels using label from the Hmisc package 34 | library(Hmisc) 35 | label(df) <- "Sweet sweet data" 36 | label(df$id) <- "id blahblah" 37 | label(df$p.label) <- "Profession with human readable information" 38 | label(df$p.code) <- "Profession code" 39 | label(df$foo) <- "Variable label for variable x.var" 40 | # modify the name of one varibe to see what happens when exported 41 | names(df)[4] <- "New crazy name for 'foo'" 42 | 43 | df 44 | 45 | x <- setwd(tempdir()) 46 | list.files() 47 | write.Hmisc.SPSS(df, "df.sav", "df.sps") 48 | cat(readLines("df.sav"), sep = "\n") 49 | cat(readLines("df.sps"), sep = "\n") 50 | file.remove("df.sav", "df.sps") 51 | setwd(x) 52 | 53 | } 54 | \references{ 55 | \url{http://stackoverflow.com/a/10261534/1270695} 56 | } 57 | \author{ 58 | Ananda Mahto. Includes code from Chuck Cleland 59 | } 60 | -------------------------------------------------------------------------------- /man/getMyRows.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/getMyRows.R 3 | \name{getMyRows} 4 | \alias{getMyRows} 5 | \title{Get Rows Before and After a Specific Value or Rowname} 6 | \usage{ 7 | getMyRows(data, pattern, range, isNumeric = TRUE) 8 | } 9 | \arguments{ 10 | \item{data}{The input \code{data.frame}.} 11 | 12 | \item{pattern}{Either the pattern to match in the \code{rownames} or the 13 | numeric position of the initial rows.} 14 | 15 | \item{range}{A vector indicating the range of rows you want to extract (in 16 | the form of \code{-2:3}). In this case, it would extract two rows before and 17 | three rows after the matched index or pattern. Alternatively, a specific 18 | vector (instead of a range) can be supplied, as in \code{c(-1, 1)} in which 19 | case only the previous and next row will be returned, \emph{but not the row 20 | itself}.} 21 | 22 | \item{isNumeric}{Logical. Is \code{pattern} a numeric vector of row 23 | positions (\code{isNumeri = TRUE}) or is it a string value that needs to be 24 | matched against the \code{rownames}? Defaults to \code{TRUE}.} 25 | } 26 | \value{ 27 | A \code{list} of \code{data.frame}s with the relevant rows 28 | extracted. 29 | } 30 | \description{ 31 | Extracts (possibly overlapping) rows provided both a pattern or index 32 | position to match and a range specifying how many rows before and after the 33 | matched row. 34 | } 35 | \examples{ 36 | 37 | set.seed(1) 38 | dat1 <- data.frame(ID = 1:25, V1 = sample(100, 25, replace = TRUE)) 39 | rownames(dat1) <- paste("rowname", sample(apply(combn(LETTERS[1:4], 2), 40 | 2, paste, collapse = ""), 41 | 25, replace = TRUE), 42 | sprintf("\%02d", 1:25), sep = ".") 43 | getMyRows(dat1, c(2, 10), -3:2) 44 | getMyRows(dat1, c("AB", "AC"), -1:1, FALSE) 45 | getMyRows(dat1, c("AB", "AC"), c(-1, 1), FALSE) 46 | 47 | } 48 | \references{ 49 | \url{http://stackoverflow.com/a/13155669/1270695} 50 | } 51 | \author{ 52 | Ananda Mahto 53 | } 54 | -------------------------------------------------------------------------------- /man/mySOreputation.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mySOreputation.R 3 | \name{mySOreputation} 4 | \alias{mySOreputation} 5 | \title{Parse Your Reputation Page From Any of the Stack Exchange Sites} 6 | \usage{ 7 | mySOreputation(rep_file) 8 | } 9 | \arguments{ 10 | \item{rep_file}{The path to a text version of your reputation page. Windows 11 | and Linux users can copy the text on the page with select all + copy, and 12 | simply use "clipboard" instead of saving the contents to a local file.} 13 | } 14 | \description{ 15 | It is very easy to \emph{view} a detailed account of your reputation at any 16 | of the Stack Exchange sites by visiting \code{http://"sitename"/reputation} 17 | (obviously substituting "sitename" for the actual site of interest, for 18 | example, \url{http://stackoverflow.com/reputation}). However, that format 19 | is not very user-friendly if you want to do any analysis with it. This 20 | function parses that page into an R \code{data.frame}. 21 | } 22 | \examples{ 23 | 24 | ## This is a real reputation file, 25 | ## but the "question_id" variable is 26 | ## made up. 27 | rep_file <- system.file("soreputation.txt", package = "SOfun") 28 | readLines(rep_file, 15) 29 | mydf <- mySOreputation(rep_file = rep_file) 30 | head(mydf, 15) 31 | str(mydf) 32 | plot(mydf$date, cumsum(mydf$rep_change)) 33 | 34 | \dontrun{ 35 | library(xts) 36 | mydfx <- xts(mydf$rep_change, mydf$date) 37 | apply.monthly(mydfx, sum) 38 | plot(apply.monthly(mydfx, sum)) 39 | } 40 | 41 | 42 | } 43 | \references{ 44 | Values for the "actions" variable determined after visiting 45 | \url{http://meta.stackexchange.com/a/43005/214964}. 46 | There is one value not mentioned at that page, coded as \code{action_id == 47 | 99} and \code{action == Bonus} that corresponds to the bonus that a user 48 | gets when they have above a certain reputation and are active on multiple 49 | Stack Exchange sites. 50 | } 51 | \author{ 52 | Paul Hiemstra provided the base parser. Built upon by Ananda Mahto. 53 | } 54 | -------------------------------------------------------------------------------- /docs/bootstrap-toc.css: -------------------------------------------------------------------------------- 1 | /*! 2 | * Bootstrap Table of Contents v0.4.1 (http://afeld.github.io/bootstrap-toc/) 3 | * Copyright 2015 Aidan Feldman 4 | * Licensed under MIT (https://github.com/afeld/bootstrap-toc/blob/gh-pages/LICENSE.md) */ 5 | 6 | /* modified from https://github.com/twbs/bootstrap/blob/94b4076dd2efba9af71f0b18d4ee4b163aa9e0dd/docs/assets/css/src/docs.css#L548-L601 */ 7 | 8 | /* All levels of nav */ 9 | nav[data-toggle='toc'] .nav > li > a { 10 | display: block; 11 | padding: 4px 20px; 12 | font-size: 13px; 13 | font-weight: 500; 14 | color: #767676; 15 | } 16 | nav[data-toggle='toc'] .nav > li > a:hover, 17 | nav[data-toggle='toc'] .nav > li > a:focus { 18 | padding-left: 19px; 19 | color: #563d7c; 20 | text-decoration: none; 21 | background-color: transparent; 22 | border-left: 1px solid #563d7c; 23 | } 24 | nav[data-toggle='toc'] .nav > .active > a, 25 | nav[data-toggle='toc'] .nav > .active:hover > a, 26 | nav[data-toggle='toc'] .nav > .active:focus > a { 27 | padding-left: 18px; 28 | font-weight: bold; 29 | color: #563d7c; 30 | background-color: transparent; 31 | border-left: 2px solid #563d7c; 32 | } 33 | 34 | /* Nav: second level (shown on .active) */ 35 | nav[data-toggle='toc'] .nav .nav { 36 | display: none; /* Hide by default, but at >768px, show it */ 37 | padding-bottom: 10px; 38 | } 39 | nav[data-toggle='toc'] .nav .nav > li > a { 40 | padding-top: 1px; 41 | padding-bottom: 1px; 42 | padding-left: 30px; 43 | font-size: 12px; 44 | font-weight: normal; 45 | } 46 | nav[data-toggle='toc'] .nav .nav > li > a:hover, 47 | nav[data-toggle='toc'] .nav .nav > li > a:focus { 48 | padding-left: 29px; 49 | } 50 | nav[data-toggle='toc'] .nav .nav > .active > a, 51 | nav[data-toggle='toc'] .nav .nav > .active:hover > a, 52 | nav[data-toggle='toc'] .nav .nav > .active:focus > a { 53 | padding-left: 28px; 54 | font-weight: 500; 55 | } 56 | 57 | /* from https://github.com/twbs/bootstrap/blob/e38f066d8c203c3e032da0ff23cd2d6098ee2dd6/docs/assets/css/src/docs.css#L631-L634 */ 58 | nav[data-toggle='toc'] .nav > .active > ul { 59 | display: block; 60 | } 61 | -------------------------------------------------------------------------------- /man/helpExtract.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helpExtract.R 3 | \name{helpExtract} 4 | \alias{helpExtract} 5 | \title{Extract Portions from R Help Files for Use in Documents} 6 | \usage{ 7 | helpExtract(Function, section = "Usage", type = "m_code", ...) 8 | } 9 | \arguments{ 10 | \item{Function}{The function that you are extracting the help file from.} 11 | 12 | \item{section}{The section you want to extract. Defaults to \code{"Usage"}.} 13 | 14 | \item{type}{The type of character vector you want returned. Defaults to 15 | \code{"m_code"}. See \emph{Details}} 16 | 17 | \item{\dots}{Other arguments passed to \code{getHelpFile}.} 18 | } 19 | \value{ 20 | A character vector to be used in a Sweave or R-markdown document. 21 | } 22 | \description{ 23 | Extracts specified portions of R help files for use in Sweave or R-markdown 24 | documents. 25 | } 26 | \details{ 27 | The \code{type} argument accepts: \itemize{ \item \code{"m_code"}: For use 28 | with markdown documents in instances where highlighted code is expected, for 29 | example the "Usage" section. \item \code{"m_text"}: For use with markdown 30 | documents in instances where regular text is expected, for example the 31 | "Description" section. \item \code{"s_code"}: For use with Sweave documents 32 | in instances where highlighted code is expected, for example the "Usage" 33 | section. \item \code{"s_text"}: For use with Sweave documents in instances 34 | where regular text is expected, for example the "Description" section. } To 35 | insert a chunk into a markdown document, use something like: 36 | 37 | \verb{```{r, echo=FALSE, results='asis'}} \verb{cat(helpExtract(cor), sep = 38 | "\n")} \verb{```} 39 | 40 | To insert a chunk into a Sweave document, use something like: 41 | 42 | \verb{\Sexpr{knit_child(textConnection(helpExtract(cor, type = "s_code")), 43 | options = list(tidy = FALSE, eval = FALSE))}} 44 | } 45 | \examples{ 46 | 47 | cat(helpExtract(cor), sep = "\n") 48 | 49 | cat(helpExtract(cor, type = "m_text")) 50 | 51 | cat(helpExtract(cor, type = "m_text", section="Description")) 52 | 53 | } 54 | \author{ 55 | Ananda Mahto 56 | } 57 | -------------------------------------------------------------------------------- /R/read.mtable.R: -------------------------------------------------------------------------------- 1 | #' Read Data from a File Containing Multiple Datasets 2 | #' 3 | #' Sometimes, a single file might have multiple datasets, each separated with a 4 | #' "header" of some sort. This function attempts to read the most basic of 5 | #' those types of files. 6 | #' 7 | #' @param inFile The path to the input file 8 | #' @param chunkId A pattern in the text that identifies the "header" that 9 | #' indicates the start of a new dataset 10 | #' @param \dots Other arguments to be passed to \code{read.table} 11 | #' @return A \code{list} of \code{data.frame}s 12 | #' @note \code{names} are added to the resulting \code{list}, but these are not 13 | #' likely to be syntactically valid R names. 14 | #' @author Ananda Mahto 15 | #' @references \url{http://stackoverflow.com/a/11530036/1270695}, 16 | #' \url{http://stackoverflow.com/a/11555316/1270695} 17 | #' @examples 18 | #' 19 | #' x <- tempfile() 20 | #' cat("'Experiment Name: Here Be',,", "1,2,3", "4,5,6", "7,8,9", 21 | #' "'Experiment Name: The Dragons',,", "10,11,12", "13,14,15", 22 | #' "16,17,18", file = x, sep = "\n") 23 | #' 24 | #' read.mtable(x, "Experi", sep = ",") 25 | #' 26 | #' cat("Header: Boston city data", 27 | #' "Month Data1 Data2 Data3", 28 | #' "1 1.5 9.1342 8.1231", 29 | #' "2 12.3 12.31 1.129", 30 | #' "", "", "Header: Chicago city data", 31 | #' "Month Data1 Data2 Data3", 32 | #' "1 1.5 9.1342 8.1231", 33 | #' "2 12.3 12.31 1.129", 34 | #' file = x, sep = "\n") 35 | #' 36 | #' read.mtable(x, "Header", header = TRUE) 37 | #' 38 | #' @export read.mtable 39 | read.mtable <- function(inFile, chunkId, ...) { 40 | temp <- readLines(inFile) 41 | temp.loc <- grep(chunkId, temp) 42 | temp.loc <- c(temp.loc, length(temp)+1) 43 | temp.nam <- grep(chunkId, temp, value = TRUE) 44 | temp.out <- vector("list", length = length(temp.nam)) 45 | 46 | for (i in seq_along(temp.nam)) { 47 | temp.out[[i]] <- read.table( 48 | text = temp[seq(from = temp.loc[i]+1, to = temp.loc[i+1]-1)], ...) 49 | names(temp.out)[i] = temp.nam[i] 50 | } 51 | temp.out 52 | } 53 | NULL 54 | -------------------------------------------------------------------------------- /R/ragged.R: -------------------------------------------------------------------------------- 1 | #' Display a `data.frame` with "ragged" keys 2 | #' 3 | #' This is a display method for `data.frame`s to show ragged key/grouping variables, 4 | #' similar to `ftable` 5 | #' 6 | #' @param indt The input `data.frame` or `data.table` 7 | #' @param keys The variables to be used as keys or grouping variables 8 | #' @param blank The character to print to show nesting. Defaults to "". 9 | #' @return A `list` with a "ragged" object and the sorted `data.table`. The custom 10 | #' `print` method displays the "ragged" result, but allows further use of `data.table`. 11 | #' @author Ananda Mahto 12 | #' @references 13 | #' @seealso [stats::ftable()] 14 | #' @examples 15 | #' 16 | #' before= data.frame(C1= c(rep("A", 5), rep("L", 2)), 17 | #' C2= c("B", rep("E", 3), rep("K", 2), "L"), 18 | #' C3= c("C", "F", rep("H", 5)), 19 | #' C4= c("D", "G", "I", rep("J", 4)), 20 | #' stringsAsFactors = FALSE) 21 | #' 22 | #' ragged(before, c("C1", "C2")) 23 | #' ragged(before, names(before), ":") 24 | #' ragged(head(ggplot2::diamonds, 30), c("cut", "color"), ":")[, mean(price), .(cut, color)] 25 | #' 26 | #' @export ragged 27 | ragged <- function(indt, keys, blank = "") { 28 | indt <- data.table::setkeyv(data.table::as.data.table(indt), keys) 29 | vals <- setdiff(names(indt), keys) 30 | nams <- paste0(keys, "_copy") 31 | for (i in seq_along(nams)) { 32 | indt[, (nams[i]) := c(as.character(get(key(indt)[i])[1]), 33 | rep(blank, .N-1)), by = eval(keys[seq(i)])] 34 | } 35 | out <- cbind(indt[, ..nams], indt[, ..vals]) 36 | out <- data.table::setnames(out, nams, keys)[] 37 | out <- list(indt = indt[, (nams) := NULL][], out = out, keys = keys, blank = blank) 38 | class(out) <- c("ragged", class(out)) 39 | out 40 | } 41 | NULL 42 | 43 | utils::globalVariables(c("..nams", "..vals")) 44 | 45 | #' @rdname ragged 46 | #' @export 47 | #' @param x The object to be printed. 48 | #' @param \dots Not used. 49 | print.ragged <- function(x, ...) { 50 | print(x$out, ...) 51 | } 52 | NULL 53 | 54 | #' @export 55 | `[.ragged` <- function(x, ...) { 56 | out <- x$indt[...] 57 | out <- ragged(out, keys = intersect(x$keys, names(out)), blank = x$blank) 58 | out 59 | } 60 | NULL 61 | -------------------------------------------------------------------------------- /R/getMyRows.R: -------------------------------------------------------------------------------- 1 | #' Get Rows Before and After a Specific Value or Rowname 2 | #' 3 | #' Extracts (possibly overlapping) rows provided both a pattern or index 4 | #' position to match and a range specifying how many rows before and after the 5 | #' matched row. 6 | #' 7 | #' 8 | #' @param data The input \code{data.frame}. 9 | #' @param pattern Either the pattern to match in the \code{rownames} or the 10 | #' numeric position of the initial rows. 11 | #' @param range A vector indicating the range of rows you want to extract (in 12 | #' the form of \code{-2:3}). In this case, it would extract two rows before and 13 | #' three rows after the matched index or pattern. Alternatively, a specific 14 | #' vector (instead of a range) can be supplied, as in \code{c(-1, 1)} in which 15 | #' case only the previous and next row will be returned, \emph{but not the row 16 | #' itself}. 17 | #' @param isNumeric Logical. Is \code{pattern} a numeric vector of row 18 | #' positions (\code{isNumeri = TRUE}) or is it a string value that needs to be 19 | #' matched against the \code{rownames}? Defaults to \code{TRUE}. 20 | #' @return A \code{list} of \code{data.frame}s with the relevant rows 21 | #' extracted. 22 | #' @author Ananda Mahto 23 | #' @references \url{http://stackoverflow.com/a/13155669/1270695} 24 | #' @examples 25 | #' 26 | #' set.seed(1) 27 | #' dat1 <- data.frame(ID = 1:25, V1 = sample(100, 25, replace = TRUE)) 28 | #' rownames(dat1) <- paste("rowname", sample(apply(combn(LETTERS[1:4], 2), 29 | #' 2, paste, collapse = ""), 30 | #' 25, replace = TRUE), 31 | #' sprintf("%02d", 1:25), sep = ".") 32 | #' getMyRows(dat1, c(2, 10), -3:2) 33 | #' getMyRows(dat1, c("AB", "AC"), -1:1, FALSE) 34 | #' getMyRows(dat1, c("AB", "AC"), c(-1, 1), FALSE) 35 | #' 36 | #' @export getMyRows 37 | getMyRows <- function(data, pattern, range, isNumeric = TRUE) { 38 | if (isTRUE(isNumeric)) { 39 | if (!is.numeric(pattern)) stop("set isNumeric to FALSE or check your input pattern") 40 | x <- pattern 41 | } else { 42 | x <- grep(paste(pattern, collapse = "|"), rownames(data)) 43 | } 44 | lapply(x, function(y) { 45 | Z <- y + range 46 | data[Z[Z > 0 & Z <= nrow(data)], ] 47 | }) 48 | } 49 | 50 | -------------------------------------------------------------------------------- /man/list_reduction.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/list_reduction.R 3 | \name{list_reduction} 4 | \alias{list_reduction} 5 | \title{Successively Applies a Function at Each Index in a List} 6 | \usage{ 7 | list_reduction( 8 | inlist, 9 | FUN = intersect, 10 | flatten = FALSE, 11 | sorted = FALSE, 12 | MoreArgs = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{inlist}{The input \code{list}.} 17 | 18 | \item{FUN}{The function to be applied. Note that the supplied function should be one 19 | that you would expect to have work with two or more \code{vectors} as the given arguments. 20 | Thus, you can expect \code{range} to work, but not \code{mean}.} 21 | 22 | \item{flatten}{Logical. Should the output be simplified from a \code{list}. Defaults to 23 | \code{FALSE}. This is useful when you expect the result at each \code{list} index to be a 24 | single value (for example, when using a function like \code{sum} or \code{max}).} 25 | 26 | \item{sorted}{Logical. Should the values at each \code{list} index be sorted? Defaults 27 | to \code{FALSE}.} 28 | 29 | \item{MoreArgs}{A \code{list} of additional arguments to be passed to \code{FUN}. See 30 | \code{\link[base:mapply]{base::mapply()}} for more details.} 31 | } 32 | \value{ 33 | A \code{list} (default) or a simple \code{vector} (if \code{flatten = TRUE}). 34 | } 35 | \description{ 36 | Successively applies a function (\code{intersect}, by default) to elements 37 | at each index level in a \code{list}. 38 | } 39 | \examples{ 40 | 41 | L <- list(colA = list(c("a", "b", "c", "ñ"), c("f", "g", "h"), c("i", "j", "k")), 42 | colB = list(c("d", "b", "e"), c("f", "g", "m", "p"), c("f", "o", "j")), 43 | colC = list(c("a", "b", "g"), c("l", "g", "f", "k", "h"), c("j", "o", "l"))) 44 | list_reduction(L) 45 | list_reduction(L, flatten = TRUE) 46 | 47 | set.seed(1) 48 | L2 <- replicate(3, replicate(3, sample(sample(20), sample(10), TRUE), FALSE), FALSE) 49 | list_reduction(L2) 50 | list_reduction(L2, sum, flatten = TRUE) 51 | list_reduction(L2, range) 52 | list_reduction(L2, union) 53 | list_reduction(L2, union, sorted = TRUE) 54 | 55 | } 56 | \references{ 57 | See: \url{https://stackoverflow.com/q/62454705/1270695} 58 | } 59 | \seealso{ 60 | \code{\link[base:Reduce]{base::Reduce()}}, \code{\link[base:mapply]{base::mapply()}} 61 | } 62 | \author{ 63 | Ananda Mahto 64 | } 65 | -------------------------------------------------------------------------------- /docs/docsearch.js: -------------------------------------------------------------------------------- 1 | $(function() { 2 | 3 | // register a handler to move the focus to the search bar 4 | // upon pressing shift + "/" (i.e. "?") 5 | $(document).on('keydown', function(e) { 6 | if (e.shiftKey && e.keyCode == 191) { 7 | e.preventDefault(); 8 | $("#search-input").focus(); 9 | } 10 | }); 11 | 12 | $(document).ready(function() { 13 | // do keyword highlighting 14 | /* modified from https://jsfiddle.net/julmot/bL6bb5oo/ */ 15 | var mark = function() { 16 | 17 | var referrer = document.URL ; 18 | var paramKey = "q" ; 19 | 20 | if (referrer.indexOf("?") !== -1) { 21 | var qs = referrer.substr(referrer.indexOf('?') + 1); 22 | var qs_noanchor = qs.split('#')[0]; 23 | var qsa = qs_noanchor.split('&'); 24 | var keyword = ""; 25 | 26 | for (var i = 0; i < qsa.length; i++) { 27 | var currentParam = qsa[i].split('='); 28 | 29 | if (currentParam.length !== 2) { 30 | continue; 31 | } 32 | 33 | if (currentParam[0] == paramKey) { 34 | keyword = decodeURIComponent(currentParam[1].replace(/\+/g, "%20")); 35 | } 36 | } 37 | 38 | if (keyword !== "") { 39 | $(".contents").unmark({ 40 | done: function() { 41 | $(".contents").mark(keyword); 42 | } 43 | }); 44 | } 45 | } 46 | }; 47 | 48 | mark(); 49 | }); 50 | }); 51 | 52 | /* Search term highlighting ------------------------------*/ 53 | 54 | function matchedWords(hit) { 55 | var words = []; 56 | 57 | var hierarchy = hit._highlightResult.hierarchy; 58 | // loop to fetch from lvl0, lvl1, etc. 59 | for (var idx in hierarchy) { 60 | words = words.concat(hierarchy[idx].matchedWords); 61 | } 62 | 63 | var content = hit._highlightResult.content; 64 | if (content) { 65 | words = words.concat(content.matchedWords); 66 | } 67 | 68 | // return unique words 69 | var words_uniq = [...new Set(words)]; 70 | return words_uniq; 71 | } 72 | 73 | function updateHitURL(hit) { 74 | 75 | var words = matchedWords(hit); 76 | var url = ""; 77 | 78 | if (hit.anchor) { 79 | url = hit.url_without_anchor + '?q=' + escape(words.join(" ")) + '#' + hit.anchor; 80 | } else { 81 | url = hit.url + '?q=' + escape(words.join(" ")); 82 | } 83 | 84 | return url; 85 | } 86 | -------------------------------------------------------------------------------- /R/naLast.R: -------------------------------------------------------------------------------- 1 | #' Move All \code{NA} Values to the End of the Rows or Columns of a Matrix 2 | #' 3 | #' Moves all of the \code{NA} values in the rows or columns of a matrix to the 4 | #' end of the respective rows or columns. 5 | #' 6 | #' 7 | #' @param inmat The input matrix. 8 | #' @param by Should be either \code{"row"} or \code{"col"}, depending on if you 9 | #' want to shift non-\code{NA} values left or up. 10 | #' @param outList Logical. Do you just want a \code{list} of the non-\code{NA} 11 | #' values? Defaults to \code{FALSE}. 12 | #' @param fill While you're at it, do you want to replace \code{NA} with some 13 | #' other value? 14 | #' @return Either a \code{matrix} with the same dimensions as the input matrix 15 | #' or a \code{list} with the same number of rows or columns as the input matrix 16 | #' (depending on the choice made in \code{by}). 17 | #' @author Ananda Mahto 18 | #' @references \url{http://stackoverflow.com/q/23008142/1270695} 19 | #' @examples 20 | #' 21 | #' set.seed(1) 22 | #' m <- matrix(sample(25, 20, TRUE), ncol = 4, 23 | #' dimnames = list(letters[1:5], LETTERS[1:4])) 24 | #' m[sample(prod(dim(m)), prod(dim(m)) * .6)] <- NA 25 | #' 26 | #' m 27 | #' 28 | #' naLast(m, by = "row") 29 | #' naLast(m, by = "col") 30 | #' naLast(m, by = "col", outList = TRUE) 31 | #' 32 | #' @export naLast 33 | naLast <- function(inmat, by = "row", outList = FALSE, fill = NA) { 34 | A <- dim(inmat) 35 | M <- matrix(fill, nrow = A[1], ncol = A[2]) 36 | dimnames(M) <- dimnames(inmat) 37 | switch(by, 38 | row = { 39 | myFun1 <- function(x) { y <- inmat[x, ]; y[!is.na(y)] } 40 | B <- sequence(A[1]) 41 | }, 42 | col = { 43 | myFun1 <- function(x) { y <- inmat[, x]; y[!is.na(y)] } 44 | B <- sequence(A[2]) 45 | }, 46 | stop("'by' must be either 'row' or 'col'")) 47 | 48 | myList <- lapply(B, myFun1) 49 | if (isTRUE(outList)) { 50 | myList 51 | } else { 52 | Len <- vapply(myList, length, 1L) 53 | switch(by, 54 | row = { 55 | IJ <- cbind(rep(sequence(A[1]), Len), sequence(Len)) 56 | }, 57 | col = { 58 | IJ <- cbind(sequence(Len), rep(sequence(A[2]), Len)) 59 | }, 60 | stop("'by' must be either 'row' or 'col'")) 61 | M[IJ] <- unlist(myList, use.names=FALSE) 62 | M 63 | } 64 | } 65 | NULL 66 | -------------------------------------------------------------------------------- /R/list_reduction.R: -------------------------------------------------------------------------------- 1 | #' Successively Applies a Function at Each Index in a List 2 | #' 3 | #' Successively applies a function (`intersect`, by default) to elements 4 | #' at each index level in a `list`. 5 | #' 6 | #' @param inlist The input `list`. 7 | #' @param FUN The function to be applied. Note that the supplied function should be one 8 | #' that you would expect to have work with two or more `vectors` as the given arguments. 9 | #' Thus, you can expect `range` to work, but not `mean`. 10 | #' @param flatten Logical. Should the output be simplified from a `list`. Defaults to 11 | #' `FALSE`. This is useful when you expect the result at each `list` index to be a 12 | #' single value (for example, when using a function like `sum` or `max`). 13 | #' @param sorted Logical. Should the values at each `list` index be sorted? Defaults 14 | #' to `FALSE`. 15 | #' @param MoreArgs A `list` of additional arguments to be passed to `FUN`. See 16 | #' [base::mapply()] for more details. 17 | #' @return A `list` (default) or a simple `vector` (if `flatten = TRUE`). 18 | #' @author Ananda Mahto 19 | #' @seealso [base::Reduce()], [base::mapply()] 20 | #' @references See: 21 | #' @examples 22 | #' 23 | #' L <- list(colA = list(c("a", "b", "c", "ñ"), c("f", "g", "h"), c("i", "j", "k")), 24 | #' colB = list(c("d", "b", "e"), c("f", "g", "m", "p"), c("f", "o", "j")), 25 | #' colC = list(c("a", "b", "g"), c("l", "g", "f", "k", "h"), c("j", "o", "l"))) 26 | #' list_reduction(L) 27 | #' list_reduction(L, flatten = TRUE) 28 | #' 29 | #' set.seed(1) 30 | #' L2 <- replicate(3, replicate(3, sample(sample(20), sample(10), TRUE), FALSE), FALSE) 31 | #' list_reduction(L2) 32 | #' list_reduction(L2, sum, flatten = TRUE) 33 | #' list_reduction(L2, range) 34 | #' list_reduction(L2, union) 35 | #' list_reduction(L2, union, sorted = TRUE) 36 | #' 37 | #' @export list_reduction 38 | list_reduction <- function(inlist, FUN = intersect, flatten = FALSE, sorted = FALSE, MoreArgs = NULL) { 39 | temp <- Reduce(function(x, y) mapply(FUN, x, y, MoreArgs = MoreArgs, SIMPLIFY = FALSE), inlist) 40 | if (sorted) temp <- lapply(temp, sort) 41 | if (flatten) { 42 | if (all(lengths(temp) == 1L)) { 43 | return(unlist(temp, use.names = FALSE)) 44 | } else { 45 | return(vapply(temp, toString, character(1L))) 46 | } 47 | } else { 48 | return(temp) 49 | } 50 | } 51 | NULL 52 | -------------------------------------------------------------------------------- /man/GroupedMedian.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/GroupedMedian.R 3 | \name{GroupedMedian} 4 | \alias{GroupedMedian} 5 | \title{Calculate the Median of Already Grouped Data} 6 | \usage{ 7 | GroupedMedian(frequencies, intervals, sep = NULL, trim = NULL) 8 | } 9 | \arguments{ 10 | \item{frequencies}{A vector of frequencies.} 11 | 12 | \item{intervals}{A 2-row \code{matrix} with the same number of columns as 13 | the length of frequencies, with the first row being the lower class 14 | boundary, and the second row being the upper class boundary. Alternatively, 15 | \code{intervals} may be a column in your \code{data.frame}, and you may 16 | specify \code{sep} (and possibly, \code{trim}) to have the 17 | \code{GroupedMedian} function automatically create the required 18 | \code{matrix} for you.} 19 | 20 | \item{sep}{Optional. If the \code{intervals} are represented by a character 21 | vector with a character separating the interval ranges.} 22 | 23 | \item{trim}{Characters to trim from the vector before splitting. For 24 | example, if you are doing this on the output of \code{cut} (where, for some 25 | reason, you no longer have access to the original data), you can use the 26 | pre-set trim pattern \code{"cut"}.} 27 | } 28 | \value{ 29 | A single numeric value representing the grouped median. 30 | } 31 | \description{ 32 | Calculates the median of already grouped data given the interval ranges and 33 | the frequencies of each group. 34 | } 35 | \examples{ 36 | 37 | mydf <- structure(list(salary = c("1500-1600", "1600-1700", "1700-1800", 38 | "1800-1900", "1900-2000", "2000-2100", "2100-2200", "2200-2300", 39 | "2300-2400", "2400-2500"), number = c(110L, 180L, 320L, 460L, 40 | 850L, 250L, 130L, 70L, 20L, 10L)), .Names = c("salary", "number"), 41 | class = "data.frame", row.names = c(NA, -10L)) 42 | mydf 43 | 44 | GroupedMedian(frequencies = mydf$number, intervals = mydf$salary, sep = "-") 45 | 46 | ## Example with intervals manually specified 47 | X <- rbind(c(1500, 1600, 1700, 1800, 1900, 2000, 2100, 2200, 2300, 2400), 48 | c(1600, 1700, 1800, 1900, 2000, 2100, 2200, 2300, 2400, 2500)) 49 | 50 | GroupedMedian(mydf$number, X) 51 | 52 | set.seed(1) 53 | x <- sample(100, 100, replace = TRUE) 54 | y <- data.frame(table(cut(x, 10))) 55 | 56 | GroupedMedian(y$Freq, y$Var1, sep = ",", trim = "cut") 57 | 58 | } 59 | \references{ 60 | \url{http://stackoverflow.com/a/18931054/1270695} 61 | } 62 | \author{ 63 | Ananda Mahto 64 | } 65 | -------------------------------------------------------------------------------- /R/Factor.R: -------------------------------------------------------------------------------- 1 | #' @name Factor 2 | #' @rdname Factor 3 | #' @title Factor Vectors with Multiple Levels 4 | #' 5 | #' @description [base::factor()] does not let you use duplicated levels nicely. 6 | #' It results in an ugly warning message and you need to use [base::droplevels()] 7 | #' to get the desired output. The "solution" is to first factor the vector, and 8 | #' then use a named `list` with the [base::levels()] function. This function is 9 | #' a wrapper around those steps. 10 | #' 11 | #' @param invec A `vector` that needs to be factored. 12 | #' @param levels A named `list` of the levels. The `name` is the 13 | #' level and the values are what should be mapped to those levels. 14 | #' @param store Logical. Should the input values be stored as an attribute? 15 | #' @param \dots Additional arguments to `factor`. 16 | #' @param x The object to be printed. 17 | #' @return A factored variable with `class` of `factor` and `Factor`, optionally 18 | #' with an `attribute` of `"Input"` which stores the original input values. 19 | #' @author Ananda Mahto 20 | #' @seealso [base::factor()], [base::levels()] 21 | #' @references 22 | NULL 23 | 24 | #' @rdname Factor 25 | #' @examples 26 | #' 27 | #' x <- c("Y", "Y", "Yes", "N", "No", "H") 28 | #' Factor(x, list(Yes = c("Yes", "Y"), No = c("No", "N"))) 29 | #' Factor(x, list(Yes = c("Yes", "Y"), No = c("No", "N")), FALSE) 30 | #' y <- Factor(x, list(No = c("No", "N"), Yes = c("Yes", "Y")), ordered = TRUE) 31 | #' y 32 | #' 33 | #' RestoreFactor(y) 34 | #' 35 | #' @export Factor 36 | #' @aliases Factor 37 | Factor <- function(invec, levels = list(), store = TRUE, ...) { 38 | Fac <- factor(invec, ...) 39 | levels(Fac) <- levels 40 | if (isTRUE(store)) attr(Fac, "Input") <- invec 41 | class(Fac) <- c("Factor", class(Fac)) 42 | Fac 43 | } 44 | 45 | #' @rdname Factor 46 | #' @export 47 | #' @aliases print.Factor 48 | print.Factor <- function(x, ...) { 49 | if (!is.null(attr(x, "Input"))) { 50 | cat("Input values:\n") 51 | print(attr(x, "Input")) 52 | attr(x, "Input") <- NULL 53 | cat("\n") 54 | cat("Factored output:\n") 55 | print.factor(x) 56 | } else { 57 | cat("Factored output:\n") 58 | print.factor(x) 59 | } 60 | } 61 | 62 | #' @rdname Factor 63 | #' @export RestoreFactor 64 | #' @aliases RestoreFactor 65 | RestoreFactor <- function(invec) { 66 | if (!"Factor" %in% class(invec)) stop("Wrong class of input.") 67 | if (is.null(attr(invec, "Input"))) stop("No attribute named 'Input' found.") 68 | attr(invec, "Input") 69 | } 70 | -------------------------------------------------------------------------------- /R/dailyCalendar.R: -------------------------------------------------------------------------------- 1 | #' @name dailyCalendar 2 | #' @rdname dailyCalendar 3 | #' @title Creates a Calendar in R 4 | #' 5 | #' @description Creates a daily calendar in R. 6 | 7 | #' @return A vector, a `data.frame`, or a `list`, depending on which function is 8 | #' called with what arguments. 9 | #' @author Ananda Mahto 10 | NULL 11 | 12 | #' @rdname dailyCalendar 13 | #' @param startOn The day of the week to start on. Defaults to `"Monday"`. 14 | #' @param abbreviate Logical. Should the result be the abbreviated weekday name? 15 | #' Defaults to `FALSE`. 16 | #' @examples 17 | #' WeekDays() 18 | #' WeekDays("Thursday", TRUE) 19 | #' @export 20 | #' @aliases WeekDays 21 | WeekDays <- function(startOn = "Monday", abbreviate = FALSE) { 22 | WD <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday") 23 | x <- match(startOn, WD) 24 | WD <- WD[c(x:7, setdiff(1:7, x:7))] 25 | if (isTRUE(abbreviate)) { 26 | substring(WD, 0, 3) 27 | } else WD 28 | } 29 | NULL 30 | 31 | #' @rdname dailyCalendar 32 | #' @param startDate What should be the first date in the calendar? Defaults to 33 | #' `Sys.Date()`. 34 | #' @param days How many days do you want in your calendar? Defaults to `30`. 35 | #' @param fancy Logical. Should a more nicely formatted version of the calendar 36 | #' be displayed? Defaults to `FALSE`. 37 | #' @examples 38 | #' dailyCalendar(startDate = "2013-12-27", days = 10) 39 | #' dailyCalendar(startDate = "2013-12-27", days = 10, startOn = "Friday") 40 | #' dailyCalendar(days = 40, fancy = TRUE) 41 | #' @export 42 | #' @aliases dailyCalendar 43 | dailyCalendar <- function(startDate = Sys.Date(), days = 30, startOn = "Monday", fancy = FALSE) { 44 | inDailyTs <- ts(as.character(seq(as.Date(startDate), length.out = days, by = 1)), frequency = 7) 45 | weekday <- NULL 46 | temp <- data.table::data.table( 47 | weekday = factor(weekdays(as.Date(as.character(inDailyTs))), WeekDays(startOn)), 48 | date = inDailyTs, 49 | month = format(as.Date(as.character(inDailyTs)), "%B"), 50 | day = format(as.Date(as.character(inDailyTs)), "%d"), 51 | year = format(as.Date(as.character(inDailyTs)), "%Y")) 52 | temp[, week := cumsum(weekday == startOn)] 53 | 54 | if (isTRUE(fancy)) { 55 | A <- paste(temp$month, temp$year) 56 | X <- split(temp, factor(A, unique(A), ordered=TRUE)) 57 | lapply(X, function(y) { 58 | data.table::dcast(y, week ~ weekday, value.var = "day", fill = "", drop=FALSE)[, week := NULL][] 59 | }) 60 | } else { 61 | data.table::dcast(temp, week ~ weekday, value.var = "date", fill = "")[, week := NULL][] 62 | } 63 | } 64 | NULL -------------------------------------------------------------------------------- /man/makemeNA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/makemeNA.R 3 | \name{makemeNA} 4 | \alias{makemeNA} 5 | \title{Recode Certain Values in a \code{data.frame} into \code{NA}} 6 | \usage{ 7 | makemeNA(mydf, NAStrings, fixed = TRUE) 8 | } 9 | \arguments{ 10 | \item{mydf}{The input \code{data.frame}.} 11 | 12 | \item{NAStrings}{The values or a vector of values that should be treated as 13 | \code{NA}. Alternatively, this can be a regular expression.} 14 | 15 | \item{fixed}{Logical. Defaults to \code{TRUE}. Set to \code{FALSE} if being 16 | used with regular expressions.} 17 | } 18 | \value{ 19 | A \code{data.frame}. 20 | } 21 | \description{ 22 | A flexible alternative to some of the tricks used to convert certain values 23 | into \code{NA} after a dataset is already loaded in the workspace. Uses 24 | \code{type.convert} and \code{na.strings} to allow conversion of multiple 25 | values into \code{NA}. 26 | } 27 | \examples{ 28 | 29 | df1 <- structure(list( 30 | KY27PHY1 = c("4", "5", "5", "4", "-", "4", "2","3", 31 | "5", "-", "4", "3", "3", "5", "5"), 32 | KY27PHY2 = c("4", "4","4", "4", "-", "5", "2", "3", 33 | "5", "-", "5", "3", "3", "5", "5"), 34 | KY27PHY3 = c("5", "4", "4", "4", "-", "5", "1", "4", 35 | "5","-", "4", "3", "3", "5", "5")), 36 | .Names = c("KY27PHY1", "KY27PHY2","KY27PHY3"), 37 | row.names = 197:211, class = "data.frame") 38 | df1 39 | makemeNA(df1, "-") 40 | 41 | df2 <- data.frame(A = c(1, 2, "-", "not applicable", 5), 42 | B = c("not available", 1, 2, 3, 4), 43 | C = c("-", letters[1:4])) 44 | df2 45 | makemeNA(df2, "not.*|-", fixed = FALSE) 46 | 47 | temp <- structure( 48 | list(age = c(64.3573, 69.9043, 65.6633, 50.3693, 49 | 57.0334, 81.4939, 56.954, 76.9298), 50 | CALCIUM = c(1.1, 8.1, 8.6, 8.1, 8.7, 1.1, 9.8, 9.1), 51 | CREATININE = c(NA, 1.1, 0.8, 1.3, 0.8, NA, 1, 0.8), 52 | GLUCOSE = structure(c(5L, 4L, 3L, 2L, 6L, 6L, 1L, 6L), 53 | .Label = c("", "418", "461", "472", "488", "NEG"), 54 | class = "factor")), 55 | .Names = c("age", "CALCIUM", "CREATININE", "GLUCOSE"), 56 | class = "data.frame", row.names = c(NA, -8L)) 57 | temp 58 | ## Change anything that is just text to NA 59 | makemeNA(temp, "[A-Za-z]", fixed = FALSE) 60 | ## Change any exact matches with "NEG" to NA 61 | makemeNA(temp, "NEG") 62 | ## Change any matches with 3-digit integers to NA 63 | makemeNA(temp, "^[0-9]{3}$", fixed = FALSE) 64 | 65 | } 66 | \references{ 67 | \url{http://stackoverflow.com/a/14898521/1270695} 68 | } 69 | \author{ 70 | Ananda Mahto 71 | } 72 | -------------------------------------------------------------------------------- /man/almostComplete.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/almostComplete.R 3 | \name{almostComplete} 4 | \alias{almostComplete} 5 | \title{Subset a \code{data.frame} by Completeness of Rows or Columns} 6 | \usage{ 7 | almostComplete(dataset, rowPct, colPct = rowPct, n = 1) 8 | } 9 | \arguments{ 10 | \item{dataset}{The input \code{data.frame}} 11 | 12 | \item{rowPct}{The maximum percent of \code{NA} values in rows, as a decimal.} 13 | 14 | \item{colPct}{The maximum percent of \code{NA} values in columns, as a decimal.} 15 | 16 | \item{n}{When \code{rowPct} and \code{colPct} are \code{NULL}, the function will drop at 17 | least the number of rows and columns specified here, by "rank", if any 18 | contain \code{NA}. See "Details".} 19 | } 20 | \value{ 21 | A \code{data.frame} 22 | } 23 | \description{ 24 | An alternative to \code{\link[stats:complete.cases]{stats::complete.cases()}} that lets you specify the 25 | percentage of completeness desired. 26 | } 27 | \details{ 28 | When \code{n} is specified and \code{rowPct} and \code{colPct} are \code{NULL}, the function 29 | calculates the number of \code{NA} values by row and column. By default, it then 30 | drops the rows and columns with the highest number of missing values. With 31 | the dataset in the \emph{Examples} section, if you use \code{n = 2}, the function will 32 | remove rows 1, 3, and 6 and columns A, B, C, and F. Compare this behavior 33 | with the results of \code{rowSums(is.na(mydf))} and \code{colSums(is.na(mydf))}. 34 | } 35 | \examples{ 36 | 37 | mydf <- read.csv(text=" 38 | SampleID,A,B,C,D,E,F 39 | x1,NA,x,NA,x,NA,x 40 | x2,x,x,NA,x,x,NA 41 | x3,NA,NA,x,x,x,NA 42 | x4,x,x,x,NA,x,x 43 | x5,x,x,x,x,x,x 44 | x6,NA,NA,NA,x,NA,NA 45 | x7,x,x,x,NA,x,x 46 | x8,NA,NA,x,x,x,x 47 | x9,x,x,x,x,x,NA 48 | x10,x,x,x,x,x,x 49 | x11,NA,x,x,x,x,NA") 50 | 51 | ## What do the data look like? 52 | ## How many NAs are there per column and row? 53 | mydf 54 | colSums(is.na(mydf)) 55 | rowSums(is.na(mydf)) 56 | 57 | ## What does complete.cases do? 58 | mydf[complete.cases(mydf), ] 59 | 60 | ## Drop whichever row and column have 61 | ## the highest percentage of NA values 62 | almostComplete(mydf, NULL, NULL) 63 | 64 | ## Drop the rows and columns which have 65 | ## more than the second highest percentage of NA values 66 | almostComplete(mydf, NULL, NULL, n = 2) 67 | 68 | ## Set one threshold value for both rows and columns. 69 | almostComplete(mydf, .7) 70 | 71 | ## Specify row and column threshold values separately. 72 | almostComplete(mydf, rowPct = .2, colPct = .5) 73 | 74 | } 75 | \references{ 76 | \url{http://stackoverflow.com/a/20475029/1270695} 77 | } 78 | \author{ 79 | Ananda Mahto 80 | } 81 | -------------------------------------------------------------------------------- /R/moveMe.R: -------------------------------------------------------------------------------- 1 | #' Reorders the Contents of a Vector 2 | #' 3 | #' Shuffle the order of a vector around using natural language statements. 4 | #' 5 | #' This can be a useful function for reordering the columns of a 6 | #' \code{data.frame} or \code{data.table} in a convenient manner. In such 7 | #' cases, the \code{invec} would be \code{names(your_data_frame)}. When using 8 | #' \code{data.table}s, remember to use \code{setcolorder} to avoid copying. 9 | #' 10 | #' The \code{movecommand} argument is specified in the form of \code{"a, b 11 | #' before f"}. The positions to move are: \itemize{ \item \strong{first}: move 12 | #' the specified items to the first postion. \item \strong{last}: move the 13 | #' specified items to the last position. \item \strong{before}: move the 14 | #' specified items before the value mentioned. \item \strong{after}: move the 15 | #' specified items after the value mentioned. } Multiples are allowed: 16 | #' \itemize{ \item Specify multiple values to be moved by separating them with 17 | #' a comma. \item Chain multiple move commands by separating them with a 18 | #' semicolon. } 19 | #' 20 | #' @param invec The input vector 21 | #' @param movecommand The command that describes how you want to shuffle the 22 | #' vector. See \emph{Details}. 23 | #' @return A vector. 24 | #' @author Ananda Mahto 25 | #' @references \url{http://stackoverflow.com/a/18420673/1270695} 26 | #' @examples 27 | #' 28 | #' myvec <- letters[1:10] 29 | #' myvec 30 | #' moveMe(myvec, "a last; b, e, g before d; c first; h after j") 31 | #' 32 | #' x <- names(mtcars) 33 | #' x 34 | #' moveMe(x, "hp first; cyl after drat; vs, am, gear before mpg; wt last") 35 | #' 36 | #' @export moveMe 37 | moveMe <- function(invec, movecommand) { 38 | movecommand <- lapply(strsplit(strsplit(movecommand, ";")[[1]], ",|\\s+"), 39 | function(x) x[x != ""]) 40 | movelist <- lapply(movecommand, function(x) { 41 | Where <- x[which(x %in% c("before", "after", "first", "last")):length(x)] 42 | ToMove <- setdiff(x, Where) 43 | list(ToMove, Where) 44 | }) 45 | myVec <- invec 46 | for (i in seq_along(movelist)) { 47 | temp <- setdiff(myVec, movelist[[i]][[1]]) 48 | A <- movelist[[i]][[2]][1] 49 | if (A %in% c("before", "after")) { 50 | ba <- movelist[[i]][[2]][2] 51 | if (A == "before") { 52 | after <- match(ba, temp)-1 53 | } else if (A == "after") { 54 | after <- match(ba, temp) 55 | } 56 | } else if (A == "first") { 57 | after <- 0 58 | } else if (A == "last") { 59 | after <- length(myVec) 60 | } 61 | myVec <- append(temp, values = movelist[[i]][[1]], after = after) 62 | } 63 | myVec 64 | } 65 | NULL 66 | -------------------------------------------------------------------------------- /R/makemeNA.R: -------------------------------------------------------------------------------- 1 | #' Recode Certain Values in a \code{data.frame} into \code{NA} 2 | #' 3 | #' A flexible alternative to some of the tricks used to convert certain values 4 | #' into \code{NA} after a dataset is already loaded in the workspace. Uses 5 | #' \code{type.convert} and \code{na.strings} to allow conversion of multiple 6 | #' values into \code{NA}. 7 | #' 8 | #' 9 | #' @param mydf The input \code{data.frame}. 10 | #' @param NAStrings The values or a vector of values that should be treated as 11 | #' \code{NA}. Alternatively, this can be a regular expression. 12 | #' @param fixed Logical. Defaults to \code{TRUE}. Set to \code{FALSE} if being 13 | #' used with regular expressions. 14 | #' @return A \code{data.frame}. 15 | #' @author Ananda Mahto 16 | #' @references \url{http://stackoverflow.com/a/14898521/1270695} 17 | #' @examples 18 | #' 19 | #' df1 <- structure(list( 20 | #' KY27PHY1 = c("4", "5", "5", "4", "-", "4", "2","3", 21 | #' "5", "-", "4", "3", "3", "5", "5"), 22 | #' KY27PHY2 = c("4", "4","4", "4", "-", "5", "2", "3", 23 | #' "5", "-", "5", "3", "3", "5", "5"), 24 | #' KY27PHY3 = c("5", "4", "4", "4", "-", "5", "1", "4", 25 | #' "5","-", "4", "3", "3", "5", "5")), 26 | #' .Names = c("KY27PHY1", "KY27PHY2","KY27PHY3"), 27 | #' row.names = 197:211, class = "data.frame") 28 | #' df1 29 | #' makemeNA(df1, "-") 30 | #' 31 | #' df2 <- data.frame(A = c(1, 2, "-", "not applicable", 5), 32 | #' B = c("not available", 1, 2, 3, 4), 33 | #' C = c("-", letters[1:4])) 34 | #' df2 35 | #' makemeNA(df2, "not.*|-", fixed = FALSE) 36 | #' 37 | #' temp <- structure( 38 | #' list(age = c(64.3573, 69.9043, 65.6633, 50.3693, 39 | #' 57.0334, 81.4939, 56.954, 76.9298), 40 | #' CALCIUM = c(1.1, 8.1, 8.6, 8.1, 8.7, 1.1, 9.8, 9.1), 41 | #' CREATININE = c(NA, 1.1, 0.8, 1.3, 0.8, NA, 1, 0.8), 42 | #' GLUCOSE = structure(c(5L, 4L, 3L, 2L, 6L, 6L, 1L, 6L), 43 | #' .Label = c("", "418", "461", "472", "488", "NEG"), 44 | #' class = "factor")), 45 | #' .Names = c("age", "CALCIUM", "CREATININE", "GLUCOSE"), 46 | #' class = "data.frame", row.names = c(NA, -8L)) 47 | #' temp 48 | #' ## Change anything that is just text to NA 49 | #' makemeNA(temp, "[A-Za-z]", fixed = FALSE) 50 | #' ## Change any exact matches with "NEG" to NA 51 | #' makemeNA(temp, "NEG") 52 | #' ## Change any matches with 3-digit integers to NA 53 | #' makemeNA(temp, "^[0-9]{3}$", fixed = FALSE) 54 | #' 55 | #' @export makemeNA 56 | makemeNA <- function (mydf, NAStrings, fixed = TRUE) { 57 | if (!isTRUE(fixed)) { 58 | mydf[] <- lapply(mydf, function(x) gsub(NAStrings, "", x)) 59 | NAStrings <- "" 60 | } 61 | mydf[] <- lapply(mydf, function(x) type.convert( 62 | as.character(x), na.strings = NAStrings)) 63 | mydf 64 | } 65 | -------------------------------------------------------------------------------- /R/helpExtract.R: -------------------------------------------------------------------------------- 1 | #' Extract Portions from R Help Files for Use in Documents 2 | #' 3 | #' Extracts specified portions of R help files for use in Sweave or R-markdown 4 | #' documents. 5 | #' 6 | #' The \code{type} argument accepts: \itemize{ \item \code{"m_code"}: For use 7 | #' with markdown documents in instances where highlighted code is expected, for 8 | #' example the "Usage" section. \item \code{"m_text"}: For use with markdown 9 | #' documents in instances where regular text is expected, for example the 10 | #' "Description" section. \item \code{"s_code"}: For use with Sweave documents 11 | #' in instances where highlighted code is expected, for example the "Usage" 12 | #' section. \item \code{"s_text"}: For use with Sweave documents in instances 13 | #' where regular text is expected, for example the "Description" section. } To 14 | #' insert a chunk into a markdown document, use something like: 15 | #' 16 | #' \verb{```{r, echo=FALSE, results='asis'}} \verb{cat(helpExtract(cor), sep = 17 | #' "\n")} \verb{```} 18 | #' 19 | #' To insert a chunk into a Sweave document, use something like: 20 | #' 21 | #' \verb{\Sexpr{knit_child(textConnection(helpExtract(cor, type = "s_code")), 22 | #' options = list(tidy = FALSE, eval = FALSE))}} 23 | #' 24 | #' @param Function The function that you are extracting the help file from. 25 | #' @param section The section you want to extract. Defaults to \code{"Usage"}. 26 | #' @param type The type of character vector you want returned. Defaults to 27 | #' \code{"m_code"}. See \emph{Details} 28 | #' @param \dots Other arguments passed to \code{getHelpFile}. 29 | #' @return A character vector to be used in a Sweave or R-markdown document. 30 | #' @author Ananda Mahto 31 | #' @examples 32 | #' 33 | #' cat(helpExtract(cor), sep = "\n") 34 | #' 35 | #' cat(helpExtract(cor, type = "m_text")) 36 | #' 37 | #' cat(helpExtract(cor, type = "m_text", section="Description")) 38 | #' 39 | #' @export helpExtract 40 | helpExtract <- function(Function, section = "Usage", type = "m_code", ...) { 41 | A <- deparse(substitute(Function)) 42 | x <- capture.output(tools::Rd2txt(utils:::.getHelpFile(utils::help(A, ...)), 43 | options = list(sectionIndent = 0))) 44 | B <- grep("^_", x) ## section start lines 45 | x <- gsub("_\b", "", x, fixed = TRUE) ## remove "_\b" 46 | X <- rep(FALSE, length(x)) 47 | X[B] <- 1 48 | out <- split(x, cumsum(X)) 49 | out <- out[[which(sapply(out, function(x) 50 | grepl(section, x[1], fixed = TRUE)))]][-c(1, 2)] 51 | while(TRUE) { 52 | out <- out[-length(out)] 53 | if (out[length(out)] != "") { break } 54 | } 55 | 56 | switch( 57 | type, 58 | m_code = c("```r", out, "```"), 59 | s_code = c("<<>>=", out, "@"), 60 | m_text = paste(" ", out, collapse = "\n"), 61 | s_text = c("\\begin{verbatim}", out, "\\end{verbatim}"), 62 | stop("`type` must be either `m_code`, `s_code`, `m_text`, or `s_text`") 63 | ) 64 | } 65 | -------------------------------------------------------------------------------- /R/GroupedMedian.R: -------------------------------------------------------------------------------- 1 | #' Calculate the Median of Already Grouped Data 2 | #' 3 | #' Calculates the median of already grouped data given the interval ranges and 4 | #' the frequencies of each group. 5 | #' 6 | #' 7 | #' @param frequencies A vector of frequencies. 8 | #' @param intervals A 2-row \code{matrix} with the same number of columns as 9 | #' the length of frequencies, with the first row being the lower class 10 | #' boundary, and the second row being the upper class boundary. Alternatively, 11 | #' \code{intervals} may be a column in your \code{data.frame}, and you may 12 | #' specify \code{sep} (and possibly, \code{trim}) to have the 13 | #' \code{GroupedMedian} function automatically create the required 14 | #' \code{matrix} for you. 15 | #' @param sep Optional. If the \code{intervals} are represented by a character 16 | #' vector with a character separating the interval ranges. 17 | #' @param trim Characters to trim from the vector before splitting. For 18 | #' example, if you are doing this on the output of \code{cut} (where, for some 19 | #' reason, you no longer have access to the original data), you can use the 20 | #' pre-set trim pattern \code{"cut"}. 21 | #' @return A single numeric value representing the grouped median. 22 | #' @author Ananda Mahto 23 | #' @references \url{http://stackoverflow.com/a/18931054/1270695} 24 | #' @examples 25 | #' 26 | #' mydf <- structure(list(salary = c("1500-1600", "1600-1700", "1700-1800", 27 | #' "1800-1900", "1900-2000", "2000-2100", "2100-2200", "2200-2300", 28 | #' "2300-2400", "2400-2500"), number = c(110L, 180L, 320L, 460L, 29 | #' 850L, 250L, 130L, 70L, 20L, 10L)), .Names = c("salary", "number"), 30 | #' class = "data.frame", row.names = c(NA, -10L)) 31 | #' mydf 32 | #' 33 | #' GroupedMedian(frequencies = mydf$number, intervals = mydf$salary, sep = "-") 34 | #' 35 | #' ## Example with intervals manually specified 36 | #' X <- rbind(c(1500, 1600, 1700, 1800, 1900, 2000, 2100, 2200, 2300, 2400), 37 | #' c(1600, 1700, 1800, 1900, 2000, 2100, 2200, 2300, 2400, 2500)) 38 | #' 39 | #' GroupedMedian(mydf$number, X) 40 | #' 41 | #' set.seed(1) 42 | #' x <- sample(100, 100, replace = TRUE) 43 | #' y <- data.frame(table(cut(x, 10))) 44 | #' 45 | #' GroupedMedian(y$Freq, y$Var1, sep = ",", trim = "cut") 46 | #' 47 | #' @export GroupedMedian 48 | GroupedMedian <- function(frequencies, intervals, sep = NULL, trim = NULL) { 49 | if (!is.null(sep)) { 50 | if (is.null(trim)) pattern <- "" 51 | else if (trim == "cut") pattern <- "\\[|\\]|\\(|\\)" 52 | else pattern <- trim 53 | intervals <- sapply(strsplit(gsub(pattern, "", intervals), sep), as.numeric) 54 | } 55 | 56 | Midpoints <- rowMeans(intervals) 57 | cf <- cumsum(frequencies) 58 | Midrow <- findInterval(max(cf)/2, cf) + 1 59 | L <- intervals[1, Midrow] 60 | h <- diff(intervals[, Midrow]) 61 | f <- frequencies[Midrow] 62 | cf2 <- cf[Midrow - 1] 63 | n_2 <- max(cf)/2 64 | 65 | unname(L + (n_2 - cf2)/f * h) 66 | } 67 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | #' @import Hmisc 2 | NULL 3 | 4 | #' @import data.table 5 | NULL 6 | 7 | #' @import stringr 8 | NULL 9 | 10 | #' @import utils 11 | NULL 12 | 13 | #' @importFrom stats ave embed ftable runif setNames ts 14 | NULL 15 | 16 | .id <- rn <- value <- writeClipboard <- NULL 17 | 18 | #' Read Clipboard Regardless of OS 19 | #' 20 | #' Different operating systems have different ways of handling the clipboard. 21 | #' Given the frequency with which text is copied to the clipboard to place in 22 | #' an answer on StackOverflow, this utility is provided. 23 | #' 24 | #' @return character string containing text on the clipboard. 25 | #' 26 | readClip <- function() { 27 | OS <- Sys.info()["sysname"] 28 | cliptext <- switch( 29 | OS, 30 | Darwin = { 31 | con <- pipe("pbpaste") 32 | text <- readLines(con) 33 | close(con) 34 | text 35 | }, 36 | Windows = readClipboard(), 37 | Linux = { 38 | if (Sys.which("xclip") == "") { 39 | mess <- c("Clipboard on Linux requires 'xclip'. Try using:", 40 | "sudo apt-get install xclip") 41 | message(paste(mess, collapse = "\n")) 42 | } 43 | con <- pipe("xclip -o -selection clipboard") 44 | text <- readLines(con = con) 45 | close(con) 46 | text 47 | }, 48 | stop("Reading from clipboard not yet supported on your OS")) 49 | cliptext 50 | } 51 | 52 | #' Write to Clipboard on Multiple OSes 53 | #' 54 | #' This function works on Windows, Mac and Linux. It copies a 55 | #' character string or vector of characters to the clipboard and interprets 56 | #' a vector of characters as one character with each element being newline 57 | #' separated. If using Linux, xclip is used as the clipboard. So for the 58 | #' function to work, xclip must be installed. 59 | #' 60 | #' @param object character. Character to be copied to the clipboard 61 | #' 62 | #' @return Returns nothing to R. Returns character string to the clipboard 63 | #' 64 | #' @details If using Linux, xclip will be used as the clipboard. To paste from 65 | #' xclip, either use middle click or the command \code{xclip -o} in the shell. 66 | #' 67 | writeClip <- function(object) { 68 | OS <- Sys.info()["sysname"] 69 | if(!(OS %in% c("Darwin", "Windows", "Linux"))) { 70 | stop("Copying to clipboard not yet supported on your OS") 71 | } 72 | switch( 73 | OS, 74 | Darwin = { 75 | con <- pipe("pbcopy", "w") 76 | writeLines(object, con=con) 77 | close(con) 78 | }, 79 | Windows = writeClipboard(object, format = 1), 80 | Linux = { 81 | if (Sys.which("xclip") == "") { 82 | if (Sys.which("xclip") == "") { 83 | mess <- c("Clipboard on Linux requires 'xclip'. Try using:", 84 | "sudo apt-get install xclip") 85 | message(paste(mess, collapse = "\n")) 86 | } 87 | } 88 | con <- pipe("xclip -selection clipboard -i", open = "w") 89 | writeLines(object, con=con) 90 | close(con) 91 | }) 92 | } 93 | 94 | getDots <- function(...) sapply(substitute(list(...))[-1], deparse) 95 | NULL -------------------------------------------------------------------------------- /R/almostComplete.R: -------------------------------------------------------------------------------- 1 | #' Subset a `data.frame` by Completeness of Rows or Columns 2 | #' 3 | #' An alternative to [stats::complete.cases()] that lets you specify the 4 | #' percentage of completeness desired. 5 | #' 6 | #' When `n` is specified and `rowPct` and `colPct` are `NULL`, the function 7 | #' calculates the number of `NA` values by row and column. By default, it then 8 | #' drops the rows and columns with the highest number of missing values. With 9 | #' the dataset in the *Examples* section, if you use `n = 2`, the function will 10 | #' remove rows 1, 3, and 6 and columns A, B, C, and F. Compare this behavior 11 | #' with the results of `rowSums(is.na(mydf))` and `colSums(is.na(mydf))`. 12 | #' 13 | #' @param dataset The input `data.frame` 14 | #' @param rowPct The maximum percent of `NA` values in rows, as a decimal. 15 | #' @param colPct The maximum percent of `NA` values in columns, as a decimal. 16 | #' @param n When `rowPct` and `colPct` are `NULL`, the function will drop at 17 | #' least the number of rows and columns specified here, by "rank", if any 18 | #' contain `NA`. See "Details". 19 | #' @return A `data.frame` 20 | #' @author Ananda Mahto 21 | #' @references 22 | #' @examples 23 | #' 24 | #' mydf <- read.csv(text=" 25 | #' SampleID,A,B,C,D,E,F 26 | #' x1,NA,x,NA,x,NA,x 27 | #' x2,x,x,NA,x,x,NA 28 | #' x3,NA,NA,x,x,x,NA 29 | #' x4,x,x,x,NA,x,x 30 | #' x5,x,x,x,x,x,x 31 | #' x6,NA,NA,NA,x,NA,NA 32 | #' x7,x,x,x,NA,x,x 33 | #' x8,NA,NA,x,x,x,x 34 | #' x9,x,x,x,x,x,NA 35 | #' x10,x,x,x,x,x,x 36 | #' x11,NA,x,x,x,x,NA") 37 | #' 38 | #' ## What do the data look like? 39 | #' ## How many NAs are there per column and row? 40 | #' mydf 41 | #' colSums(is.na(mydf)) 42 | #' rowSums(is.na(mydf)) 43 | #' 44 | #' ## What does complete.cases do? 45 | #' mydf[complete.cases(mydf), ] 46 | #' 47 | #' ## Drop whichever row and column have 48 | #' ## the highest percentage of NA values 49 | #' almostComplete(mydf, NULL, NULL) 50 | #' 51 | #' ## Drop the rows and columns which have 52 | #' ## more than the second highest percentage of NA values 53 | #' almostComplete(mydf, NULL, NULL, n = 2) 54 | #' 55 | #' ## Set one threshold value for both rows and columns. 56 | #' almostComplete(mydf, .7) 57 | #' 58 | #' ## Specify row and column threshold values separately. 59 | #' almostComplete(mydf, rowPct = .2, colPct = .5) 60 | #' 61 | #' @export almostComplete 62 | almostComplete <- function(dataset, rowPct, colPct = rowPct, n = 1) { 63 | if (sum(is.na(dataset)) == 0) out <- dataset 64 | else { 65 | CS <- colSums(is.na(dataset))/ncol(dataset) 66 | RS <- rowSums(is.na(dataset))/nrow(dataset) 67 | if (is.null(rowPct)) rowPct <- head(sort(unique(RS), 68 | decreasing=TRUE), n)[n] 69 | if (is.null(colPct)) colPct <- head(sort(unique(CS), 70 | decreasing=TRUE), n)[n] 71 | 72 | dropCols <- which(CS >= colPct) 73 | dropRows <- which(RS >= rowPct) 74 | out <- dataset[setdiff(sequence(nrow(dataset)), dropRows), 75 | setdiff(sequence(ncol(dataset)), dropCols), 76 | drop = FALSE] 77 | } 78 | out 79 | } 80 | -------------------------------------------------------------------------------- /R/Riffle.R: -------------------------------------------------------------------------------- 1 | #' Interleaves Values Within Matrices or Vectors 2 | #' 3 | #' Mimics some of the behavior of the \code{Riffle} function 4 | #' (\url{http://reference.wolfram.com/mathematica/ref/Riffle.html}) in 5 | #' Mathematica. For matrices, it interleaves the columns. For vectors, it 6 | #' interleaves differently according to whether the subsequent values are 7 | #' presented as separate values or whether they are grouped with \code{c()}. 8 | #' 9 | #' It is expected that all matrices to be interleaved would have the same 10 | #' number of rows, though they may have differing numbers of columns. If they 11 | #' have differing numbers of columns, they are all made to conform to the same 12 | #' dimension before proceeding by recycling the existing columns. 13 | #' 14 | #' @param \dots The objects or values that need to be interleaved. 15 | #' @return A vector or a matrix depending on the input. If one or more input 16 | #' objects is a matrix, the result will also be a matrix. 17 | #' @author Ananda Mahto 18 | #' @references \url{http://stackoverflow.com/q/21347207/1270695} 19 | #' @examples 20 | #' 21 | #' m1 <- matrix(1:9, nrow = 3, ncol = 3) 22 | #' m2 <- matrix(letters[1:9], nrow = 3, ncol = 3) 23 | #' 24 | #' Riffle(m1, m2) 25 | #' Riffle(m1, "||", m2) 26 | #' 27 | #' m3 <- matrix(LETTERS[1:6], nrow = 3, ncol = 2) 28 | #' 29 | #' Riffle(m1, m2, m3) 30 | #' 31 | #' ## Just vectors 32 | #' 33 | #' Riffle(1:6, "x") 34 | #' Riffle(1:6, "x", "y") 35 | #' Riffle(1:6, c("x", "y")) 36 | #' 37 | #' @export Riffle 38 | Riffle <- function(...) { 39 | x <- list(...) 40 | if (!all(vapply(x, function(y) is.matrix(y) | is.vector(y), logical(1L)))) { 41 | stop("input must be either vectors or matrices") 42 | } 43 | isMat <- vapply(x, is.matrix, logical(1L)) 44 | isVec <- vapply(x, is.vector, logical(1L)) 45 | if (!any(isVec)) LenV <- 0 else LenV <- max(vapply(x[isVec], length, 1L)) 46 | if (!any(isMat)) LenM <- NRow <- LenV else LenM <- max(vapply(x[isMat], length, 1L)) 47 | if (LenV > LenM) stop("longest vector is longer than biggest matrix") 48 | if (any(isMat)) { 49 | Dims <- vapply(x[isMat], dim, c(row = 1L, col = 1L)) 50 | if (length(unique(Dims["row", ])) > 1) { 51 | stop("All matrices must have the same number of rows") 52 | } 53 | MCol <- max(Dims["col", ]) 54 | NRow <- Dims["row", 1] 55 | } 56 | if (all(isMat)) TYPE <- "allmat" 57 | if (all(isVec)) TYPE <- "allvec" 58 | if (sum(isMat) >= 1 & sum(isVec) >= 1) { 59 | x[isVec] <- lapply(x[isVec], function(y) { 60 | matrix(rep(y, length.out = NRow), nrow = NRow, ncol = MCol) 61 | }) 62 | TYPE <- "allmat" 63 | } 64 | switch( 65 | TYPE, 66 | allmat = { 67 | if (length(unique(Dims["col", ])) > 1) { 68 | Fix <- which(Dims["col", ] < MCol) 69 | x[Fix] <- lapply(x[Fix], function(y) { 70 | matrix(rep(y, length.out = LenM), nrow = Dims["row", 1]) 71 | }) 72 | } 73 | NewDims <- vapply(x, dim, c(row = 1L, col = 1L)) 74 | A <- do.call(cbind, x)[, order(sequence(rep(NewDims["col", 1], ncol(NewDims))))] 75 | }, 76 | allvec = { 77 | x <- lapply(x, function(y) rep(y, length.out = LenV)) 78 | A <- as.vector(t(do.call(cbind, x))) 79 | }) 80 | A 81 | } 82 | -------------------------------------------------------------------------------- /R/mySOreputation.R: -------------------------------------------------------------------------------- 1 | #' Parse Your Reputation Page From Any of the Stack Exchange Sites 2 | #' 3 | #' It is very easy to \emph{view} a detailed account of your reputation at any 4 | #' of the Stack Exchange sites by visiting \code{http://"sitename"/reputation} 5 | #' (obviously substituting "sitename" for the actual site of interest, for 6 | #' example, \url{http://stackoverflow.com/reputation}). However, that format 7 | #' is not very user-friendly if you want to do any analysis with it. This 8 | #' function parses that page into an R \code{data.frame}. 9 | #' 10 | #' 11 | #' @param rep_file The path to a text version of your reputation page. Windows 12 | #' and Linux users can copy the text on the page with select all + copy, and 13 | #' simply use "clipboard" instead of saving the contents to a local file. 14 | #' @author Paul Hiemstra provided the base parser. Built upon by Ananda Mahto. 15 | #' @references Values for the "actions" variable determined after visiting 16 | #' \url{http://meta.stackexchange.com/a/43005/214964}. 17 | #' There is one value not mentioned at that page, coded as \code{action_id == 18 | #' 99} and \code{action == Bonus} that corresponds to the bonus that a user 19 | #' gets when they have above a certain reputation and are active on multiple 20 | #' Stack Exchange sites. 21 | #' @examples 22 | #' 23 | #' ## This is a real reputation file, 24 | #' ## but the "question_id" variable is 25 | #' ## made up. 26 | #' rep_file <- system.file("soreputation.txt", package = "SOfun") 27 | #' readLines(rep_file, 15) 28 | #' mydf <- mySOreputation(rep_file = rep_file) 29 | #' head(mydf, 15) 30 | #' str(mydf) 31 | #' plot(mydf$date, cumsum(mydf$rep_change)) 32 | #' 33 | #' \dontrun{ 34 | #' library(xts) 35 | #' mydfx <- xts(mydf$rep_change, mydf$date) 36 | #' apply.monthly(mydfx, sum) 37 | #' plot(apply.monthly(mydfx, sum)) 38 | #' } 39 | #' 40 | #' 41 | #' @export mySOreputation 42 | mySOreputation <- function(rep_file) { 43 | all_data <- readLines(rep_file) 44 | if (isTRUE(grepl("^total votes", all_data[1]))) { all_data <- all_data[-1] } 45 | else all_data <- all_data 46 | all_data <- gsub("-- bonuses\\s+(.*)", " 99 NA \\1", all_data) 47 | 48 | date_entries <- grep("^-", all_data) 49 | actions_per_day <- c(date_entries[1], diff(date_entries)) - 1 50 | 51 | dat <- read.table( 52 | text = all_data[-c(date_entries, 53 | date_entries[length(date_entries)]:length(all_data))]) 54 | names(dat) <- c("action_id", "question_id", "rep_change") 55 | dat$rep_change <- as.numeric(gsub("\\(|\\)|\\[|\\]", "", dat$rep_change)) 56 | 57 | dat$date <- rep(all_data[date_entries], times = actions_per_day) 58 | dat$date <- as.Date(gsub("-- (.*) rep.*", "\\1", dat$date)) 59 | 60 | actions <- as.character(dat$action_id) 61 | actions[dat$action_id == 1] <- with( 62 | dat[dat$action_id == 1, ], 63 | ifelse(rep_change == 15, "YourAnswerAccepted", "AnswerAcceptedByYou")) 64 | actions[dat$action_id == 3] <- with( 65 | dat[dat$action_id == 3, ], 66 | ifelse(rep_change == -1, "YouDownvoted", "YouWereDownvoted")) 67 | dat$actions <- factor( 68 | actions, levels = c("AnswerAcceptedByYou", "YourAnswerAccepted", 2, 69 | "YouDownvoted", "YouWereDownvoted", 4, 8, 9, 12, 16, 99), 70 | labels = c("AnswerAcceptedByYou", "YourAnswerAccepted", "Upvote", "YouDownvoted", 71 | "YouWereDownvoted", "Penalty-Offensive", "BountyOffered", 72 | "BountyReceived", "Penalty-Spam", "EditApproved", "Bonus")) 73 | 74 | dat$action_id <- factor(dat$action_id, c(1:4, 8, 9, 12, 16, 99)) 75 | dat 76 | } -------------------------------------------------------------------------------- /R/grouped_stem.R: -------------------------------------------------------------------------------- 1 | #' Create a Grouped Stem-and-Leaf Plot 2 | #' 3 | #' Create a stem-and-leaf plot where the stems can be grouped by multiple values 4 | #' and the leaves indicate where the values are split 5 | #' 6 | #' @param invec The input vector. This function only works with integers. 7 | #' @param n The number of stem values to be grouped 8 | #' @return A `list` printed with stem-and-leaf formatting 9 | #' @author Ananda Mahto 10 | #' @references 11 | #' @seealso [graphics::stem()] 12 | #' @examples 13 | #' 14 | #' set.seed(1) 15 | #' data_pos <- sample(0:50, 100, TRUE) 16 | #' grouped_stem(data_pos, 2) 17 | #' 18 | #' data_neg <- sample(-50:-1, 100, TRUE) 19 | #' grouped_stem(data_neg, 2) 20 | #' 21 | #' data_pos_neg <- c(0, sample(-50:50, 100, TRUE)) 22 | #' grouped_stem(data_pos_neg, 3) 23 | #' 24 | #' @export grouped_stem 25 | grouped_stem <- function(invec, n = 2) { 26 | if (!all(as.numeric(invec) == as.integer(invec))) stop("This function only works with integers") 27 | invec <- sort(invec) 28 | negative <- if (any(invec < 0)) TRUE else FALSE 29 | positive <- if (any(invec >= 0)) TRUE else FALSE 30 | type <- c("positive", "negative")[c(positive, negative)] 31 | type <- if (length(type) == 2) "both" else type 32 | out <- switch(type, 33 | negative = gsn(invec[invec < 0], n), 34 | positive = gsp(invec[invec >= 0], n), 35 | both = c(gsn(invec[invec < 0], n), 36 | gsp(invec[invec >= 0], n))) 37 | class(out) <- c("grouped_stem", class(out)) 38 | out 39 | } 40 | NULL 41 | 42 | gsn <- function(negs, n = 2) { 43 | cuts <- seq(((min(negs) %/% 10)-1) * 10, 0) 44 | labs <- sub("(.*).$", "\\1", cuts+1) 45 | labs <- replace(labs, labs == "-" | !nzchar(labs), "-0") 46 | temp <- split(negs, cut(negs, cuts, labs[-length(labs)], right = TRUE)) 47 | temp <- relist(sub(".*(.)$", "\\1", unlist(temp, use.names = FALSE)), temp) 48 | combined <- vapply(temp, function(y) sprintf("%s*", paste(y, collapse = "")), character(1L)) 49 | splits <- split(combined, ((seq_along(combined)-1) %/% n)) 50 | stems <- vapply(splits, function(x) { 51 | paste(names(x)[1], names(x)[length(x)], sep = " to ") 52 | }, character(1L)) 53 | leaves <- vapply(splits, function(x) { 54 | sub("[*]$", "", paste(x, sep = "", collapse = "")) 55 | }, character(1L)) 56 | setNames(as.list(leaves), stems) 57 | } 58 | NULL 59 | 60 | gsp <- function(poss, n = 2) { 61 | cuts <- seq((min(poss) %/% 10) * 10, round(max(poss)+10, -(nchar(max(poss))-1)), 10) 62 | labs <- sub("(.*).$", "\\1", cuts) 63 | labs <- replace(labs, !nzchar(labs), "0") 64 | temp <- split(poss, cut(poss, cuts, labs[-length(labs)], right = FALSE)) 65 | temp <- relist(sub(".*(.)$", "\\1", unlist(temp, use.names = FALSE)), temp) 66 | combined <- vapply(temp, function(y) sprintf("%s*", paste(y, collapse = "")), character(1L)) 67 | splits <- split(combined, ((seq_along(combined)-1) %/% n)) 68 | stems <- vapply(splits, function(x) { 69 | paste(names(x)[1], names(x)[length(x)], sep = " to ") 70 | }, character(1L)) 71 | leaves <- vapply(splits, function(x) { 72 | sub("[*]$", "", paste(x, sep = "", collapse = "")) 73 | }, character(1L)) 74 | setNames(as.list(leaves), stems) 75 | } 76 | NULL 77 | 78 | #' @rdname grouped_stem 79 | #' @export 80 | #' @param x The object to be printed. 81 | #' @param \dots Not used. 82 | #' @aliases print.grouped_stem 83 | print.grouped_stem <- function(x, ...) { 84 | cat(sprintf(sprintf("%%%ss | %%s", max(nchar(names(x)))+2), 85 | names(x), unlist(x, use.names = FALSE)), sep = "\n") 86 | } 87 | NULL 88 | -------------------------------------------------------------------------------- /docs/pkgdown.js: -------------------------------------------------------------------------------- 1 | /* http://gregfranko.com/blog/jquery-best-practices/ */ 2 | (function($) { 3 | $(function() { 4 | 5 | $('.navbar-fixed-top').headroom(); 6 | 7 | $('body').css('padding-top', $('.navbar').height() + 10); 8 | $(window).resize(function(){ 9 | $('body').css('padding-top', $('.navbar').height() + 10); 10 | }); 11 | 12 | $('[data-toggle="tooltip"]').tooltip(); 13 | 14 | var cur_path = paths(location.pathname); 15 | var links = $("#navbar ul li a"); 16 | var max_length = -1; 17 | var pos = -1; 18 | for (var i = 0; i < links.length; i++) { 19 | if (links[i].getAttribute("href") === "#") 20 | continue; 21 | // Ignore external links 22 | if (links[i].host !== location.host) 23 | continue; 24 | 25 | var nav_path = paths(links[i].pathname); 26 | 27 | var length = prefix_length(nav_path, cur_path); 28 | if (length > max_length) { 29 | max_length = length; 30 | pos = i; 31 | } 32 | } 33 | 34 | // Add class to parent
  • , and enclosing
  • if in dropdown 35 | if (pos >= 0) { 36 | var menu_anchor = $(links[pos]); 37 | menu_anchor.parent().addClass("active"); 38 | menu_anchor.closest("li.dropdown").addClass("active"); 39 | } 40 | }); 41 | 42 | function paths(pathname) { 43 | var pieces = pathname.split("/"); 44 | pieces.shift(); // always starts with / 45 | 46 | var end = pieces[pieces.length - 1]; 47 | if (end === "index.html" || end === "") 48 | pieces.pop(); 49 | return(pieces); 50 | } 51 | 52 | // Returns -1 if not found 53 | function prefix_length(needle, haystack) { 54 | if (needle.length > haystack.length) 55 | return(-1); 56 | 57 | // Special case for length-0 haystack, since for loop won't run 58 | if (haystack.length === 0) { 59 | return(needle.length === 0 ? 0 : -1); 60 | } 61 | 62 | for (var i = 0; i < haystack.length; i++) { 63 | if (needle[i] != haystack[i]) 64 | return(i); 65 | } 66 | 67 | return(haystack.length); 68 | } 69 | 70 | /* Clipboard --------------------------*/ 71 | 72 | function changeTooltipMessage(element, msg) { 73 | var tooltipOriginalTitle=element.getAttribute('data-original-title'); 74 | element.setAttribute('data-original-title', msg); 75 | $(element).tooltip('show'); 76 | element.setAttribute('data-original-title', tooltipOriginalTitle); 77 | } 78 | 79 | if(ClipboardJS.isSupported()) { 80 | $(document).ready(function() { 81 | var copyButton = ""; 82 | 83 | $(".examples, div.sourceCode").addClass("hasCopyButton"); 84 | 85 | // Insert copy buttons: 86 | $(copyButton).prependTo(".hasCopyButton"); 87 | 88 | // Initialize tooltips: 89 | $('.btn-copy-ex').tooltip({container: 'body'}); 90 | 91 | // Initialize clipboard: 92 | var clipboardBtnCopies = new ClipboardJS('[data-clipboard-copy]', { 93 | text: function(trigger) { 94 | return trigger.parentNode.textContent; 95 | } 96 | }); 97 | 98 | clipboardBtnCopies.on('success', function(e) { 99 | changeTooltipMessage(e.trigger, 'Copied!'); 100 | e.clearSelection(); 101 | }); 102 | 103 | clipboardBtnCopies.on('error', function() { 104 | changeTooltipMessage(e.trigger,'Press Ctrl+C or Command+C to copy'); 105 | }); 106 | }); 107 | } 108 | })(window.jQuery || window.$) 109 | -------------------------------------------------------------------------------- /R/write.Hmisc.SPSS.R: -------------------------------------------------------------------------------- 1 | #' Write an Hmisc data.frame with labels to SPSS 2 | #' 3 | #' The Hmisc package lets you assign labels to data. This information is not 4 | #' included when using write.spss from the "foreign" package. This function 5 | #' tries to address that. 6 | #' 7 | #' 8 | #' @param data The input data.frame 9 | #' @param datafile The name for the resulting SPSS data file 10 | #' @param codefile The name for the resulting SPSS code file 11 | #' @return Two files will be created in your working directory: a script file 12 | #' and a data file that can be used with SPSS 13 | #' @author Ananda Mahto. Includes code from Chuck Cleland 14 | #' @references \url{http://stackoverflow.com/a/10261534/1270695} 15 | #' @examples 16 | #' 17 | #' df <- data.frame(id = c(1:6), 18 | #' p.code = c(1, 5, 4, NA, 0, 5), 19 | #' p.label = c('Optometrists', 'Nurses', 20 | #' 'Financial analysts', '', 21 | #' '0', 'Nurses'), 22 | #' foo = LETTERS[1:6]) 23 | #' # Add some variable labels using label from the Hmisc package 24 | #' library(Hmisc) 25 | #' label(df) <- "Sweet sweet data" 26 | #' label(df$id) <- "id blahblah" 27 | #' label(df$p.label) <- "Profession with human readable information" 28 | #' label(df$p.code) <- "Profession code" 29 | #' label(df$foo) <- "Variable label for variable x.var" 30 | #' # modify the name of one varibe to see what happens when exported 31 | #' names(df)[4] <- "New crazy name for 'foo'" 32 | #' 33 | #' df 34 | #' 35 | #' x <- setwd(tempdir()) 36 | #' list.files() 37 | #' write.Hmisc.SPSS(df, "df.sav", "df.sps") 38 | #' cat(readLines("df.sav"), sep = "\n") 39 | #' cat(readLines("df.sps"), sep = "\n") 40 | #' file.remove("df.sav", "df.sps") 41 | #' setwd(x) 42 | #' 43 | #' @export write.Hmisc.SPSS 44 | write.Hmisc.SPSS = function(data, datafile, codefile) { 45 | a = do.call(llist, data) 46 | tempout = vector("list", length(a)) 47 | 48 | for (i in 1:length(a)) { 49 | tempout[[i]] = label(a[[i]]) 50 | } 51 | b = unlist(tempout) 52 | label.temp = structure(c(b), .Names = names(data)) 53 | attributes(data)$variable.labels = label.temp 54 | write.SPSS <- function (df, datafile, codefile, varnames = NULL) { 55 | # Author: Chuck Cleland 56 | # https://stat.ethz.ch/pipermail/r-help/2006-January/085941.html 57 | adQuote <- function(x){paste("\"", x, "\"", sep = "")} 58 | dfn <- lapply(df, function(x) if (is.factor(x)) as.numeric(x) else x) 59 | write.table(dfn, file = datafile, row.names = FALSE, col.names = FALSE) 60 | if(is.null(attributes(df)$variable.labels)) varlabels <- names(df) 61 | else varlabels <- attributes(df)$variable.labels 62 | if (is.null(varnames)) { 63 | varnames <- abbreviate(names(df), 8) 64 | if (any(sapply(varnames, nchar) > 8)) 65 | stop("I cannot abbreviate the variable names to eight or fewer letters") 66 | if (any(varnames != names(df))) 67 | warning("some variable names were abbreviated") 68 | } 69 | cat("DATA LIST FILE=", dQuote(datafile), " free\n", file = codefile) 70 | cat("/", varnames, " .\n\n", file = codefile, append = TRUE) 71 | cat("VARIABLE LABELS\n", file = codefile, append = TRUE) 72 | cat(paste(varnames, adQuote(varlabels), "\n"), ".\n", 73 | file = codefile, append = TRUE) 74 | factors <- sapply(df, is.factor) 75 | if (any(factors)) { 76 | cat("\nVALUE LABELS\n", file = codefile, append = TRUE) 77 | for (v in which(factors)) { 78 | cat("/\n", file = codefile, append = TRUE) 79 | cat(varnames[v], " \n", file = codefile, append = TRUE) 80 | levs <- levels(df[[v]]) 81 | cat(paste(1:length(levs), adQuote(levs), "\n", sep = " "), 82 | file = codefile, append = TRUE) 83 | } 84 | cat(".\n", file = codefile, append = TRUE) 85 | } 86 | cat("\nEXECUTE.\n", file = codefile, append = TRUE) } 87 | write.SPSS(data, datafile, codefile) 88 | } 89 | NULL 90 | -------------------------------------------------------------------------------- /R/ftable2dt.R: -------------------------------------------------------------------------------- 1 | #' @name ftable2dt 2 | #' @rdname ftable2dt 3 | #' @title Convert an `ftable` or an `array` Object to a `data.table` 4 | #' 5 | #' @description While convenient methods exist for converting `table`s and other 6 | #' objects to `data.tables`s, such methods do not exist for converting an 7 | #' `ftable` to a `data.table`. An `ftable` is essentially a `matrix` with 8 | #' `attributes` for the rows and columns, which can be nested. 9 | #' 10 | #' @param inarray The input `ftable` or `array`. 11 | #' @param direction Should the reslut be "wide" (with multiple measurement. 12 | #' columns) or "long" (with a single measurement column)? Defaults to `"wide"`. 13 | #' @return A `data.table` 14 | #' @author Ananda Mahto 15 | #' @references 16 | #' @note If the array has no `dimnames`, names would be added using the 17 | #' `provideDimnames` function. Defaults to [reshape2::melt()] if the input is a 18 | #' simple matrix and not a multidimensional array. 19 | #' @examples 20 | #' 21 | #' x <- ftable(Titanic, row.vars = 1:3) 22 | #' x 23 | #' ftable2dt(x) 24 | #' ftable2dt(x, direction = "long") 25 | #' 26 | #' \dontrun{ 27 | #' dims <- c(2, 1, 2, 3, 2) 28 | #' set.seed(1) 29 | #' M <- `dim<-`(sample(100, prod(dims), TRUE), dims) 30 | #' N <- O <- `dimnames<-`(M, lapply(dims, function(x) 31 | #' c(letters, LETTERS)[seq_len(x)])) 32 | #' names(attributes(O)$dimnames) <- c("first", "second", "third", 33 | #' "fourth", "fifth") 34 | #' 35 | #' ftable2dt(M) 36 | #' ftable2dt(N) 37 | #' ftable2dt(O) 38 | #' ftable2dt(M, "long") 39 | #' ftable2dt(N, "long") 40 | #' ftable2dt(O, "long") 41 | #' } 42 | #' 43 | #' @export ftable2dt 44 | ftable2dt <- function(inarray, direction = "wide") { 45 | InArray <- copy(inarray) 46 | if (!is.array(InArray)) stop("input must be an array") 47 | dims <- dim(InArray) 48 | if (length(dims) == 1) { 49 | stop("nothing to do here....") 50 | } else if (length(dims) == 2 & (!any(class(InArray) %in% "ftable"))) { 51 | switch(direction, 52 | wide = as.data.table(InArray), 53 | long = setDT(melt(InArray))[], 54 | stop("direction must be 'wide' or 'long'")) 55 | } else { 56 | FIX <- !any(names(attributes(InArray)) %in% c("dimnames", "row.vars")) 57 | if (is.null(dimnames(InArray))) { 58 | InArray <- provideDimnames(InArray, base = list( 59 | as.character(seq_len(max(dims))))) 60 | } 61 | FT <- if (any(class(InArray) %in% "ftable")) InArray else ftable(InArray) 62 | temp <- ftablewide(FT, FIX = FIX) 63 | switch(direction, 64 | long = ftablelong(temp, FIX = FIX)[], 65 | wide = setorderv(temp[["Data"]], temp[["Names"]])[], 66 | stop("direction must be 'wide' or 'long'")) 67 | } 68 | } 69 | NULL 70 | 71 | ftablewide <- function(FT, FIX = TRUE) { 72 | ft_attr <- attributes(FT) 73 | rows <- setDT(rev(expand.grid(rev(ft_attr$row.vars), 74 | stringsAsFactors = FALSE))) 75 | if (is.null(names(ft_attr$row.vars))) setnames( 76 | rows, paste0("V", seq_len(ncol(rows)))) 77 | Nam <- names(rows) 78 | cols <- data.table(setattr(FT, "class", "matrix")) 79 | setnames(cols, do.call(paste, c(rev(expand.grid( 80 | rev(ft_attr$col.vars), stringsAsFactors = FALSE)), sep = "_"))) 81 | temp <- data.table(rows, cols) 82 | if (isTRUE(FIX)) temp[, (Nam) := lapply(.SD, as.integer), .SDcols = Nam] 83 | list(Attributes = ft_attr, Names = Nam, Data = temp) 84 | } 85 | NULL 86 | 87 | ftablelong <- function(inlist, FIX = TRUE) { 88 | temp <- melt(inlist[["Data"]], id.vars = inlist[["Names"]], 89 | variable.factor = FALSE) 90 | if (isTRUE(FIX)) set(temp, i = NULL, j = match("variable", names(temp)), 91 | value = as.integer(temp[["variable"]])) 92 | varName <- names(inlist[["Attributes"]]$col.vars) 93 | varName <- if (is.null(varName)) paste0("V", length(inlist[[2]])+1) else varName 94 | setnames(temp, "variable", varName) 95 | } 96 | NULL 97 | -------------------------------------------------------------------------------- /docs/bootstrap-toc.js: -------------------------------------------------------------------------------- 1 | /*! 2 | * Bootstrap Table of Contents v0.4.1 (http://afeld.github.io/bootstrap-toc/) 3 | * Copyright 2015 Aidan Feldman 4 | * Licensed under MIT (https://github.com/afeld/bootstrap-toc/blob/gh-pages/LICENSE.md) */ 5 | (function() { 6 | 'use strict'; 7 | 8 | window.Toc = { 9 | helpers: { 10 | // return all matching elements in the set, or their descendants 11 | findOrFilter: function($el, selector) { 12 | // http://danielnouri.org/notes/2011/03/14/a-jquery-find-that-also-finds-the-root-element/ 13 | // http://stackoverflow.com/a/12731439/358804 14 | var $descendants = $el.find(selector); 15 | return $el.filter(selector).add($descendants).filter(':not([data-toc-skip])'); 16 | }, 17 | 18 | generateUniqueIdBase: function(el) { 19 | var text = $(el).text(); 20 | var anchor = text.trim().toLowerCase().replace(/[^A-Za-z0-9]+/g, '-'); 21 | return anchor || el.tagName.toLowerCase(); 22 | }, 23 | 24 | generateUniqueId: function(el) { 25 | var anchorBase = this.generateUniqueIdBase(el); 26 | for (var i = 0; ; i++) { 27 | var anchor = anchorBase; 28 | if (i > 0) { 29 | // add suffix 30 | anchor += '-' + i; 31 | } 32 | // check if ID already exists 33 | if (!document.getElementById(anchor)) { 34 | return anchor; 35 | } 36 | } 37 | }, 38 | 39 | generateAnchor: function(el) { 40 | if (el.id) { 41 | return el.id; 42 | } else { 43 | var anchor = this.generateUniqueId(el); 44 | el.id = anchor; 45 | return anchor; 46 | } 47 | }, 48 | 49 | createNavList: function() { 50 | return $('
      '); 51 | }, 52 | 53 | createChildNavList: function($parent) { 54 | var $childList = this.createNavList(); 55 | $parent.append($childList); 56 | return $childList; 57 | }, 58 | 59 | generateNavEl: function(anchor, text) { 60 | var $a = $(''); 61 | $a.attr('href', '#' + anchor); 62 | $a.text(text); 63 | var $li = $('
    • '); 64 | $li.append($a); 65 | return $li; 66 | }, 67 | 68 | generateNavItem: function(headingEl) { 69 | var anchor = this.generateAnchor(headingEl); 70 | var $heading = $(headingEl); 71 | var text = $heading.data('toc-text') || $heading.text(); 72 | return this.generateNavEl(anchor, text); 73 | }, 74 | 75 | // Find the first heading level (`

      `, then `

      `, etc.) that has more than one element. Defaults to 1 (for `

      `). 76 | getTopLevel: function($scope) { 77 | for (var i = 1; i <= 6; i++) { 78 | var $headings = this.findOrFilter($scope, 'h' + i); 79 | if ($headings.length > 1) { 80 | return i; 81 | } 82 | } 83 | 84 | return 1; 85 | }, 86 | 87 | // returns the elements for the top level, and the next below it 88 | getHeadings: function($scope, topLevel) { 89 | var topSelector = 'h' + topLevel; 90 | 91 | var secondaryLevel = topLevel + 1; 92 | var secondarySelector = 'h' + secondaryLevel; 93 | 94 | return this.findOrFilter($scope, topSelector + ',' + secondarySelector); 95 | }, 96 | 97 | getNavLevel: function(el) { 98 | return parseInt(el.tagName.charAt(1), 10); 99 | }, 100 | 101 | populateNav: function($topContext, topLevel, $headings) { 102 | var $context = $topContext; 103 | var $prevNav; 104 | 105 | var helpers = this; 106 | $headings.each(function(i, el) { 107 | var $newNav = helpers.generateNavItem(el); 108 | var navLevel = helpers.getNavLevel(el); 109 | 110 | // determine the proper $context 111 | if (navLevel === topLevel) { 112 | // use top level 113 | $context = $topContext; 114 | } else if ($prevNav && $context === $topContext) { 115 | // create a new level of the tree and switch to it 116 | $context = helpers.createChildNavList($prevNav); 117 | } // else use the current $context 118 | 119 | $context.append($newNav); 120 | 121 | $prevNav = $newNav; 122 | }); 123 | }, 124 | 125 | parseOps: function(arg) { 126 | var opts; 127 | if (arg.jquery) { 128 | opts = { 129 | $nav: arg 130 | }; 131 | } else { 132 | opts = arg; 133 | } 134 | opts.$scope = opts.$scope || $(document.body); 135 | return opts; 136 | } 137 | }, 138 | 139 | // accepts a jQuery object, or an options object 140 | init: function(opts) { 141 | opts = this.helpers.parseOps(opts); 142 | 143 | // ensure that the data attribute is in place for styling 144 | opts.$nav.attr('data-toggle', 'toc'); 145 | 146 | var $topContext = this.helpers.createChildNavList(opts.$nav); 147 | var topLevel = this.helpers.getTopLevel(opts.$scope); 148 | var $headings = this.helpers.getHeadings(opts.$scope, topLevel); 149 | this.helpers.populateNav($topContext, topLevel, $headings); 150 | } 151 | }; 152 | 153 | $(function() { 154 | $('nav[data-toggle="toc"]').each(function(i, el) { 155 | var $nav = $(el); 156 | Toc.init($nav); 157 | }); 158 | }); 159 | })(); 160 | -------------------------------------------------------------------------------- /docs/404.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Page not found (404) • SOfun 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 55 | 56 | 57 | 58 | 59 | 60 | 61 |
      62 |
      63 | 105 | 106 | 107 | 108 |
      109 | 110 |
      111 |
      112 |
      113 |

      Page not found (404)

      114 |
      115 | 116 | Content not found. Please use links in the navbar. 117 | 118 |
      119 | 120 | 125 | 126 |
      127 | 128 | 129 | 130 |
      131 |
      132 |

      Developed by Ananda Mahto, Jota, Ed Morton.

      133 |
      134 | 135 |
      136 |

      Site built with pkgdown 1.5.1.9000.

      137 |
      138 | 139 |
      140 |
      141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | -------------------------------------------------------------------------------- /docs/authors.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Authors • SOfun 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 55 | 56 | 57 | 58 | 59 | 60 | 61 |
      62 |
      63 | 105 | 106 | 107 | 108 |
      109 | 110 |
      111 |
      112 |
      113 |

      Authors

      114 |
      115 | 116 |
        117 |
      • 118 |

        Ananda Mahto. Author, maintainer. 119 |

        120 |
        • 121 |
      • 122 |

        Jota. Author. 123 |

        124 |
        • 125 |
      • 126 |

        Ed Morton. Author. 127 |

        128 |
        • 129 |
      130 | 131 |
      132 | 133 |
      134 | 135 | 136 | 137 |
      138 |
      139 |

      Developed by Ananda Mahto, Jota, Ed Morton.

      140 |
      141 | 142 |
      143 |

      Site built with pkgdown 1.5.1.9000.

      144 |
      145 | 146 |
      147 |
      148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | -------------------------------------------------------------------------------- /docs/reference/readClip.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Read Clipboard Regardless of OS — readClip • SOfun 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 58 | 59 | 60 | 61 | 62 | 63 | 64 |
      65 |
      66 | 108 | 109 | 110 | 111 |
      112 | 113 |
      114 |
      115 |
      116 |

      Read Clipboard Regardless of OS

      117 | Source: R/utils.R 118 | 119 |
      120 | 121 |
      122 |

      Different operating systems have different ways of handling the clipboard. 123 | Given the frequency with which text is copied to the clipboard to place in 124 | an answer on StackOverflow, this utility is provided.

      125 |
      126 | 127 | 
      readClip()
      128 | 129 | 130 |

      Value

      131 | 132 |

      character string containing text on the clipboard.

      133 | 134 |
      135 | 140 |
      141 | 142 | 143 |
      144 |
      145 |

      Developed by Ananda Mahto, Jota, Ed Morton.

      146 |
      147 | 148 |
      149 |

      Site built with pkgdown 1.5.1.9000.

      150 |
      151 | 152 |
      153 |
      154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | Functions From Answers to R Questions on Stack Overflow • SOfun 9 | 10 | 11 | 12 | 13 | 14 | 15 | 17 | 21 | 22 | 23 |
      24 |
      67 | 68 | 69 | 70 | 71 |
      72 |
      73 |
      74 |

      75 | SOfun

      76 |

      Functions I’ve written as answers to R questions on Stack Overflow. Destined to be the most important R package you have ever loaded in your R session.

      77 | 83 |
      84 |

      85 | Contents

      86 |

      The “SOfun” package is filled with a very strongly cohesive set of functions.

      87 |

      Visit the Reference page for an overview of the functions in this package.

      88 |

      Don’t ask me why I did this.

      89 |
      90 |
      91 |
      92 | 93 | 117 |
      118 | 119 | 120 |
      121 |

      Developed by Ananda Mahto, Jota, Ed Morton.

      122 |
      123 | 124 |
      125 |

      Site built with pkgdown 1.5.1.9000.

      126 |
      127 | 128 |
      129 |
      130 | 131 | 132 | 133 | 134 | 135 | 136 | -------------------------------------------------------------------------------- /docs/reference/shuffler.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Shuffle the Elements of a Vector — shuffler • SOfun 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 57 | 58 | 59 | 60 | 61 | 62 | 63 |
      64 |
      65 | 107 | 108 | 109 | 110 |
      111 | 112 |
      113 |
      114 |
      115 |

      Shuffle the Elements of a Vector

      116 | Source: R/shuffler.R 117 | 118 |
      119 | 120 |
      121 |

      Shuffles the elements of a vector such that no single element is in the same 122 | place it was before.

      123 |
      124 | 125 | 
      shuffler(inVec)
      126 | 127 |

      Arguments

      128 | 129 | 130 | 131 | 132 | 133 | 134 |
      inVec

      The input vector

      135 | 136 |

      Value

      137 | 138 |

      A shuffled version of the input vector

      139 |

      References

      140 | 141 |

      http://stackoverflow.com/a/19898689/1270695

      142 |

      Author

      143 | 144 |

      Ananda Mahto

      145 | 146 |

      Examples

      147 | 
      
148 | shuffler(letters[1:10])
      #>  [1] "c" "f" "b" "h" "i" "d" "e" "g" "j" "a"
      149 |
      150 | 155 |
      156 | 157 | 158 | 168 |
      169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | --------------------------------------------------------------------------------