Nothing
##' Number of non-NA unique elements in a vector
##'
##' Returns the number of non-NA unique elements in a vector. A wrapper to
##' \code{length( unique( x[!is.na(x)], ... ) )}.
##' Primarily intended for interactive, not programmatic, use.
##' @export
##' @param x a vector
##' @param ... passed to \code{\link{unique}}
lu <- function( x, ...) {
length( unique( x[!is.na(x)], ... ) )
}
##' Unique elements in a vector
##'
##' Returns the unique elements in a vector. A wrapper to
##' \code{\link{unique}()}.
##' Primarily intended for interactive, not programmatic, use.
##' @param ... passed to \code{\link{unique}}.
u <- function(...) {
unique( ... )
}
##' length( grep( ... ) )
##'
##' This is a wrapper to a \code{length( grep( ... ) )}. See examples for usage.
##' Primarily intended for interactive, not programmatic, use.
##' @param pattern regex pattern passed to \code{grep}.
##' @param x a vector on which we attempt to match \code{pattern} on.
##' @param perl boolean. use perl-compatible regular expressions?
##' @param ... additional arguments passed to \code{\link{grep}}.
##' @seealso \code{\link{re_exists}}
##' @export
##' @examples
##' x <- c("apple", "banana", "cherry")
##' if( lg( "^ap", x ) > 0 ) {
##' print( "regular expression '^ap' found in 'x'" )
##' }
lg <- function(pattern, x, perl=TRUE, ...) {
length( grep( pattern, x, perl=perl, ... ) )
}
##' unlist( strsplit( ... ) )
##'
##' This is a thin wrapper to \code{ unlist( strsplit( ... ) ) }.
##' Primarily intended for interactive, not programmatic, use.
##' @param x vector of items, as passed to \code{\link{strsplit}}
##' @param split the delimiter to split on
##' @param ... optional arguments passed to strsplit
##' @export
##' @seealso \code{\link{unlist}}, \code{\link{strsplit}}
##' @examples
##' x <- "apple_banana_cherry"
##' us(x, "_")
us <- function(x, split="", ...) { unlist( strsplit( x, split=split, ...) ) }
##' Set Working Directory
##'
##' A small convenience function that wraps \code{file.path} into a
##' \code{setwd} call.
##'
##' @param ... the set of strings to paste together. if no arguments are
##' submitted, then we return to the home directory.
##' @export
##' @examples
##' x <- "my_favourite_dir"
##' #setwd( "C:/", x, "really_awesome_stuff" )
##' ## calls setwd( paste( "C:/", x, "really_awesome_stuff", collapse="" ) )
cd <- function(...) {
args <- list(...)
if( length(args) == 0 ) {
base::setwd("~")
return( invisible(NULL) )
}
base::setwd( file.path( ... ) )
return( invisible(NULL) )
}
##' Apply a Function over a List
##'
##' A convenience function that works like \code{lapply}, but coerces the output
##' to a \code{data.frame} if possible. We set \code{stringsAsFactors=FALSE}, and
##' \code{optional=TRUE}, to minimize the amount of automatic coersion \R might
##' try to do.
##'
##' This function is preferable to \code{\link{sapply}} or \code{\link{lapply}}
##' when you explicitly want a data frame returned.
##'
##' @param X a vector, expression object, or a \code{data.frame}
##' @param FUN function to be applied to each element of \code{X}.
##' @param ... optional arguments to \code{FUN}.
##' @seealso \code{\link{lapply}}, \code{\link{lapply}}
##' @export
##' @importFrom data.table setattr
##' @examples
##' dat <- data.frame(
##' x = rnorm(10),
##' y = rnorm(10)
##' )
##'
##' ## Calculate 0.025, 0.975 quantiles for each column in a data.frame,
##' ## and return result as data.frame .
##' dapply( dat, function(x) {
##' quantile(x, c(0.025, 0.975))
##' } )
##'
##' dapply( dat, summary )
##' str( dapply( dat, summary ) )
dapply <- function(X, FUN, ...) {
tmp <- lapply(X, FUN, ...)
nm <- names(tmp[[1]])
list2df(tmp, inplace=TRUE)
if (!is.null(nm)) {
setattr(tmp, "row.names", nm)
}
return(tmp)
}
##' Read Tabular Data from the Clipboard
##'
##' Convenience function for reading tabular data from the clipboard.
##' The function checks the system OS and provides the appropriate wrapper
##' call to \code{\link{read.table}}.
##' @export
##' @param sep the delimiter used in the copied text.
##' @param header boolean; does the first row contain column names?
##' @param ... optional arguments passed to \code{read.table}.
##' @seealso \code{\link{read.table}}
##' @examples
##' ## with some data on the clipboard, simply write
##' # x <- read.cb()
read.cb <- function(sep='\t', header=TRUE, ...) {
sn <- Sys.info()["sysname"]
if (sn == "Darwin") {
read.table( pipe("pbpaste"), header=header, sep=sep, ... )
} else if (sn == "Windows") {
read.table( "clipboard", header=header, sep=sep, ... )
} else {
stop("Reading from the clipboard is not implemented for your system (",
sn, ") in this package.")
}
}
##' Read Data from the Clipboard
##'
##' Convenience function for reading data from the clipboard.
##' Wraps to \code{\link{scan}}. By default, we assume the data is
##' \code{character}, and delimit by new lines.
##' @export
##' @param what passed to \code{scan}.
##' @param sep passed to \code{scan}.
##' @param quiet passed to \code{scan}.
##' @param ... passed to \code{scan}.
##' @seealso \code{\link{scan}}
scan.cb <- function( what=character(), sep="\n", quiet=TRUE, ... ) {
sn <- Sys.info()["sysname"]
if (sn == "Darwin") {
file <- pipe("pbpaste")
output <- scan( file, what=what, sep=sep, quiet=quiet, ... )
close(file)
} else if (sn == "Windows") {
output <- scan( "clipboard", what=what, sep=sep, quiet=quiet, ... )
} else {
stop("Reading from the clipboard is not implemented for your system (",
sn, ") in this package.")
}
return(output)
}
##' Write Tabular Data to the Clipboard
##'
##' Directs output of \code{write.table} to the clipboard. This can be
##' useful if you want to quickly write some \R table out and paste it into
##' some other file, eg. a Word document, Excel table, and so on.
##' @export
##' @param dat the data file you want to write out; passed to \code{write.table}.
##' @param row.names logical. include the row names of dat?
##' @param col.names logical. include the column names of dat?
##' @param sep the delimiter used to separate elements after exporting dat.
##' @param quote logical. include quotes around character vectors in dat?
##' @seealso \code{\link{write.table}}
##'
write.cb <- function( dat,
row.names=FALSE,
col.names=TRUE,
sep='\t',
quote=FALSE ) {
sn <- Sys.info()["sysname"]
if (sn == "Darwin") {
file <- pipe("pbcopy")
write.table( dat, file=file,
row.names=row.names,
col.names=col.names,
sep=sep,
quote=quote
)
close(file)
} else if (sn == "Windows") {
write.table( dat, file="clipboard",
row.names = row.names,
col.names = col.names,
sep = sep,
quote = quote
)
} else {
stop("Writing to the clipboard is not implemented for your system (",
sn, ") in this package.")
}
}
##' Write Data to the Clipboard
##'
##' This function writes data to the clipboard, using \code{\link{cat}}.
##' @param dat data to be written to the clipboard.
##' @param ... optional arguments passed to \code{cat}.
##' @seealso \code{\link{write.cb}}, \code{\link{cat}}
##' @export
cat.cb <- function( dat, ... ) {
sn <- Sys.info()["sysname"]
if (sn == "Darwin") {
file <- pipe("pbcopy")
cat( dat, file=file, ... )
close(file)
} else if (sn == "Windows") {
cat( dat, file="clipboard", ... )
} else {
stop("Reading from the clipboard is not implemented for your system (",
sn, ") in this package.")
}
}
##' Converts Factors to Characters in an Object
##'
##' Converts factors to characters in an object. Leaves non-character
##' elements untouched.
##'
##' We iterate through all elements in the object (e.g. if
##' it is a list) and convert anything that is a factor into a character.
##' @param X an object.
##' @param inplace Boolean; if \code{TRUE} we modify the object in place.
##' Useful if you're modifying a list and don't want to force a copy, but
##' be wary of other symbols pointing as the same data.
##' @export
factor_to_char <- function(X, inplace=FALSE) {
invisible( .Call(Cfactor_to_char, X, as.logical(inplace)) )
}
##' Converts Characters to Factors in an Object
##'
##' Converts characters to factors in an object. Leaves non-factor elements
##' untouched.
##'
##' @param X an object.
##' @param inplace boolean; if \code{TRUE} the object is modified in place.
##' Useful if you're modifying a list and don't want to force a copy, but
##' be wary of other symbols pointing as the same data.
##' @param ... Ignored.
##' @export
char_to_factor <- function(X, inplace=FALSE, ...) {
invisible( .Call(CKmisc_char_to_factor, X, inplace) )
}
##' Make Dummy Variables from a Factor
##'
##' This functions converts a single factor into dummy variables, with one
##' dummy variable for each level of that factor. Names are constructed as
##' \code{<varName>_<level>}.
##' @param x an object coercable to \code{factor}.
##' @export
##' @examples
##' x <- factor( rep( c("a", "b", "c", "d"), each=25 ) )
##' make_dummy(x)
make_dummy <- function(x) {
if( is.data.frame(x) ) {
name <- names(x)
x <- x[,1]
} else {
name <- deparse( substitute( x ) )
name <- gsub( ".*\\$", "", name )
}
levs <- unique(x)
out <- vector("list", length(levs))
for( i in seq_along(levs) ) {
lev <- levs[i]
tmp <- as.character(x)
tmp[ x == lev ] <- 1
tmp[ x != lev ] <- 0
out[[lev]] <- tmp
names( out )[i] <- paste( name, lev, sep = "_" )
}
return( char_to_factor( as.data.frame(do.call(cbind, out)) ) )
}
##' k-means Diagnostic Plot
##'
##' Using \code{kmeans}, plot percentage variance explained vs. number of clusters.
##' Used as a means of picking \code{k}.
##'
##' @importFrom lattice xyplot panel.grid panel.polygon panel.xyplot panel.abline
##' @param dat numeric matrix of data, or an object that can be coerced to
##' such a matrix (such as a numeric vector or a data frame with all
##' numeric columns).
##' @param nmax maximum number of clusters to examine
##' @param ... optional arguments passed to xyplot
##' @seealso \code{\link{kmeans}}
##' @export
##' @examples
##' data(iris)
##' kmeans_plot(iris[,1:4])
kmeans_plot <- function( dat, nmax=20, ... ) {
y <- rep(0,nmax)
for( i in 1:nmax ) {
tmp <- kmeans( dat, i )
y[i] <- tmp$betweenss / tmp$totss
}
print( xyplot( y ~ (1:nmax), type = c("p", "l"), ... ) )
}
##' Strip File Extension
##'
##' Strips the extension from a file name. By default, we assume the extension
##' is separated from the file name by a single period; however, the \code{lvl}
##' argument lets us specify how many periods are used in forming the file
##' extension.
##' @param x the file name, including extension.
##' @param lvl the number of \code{'.'} used in defining the file extension.
##' @export
##' @examples
##' x <- "path_to_file.tar.gz"
##' strip_extension(x, lvl=2)
strip_extension <- function(x, lvl=1) {
if( length(x) == 0 ) {
return(x)
}
tmp <- unlist( strsplit( x, "/" ) )
tmp2 <- tmp[length(tmp)]
tmp2 <- unlist( strsplit( tmp2, "\\." ) )
tmp2 <- paste( tmp2[1:(length(tmp2)-lvl)], collapse ="." )
tmp <- paste( tmp[-length(tmp)], collapse="/")
if( tmp != "" ) {
tmp2 <- paste( tmp, tmp2, sep = "/" )
}
return(tmp2)
}
##' Load and Assign an R Object
##'
##' The regular \code{load} function keeps the old variable name used when
##' saving that object. Often, we would prefer to assign the \code{load}ed
##' object to a new variable name. Hence, this function.
##'
##' If multiple arguments are supplied, they will be concatenated through
##' \code{file.path}.
##' @param ... args to pass to \code{load}
##' @seealso \code{\link{load}}
##' @export
##' @return the object stored in the \code{load}-ed object
##' @examples
##' dat <- data.frame( x = c(1,2,3), y=c('a','b','c') )
##' save( dat, file="dat.rda" )
##' rm( dat )
##' my_data <- kLoad( "dat.rda" )
##' ## we protect ourselves from 'forgetting' the name of the
##' ## object we saved
kLoad <- function( ... ) {
get( load( file.path( ... ) ) )
}
##' @rdname kLoad
##' @export
getload <- kLoad
##' Write out and Save a Tabular File
##'
##' A function that both writes a file to table with \code{write.table},
##' and saves it with the same name but a separate file extension.
##' @param x the R object you want to save / write to file
##' @param file the location to write the file to, with extension desired for object written by write.table
##' @param lvl how many extensions do you want to strip from your output file?
##' @param Rext the extension to use for the saved object.
##' @param ... optional arguments passed to \code{write.table}
##' @export
##' @examples
##' dat <- data.frame( x=c(1,2,3), y=c('a','b','c') )
##' kSave( dat, file="dat.txt" )
##' ## the file 'dat.rda' is written as well - let's see if it exists
##' dat2 <- kLoad( "dat.rda" )
##' stopifnot( identical(dat, dat2) ) ## TRUE
kSave <- function( x, file, lvl=1, Rext=".rda", ... ) {
write.table( x,
file = file,
... )
tmp <- strip_extension( file, lvl=lvl )
save( x,
file=paste( tmp, Rext, sep="" )
)
}
##' Merge (Left Join) with Order Retainment
##'
##' \code{merge} will mangle the order of the data frames it is merging. This is
##' a simple modification to ensure that the order in data frame \code{x} is preserved
##' when doing a 'left join'; ie, \code{merge( x, y, all.x=TRUE, ... )}.
##' That is, if we want to merge a data frame \code{x} with another
##' data frame \code{y}, we can merge in the parts of \code{y} whose index matches
##' with that of \code{x}, while preserving the ordering of \code{x}.
##'
##' @param x the \code{data.frame} you wish to merge \code{y} into.
##' @param y the \code{data.frame} to be merged.
##' @param by specifications of the columns used for merging. See 'Details' of \code{\link{merge}}.
##' @param by.x specifications of the columns used for merging. See 'Details' of \code{\link{merge}}.
##' @param by.y specifications of the columns used for merging. See 'Details' of \code{\link{merge}}.
##' @param ... optional arguments passed to \code{merge}.
##' @export
##' @return \code{data.frame}
##' @seealso \code{\link{merge}}
##' @examples
##' x <- data.frame( id=5:1, nums=rnorm(5) )
##' y <- data.frame( id=1:3, labels=c(1, 2, 2) )
##' merge(x, y, all.x=TRUE) ## re-ordered the data.frame
##' merge(x, y, all.x=TRUE, sort=FALSE) ## nope - NAs cause problems
##' kMerge(x, y, by="id") ## preserves ordering of x, even with NAs
##'
##' ## an id entry appears more than once in y
##' y <- data.frame( id=c(1, 1, 2), labels=c(1, 2, 3) )
##' kMerge(x, y, by="id")
kMerge <- function( x, y, by=intersect( names(x), names(y) ), by.x=by, by.y=by, ... ) {
x[["__KMERGE_TMP__"]] <- 1:nrow(x)
tmp <- merge( x=x, y=y, by=by, by.x=by.x, by.y=by.y, all.x = TRUE, ... )
tmp <- tmp[order(tmp[["__KMERGE_TMP__"]]),]
tmp <- tmp[ names(tmp) != "__KMERGE_TMP__"]
rownames(tmp) <- 1:nrow(tmp)
return( tmp )
}
##' Generate Gradient from Continuous Variable
##'
##' Assign colors based on a continuous variable. Useful for plotting functions
##' where you would like to generate a gradient based on (a function of) the
##' continuous variables you are plotting quickly.
##'
##' @param x a continuous variable to generate colors over.
##' @param m the number of distinct colors you wish to pull from the pallete.
##' @param cols the colors to interpolate over. passed to \code{\link{colorRampPalette}}.
##' @seealso \code{\link{colorRampPalette}}
##' @export
##' @examples
##' dat <- data.frame(y=rnorm(100), x=rnorm(100))
##' with( dat, plot( y ~ x, col=gradient(y) ) )
gradient <- function(x, m=10, cols=c("darkorange","grey60","darkblue") ) {
x.cut <- as.integer( cut(x, m) )
cols <- colorRampPalette( cols )(m)
x.cols <- cols[x.cut]
return( x.cols )
}
##' Make Nicely Formatted Tables
##'
##' Function for creating nice 1D and 2D tables. Tables are generated and
##' formatted with both counts and percentages. Primarily intended to be used
##' with R Markdown documents, calling some of the table printing functions.
##' The function returns a \code{data.frame} in a format that can be used with
##' utility HTML generation functions.
##' @param x the \code{x} variable to build a table on.
##' @param y optional: the \code{y} variable to build a table on.
##' Used for 2x2 contingency tables.
##' @param deparse.level passed to \code{table}; \code{deparse.level=2} allows
##' us to pass through variable names.
##' @param top.left.cell the string to set in the top left cell of the table.
##' @param col.names a vector of column names to use on the outputted table;
##' typically this is parsed from the variables passed through.
##' @param row.names a vector of row names to use on the outputted table;
##' typically this is parsed from the variables passed through.
##' @param left.label the label to use for the rows; typically parsed from
##' \code{x}. Only used for 2D tables (ie, when \code{y} is not null).
##' @param top.label the label to use for the columns; typically parsed from
##' \code{y}. Only used for 2D tables (ie, when \code{y} is not null).
##' @param google used if you plan on passing the table to \code{gvistable}
##' from the \code{googleVis} package.
##' @export
##' @examples
##' x <- rbinom(100, size=2, p=0.1)
##' y <- rbinom(100, size=2, p=0.1)
##'
##' ## try these in an R markdown document for best results
##' kTable(x)
##' my_table <- kTable(x, y, top.left.cell="foo", left.label="bar", top.label="baz")
##' pxt( my_table )
kTable <- function( x,
y=NULL,
deparse.level=2,
top.left.cell="",
col.names=NULL,
row.names=NULL,
left.label=NULL,
top.label=NULL,
google=FALSE
) {
if( !is.null(y) & isTRUE(google) ) {
stop("cannot generate google tables from 2x2 contingency tables")
}
if( is.null(left.label) ) {
left.label <- gsub( ".*\\$", "", deparse( substitute( x ) ) )
}
if( is.null( top.label ) ) {
top.label <- gsub( ".*\\$", "", deparse( substitute( y ) ) )
}
suppressWarnings(
if( any( is.na( x ) ) || any( is.na( y ) ) ) {
useNA <- 'always'
} else {
useNA <- 'no'
}
)
if( is.null(y) ) {
tmp <- base::table( x, deparse.level=deparse.level, useNA=useNA )
## Row names
if( is.null( row.names ) ) {
my_rowNames <- rownames(tmp)
} else {
my_rowNames <- row.names
}
## Col names
if( is.null( col.names ) ) {
my_colNames <- deparse( substitute( x ) )
} else {
my_colNames <- col.names
}
## Row, column sums
tmp <- matrix(tmp, nrow=nrow(tmp), ncol=1 )
my_colSum <- colSums(tmp)
my_rowSum <- rowSums(tmp)
my_col_nchar <- apply( tmp, 2, function(x) { max( nchar( x ) ) } )
## Add in percentages
for( i in 1:nrow(tmp) ) {
for( j in 1:ncol(tmp) ) {
tmp[i,j] <- paste( sep="",
paste( sep="",
rep(" ", times=my_col_nchar[j] - nchar(tmp[i,j])), collapse=""
),
tmp[i,j],
" (",
substr(
sprintf("%.3f%%", as.numeric(tmp[i,j]) / my_colSum[j] * 100 ),
1,
4
),
"%)"
)
}
}
tmp <- rbind( tmp, my_colSum )
## Row, column names
tmp <- cbind( c( my_rowNames, "Total" ), tmp )
tmp <- rbind( c(
gsub( ".*\\$", "", deparse( substitute( x ) ) ),
"Count (%)"
), tmp )
## Top-Left cell
if( top.left.cell != "" ) {
tmp[1,1] <- top.left.cell
} else {
tmp[1,1] <- left.label
}
} else {
tmp <- base::table( x, y, deparse.level=deparse.level, useNA=useNA )
my_rowNames <- rownames(tmp)
my_colNames <- colnames(tmp)
## Row, column sums
tmp <- matrix(tmp, nrow=nrow(tmp) )
my_rowSum <- rowSums(tmp)
my_colSum <- colSums(tmp)
my_col_nchar <- apply( tmp, 2, function(x) { max( nchar( x ) ) } )
## Add in percentages
for( i in 1:nrow(tmp) ) {
for( j in 1:ncol(tmp) ) {
if( my_colSum[j] != 0 ) {
tmp[i,j] <- paste( sep="",
paste( sep="",
rep(" ", times=my_col_nchar[j] - nchar(tmp[i,j])), collapse="" ),
tmp[i,j],
" (",
substr(
sprintf("%.3f%%", as.numeric(tmp[i,j]) / my_colSum[j] * 100 ),
1,
4
),
"%)"
)
}
}
}
## Add in the row, column sums
tmp <- cbind( tmp, my_rowSum )
tmp <- rbind( tmp, c( my_colSum, sum(my_rowSum) ) )
## Row names
tmp <- cbind( c( my_rowNames, "Total" ), tmp )
## Col names
tmp <- rbind( c("", my_colNames, "Total" ), tmp )
## left Label
tmp <- cbind( c("", left.label, rep("", times=nrow(tmp)-2 ) ), tmp )
## top label
tmp <- rbind( c("", "", top.label, rep("", times=ncol(tmp)-3 ) ), tmp )
## top left cell
if( is.null( top.left.cell ) ) {
tmp[1,1] <- paste(
gsub( ".*\\$", "", deparse( substitute( x ) ) ),
gsub( ".*\\$", "", deparse( substitute( y ) ) ),
sep=" \\ "
)
} else {
tmp[1,1] <- top.left.cell
}
}
tmp[ is.na(tmp) ] <- "Missing"
tmp <- gsub( "100\\.%", " 100%", tmp )
## Formatting for gvisTable
if( google ) {
rownames(tmp) <- 1:nrow(tmp)
tmp <- as.data.frame( tmp, stringsAsFactors=FALSE )
names(tmp) <- c(t(tmp[1,]))
tmp <- tmp[-1,]
}
return(tmp)
}
##' Nicely Formatted Model Coefficient Output
##'
##' A customized coefficient function that assigns better row names to the
##' coefficient matrix returned by \code{\link{coef}}() for a model fit. Also
##' includes some arguments for parsing of variable names.
##'
##' NOTE:
##'
##' Models with interaction effects are currently not handled.
##'
##' @param fit the model fit we wish to generate coefficients from.
##' @param remove_underscore remove underscores (and all elements after) in a variable?
##' @param remove_dollar remove all elements before and including a $ in a variable name?
##' @param swap_periods swap periods with spaces?
##' @note The names given assume default contrasts in your model fit; ie,
##' the default is \code{contr.treatment}, where each level of a factor is
##' compared to a reference.
##' @export
##' @return a matrix of coefficients with nicely formatted names.
##' @examples
##'
##' ## How the remove_underscore and remove_dollar arguments act:
##' ## An example:
##' ## kDat$variable_other_stuff
##' ## remove_underscore: +++++++++++++------------
##' ## remove_dollar: -----++++++++++++++++++++
##'
##' x <- rnorm(100); y <- x * runif(100)
##' z <- as.factor( rep( c("apple", "banana", "cherry", "date"), each=25 ) )
##' myFit <- lm( y ~ x + z )
##'
##' ## compare the output of these two: which do you prefer?
##' coef( summary( myFit ) )
##' kCoef( myFit )
kCoef <- function( fit,
remove_underscore=TRUE,
remove_dollar=TRUE,
swap_periods=TRUE
) {
if( re_exists(names(fit$coefficients), ":") ) {
warning("kCoef not implemented for models with interaction effects")
}
dat <- fit$data
coef_matrix <- coef( summary( fit ) )
## get the factors used in the model fit
my_factors <- fit$model[sapply( fit$model, is.factor )]
## if there are no factors, just return the matrix
if( length(my_factors) == 0 ) {
if( remove_underscore ) {
rownames( coef_matrix ) <- gsub( "_.*", "", rownames(coef_matrix) )
}
if( remove_dollar ) {
rownames( coef_matrix ) <- gsub( ".*\\$", "", rownames(coef_matrix) )
}
if( swap_periods ) {
rownames( coef_matrix ) <- gsub( "\\.", " ", rownames(coef_matrix) )
}
return( coef_matrix )
}
## drop the first column if it was the dependent variable
if( all(fit$model[,1] == my_factors[,1]) ) {
my_factors <- my_factors[,-1,drop=FALSE]
}
## if there are no factors, just return the matrix
if( length(my_factors) == 0 ) {
if( remove_underscore ) {
rownames( coef_matrix ) <- gsub( "_.*", "", rownames(coef_matrix) )
}
if( remove_dollar ) {
rownames( coef_matrix ) <- gsub( ".*\\$", "", rownames(coef_matrix) )
}
if( swap_periods ) {
rownames( coef_matrix ) <- gsub( "\\.", " ", rownames(coef_matrix) )
}
return( coef_matrix )
}
my_factor_levels <- lapply( my_factors, levels )
## generate old factor names
old_factor_names <- NULL
for( i in 1:length(my_factor_levels) ) {
cFactor <- names(my_factor_levels)[i]
for( j in 2:length(my_factor_levels[[i]]) ) {
cName <- my_factor_levels[[i]][j]
old_factor_names <- c( old_factor_names, paste( cFactor, cName, sep="" ))
}
}
## generate new factor names
new_factor_names <- NULL
for( i in 1:length(my_factor_levels) ) {
cFactor <- names(my_factor_levels)[i]
if( remove_underscore ) {
cFactor <- gsub( "_.*", "", cFactor )
}
cRef <- my_factor_levels[[i]][1]
for( j in 2:length(my_factor_levels[[i]]) ) {
cName <- my_factor_levels[[i]][j]
new_factor_names <- c( new_factor_names,
paste( cFactor, ": ", cRef, " -> ", cName, sep="" )
)
}
}
## handle interaction effects
new_interactions <- grep( ":", colnames( attr( fit$terms, "factors" ) ), value=T )
old_interactions <- grep( ":", rownames( coef_matrix ), value=T )
## swap the row names
rownames( coef_matrix ) <- swap( rownames( coef_matrix),
old_factor_names,
new_factor_names
)
rownames( coef_matrix ) <- swap( rownames( coef_matrix),
old_interactions,
new_interactions
)
## remove underscore stuff?
if( remove_underscore ) {
rownames( coef_matrix ) <- gsub( "_.*", "", rownames( coef_matrix ) )
}
## remove stuff before a '$'?
if( remove_dollar ) {
rownames( coef_matrix ) <- gsub( ".*\\$", "", rownames( coef_matrix ) )
}
## swap periods with a space?
if( swap_periods ) {
rownames( coef_matrix ) <- gsub( "\\.", " ", rownames(coef_matrix) )
}
return( coef_matrix )
}
##' Nicely Formatted ANOVA Table
##'
##' Returns a nicely formatted ANOVA table.
##' See \code{\link{kCoef}} for other details.
##' @param fit the model fit to generate an ANOVA table for.
##' @param test the type of test to perform. default is likelihood-ratio test (LRT).
##' @param swap.periods swap periods with spaces?
##' @export
##' @examples
##' x <- rnorm(100)
##' y <- ifelse( x + runif(100) > 1, 1, 0 )
##' myFit <- glm( y ~ x, family="binomial" )
##' kAnova( myFit )
kAnova <- function( fit, test="LRT", swap.periods=TRUE ) {
f <- function(x) {
tmp <- strsplit( x, ":" )
tmp <- lapply( tmp, function(x) { gsub( ".*\\$", "", x ) } )
tmp <- unlist( lapply( tmp, function(x) { paste(x, collapse=":" ) } ) )
return( tmp )
}
tmp <- anova( fit, test="LRT" )
class(tmp) <- "data.frame"
rownames( tmp ) <- f( rownames(tmp) )
rownames( tmp ) <- gsub( "_.*", "", rownames(tmp) )
rownames( tmp )[ rownames(tmp) == "NULL" ] <- "Null Model"
if( swap.periods ) {
rownames( tmp ) <- gsub( "\\.", " ", rownames(tmp) )
}
return( tmp )
}
##' Fivenum with Names
##'
##' A wrapper to \code{stats::fivenum} that also produces variable names.
##' @param x numeric, maybe including \code{NA}s and \code{Inf}s.
##' @param na.rm logical. remove NAs?
##' @seealso \code{\link{fivenum}}
##' @export
##' @return \code{data.frame} version of five number summary
kFivenum <- function(x, na.rm=TRUE) {
tmp <- as.data.frame( matrix( stats::fivenum(x, na.rm=na.rm), ncol=5 ) )
names(tmp) <- c("Min", "1st Qu.", "Median", "3rd Qu.", "Max")
tmp
}
##' Get all Objects in Environment
##'
##' Get all objects within an environment. Useful for inspecting the objects
##' available in a particular environment.
##' @param env an environment.
##' @return a list of the objects contained within that environment.
##' @export
##' @examples
##' myenv <- new.env()
##' assign( "foo", "bar", env=myenv )
##' assign( "baz", "spam", env=myenv )
##' getObjects( myenv )
getObjects <- function( env ) {
stopifnot( typeof( env ) == "environment" )
objs <- lapply( objects(env), function(x) {
get( x, envir=env )
})
names( objs ) <- objects(env)
return(objs)
}
##' Remove NA Entries from a Vector
##'
##' This function removes all \code{NA} entries from a vector.
##'
##' For \code{data.frames}, we use \code{complete.cases} to remove \code{NA}s,
##' and hence remove all rows for which an \code{NA} value in encountered.
##'
##' @param x An (atomic) vector, or a list / data.frame.
##' @export
remove_na <- function(x) {
if( is.data.frame(x) ) {
return( x[complete.cases(x), ] )
} else if( is.list(x) ) {
return( lapply(x, remove_na) )
} else {
return( x[ !is.na(x) ] )
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.