Share your functions & code

[trinker]

For you package makers here's one that generates basic roxygen framework for data sets that can be set to print to your package's main .R file. Here it is:

dat4rox <- function(..., file = NULL, append = FALSE) {
    dat.sets <- as.character(match.call(expand.dots = FALSE)[[2]]) 
    dat.list <- invisible(lapply(dat.sets, get))
    names(dat.list) <- dat.sets
    dat.file <- function(dat, name, file = "", append = FALSE) {
        is.enviroment <- function(x) class(x) == "environment"
        x <- "#'"
        what <- function(x) {
            if (is.data.frame(x)) {
                return("data frame")
            }
            if (is.list(x) & !is.data.frame(x)) {
                return("list")
            }
            if (is.vector(x)) {
                return("vector")
            }
            if (class(x) == "character") {
                return("character vector")
            }            
            if (is.environment(x)) {
                return("environment")
            }
        }
        type <- what(dat)
        if (type == "environment") {
            desc <- "#' A dataset containing an environment"
        } else {
            if (type == "data frame") {
                desc <- "#' A dataset containing"
            } else {
                if (type %in% c("character vector", "vector", "list")) {
                    desc <- paste("#' A dataset containing a", type)
                }
            }
        }
        if (is.data.frame(dat)) {
        	dets <- c("#' \\itemize{", paste("#'   \\item ", colnames(dat), ".", 
        	    sep = ""), "#' }")
        } else {
            if (is.vector(dat) | is.enviroment(dat) | class(dat) == "character") {
            	dets <- x
            } else {
                if (!is.data.frame(dat) && is.list(dat)) {
        	        dets <- c("#' \\describe{", paste("#'   \\item{", 
                        names(dat), "}{}", sep = ""), "#' }")
                }
            }
        }
        if (type == "data frame") {
            elems <- c(nrow(dat), "rows and", ncol(dat), "variables")
        } else {
            if (type %in% c("character vector", "vector")) {
                elems <- c(length(dat), "elements")
            } else {
                if (type == "list") {
                    elems <- c(length(dat), "elements")
                } else {
                    if (type == "environment") {
                        elems <- NULL
                    }
                }
            }    
        }
        out <- c("#'", x, desc, x, "#' @details",
            dets, x, "#' @docType data", "#' @keywords datasets",
            paste("#' @name", name), paste0("#' @usage data(", name, ")"),
            paste("#' @format A", type, "with", paste(elems, collapse = " ")), 
            "#' @references", "NULL\n")
        cat(paste(out, "\n", collapse=""), file = file, append = append)
    }
    invisible(lapply(seq_along(dat.list), function(i) {
        dat.file(dat.list[[i]], names(dat.list)[i])
    }))
    if (!is.null(file)) {
        apen <- rep(TRUE, length(dat.list))
        if (!append) {
            apen[1] <- FALSE
        }
        invisible(lapply(seq_along(dat.list), function(i) {
            dat.file(dat.list[[i]], names(dat.list)[i], file = file, append = apen[i])
        }))
    }
}


dat4rox(mtcars, CO2, file = "new.txt") #print to new file
dat4rox(mtcars, CO2, file = "qdap-package.R", append = TRUE) #print to package.R file

This yields:

Spoiler:

#' 
#' 
#' A dataset containing 
#' 
#' @details 
#' \itemize{ 
#'   \item mpg. 
#'   \item cyl. 
#'   \item disp. 
#'   \item hp. 
#'   \item drat. 
#'   \item wt. 
#'   \item qsec. 
#'   \item vs. 
#'   \item am. 
#'   \item gear. 
#'   \item carb. 
#' } 
#' 
#' @docType data 
#' @keywords datasets 
#' @name mtcars 
#' @usage data(mtcars) 
#' @format A data frame with 32 rows and 11 variables 
#' @references 
NULL
 
#' 
#' 
#' A dataset containing 
#' 
#' @details 
#' \itemize{ 
#'   \item Plant. 
#'   \item Type. 
#'   \item Treatment. 
#'   \item conc. 
#'   \item uptake. 
#' } 
#' 
#' @docType data 
#' @keywords datasets 
#' @name CO2 
#' @usage data(CO2) 
#' @format A data frame with 84 rows and 5 variables 
#' @references 
NULL

I threw it in a package on my github as well:

# install.packages("devtools")

library(devtools)
install_github("acc.roxygen2", "trinker")

EDIT 1: I am going to clean up acc.roxygen2 more and make it OS independent in the future.
EDIT 2: Added handling for environments, lists and vectors.

[Nathan G]

Here's a Caesar Cypher I whipped up in response to a question.. I told him he needed to do some diligence before answering, but if he finds it here, good for him.

crypt <- function(x,offset){
	Letters <- c(letters[],LETTERS[])
	stringlist <- substring(x, seq(1,nchar(x),1), seq(1,nchar(x),1))
	crypted <- lapply(stringlist, function(i)  ifelse(!is.na(match(i,Letters)), ifelse((match(i, Letters) + offset)<52,sub(i, Letters[match(i, Letters) + offset],i),sub(i, Letters[offset - (52 - match(i,Letters))],i)), i))
	return(paste(crypted,collapse=""))
}

decrypt <- function(x,offset){
	Letters <- c(letters[],LETTERS[])
	stringlist <- substring(x, seq(1,nchar(x),1), seq(1,nchar(x),1))
	decrypted <- lapply(stringlist, function(i)  ifelse(!is.na(match(i,Letters)), ifelse((match(i, Letters) - offset)>0,sub(i, Letters[match(i, Letters) - offset],i),sub(i, Letters[52 - (offset - match(i,Letters))],i)), i))
	return(paste(decrypted,collapse=""))
}

x <- "The quick brown foX jumped over the laZY dog."

test <- crypt(x,3)
detest <- decrypt(test, 3)

If you can do better, I would love any advice to improving my coding skills. I realize there are some messy one-liners in there.

decrypt("Li wulqnhu uhdgv wklv, kh pxvw eh d Yhorfludswru.", 3)

[Nathan G]

Why did the statistician take Viagra?

decrypt("av yhpzl opz w-ChsBl!!", 7)

[bryangoodrich]

I don't have this function decrypt that you speak of

[Nathan G]

It's a couple posts previous on the same thread.

[trinker]

I created a package to assist in writing apa6 style reports and presentations.

Here's an introductory video: http://youtu.be/qBgsJG546gE
Here's the github website: https://github.com/trinker/reports

[Nathan G]

Here's a nice little function that can rotate, shift, or circular shift matrices.

morph <- function(x, type, offset = 1, fill = 0, wrap = FALSE, dir = "col"){
	
	if (!is.matrix(x) & !is.data.frame(x))
		stop("Argument 'x' is not a matrix or data.frame.")
	if (offset != trunc(offset)) 
		stop("Argument 'offset' is not an integer.")

	if (type == "rot"){
		if(offset%%4 == 0)
			return(x)
		if(offset%%4 == 1)
			return( t(x[, ncol(x):1]) )			# rotate 90
		if(offset%%4 == 2)
			return( x[nrow(x):1, ncol(x):1] ) 	# rotate 180
		if(offset%%4 == 3)
			return( t(x[nrow(x):1, ]) )			# rotate 270
	}

	if (type == "shift" ){
		if(wrap){
			if (dir == "col")
				return( x[, ((1:ncol(x))-1-offset)%%ncol(x)+1] )
			if (dir == "row")
				return( x[((1:nrow(x))-1-offset)%%nrow(x)+1, ] )
		}
		if(!wrap){
			if(offset == 0)
				return(x)
			if (dir == "col"){
				if(offset < 0){
					return(morph(cbind(x[, 2:ncol(x)], N=rep(fill, nrow(x))), 
									 type, offset + 1, fill, wrap, dir))
				}	
				if(offset > 0){
					return(morph(cbind(N=rep(fill, nrow(x)), x[, 1:ncol(x) - 1]), 
									 type, offset - 1, fill, wrap, dir))
				}					
			}
			if (dir == "row"){
				if(offset < 0){
					return(morph(rbind(x[2:nrow(x), ], rep(fill, ncol(x))), 
									type, offset + 1, fill, wrap, dir))
				}	
				if(offset > 0){
					return(morph(rbind(rep(fill, ncol(x)), x[1:nrow(x) - 1, ]), 
									 type, offset - 1, fill, wrap, dir))
				}
			}
		}
	}
	stop("Invalid morph type or direction.")
}

For example:

(test <- matrix(1:16, 4))
#     [,1] [,2] [,3] [,4]
#[1,]    1    5    9   13
#[2,]    2    6   10   14
#[3,]    3    7   11   15
#[4,]    4    8   12   16
morph(test, 'rot')
#     [,1] [,2] [,3] [,4]
#[1,]   13   14   15   16
#[2,]    9   10   11   12
#[3,]    5    6    7    8
#[4,]    1    2    3    4
morph(test, 'rot', -1)
#     [,1] [,2] [,3] [,4]
#[1,]    4    3    2    1
#[2,]    8    7    6    5
#[3,]   12   11   10    9
#[4,]   16   15   14   13
morph(test, 'shift', 2, 'hi')
#     N    N           
#[1,] "hi" "hi" "1" "5"
#[2,] "hi" "hi" "2" "6"
#[3,] "hi" "hi" "3" "7"
#[4,] "hi" "hi" "4" "8"
morph(test, 'shift', -1, 'ho', dir='row')
#     [,1] [,2] [,3] [,4]
#[1,] "2"  "6"  "10" "14"
#[2,] "3"  "7"  "11" "15"
#[3,] "4"  "8"  "12" "16"
#[4,] "ho" "ho" "ho" "ho"
morph(test, 'shift', 1, wrap=TRUE)
#     [,1] [,2] [,3] [,4]
#[1,]   13    1    5    9
#[2,]   14    2    6   10
#[3,]   15    3    7   11
#[4,]   16    4    8   12
morph(test, 'shift', -2, wrap=TRUE, dir='row')
#     [,1] [,2] [,3] [,4]
#[1,]    3    7   11   15
#[2,]    4    8   12   16
#[3,]    1    5    9   13
#[4,]    2    6   10   14
#