Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Trim trailing whitespace

  • Loading branch information...
commit e2b8eb343cb36ae27a9257742fe333dac68553b7 1 parent bb0ac9c
@hadley authored
View
70 R/cast.r
@@ -1,16 +1,16 @@
#' Cast functions
#' Cast a molten data frame into an array or data frame.
#'
-#' Use \code{acast} or \code{dcast} depending on whether you want
-#' vector/matrix/array output or data frame output. Data frames can have at
+#' Use \code{acast} or \code{dcast} depending on whether you want
+#' vector/matrix/array output or data frame output. Data frames can have at
#' most two dimensions.
#'
-#' The cast formula has the following format:
+#' The cast formula has the following format:
#' \code{x_variable + x_2 ~ y_variable + y_2 ~ z_variable ~ ... }
#' The order of the variables makes a difference. The first varies slowest,
#' and the last fastest. There are a couple of special variables: "..."
-#' represents all other variables not used in the formula and "." represents
-#' no variable, so you can do \code{formula = var1 ~ .}.
+#' represents all other variables not used in the formula and "." represents
+#' no variable, so you can do \code{formula = var1 ~ .}.
#'
#' Alternatively, you can supply a list of quoted expressions, in the form
#' \code{list(.(x_variable, x_2), .(y_variable, y_2), .(z))}. The advantage
@@ -30,7 +30,7 @@
#' @keywords manip
#' @param data molten data frame, see \code{\link{melt}}.
#' @param formula casting formula, see details for specifics.
-#' @param fun.aggregate aggregation function needed if variables do not
+#' @param fun.aggregate aggregation function needed if variables do not
#' identify a single observation for each output cell. Defaults to length
#' (with a message) if needed but not specified.
#' @param ... further arguments are passed to aggregating function
@@ -54,7 +54,7 @@
#' #Air quality example
#' names(airquality) <- tolower(names(airquality))
#' aqm <- melt(airquality, id=c("month", "day"), na.rm=TRUE)
-#'
+#'
#' acast(aqm, day ~ month ~ variable)
#' acast(aqm, month ~ variable, mean)
#' acast(aqm, month ~ variable, mean, margins = TRUE)
@@ -67,27 +67,27 @@
#' #Chick weight example
#' names(ChickWeight) <- tolower(names(ChickWeight))
#' chick_m <- melt(ChickWeight, id=2:4, na.rm=TRUE)
-#'
+#'
#' dcast(chick_m, time ~ variable, mean) # average effect of time
#' dcast(chick_m, diet ~ variable, mean) # average effect of diet
#' acast(chick_m, diet ~ time, mean) # average effect of diet & time
-#'
+#'
#' # How many chicks at each time? - checking for balance
#' acast(chick_m, time ~ diet, length)
#' acast(chick_m, chick ~ time, mean)
#' acast(chick_m, chick ~ time, mean, subset = .(time < 10 & chick < 20))
-#'
+#'
#' acast(chick_m, time ~ diet, length)
-#'
+#'
#' dcast(chick_m, diet + chick ~ time)
#' acast(chick_m, diet + chick ~ time)
#' acast(chick_m, chick ~ time ~ diet)
#' acast(chick_m, diet + chick ~ time, length, margins="diet")
#' acast(chick_m, diet + chick ~ time, length, drop = FALSE)
-#'
+#'
#' #Tips example
#' dcast(melt(tips), sex ~ smoker, mean, subset = .(variable == "total_bill"))
-#'
+#'
#' ff_d <- melt(french_fries, id=1:4, na.rm=TRUE)
#' acast(ff_d, subject ~ time, length)
#' acast(ff_d, subject ~ time, length, fill=0)
@@ -97,53 +97,53 @@
NULL
cast <- function(data, formula, fun.aggregate = NULL, ..., subset = NULL, fill = NULL, drop = TRUE, value.var = guess_value(data)) {
-
+
if (!is.null(subset)) {
include <- data.frame(eval.quoted(subset, data))
data <- data[rowSums(include) == ncol(include), ]
}
-
+
formula <- parse_formula(formula, names(data), value.var)
value <- data[[value.var]]
-
+
# Need to branch here depending on whether or not we have strings or
# expressions - strings should avoid making copies of the data
vars <- lapply(formula, eval.quoted, envir = data, enclos = parent.frame(2))
-
+
# Compute labels and id values
ids <- lapply(vars, id, drop = drop)
labels <- mapply(split_labels, vars, ids, MoreArgs = list(drop = drop),
SIMPLIFY = FALSE, USE.NAMES = FALSE)
overall <- id(rev(ids), drop = FALSE)
-
+
ns <- vapply(ids, attr, 0, "n")
n <- attr(overall, "n")
-
+
# Aggregate duplicates
if (any(duplicated(overall)) || !is.null(fun.aggregate)) {
if (is.null(fun.aggregate)) {
message("Aggregation function missing: defaulting to length")
fun.aggregate <- length
}
-
- ordered <- vaggregate(.value = value, .group = overall,
+
+ ordered <- vaggregate(.value = value, .group = overall,
.fun = fun.aggregate, ..., .default = fill, .n = n)
overall <- seq_len(n)
-
+
} else {
# Add in missing values, if necessary
if (length(overall) < n) {
overall <- match(seq_len(n), overall, nomatch = NA)
} else {
overall <- order(overall)
- }
-
+ }
+
ordered <- value[overall]
if (!is.null(fill)) {
ordered[is.na(ordered)] <- fill
}
}
-
+
list(
data = structure(ordered, dim = ns),
labels = labels
@@ -156,18 +156,18 @@ dcast <- function(data, formula, fun.aggregate = NULL, ..., margins = NULL, subs
if (length(formula) > 2) {
stop("Dataframes have at most two output dimensions")
}
-
+
if (!is.null(margins)) {
data <- add_margins(data, lapply(formula, names), margins)
}
-
- res <- cast(data, formula, fun.aggregate, ...,
- subset = subset, fill = fill, drop = drop,
+
+ res <- cast(data, formula, fun.aggregate, ...,
+ subset = subset, fill = fill, drop = drop,
value.var = value.var)
data <- as.data.frame.matrix(res$data, stringsAsFactors = FALSE)
names(data) <- array_names(res$labels[[2]])
-
+
stopifnot(nrow(res$labels[[1]]) == nrow(data))
cbind(res$labels[[1]], data)
}
@@ -175,14 +175,14 @@ dcast <- function(data, formula, fun.aggregate = NULL, ..., margins = NULL, subs
acast <- function(data, formula, fun.aggregate = NULL, ..., margins = NULL, subset = NULL, fill=NULL, drop = TRUE, value.var = guess_value(data)) {
formula <- parse_formula(formula, names(data), value.var)
-
+
if (!is.null(margins)) {
- data <- add_margins(data, lapply(formula, names), margins)
+ data <- add_margins(data, lapply(formula, names), margins)
}
-
- res <- cast(data, formula, fun.aggregate, ...,
+
+ res <- cast(data, formula, fun.aggregate, ...,
subset = subset, fill = fill, drop = drop, value.var = value.var)
-
+
dimnames(res$data) <- lapply(res$labels, array_names)
res$data
}
View
44 R/data.r
@@ -3,21 +3,21 @@
#' This data was collected from a sensory experiment conducted at Iowa State
#' University in 2004. The investigators were interested in the effect of
#' using three different fryer oils had on the taste of the fries.
-#'
+#'
#' Variables:
-#'
+#'
#' \itemize{
#' \item time in weeks from start of study.
-#' \item treatment (type of oil),
-#' \item subject,
-#' \item replicate,
-#' \item potato-y flavour,
-#' \item buttery flavour,
+#' \item treatment (type of oil),
+#' \item subject,
+#' \item replicate,
+#' \item potato-y flavour,
+#' \item buttery flavour,
#' \item grassy flavour,
#' \item rancid flavour,
-#' \item painty flavour
+#' \item painty flavour
#' }
-#'
+#'
#' @docType data
#' @name french_fries
#' @usage data(french_fries)
@@ -39,22 +39,22 @@ NULL
#' Tipping data
-#'
-#'
-#' One waiter recorded information about each tip he received over a
+#'
+#'
+#' One waiter recorded information about each tip he received over a
#' period of a few months working in one restaurant. He collected several
-#' variables:
-#'
+#' variables:
+#'
#' \itemize{
-#' \item tip in dollars,
-#' \item bill in dollars,
-#' \item sex of the bill payer,
-#' \item whether there were smokers in the party,
-#' \item day of the week,
-#' \item time of day,
-#' \item size of the party.
+#' \item tip in dollars,
+#' \item bill in dollars,
+#' \item sex of the bill payer,
+#' \item whether there were smokers in the party,
+#' \item day of the week,
+#' \item time of day,
+#' \item size of the party.
#' }
-#'
+#'
#' In all he recorded 244 tips. The data was reported in a collection of
#' case studies for business statistics (Bryant & Smith 1995).
#'
View
18 R/formula.r
@@ -1,12 +1,12 @@
#' Parse casting formulae.
-#'
+#'
#' There are a two ways to specify a casting formula: either as a string, or
#' a list of quoted variables. This function converts the former to the
-#' latter.
-#'
+#' latter.
+#'
#' Casting formulas separate dimensions with \code{~} and variables within
-#' a dimension with \code{+} or \code{*}. \code{.} can be used as a
-#' placeholder, and \code{...} represents all other variables not otherwise
+#' a dimension with \code{+} or \code{*}. \code{.} can be used as a
+#' placeholder, and \code{...} represents all other variables not otherwise
#' used.
#'
#' @param formula formula to parse
@@ -21,11 +21,11 @@ parse_formula <- function(formula = "... ~ variable", varnames, value.var = "va
replace.remainder <- function(x) {
if (any(x == "...")) c(x[x != "..."], remainder) else x
}
-
+
if (is.formula(formula)) {
formula <- str_c(deparse(formula, 500), collapse = "")
}
-
+
if (is.character(formula)) {
dims <- str_split(formula, fixed("~"))[[1]]
formula <- lapply(str_split(dims, "[+*]"), str_trim)
@@ -38,10 +38,10 @@ parse_formula <- function(formula = "... ~ variable", varnames, value.var = "va
formula <- lapply(formula, replace.remainder)
}
}
-
+
if (!is.list(formula)) {
stop("Don't know how to parse", formula, call. = FALSE)
}
-
+
lapply(formula, as.quoted)
}
View
8 R/helper-colsplit.r
@@ -1,9 +1,9 @@
#' Split a vector into multiple columns
-#'
-#' Useful for splitting variable names that a combination of multiple
+#'
+#' Useful for splitting variable names that a combination of multiple
#' variables. Uses \code{\link{type.convert}} to convert each column to
#' correct type, but will not convert character to factor.
-#'
+#'
#' @param string character vector or factor to split up
#' @param pattern regular expression to split on
#' @param names names for output columns
@@ -20,7 +20,7 @@ colsplit <- function(string, pattern, names) {
df <- data.frame(alply(vars, 2, type.convert, as.is = TRUE),
stringsAsFactors = FALSE)
names(df) <- names
-
+
df
}
View
8 R/helper-guess-value.r
@@ -1,19 +1,19 @@
#' Guess name of value column
-#'
+#'
#' Strategy:
#' \enumerate{
#' \item Is value or (all) column present? If so, use that
#' \item Otherwise, guess that last column is the value column
#' }
-#'
+#'
#' @param df data frame to guess value column from
#' @keywords internal
guess_value <- function(df) {
if ("value" %in% names(df)) return("value")
if ("(all)" %in% names(df)) return("(all)")
-
+
last <- names(df)[ncol(df)]
message("Using ", last, " as value column: use value.var to override.")
-
+
last
}
View
22 R/helper-margins.r
@@ -10,9 +10,9 @@
#' \code{TRUE} will compute all possible margins.
#' @keywords manip internal
#' @return list of margining combinations, or \code{NULL} if none. These are
-#' the combinations of variables that should have their values set to
+#' the combinations of variables that should have their values set to
#' \code{(all)}
-margins <- function(vars, margins = NULL) {
+margins <- function(vars, margins = NULL) {
if (is.null(margins) || identical(margins, FALSE)) return(NULL)
all_vars <- unlist(vars)
@@ -20,11 +20,11 @@ margins <- function(vars, margins = NULL) {
margins <- all_vars
}
- # Start by grouping margins by dimension
+ # Start by grouping margins by dimension
dims <- lapply(vars, intersect, margins)
-
+
# Next, ensure high-level margins include lower-levels
- dims <- mapply(function(vars, margin) {
+ dims <- mapply(function(vars, margin) {
lapply(margin, downto, vars)
}, vars, dims, SIMPLIFY = FALSE, USE.NAMES = FALSE)
@@ -33,11 +33,11 @@ margins <- function(vars, margins = NULL) {
indices <- expand.grid(lapply(dims, seq_0), KEEP.OUT.ATTRS = FALSE)
# indices <- indices[rowSums(indices) > 0, ]
- lapply(seq_len(nrow(indices)), function(i){
+ lapply(seq_len(nrow(indices)), function(i){
unlist(mapply("[", dims, indices[i, ], SIMPLIFY = FALSE))
})
}
-
+
upto <- function(a, b) {
b[seq_len(match(a, b, nomatch = 0))]
}
@@ -58,10 +58,10 @@ downto <- function(a, b) {
#' @export
add_margins <- function(df, vars, margins = TRUE) {
margin_vars <- margins(vars, margins)
-
+
# Return data frame if no margining necessary
if (length(margin_vars) == 0) return(df)
-
+
# Prepare data frame for addition of margins
addAll <- function(x) {
x <- addNA(x, TRUE)
@@ -71,13 +71,13 @@ add_margins <- function(df, vars, margins = TRUE) {
df[vars] <- lapply(df[vars], addAll)
rownames(df) <- NULL
-
+
# Loop through all combinations of margin variables, setting
# those variables to (all)
margin_dfs <- llply(margin_vars, function(vars) {
df[vars] <- rep(list(factor("(all)")), length(vars))
df
})
-
+
rbind.fill(margin_dfs)
}
View
52 R/melt.r
@@ -11,7 +11,7 @@
#'
#' @keywords manip
#' @param data Data set to melt
-#' @param na.rm Should NA values be removed from the data set? This will
+#' @param na.rm Should NA values be removed from the data set? This will
#' convert explicit missings to implicit missings.
#' @param ... further arguments passed to or from other methods.
#' @param value.name name of variable used to store values
@@ -24,7 +24,7 @@ melt <- function(data, ..., na.rm = FALSE, value.name = "value") {
#' For vectors, makes a column of a data frame
#'
#' @param data vector to melt
-#' @param na.rm Should NA values be removed from the data set? This will
+#' @param na.rm Should NA values be removed from the data set? This will
#' convert explicit missings to implicit missings.
#' @param ... further arguments passed to or from other methods.
#' @param value.name name of variable used to store values
@@ -37,7 +37,7 @@ melt.default <- function(data, ..., na.rm = FALSE, value.name = "value") {
}
#' Melt a list by recursively melting each component.
-#'
+#'
#' @keywords manip
#' @S3method melt list
#' @method melt list
@@ -58,18 +58,18 @@ melt.default <- function(data, ..., na.rm = FALSE, value.name = "value") {
melt.list <- function(data, ..., level = 1) {
parts <- lapply(data, melt, level = level + 1, ...)
result <- rbind.fill(parts)
-
+
# Add labels
names <- names(data) %||% seq_along(data)
lengths <- vapply(parts, nrow, integer(1))
labels <- rep(names, lengths)
-
+
label_var <- attr(data, "varname") %||% paste("L", level, sep = "")
result[[label_var]] <- labels
-
+
# result <- cbind(labels, result)
# result[, c(setdiff(names(result), "value"), "value")]
-
+
result
}
@@ -84,13 +84,13 @@ melt.list <- function(data, ..., level = 1) {
#'
#' @param data data frame to melt
#' @param id.vars vector of id variables. Can be integer (variable position)
-#' or string (variable name)If blank, will use all non-measured variables.
+#' or string (variable name)If blank, will use all non-measured variables.
#' @param measure.vars vector of measured variables. Can be integer (variable
#' position) or string (variable name)If blank, will use all non id.vars
-# variables.
+# variables.
#' @param variable.name name of variable used to store measured variable names
#' @param value.name name of variable used to store values
-#' @param na.rm Should NA values be removed from the data set? This will
+#' @param na.rm Should NA values be removed from the data set? This will
#' convert explicit missings to implicit missings.
#' @param ... further arguments passed to or from other methods.
#' @keywords manip
@@ -108,15 +108,15 @@ melt.data.frame <- function(data, id.vars, measure.vars, variable.name = "variab
if (length(var$measure) == 0) {
return(ids)
}
-
+
# Turn factors to characters
factors <- vapply(data, is.factor, logical(1))
data[factors] <- lapply(data[factors], as.character)
-
+
value <- unlist(unname(data[var$measure]))
- variable <- factor(rep(var$measure, each = nrow(data)),
+ variable <- factor(rep(var$measure, each = nrow(data)),
levels = var$measure)
-
+
df <- data.frame(ids, variable, value, stringsAsFactors = FALSE)
names(df) <- c(names(ids), variable.name, value.name)
@@ -130,12 +130,12 @@ melt.data.frame <- function(data, id.vars, measure.vars, variable.name = "variab
#' Melt an array.
#'
#' This code is conceptually similar to \code{\link{as.data.frame.table}}
-#'
+#'
#' @param data array to melt
#' @param varnames variable names to use in molten data.frame
#' @param ... further arguments passed to or from other methods.
#' @param value.name name of variable used to store values
-#' @param na.rm Should NA values be removed from the data set? This will
+#' @param na.rm Should NA values be removed from the data set? This will
#' convert explicit missings to implicit missings.
#' @keywords manip
#' @S3method melt table
@@ -159,14 +159,14 @@ melt.array <- function(data, varnames = names(dimnames(data)), ..., na.rm = FALS
names(dn) <- varnames
labels <- expand.grid(lapply(dn, var.convert), KEEP.OUT.ATTRS = FALSE,
stringsAsFactors = FALSE)
-
+
if (na.rm) {
missing <- is.na(data)
data <- data[!missing]
labels <- labels[!missing, ]
}
- value_df <- setNames(data.frame(as.vector(data)), value.name)
+ value_df <- setNames(data.frame(as.vector(data)), value.name)
cbind(labels, value_df)
}
@@ -175,7 +175,7 @@ melt.matrix <- melt.array
#' Check that input variables to melt are appropriate.
#'
-#' If id.vars or measure.vars are missing, \code{melt_check} will do its
+#' If id.vars or measure.vars are missing, \code{melt_check} will do its
#' best to impute them. If you only supply one of id.vars and measure.vars,
#' melt will assume the remainder of the variables in the data set belong to
#' the other. If you supply neither, melt will assume discrete variables are
@@ -187,7 +187,7 @@ melt.matrix <- melt.array
#' @return a list giving id and measure variables names.
melt_check <- function(data, id.vars, measure.vars) {
varnames <- names(data)
-
+
# Convert positions to names
if (!missing(id.vars) && is.numeric(id.vars)) {
id.vars <- varnames[id.vars]
@@ -195,7 +195,7 @@ melt_check <- function(data, id.vars, measure.vars) {
if (!missing(measure.vars) && is.numeric(measure.vars)) {
measure.vars <- varnames[measure.vars]
}
-
+
# Check that variables exist
if (!missing(id.vars)) {
unknown <- setdiff(id.vars, varnames)
@@ -203,15 +203,15 @@ melt_check <- function(data, id.vars, measure.vars) {
vars <- paste(unknown, collapse=", ")
stop("id variables not found in data: ", vars, call. = FALSE)
}
- }
-
+ }
+
if (!missing(measure.vars)) {
unknown <- setdiff(measure.vars, varnames)
if (length(unknown) > 0) {
vars <- paste(unknown, collapse=", ")
stop("measure variables not found in data: ", vars, call. = FALSE)
}
- }
+ }
# Fill in missing pieces
if (missing(id.vars) && missing(measure.vars)) {
@@ -224,6 +224,6 @@ melt_check <- function(data, id.vars, measure.vars) {
} else if (missing(measure.vars)) {
measure.vars <- setdiff(varnames, id.vars)
}
-
- list(id = id.vars, measure = measure.vars)
+
+ list(id = id.vars, measure = measure.vars)
}
View
6 R/recast.r
@@ -1,7 +1,7 @@
#' Recast: melt and cast in a single step
-#'
+#'
#' This conveniently wraps melting and casting a data frame into
-#' a single step.
+#' a single step.
#'
#' @param data data set to melt
#' @param formula casting formula, see \link{cast} for specifics
@@ -19,7 +19,7 @@ recast <- function(data, formula, ..., id.var, measure.var) {
if (any(c("id.vars", "measure.vars") %in% names(match.call()))) {
stop("Use var, not vars\n")
}
-
+
molten <- melt(data, id.var, measure.var)
cast(molten, formula, ...)
}
View
12 bench/bench.r
@@ -1,18 +1,18 @@
# Data from http://www4.uwm.edu/FLL/linguistics/dialect/maps.html
-bd <- read.csv("dialects.csv.bz2", stringsAsFactors = FALSE,
+bd <- read.csv("dialects.csv.bz2", stringsAsFactors = FALSE,
strip.white = TRUE)
system.time(bdm <- melt(bd, id = 1:4))
-# Reshape1:
-# user system elapsed
-# 28.695 20.052 49.802
+# Reshape1:
+# user system elapsed
+# 28.695 20.052 49.802
names(bdm) <- c("subject", "city", "state", "zip", "question", "response")
bdm <- subset(bdm, response != 0)
system.time(dcast(bdm, ... ~ question))
-# Reshape1:
+# Reshape1:
# gave up after 40 minutes
-dcast(bdm, question ~ state)
+dcast(bdm, question ~ state)
View
BIN  bench/dialects.csv.bz2
Binary file not shown
View
62 inst/tests/test-cast.r
@@ -9,12 +9,12 @@ s3m <- melt(s3)
colnames(s3m) <- c("X1", "X2", "X3", "value")
test_that("reshaping matches t and aperm", {
- # 2d
+ # 2d
expect_equivalent(s2, acast(s2m, X1 ~ X2))
expect_equivalent(t(s2), acast(s2m, X2 ~ X1))
expect_equivalent(as.vector(s2), as.vector(acast(s2m, X2 + X1 ~ .)))
- # 3d
+ # 3d
expect_equivalent(s3, acast(s3m, X1 ~ X2 ~ X3))
expect_equivalent(as.vector(s3), as.vector(acast(s3m, X3 + X2 + X1 ~ .)))
expect_equivalent(aperm(s3, c(1,3,2)), acast(s3m, X1 ~ X3 ~ X2))
@@ -29,13 +29,13 @@ test_that("aggregation matches apply", {
# 2d -> 1d
expect_equivalent(colMeans(s2), as.vector(acast(s2m, X2 ~ ., mean)))
expect_equivalent(rowMeans(s2), as.vector(acast(s2m, X1 ~ ., mean)))
-
- # 3d -> 1d
+
+ # 3d -> 1d
expect_equivalent(apply(s3, 1, mean), as.vector(acast(s3m, X1 ~ ., mean)))
expect_equivalent(apply(s3, 1, mean), as.vector(acast(s3m, . ~ X1, mean)))
expect_equivalent(apply(s3, 2, mean), as.vector(acast(s3m, X2 ~ ., mean)))
expect_equivalent(apply(s3, 3, mean), as.vector(acast(s3m, X3 ~ ., mean)))
-
+
# 3d -> 2d
expect_equivalent(apply(s3, c(1,2), mean), acast(s3m, X1 ~ X2, mean))
expect_equivalent(apply(s3, c(1,3), mean), acast(s3m, X1 ~ X3, mean))
@@ -43,12 +43,12 @@ test_that("aggregation matches apply", {
})
names(ChickWeight) <- tolower(names(ChickWeight))
-chick_m <- melt(ChickWeight, id=2:4, na.rm=TRUE)
+chick_m <- melt(ChickWeight, id=2:4, na.rm=TRUE)
test_that("aggregation matches table", {
tab <- unclass(with(chick_m, table(chick, time)))
cst <- acast(chick_m, chick ~ time, length)
-
+
expect_that(tab, is_equivalent_to(cst))
})
@@ -56,65 +56,65 @@ test_that("grand margins are computed correctly", {
col <- acast(s2m, X1 ~ X2, mean, margins = "X1")[4, ]
row <- acast(s2m, X1 ~ X2, mean, margins = "X2")[, 5]
grand <- acast(s2m, X1 ~ X2, mean, margins = TRUE)[4, 5]
-
+
expect_equivalent(col, colMeans(s2))
expect_equivalent(row, rowMeans(s2))
expect_equivalent(grand, mean(s2))
})
-#
+#
test_that("internal margins are computed correctly", {
cast <- dcast(chick_m, diet + chick ~ time, length, margins="diet")
marg <- subset(cast, diet == "(all)")[-(1:2)]
- expect_that(as.vector(as.matrix(marg)),
+ expect_that(as.vector(as.matrix(marg)),
equals(as.vector(acast(chick_m, time ~ ., length))))
joint <- subset(cast, diet != "(all)")
- expect_that(joint,
+ expect_that(joint,
is_equivalent_to(dcast(chick_m, diet + chick ~ time, length)))
})
test_that("missing combinations filled correctly", {
s2am <- subset(s2m, !(X1 == 1 & X2 == 1))
-
+
expect_equal(acast(s2am, X1 ~ X2)[1, 1], NA_integer_)
expect_equal(acast(s2am, X1 ~ X2, length)[1, 1], 0)
expect_equal(acast(s2am, X1 ~ X2, length, fill = 1)[1, 1], 1)
-
+
})
test_that("drop = FALSE generates all combinations", {
df <- data.frame(x = c("a", "b"), y = c("a", "b"), value = 1:2)
-
+
expect_that(as.vector(acast(df, x + y ~ ., drop = FALSE)),
is_equivalent_to(as.vector(acast(df, x ~ y))))
-
+
})
test_that("aggregated values computed correctly", {
ffm <- melt(french_fries, id = 1:4)
-
+
count_c <- function(vars) as.table(acast(ffm, as.list(vars), length))
count_t <- function(vars) table(ffm[vars], useNA = "ifany")
-
+
combs <- matrix(names(ffm)[1:5][t(combn(5, 2))], ncol = 2)
a_ply(combs, 1, function(vars) {
- expect_that(count_c(vars), is_equivalent_to(count_t(vars)),
+ expect_that(count_c(vars), is_equivalent_to(count_t(vars)),
label = paste(vars, collapse = ", "))
})
-
+
})
test_that("value.var overrides value col", {
df <- data.frame(
- id1 = rep(letters[1:2],2),
+ id1 = rep(letters[1:2],2),
id2 = rep(LETTERS [1:2],each=2), var1=1:4)
df.m <- melt(df)
df.m$value2 <- df.m$value * 2
- expect_that(acast(df.m, id2 + id1 ~ ., value.var="value")[, 1],
+ expect_that(acast(df.m, id2 + id1 ~ ., value.var="value")[, 1],
equals(1:4, check.attributes = FALSE))
- expect_that(acast(df.m, id2 + id1 ~ ., value.var="value2")[, 1],
+ expect_that(acast(df.m, id2 + id1 ~ ., value.var="value2")[, 1],
equals(2 * 1:4, check.attributes = FALSE))
})
@@ -124,14 +124,14 @@ test_that("labels are correct when missing combinations dropped/kept", {
c1 <- dcast(mx[1:2, ], fac1 + fac2 ~ variable, length, drop = F)
expect_that(nrow(c1), equals(16))
-
+
c2 <- dcast(droplevels(mx[1:2, ]), fac1 + fac2 ~ variable, length, drop = F)
expect_that(nrow(c2), equals(4))
-
+
c3 <- dcast(mx[1:2, ], fac1 + fac2 ~ variable, length, drop = T)
expect_that(nrow(c3), equals(2))
-
+
})
test_that("factor value columns are handled", {
@@ -142,7 +142,7 @@ test_that("factor value columns are handled", {
expect_that(nrow(c1), equals(4))
expect_that(ncol(c1), equals(3))
expect_is(c1$x, "character")
-
+
c2 <- dcast(mx, fac1 ~ fac2 + variable)
expect_that(nrow(c2), equals(4))
expect_that(ncol(c2), equals(5))
@@ -155,12 +155,12 @@ test_that("factor value columns are handled", {
expect_that(nrow(c3), equals(4))
expect_that(ncol(c3), equals(1))
expect_true(is.character(c3))
-
+
c4 <- acast(mx, fac1 ~ fac2 + variable)
expect_that(nrow(c4), equals(4))
expect_that(ncol(c4), equals(4))
expect_true(is.character(c4))
-
+
})
test_that("dcast evaluated in correct argument", {
@@ -170,8 +170,8 @@ test_that("dcast evaluated in correct argument", {
g <- c('b', 'a')
dcast(df, y ~ ordered(x, levels = g))
})
-
+
res <- eval(expr, envir = new.env())
expect_equal(names(res), c("y", "b", "a"))
-
-})
+
+})
View
6 inst/tests/test-margins.r
@@ -1,7 +1,7 @@
context("Margins")
vars <- list(c("a", "b", "c"), c("d", "e", "f"))
-test_that("margins expanded", {
+test_that("margins expanded", {
expect_that(margins(vars, "c")[[2]], equals(c("c")))
expect_that(margins(vars, "b")[[2]], equals(c("b", "c")))
expect_that(margins(vars, "a")[[2]], equals(c("a", "b", "c")))
@@ -12,9 +12,9 @@ test_that("margins expanded", {
})
test_that("margins intersect", {
- expect_that(margins(vars, c("c", "f"))[-1],
+ expect_that(margins(vars, c("c", "f"))[-1],
equals(list("c", "f", c("c", "f"))))
-
+
})
test_that("(all) comes after NA", {
View
20 inst/tests/test-melt.r
@@ -12,14 +12,14 @@ test_that("Missing values removed when na.rm = TRUE", {
l1 <- list(v)
expect_equal(melt(l1)$value, v)
expect_equal(melt(l1, na.rm = TRUE)$value, 1:3)
-
+
l2 <- as.list(v)
expect_equal(melt(l2)$value, v)
expect_equal(melt(l2, na.rm = TRUE)$value, 1:3)
-
+
df <- data.frame(x = v)
expect_equal(melt(df)$value, v)
- expect_equal(melt(df, na.rm = TRUE)$value, 1:3)
+ expect_equal(melt(df, na.rm = TRUE)$value, 1:3)
})
test_that("value col name set by value.name", {
@@ -31,7 +31,7 @@ test_that("value col name set by value.name", {
l1 <- list(v)
expect_equal(names(melt(l1, value.name = "v"))[1], "v")
-
+
df <- data.frame(x = v)
expect_equal(names(melt(df, value.name = "v"))[2], "v")
})
@@ -39,17 +39,17 @@ test_that("value col name set by value.name", {
test_that("lists can have zero element components", {
l <- list(a = 1:10, b = integer(0))
m <- melt(l)
-
+
expect_equal(nrow(m), 10)
})
test_that("factors coerced to characters, not integers", {
df <- data.frame(
- id = 1:3,
- v1 = 1:3,
+ id = 1:3,
+ v1 = 1:3,
v2 = factor(letters[1:3]))
dfm <- melt(df, 1)
-
+
expect_equal(dfm$value, c(1:3, letters[1:3]))
-
-})
+
+})
View
2  tests/test-all.R
@@ -1,4 +1,4 @@
library(testthat)
library(reshape2)
-test_package("reshape2")
+test_package("reshape2")
Please sign in to comment.
Something went wrong with that request. Please try again.