[med-svn] [SCM] r-cran-reshape2 branch, upstream, updated. upstream/1.2.1-1-gceefa83
Charles Plessy
plessy at debian.org
Sat Apr 20 02:44:36 UTC 2013
The following commit has been merged in the upstream branch:
commit ceefa837550085edc5fdc18397c7dca7eff2e04d
Author: Charles Plessy <plessy at debian.org>
Date: Sat Apr 20 11:43:12 2013 +0900
Imported Upstream version 1.2.2
diff --git a/DESCRIPTION b/DESCRIPTION
index 18a9959..5a77905 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
Package: reshape2
Type: Package
Title: Flexibly reshape data: a reboot of the reshape package.
-Version: 1.2.1
+Version: 1.2.2
Author: Hadley Wickham <hadley at rice.edu>
Maintainer: Hadley Wickham <hadley at rice.edu>
Description: Reshape lets you flexibly restructure and aggregate data
@@ -14,6 +14,6 @@ LazyData: true
Collate: 'cast.r' 'data.r' 'formula.r' 'helper-colsplit.r'
'helper-guess-value.r' 'helper-margins.r' 'melt.r' 'recast.r'
'utils.r'
-Packaged: 2012-01-02 17:25:06 UTC; hadley
+Packaged: 2012-12-04 19:05:50 UTC; hadley
Repository: CRAN
-Date/Publication: 2012-01-10 14:05:59
+Date/Publication: 2012-12-04 23:10:53
diff --git a/MD5 b/MD5
index a9442d8..ae7cf4d 100644
--- a/MD5
+++ b/MD5
@@ -1,25 +1,23 @@
-f4b198e6181e70a54963d368d8838ee6 *DESCRIPTION
-9554fb71211613d596de6e5a629b12e7 *NAMESPACE
-5bb386e3d0066798861f80778eb096ce *NEWS
-41993ee0b081a15320ad560228c0fb9a *R/cast.r
-1dbb546df9995fe35c4ff04bcaf7e94f *R/data.r
-10525bbfc91bcce6bbac5fe92eb090c3 *R/formula.r
-23e74dbdab6b2865457dfedc2d533417 *R/helper-colsplit.r
-2c4601ded73fa842fa7b5be7694dc927 *R/helper-guess-value.r
-ee909d122a4819cdc4f77f25e16ce0c1 *R/helper-margins.r
-071800f1619fe17e4f5a4f06ba9050b9 *R/melt.r
-bb10c678cc69ca4d25a13f026ffe65ec *R/recast.r
+6259d21bc9b5e65334b961ac79f6a8af *DESCRIPTION
+2d170d25c55bab58f33ea60fdbb8afe5 *NAMESPACE
+96cb5b94a33b800bdbc9ed1c659d2466 *NEWS
+3b8a9f6833d4944a0b4330b1063a4f07 *R/cast.r
+827ca227c89be29638317fd0cf09810d *R/data.r
+64787f81028fc99b399324ea1e20d388 *R/formula.r
+be60b82da1500a97b295ec2eedcbcecd *R/helper-colsplit.r
+b88bd2b7d2e7ee40cefcf33e6b5145ab *R/helper-guess-value.r
+6d720bda805d2903c1cde371a58611ba *R/helper-margins.r
+5b4dddf778fd06aad455818ef1c97f72 *R/melt.r
+3f85fc6e083cff5060dabc1571f0a9e5 *R/recast.r
72e84fd8dbe786407e625134b251238b *R/utils.r
a29aec5b95e38f7eab2ab9c2141abd5c *README.md
-c01fb8ec071f201db31bbad5573b0129 *bench/bench.r
-ed300c9f7f3d0192b0642d847a45e23e *bench/dialects.csv.bz2
11d6f343f97ca34edc7cb5ad4a174d05 *data/french_fries.rda
931bb9da3bce71ebcb25ba53c5dcd1e5 *data/smiths.rda
6a3f0a74f813cd68547e665f42b8a3cb *data/tips.rda
dd664ad85751a470cf0b7414a1c4c3ec *inst/CITATION
-1333b1674ac6ab1e720a795646e2f43e *inst/tests/test-cast.r
-5e8b0cb7c41d8d4f8042c681ea8b283e *inst/tests/test-margins.r
-0e1abbd59d0dbcc0c0dd27e6727539cb *inst/tests/test-melt.r
+dcc9587c4ec1230deb72e502b86fc62d *inst/tests/test-cast.r
+c450402fc64e0d1a35d777917ff93ad0 *inst/tests/test-margins.r
+a60729e4f0dfd33aa100363287947386 *inst/tests/test-melt.r
a7216e25cec082f3395da6863de83ccd *man/add_margins.Rd
edde7408a7544589fc74e3552127ace8 *man/cast.Rd
8214d531229d90c6de5b6bcac3c11015 *man/colsplit.Rd
@@ -36,4 +34,4 @@ fa5c27a9488bc1a21b58a95752f38e07 *man/parse_formula.Rd
c4573be1672fa0361040a596567b38ea *man/recast.Rd
220f9b410ae11557d8f7e1d8f5424903 *man/smiths.Rd
3995a24a8f5afd24dd6077c8f34e00c4 *man/tips.Rd
-d4732ba4278ac673f4140aafc0816b0f *tests/test-all.R
+e269149e26f67e8befc86829c303bd49 *tests/test-all.R
diff --git a/NAMESPACE b/NAMESPACE
index 87187cd..7ded718 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,3 +1,9 @@
+S3method(melt,array)
+S3method(melt,data.frame)
+S3method(melt,default)
+S3method(melt,list)
+S3method(melt,matrix)
+S3method(melt,table)
export(acast)
export(add_margins)
export(colsplit)
@@ -6,8 +12,3 @@ export(melt)
export(recast)
import(plyr)
import(stringr)
-S3method(melt,array)
-S3method(melt,data.frame)
-S3method(melt,default)
-S3method(melt,list)
-S3method(melt,matrix)
diff --git a/NEWS b/NEWS
index 068b1c4..58bcde1 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,13 @@
+Version 1.2.2
+-------------
+
+* Fix incompatibility with plyr 1.8
+
+* Fix evaluation bug revealed by knitr. (Fixes #18)
+
+* Fixed a bug in `melt` where it didn't automatically get variable names
+ when used with tables. (Thanks to Winston Chang)
+
Version 1.2.1
-------------
diff --git a/R/cast.r b/R/cast.r
index 88c7f19..5854f9f 100644
--- a/R/cast.r
+++ b/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,55 @@
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())
-
+ 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")
+ # Replace zeros (empty inputs) with 1 for dimensions of output
+ ns[ns == 0] <- 1
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 +158,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 +177,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
}
diff --git a/R/data.r b/R/data.r
index 8d89935..59aecb2 100644
--- a/R/data.r
+++ b/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).
#'
diff --git a/R/formula.r b/R/formula.r
index adef081..ab4c90d 100644
--- a/R/formula.r
+++ b/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)
}
diff --git a/R/helper-colsplit.r b/R/helper-colsplit.r
index bafde3a..36de034 100644
--- a/R/helper-colsplit.r
+++ b/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
}
diff --git a/R/helper-guess-value.r b/R/helper-guess-value.r
index 4c03bf6..ec47203 100644
--- a/R/helper-guess-value.r
+++ b/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
}
diff --git a/R/helper-margins.r b/R/helper-margins.r
index e879d1d..56e65d4 100644
--- a/R/helper-margins.r
+++ b/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)
}
diff --git a/R/melt.r b/R/melt.r
index 1b18dbd..4a6c411 100644
--- a/R/melt.r
+++ b/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,14 +130,15 @@ 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
#' @S3method melt matrix
#' @S3method melt array
#' @method melt array
@@ -158,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)
}
@@ -174,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
@@ -186,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]
@@ -194,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)
@@ -202,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)) {
@@ -223,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)
}
diff --git a/R/recast.r b/R/recast.r
index efe1117..5870e8a 100644
--- a/R/recast.r
+++ b/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, ...)
}
diff --git a/bench/bench.r b/bench/bench.r
deleted file mode 100644
index 2073631..0000000
--- a/bench/bench.r
+++ /dev/null
@@ -1,18 +0,0 @@
-# Data from http://www4.uwm.edu/FLL/linguistics/dialect/maps.html
-
-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
-
-names(bdm) <- c("subject", "city", "state", "zip", "question", "response")
-bdm <- subset(bdm, response != 0)
-
-system.time(dcast(bdm, ... ~ question))
-# Reshape1:
-# gave up after 40 minutes
-
-dcast(bdm, question ~ state)
\ No newline at end of file
diff --git a/bench/dialects.csv.bz2 b/bench/dialects.csv.bz2
deleted file mode 100644
index 6e7bb86..0000000
Binary files a/bench/dialects.csv.bz2 and /dev/null differ
diff --git a/inst/tests/test-cast.r b/inst/tests/test-cast.r
index e680ebe..f0acae6 100644
--- a/inst/tests/test-cast.r
+++ b/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,10 +155,23 @@ 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", {
+ g <- c("a", "b")
+ expr <- quote({
+ df <- data.frame(x = letters[1:2], y = letters[1:3], z = rnorm(6))
+ 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"))
+
})
diff --git a/inst/tests/test-margins.r b/inst/tests/test-margins.r
index ad20704..a9483c3 100644
--- a/inst/tests/test-margins.r
+++ b/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", {
diff --git a/inst/tests/test-melt.r b/inst/tests/test-melt.r
index c988ab2..ad7c62b 100644
--- a/inst/tests/test-melt.r
+++ b/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]))
-
-})
\ No newline at end of file
+
+})
diff --git a/tests/test-all.R b/tests/test-all.R
index bd8057a..69b75ff 100644
--- a/tests/test-all.R
+++ b/tests/test-all.R
@@ -1,4 +1,4 @@
library(testthat)
library(reshape2)
-test_package("reshape2")
\ No newline at end of file
+test_package("reshape2")
--
Packaging for R/CRAN/reshape2 in Debian
More information about the debian-med-commit
mailing list