[Sciviews-commits] r307 - in pkg/SciViews: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Sep 11 12:48:20 CEST 2010
Author: phgrosjean
Date: 2010-09-11 12:48:19 +0200 (Sat, 11 Sep 2010)
New Revision: 307
Modified:
pkg/SciViews/DESCRIPTION
pkg/SciViews/NAMESPACE
pkg/SciViews/NEWS
pkg/SciViews/R/SciViews-internal.R
pkg/SciViews/R/colors.R
pkg/SciViews/R/correlation.R
pkg/SciViews/R/ln.R
pkg/SciViews/R/panels.R
pkg/SciViews/R/panels.diag.R
pkg/SciViews/R/pcomp.R
pkg/SciViews/R/vectorplot.R
pkg/SciViews/TODO
pkg/SciViews/man/SciViews-package.Rd
pkg/SciViews/man/colors.Rd
pkg/SciViews/man/correlation.Rd
pkg/SciViews/man/ln.Rd
pkg/SciViews/man/panels.Rd
pkg/SciViews/man/panels.diag.Rd
pkg/SciViews/man/pcomp.Rd
pkg/SciViews/man/snippets.Rd
pkg/SciViews/man/vectorplot.Rd
Log:
Added lb() as a synonym of log2() + stylistic changes in code and help pages
Modified: pkg/SciViews/DESCRIPTION
===================================================================
--- pkg/SciViews/DESCRIPTION 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/DESCRIPTION 2010-09-11 10:48:19 UTC (rev 307)
@@ -6,7 +6,7 @@
Enhances: base, stats
Description: Functions to install SciViews additions to R, and more (various) tools
Version: 0.9-1
-Date: 2010-02-15
+Date: 2010-09-11
Author: Philippe Grosjean
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
License: GPL-2
Modified: pkg/SciViews/NAMESPACE
===================================================================
--- pkg/SciViews/NAMESPACE 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/NAMESPACE 2010-09-11 10:48:19 UTC (rev 307)
@@ -7,6 +7,7 @@
rwb.colors,
ryg.colors,
e,
+ lb,
ln,
ln1p,
lg,
@@ -48,7 +49,7 @@
S3method(screeplot, pcomp)
S3method(biplot, pcomp)
S3method(predict, pcomp)
-#S3method(loadings, pcomp) # This is NOT a generic function, but it works well on pcomp
+#S3method(loadings, pcomp) # This is NOT a generic function, but it works well on pcomp
S3method(pairs, pcomp)
S3method(scores, pcomp)
S3method(correlation, pcomp)
Modified: pkg/SciViews/NEWS
===================================================================
--- pkg/SciViews/NEWS 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/NEWS 2010-09-11 10:48:19 UTC (rev 307)
@@ -2,7 +2,7 @@
== SciViews version 0.9-1
-* ...
+* Added lb() function as a synonym of log2().
== SciViews version 0.9-0
@@ -14,8 +14,8 @@
> install.packages("SciViews", dependencies = TRUE).
-It now plays also other roles: (1) to load all SciViews requirements with a
-single instruction:
+It now plays also other roles:
+(1) to load all SciViews requirements with a single instruction:
> require(SciViews)
Modified: pkg/SciViews/R/SciViews-internal.R
===================================================================
--- pkg/SciViews/R/SciViews-internal.R 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/R/SciViews-internal.R 2010-09-11 10:48:19 UTC (rev 307)
@@ -1,8 +1,7 @@
-".onLoad" <-
-function (lib, pkg)
+.onLoad <- function (lib, pkg)
{
- # TODO: check configuration and install everything that we need to use the
- # SciViews extensions, including the HTTP or socket server
+ ## TODO: check configuration and install everything that we need to use the
+ ## SciViews extensions, including the HTTP or socket server
#serve <- getOption("ko.serve")
#if (!is.null(serve)) {
# startSocketServer(port = as.integer(serve)[1])
@@ -10,8 +9,7 @@
#}
}
-".onUnload" <-
-function (libpath)
+.onUnload <- function (libpath)
{
#serve <- getOption("ko.serve")
#if (!is.null(serve) && "package:svSocket" %in% search())
@@ -19,4 +17,4 @@
#guiUninstall()
}
-".packageName" <- "SciViews"
+.packageName <- "SciViews"
Modified: pkg/SciViews/R/colors.R
===================================================================
--- pkg/SciViews/R/colors.R 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/R/colors.R 2010-09-11 10:48:19 UTC (rev 307)
@@ -1,33 +1,33 @@
-# We often need a red-white-blue color ramp, or a red-yellow-green one
-# So, define rwb.colors() and ryg.colors()
+## We often need a red-white-blue color ramp, or a red-yellow-green one
+## So, define rwb.colors() and ryg.colors()
rwb.colors <- function (n, alpha = 1, gamma = 1, s = 0.9, v = 0.9)
{
if ((n <- as.integer(n[1L])) <= 0) return(character(0L))
- # Define the initial (red) and final (blue) colors with white in between
+ ## Define the initial (red) and final (blue) colors with white in between
cols <- c(hsv(0, s, v, gamma, alpha), # Red
hsv(0, 0, v, gamma, alpha), # White
hsv(2/3, s, v, gamma, alpha)) # Blue
- # Use a color ramp from red to white to blue
+ ## Use a color ramp from red to white to blue
return(colorRampPalette(cols)(n))
}
-# Red-yellow-green palette (take care for color-blind people here)!
+## Red-yellow-green palette (take care for color-blind people here)!
ryg.colors <- function (n, alpha = 1, gamma = 1, s = 0.9, v = 0.9)
{
- # This is essentially rainbow(), but going from 0 (red) to 2/6 (green)
+ ## This is essentially rainbow(), but going from 0 (red) to 2/6 (green)
return(rainbow(n, s = s, v = v, start = 0, end = 2/6, gamma = gamma,
alpha = alpha))
}
-# Slighly different than cm.colors(), allowing for s, v and gamma!
-# Produce probably better results on a CMYK device (color printer)?
+## Slighly different than cm.colors(), allowing for s, v and gamma!
+## Produce probably better results on a CMYK device (color printer)?
cwm.colors <- function (n, alpha = 1, gamma = 1, s = 0.9, v = 0.9)
{
if ((n <- as.integer(n[1L])) <= 0) return(character(0L))
- # Define the initial (red) and final (blue) colors with white in between
+ ## Define the initial (red) and final (blue) colors with white in between
cols <- c(hsv(1/2, s, v, gamma, alpha), # Cyan
hsv(0, 0, v, gamma, alpha), # White
hsv(5/6, s, v, gamma, alpha)) # Magenta
- # Use a color ramp from red to white to blue
+ ## Use a color ramp from red to white to blue
return(colorRampPalette(cols)(n))
}
Modified: pkg/SciViews/R/correlation.R
===================================================================
--- pkg/SciViews/R/correlation.R 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/R/correlation.R 2010-09-11 10:48:19 UTC (rev 307)
@@ -1,11 +1,11 @@
-# A wrapper around cor() and the like, building a "correlation" S3 object
-# TODO: cov.wt(), cov2correlation(), and perhaps, functions cov.XXX() from MASS
-# TODO: max, min, range, which.max, which.min for 'correlation' objects that do
-# not consider elements on the diagonal... or put something else to avoid it is
-# extracted for max, or which.max??? + something like 'highest' which considers
-# the absolute value??? How to deal with that?
+## A wrapper around cor() and the like, building a "correlation" S3 object
+## TODO: cov.wt(), cov2correlation(), and perhaps, functions cov.XXX() from MASS
+## TODO: max, min, range, which.max, which.min for 'correlation' objects that do
+## not consider elements on the diagonal... or put something else to avoid it is
+## extracted for max, or which.max??? + something like 'highest' which considers
+## the absolute value??? How to deal with that?
-# A generic function to calculate correlation from an object
+## A generic function to calculate correlation from an object
correlation <- function (x, ...)
UseMethod("correlation")
@@ -30,10 +30,10 @@
attr(res, "na.method") <- NULL
if (!is.null(na.action))
attr(res, "na.action") <- as.character(na.action)
- res
+ return(res)
}
-# Create the 'correlation' object (same arguments as cor() in stats package)
+## Create the 'correlation' object (same arguments as cor() in stats package)
correlation.default <- function (x, y = NULL, use = "everything",
method = c("pearson", "kendall", "spearman"), ...)
{
@@ -44,17 +44,17 @@
na.method <- pmatch(use, na.methods)
method <- match.arg(method)
- # Just call cor in stats package
+ ## Just call cor in stats package
res <- stats:::cor(x = x, y = y, use = use, method = method)
- # We want to return a correlation matrix, even if there is one correlation
+ ## We want to return a correlation matrix, even if there is one correlation
if (length(res) == 1) {
- # Create a simple correlation matrix using 'x' and 'y' as labels
+ ## Create a simple correlation matrix using 'x' and 'y' as labels
res <- matrix(c(1, res, res, 1), ncol = 2,
dimnames = list(c("x", "y"), c("x", "y")))
}
- # Same strings as for cor.test()
+ ## Same strings as for cor.test()
attr(res, "method") <- switch(method,
pearson = "Pearson's product-moment correlation",
kendall = "Kendall's rank correlation tau",
@@ -67,56 +67,57 @@
return(res)
}
-# Check if an object is a correlation matrix
+## Check if an object is a correlation matrix
is.correlation <- function (x)
return(inherits(x, "correlation"))
-# Transform a square matrix or a data.frame with values between -1 and 1
-# in a 'correlation' object
-# TODO: should we keep more attributes, in order to document other correlation
-# calculations?
+## Transform a square matrix or a data.frame with values between -1 and 1
+## in a 'correlation' object
+## TODO: should we keep more attributes, in order to document other correlation
+## calculations?
as.correlation <- function (x) {
if (is.correlation(x)) return(x)
- # Make sure we have a matrix with numeric data, dimnames and nothing else
- # (drop all other arguments, except 'comment', perhaps)
+ ## Make sure we have a matrix with numeric data, dimnames and nothing else
+ ## (drop all other arguments, except 'comment', perhaps)
res <- structure(as.numeric(x), dim = dim(x), dimnames = dimnames(x))
- # Check that it is a square (2D) matrix, or an atomic number
+ ## Check that it is a square (2D) matrix, or an atomic number
d <- dim(x)
if (is.null(d)) {
- # Is this an atomic number?
+ ## Is this an atomic number?
if (length(x) == 1) {
- # Create the simplest correlation matrix using generic 'x' and 'y' labels
+ ## Create the simplest correlation matrix using
+ ## generic 'x' and 'y' labels
res <- matrix(c(1, res, res, 1), ncol = 2,
dimnames = list(c("x", "y"), c("x", "y")))
}
- } else { # Check that it is a square matrix
+ } else { # Check that it is a square matrix
if (length(d) != 2 || d[1] != d[2])
stop("x must be a square matrix")
}
- # Check the range that must be between -1 and 1
+ ## Check the range that must be between -1 and 1
rg <- range(res, na.rm = TRUE)
if (rg[1] < -1 || rg[2] > 1)
stop("A correlation matrix cannot have values lower than -1 or larger than 1")
- # Reinject comment, if it exists
+ ## Reinject comment, if it exists
comment(res) <- comment(x)
- # Look for a "method" attribute
+ ## Look for a "method" attribute
attr(res, "method") <- attr(x, "method")
- # and a na.method, or na.action attribute
+ ## ... and a na.method, or na.action attribute
attr(res, "na.action") <- attr(x, "na.action")
attr(res, "na.method") <- attr(x, "na.method")
- # Set this as both a 'correlation' and 'matrix' S3 object
+ ## Set this as both a 'correlation' and 'matrix' S3 object
class(res) <- c("correlation", "matrix")
return(res)
}
-# Print a 'correlation' object
+## Print a 'correlation' object
print.correlation <- function (x, digits = 3, cutoff = 0, ...)
{
if (!is.correlation(x))
@@ -145,30 +146,30 @@
return(invisible(x))
}
-# Summary of a 'correlation' object
+## Summary of a 'correlation' object
summary.correlation <- function (object, cutpoints = c(0.3, 0.6, 0.8, 0.9, 0.95),
symbols = c(" ", ".", ",", "+", "*", "B"), ...)
{
- # Replace the correlation matrix by symbols using symnum()
+ ## Replace the correlation matrix by symbols using symnum()
res <- symnum(unclass(object), cutpoints = cutpoints, symbols = symbols,
corr = TRUE, ...)
- # Reinject comment, if it exists
+ ## Reinject comment, if it exists
comment(res) <- comment(object)
- # Look for a "method" attribute
+ ## Look for a "method" attribute
attr(res, "method") <- attr(object, "method")
- # and na.action/na.method attributes
+ ## ... and na.action/na.method attributes
attr(res, "na.action") <- attr(object, "na.action")
attr(res, "na.method") <- attr(object, "na.method")
- # Set this as 'summary.correlation' object
+ ## Set this as 'summary.correlation' object
class(res) <- c("summary.correlation", "noquote")
return(res)
}
-# And printing method for the 'summary.correlation' object
+## Print method for the 'summary.correlation' object
print.summary.correlation <- function (x, ...)
{
method <- attr(x, "method")
@@ -193,11 +194,11 @@
return(invisible(x))
}
-# Plot a 'correlation' object (basically the ellipse's plotcorr() function, but
-# as plot() method for 'corr' object and with different default values
-# Also, numbers are printed inside the ellipses with numbers = TRUE
-# TODO: change the way labels are plotted
-# TODO: a comparison plot, when y is not NULL
+## Plot a 'correlation' object (basically the ellipse's plotcorr() function, but
+## as plot() method for 'corr' object and with different default values
+## Also, numbers are printed inside the ellipses with numbers = TRUE
+## TODO: change the way labels are plotted
+## TODO: a comparison plot, when y is not NULL
plot.correlation <- function (x, y = NULL, outline = TRUE,
cutpoints = c(0.3, 0.6, 0.8, 0.9, 0.95), palette = rwb.colors, col = NULL,
numbers = TRUE, digits = 2, type = c("full", "lower", "upper"),
@@ -208,51 +209,51 @@
type <- match.arg(type)
diag <- as.logical(diag[1])
- # Compute colors from cutpoints and palette
+ ## Compute colors from cutpoints and palette
if (is.null(col)) {
- # -1.1 to include -1 - intervals are (,]
- # cutpoints - 0.0001 for positive values to include lower limits instead
+ ## -1.1 to include -1 - intervals are (,]
+ ## cutpoints - 0.0001 for positive values to include lower limit instead
br <- c(-1.1, rev(-cutpoints), cutpoints - 0.0001, 1)
ct <- cut(x, breaks = br)
col <- palette(length(levels(ct)))[as.numeric(ct)]
}
- # Call the plotcorr() function from ellipse package
+ ## Call the plotcorr() function from ellipse package
plotcorr(x, outline = outline, col = col, numbers = FALSE, type = type,
diag = diag, cex.lab = cex.lab, cex = cex, ...)
- # Do we print the numbers inside the ellipses?
+ ## Do we print the numbers inside the ellipses?
if (isTRUE(numbers)) {
coords <- expand.grid(1:nrow(x), nrow(x):1)
labels <- format(round(x, digits = digits), digits = digits)
- # Do we plotted only upper or lower triangle and diagonal?
- # Note: we need to invert y-coordinates!
+ ## Do we plotted only upper or lower triangle and diagonal?
+ ## Note: we need to invert y-coordinates!
yinv <- max(coords) + 1 - coords[, 2]
if (diag) {
if (type == "lower") {
- # Keep only lower triangle + diagonal
+ ## Keep only lower triangle + diagonal
coords <- coords[coords[, 1] <= yinv, ]
coords <- coords[order(coords[, 1]), ]
labels <- labels[lower.tri(labels, diag = TRUE)]
} else if (type == "upper") {
- # Keep only upper triangle
+ ## Keep only upper triangle
coords <- coords[coords[, 1] >= yinv, ]
coords <- coords[order(coords[, 1]), ]
labels <- labels[upper.tri(labels, diag = TRUE)]
}
- } else { # No diagonals
+ } else { # No diagonals
if (type == "lower") {
- # Keep only lower triangle
+ ## Keep only lower triangle
coords <- coords[coords[, 1] < yinv, ]
coords <- coords[order(coords[, 1]), ]
labels <- labels[lower.tri(labels)]
} else if (type == "upper") {
- # Keep only upper triangle
+ ## Keep only upper triangle
coords <- coords[coords[, 1] > yinv - 1, ]
coords <- coords[order(coords[, 1]), ]
coords[, 2] <- coords[, 2] - 1
labels <- labels[upper.tri(labels)]
} else {
- # Plot everything, except diagonal => put test to "" there
+ ## Plot everything, except diagonal => put test to "" there
diag(labels) <- ""
}
}
@@ -261,7 +262,7 @@
return(invisible())
}
-# Add vectors for supplementary variables in a PCA correlation plot
+## Add vectors for supplementary variables in a PCA correlation plot
lines.correlation <- function (x, choices = 1L:2L, col = par("col"), lty = 2,
ar.length = 0.1, pos = NULL, cex = par("cex"), labels = rownames(x), ...)
{
@@ -269,8 +270,8 @@
arrows(0, 0, corrs[, 1], corrs[, 2], col = col, lty = lty,
length = ar.length, ...)
if (!is.null(labels)){
- # If pos is NULL, calculate pos for each variable so that label is
- # located outside
+ ## If pos is NULL, calculate pos for each variable so that label is
+ ## located outside
if (is.null(pos))
pos <- c(2, 1, 4, 3, 2)[floor((atan2(corrs[, 2], corrs[, 1])/pi +
1.25) / 0.5) + 1]
Modified: pkg/SciViews/R/ln.R
===================================================================
--- pkg/SciViews/R/ln.R 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/R/ln.R 2010-09-11 10:48:19 UTC (rev 307)
@@ -1,8 +1,9 @@
-# ln(x) and ln1p(x) are wrappers for log(x) and log1p(x) to avoid confusion
-# with log10(x) that some beginneRs do, thinking that log(x) is logarithm in
-# base 10! lg(x) is a wrapper for log10(x) for the same reason.
-# lg1p(x) is the same as log1p() but it returns its result in base 10 log
-# 'e' is a useful constant and is equal to exp(1)
+## ln(x) and ln1p(x) are wrappers for log(x) and log1p(x) to avoid confusion
+## with log10(x) that some beginneRs do, thinking that log(x) is logarithm in
+## base 10! lg(x) is a wrapper for log10(x) for the same reason,
+## and lb() is a wrapper for log2()
+## lg1p(x) is the same as log1p() but it returns its result in base 10 log
+## 'e' is a useful constant and is equal to exp(1)
ln <- function (x) log(x)
ln1p <- function (x) log1p(x)
@@ -12,3 +13,5 @@
lg1p <- function (x) log1p(x) / log(10)
e <- exp(1)
+
+lb <- function (x) log2(x)
Modified: pkg/SciViews/R/panels.R
===================================================================
--- pkg/SciViews/R/panels.R 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/R/panels.R 2010-09-11 10:48:19 UTC (rev 307)
@@ -1,11 +1,11 @@
-# More panel functions
-# TODO: define fill colors differently
-# TODO: allow for a separate treatment per group
-# TODO: a better grid for log axes: something like
+## More panel functions
+## TODO: define fill colors differently
+## TODO: allow for a separate treatment per group
+## TODO: a better grid for log axes: something like
#abline(h = c(1:10 * 0.01, 2:10 * 0.1, 2:10 * 1, 2:10 * 10), lty = "dotted", col = "lightgray")
#abline(v = c(1:10 * 0.01, 2:10 * 0.1, 2:10 * 1, 2:10 * 10), lty = "dotted", col = "lightgray")
-# Inspired from panel.car() in car package, but without smooth line...
+## Inspired from panel.car() in car package, but without smooth line...
panel.reg <- function (x, y, col = par("col"), bg = par("bg"), pch = par("pch"),
cex = par("cex"), lwd = par("lwd"), line.reg = lm, line.col = "red",
line.lwd = lwd, untf = TRUE, ...)
@@ -16,7 +16,7 @@
untf = untf, ...)
}
-# panel.ellipse (note the low conf.level to get the ellipse inside the graph)
+## panel.ellipse (note the low conf.level to get the ellipse inside the graph)
panel.ellipse <- function (x, y, col = par("col"), bg = par("bg"),
pch = par("pch"), cex = par("cex"), el.level = 0.7, el.col = "cornsilk",
el.border = "red", major = TRUE, ...)
@@ -25,7 +25,7 @@
centre = c(mean(x), mean(y)), level = el.level)
polygon(el, col = el.col, border = el.border)
if (isTRUE(major)) {
- # b is the slope of the standardized major axis
+ ## b is the slope of the standardized major axis
d <- na.omit(data.frame(y, x))
v <- cov(d) * (nrow(d) - 1)
b <- sign(v[1, 2]) * sqrt(v[1, 1] / v[2, 2])
@@ -35,39 +35,39 @@
points(x, y, col = col, bg = bg, pch = pch, cex = cex)
}
-# One way to visualize correlation coefficients, inspired from
-# http://addictedtor.free.fr/graphiques/sources/source_137.R
+## One way to visualize correlation coefficients, inspired from
+## http://addictedtor.free.fr/graphiques/sources/source_137.R
panel.cor <- function (x, y, use = "everything",
method = c("pearson", "kendall", "spearman"),
alternative = c("two.sided", "less", "greater"), digits = 2, prefix = "",
cex = par("cex"), cor.cex = cex, stars.col = "red", ...)
{
- # Set plot parameters
+ ## Set plot parameters
usr <- par("usr")
on.exit(par(usr))
par(usr = c(0, 1, 0, 1))
- # We don't use cor.test()$estimate, but result from cor()
- # That way, we have more flexibility in defining the "use" argument
+ ## We don't use cor.test()$estimate, but result from cor()
+ ## That way, we have more flexibility in defining the "use" argument
corr <- cor(x, y, use = use, method = method)
- # Format this result
+ ## Format this result
txt <- format(c(corr, 0.123456789), digits = digits)[1]
txt <- paste(prefix, txt, sep = "")
cor.cex <- cor.cex / strwidth(txt)
- # Perform a test on this coefficient
+ ## Perform a test on this coefficient
test <- cor.test(x, y, alternative = alternative, method = method)
- # Format this result
+ ## Format this result
star <- symnum(test$p.value, corr = FALSE, na = FALSE,
cutpoints = c(0, 0.001, 0.01, 0.05, 0.1, 1),
symbols = c("***", "**", "*", ".", " "))
- # Write the text on the plot
+ ## Write the text on the plot
text(0.5, 0.5, txt, cex = cor.cex * abs(corr), ...)
text(0.8, 0.8, as.character(star), cex = cor.cex, col = stars.col)
- # Return the result of the test invisibly
+ ## Return the result of the test invisibly
return(invisible(test))
}
Modified: pkg/SciViews/R/panels.diag.R
===================================================================
--- pkg/SciViews/R/panels.diag.R 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/R/panels.diag.R 2010-09-11 10:48:19 UTC (rev 307)
@@ -1,25 +1,25 @@
-# Panel function to use on the diagonal (univariate graphs)
-# TODO: define fill colors differently
+## Panel function to use on the diagonal (univariate graphs)
+## TODO: define fill colors differently
-# Boxplot
+## Boxplot
panel.boxplot <- function (x, col = par("col"), box.col = "cornsilk", ...)
{
- # Note: col is defined here, but unused, because otherwise redefining
- # col would cause an error about duplicated 'col' arguments to boxplot()!
- # further arguments to boxplot are allowed (try notch = TRUE ... not very
- # useful here, but just for test). Note that warnings are generates in
- # pairs() in case of a call with non-graphic arguments, or even, col.box =
+ ## Note: col is defined here, but unused, because otherwise redefining
+ ## col would cause an error about duplicated 'col' arguments to boxplot()!
+ ## further arguments to boxplot are allowed (try notch = TRUE ... not very
+ ## useful here, but just for test). Note that warnings are generates in
+ ## pairs() in case of a call with non-graphic arguments, or even, col.box =
par(new = TRUE)
boxplot(x, axes = FALSE, col = box.col, horizontal = TRUE,
xlim = c(0.5, 2), ...)
}
-# Density plot
+## Density plot
panel.density <- function (x, adjust = 1, rug = TRUE, col = par("col"),
lwd = par("lwd"), line.col = col, line.lwd = lwd,...)
{
- # Further arguments to density() are allowed (see examples) but it generates
- # warnings in pairs()
+ ## Further arguments to density() are allowed (see examples) but it generates
+ ## warnings in pairs()
dens.x <- density(x, adjust = adjust, ...)
lines(dens.x$x, min(x) + dens.x$y * diff(range(x)) / diff(range(dens.x$y)),
col = line.col, lwd = line.lwd)
@@ -27,28 +27,28 @@
points(x, rep(min(x), length(x)), pch = "|", col = line.col)
}
-# Histogram
+## Histogram
panel.hist <- function (x, breaks = "Sturges", hist.col = "cornsilk",
hist.border = NULL, hist.density = NULL, hist.angle = 45, ...)
{
- # Here, we try to define all arguments that are specific to the histogram
- # (col, border, density and angle) with specific arguments to allow better
- # control of the appearance of the histograms independently from the other
- # panels
+ ## Here, we try to define all arguments that are specific to the histogram
+ ## (col, border, density and angle) with specific arguments to allow better
+ ## control of the appearance of the histograms independently from the other
+ ## panels
par(new = TRUE)
hist(x, breaks = breaks, col = hist.col, border = hist.border,
density = hist.density, angle = hist.angle, axes = FALSE,
xlab = "", ylab = "", main = "")
}
-# QQ-plot agains a Normal distribution
+## QQ-plot agains a Normal distribution
panel.qqnorm <- function(x, pch = par("pch"), col = par("col"), bg = par("bg"),
cex = par("cex"), lwd = par("lwd"), qq.pch = pch, qq.col = col, qq.bg = bg,
qq.cex = cex, qqline.col = qq.col, qqline.lwd = lwd, ...)
{
par(new = TRUE)
ylim <- range(x, na.rm = TRUE)
- # Leave enough space for name of variables on top of the graph
+ ## Leave enough space for name of variables on top of the graph
ylim[2] <- ylim[2] + (ylim[2] - ylim[1]) / 4
qqnorm(x, axes = FALSE, xlab = "", ylab = "", main = "",
ylim = ylim, col = qq.col, bg = qq.bg, pch = qq.pch, cex = qq.cex)
Modified: pkg/SciViews/R/pcomp.R
===================================================================
--- pkg/SciViews/R/pcomp.R 2010-09-11 10:02:01 UTC (rev 306)
+++ pkg/SciViews/R/pcomp.R 2010-09-11 10:48:19 UTC (rev 307)
@@ -1,16 +1,16 @@
-# Define a "pcomp" S3 object for PCA, because there is too much chaos with
-# default "prcomp" and "princomp" R objects, plus "pca" in ade4 and labdsv,
-# "PCA" in FactoMineR, etc.
+## Define a "pcomp" S3 object for PCA, because there is too much chaos with
+## default "prcomp" and "princomp" R objects, plus "pca" in ade4 and labdsv,
+## "PCA" in FactoMineR, etc.
-# Create the pcomp generic function that returns a "pcomp" object
+## Create the pcomp generic function that returns a "pcomp" object
pcomp <- function (x, ...)
UseMethod("pcomp")
pcomp.formula <- function (formula, data = NULL, subset, na.action,
method = c("svd", "eigen"), ...)
{
- # Defines a PCA through the formula interface
- # Largely inspired from prcomp.formula
+ ## Define a PCA through the formula interface
+ ## Largely inspired from prcomp.formula
mt <- terms(formula, data = data)
if (attr(mt, "response") > 0L)
stop("response not allowed in formula")
@@ -33,18 +33,18 @@
if (!is.null(sc <- res$x))
res$x <- napredict(na.act, sc)
}
- res
+ return(res)
}
pcomp.default <- function (x, method = c("svd", "eigen"), scores = TRUE,
center = TRUE, scale = TRUE, tol = NULL, covmat = NULL,
subset = rep(TRUE, nrow(as.matrix(x))), ...)
{
- # Perform a PCA, either using prcomp (method = "svd"), or princomp ("eigen")
+ ## Perform a PCA, either using prcomp (method = "svd"), or princomp ("eigen")
svd.pca <- function (x, retx, center, scale, tol, ...) {
pca <- prcomp(x, retx = retx, center = center, scale = scale, tol = tol,
...)
- # Rework the result to make it fit in the "pcomp" object
+ ## Rework the result to make it fit in the "pcomp" object
names(pca$sdev) <- paste("PC", 1:length(pca$sdev), sep = "")
if (isTRUE(!pca$center)) {
pca$center <- rep(0, length(pca$sdev))
@@ -81,12 +81,12 @@
subset = subset, ...)
}
n <- length(pca$sdev)
- pc <- paste("PC", 1:n, sep = "") # rename Comp.1, ... in PC1, ...
+ pc <- paste("PC", 1:n, sep = "") # rename Comp.1, ... in PC1, ...
names(pca$sdev) <- pc
colnames(pca$loadings) <- pc
if (!is.null(pca$scores)) {
colnames(pca$scores) <- pc
- # If there are rownames to x, use it
+ ## If there are rownames to x, use it
rn <- rownames(x)
if (is.null(rn)) {
rownames(pca$scores) <- as.character(1:nrow(pca$scores))
@@ -111,7 +111,7 @@
cl <- match.call()
cl[[1L]] <- as.name("pcomp")
- # Check that all variables are numeric (otherwise, issue a clear message)!
+ ## Check that all variables are numeric (otherwise, issue a clear message)!
x <- as.data.frame(x)
if (!all(sapply(x, is.numeric)))
stop("Cannot perform a PCA: one or more variables are not numeric.")
@@ -126,15 +126,15 @@
subset = subset, ...),
stop("method must be either 'svd' or 'eigen'")
)
- # Add a call item
+ ## Add a call item
res$call <- cl
- # We return a specific object, but it is compatible (i.e., overloads), both
- # "pca" in package labdsv and "princomp" in package stats
+ ## We return a specific object, but it is compatible (i.e., overloads), both
+ ## "pca" in package labdsv and "princomp" in package stats
class(res) <- c("pcomp", "pca", "princomp")
return(res)
}
-# print method (similar to print.princomp, but reports variances instead of sds)
+## print method (similar to print.princomp, but reports variances instead of sds)
print.pcomp <- function (x, ...)
{
cat("Call:\n")
@@ -145,7 +145,7 @@
invisible(x)
}
-# summary method (same as summary.princomp, but with TRUE for loadings)
+## summary method (same as summary.princomp, but with TRUE for loadings)
summary.pcomp <- function (object, loadings = TRUE, cutoff = 0.1, ...)
{
object$cutoff <- cutoff
@@ -154,7 +154,7 @@
object
}
-#print method for summary.pcomp object (slightly modified from princomp)
+## print method for summary.pcomp object (slightly modified from princomp)
print.summary.pcomp <- function (x, digits = 3, loadings = x$print.loadings,
cutoff = x$cutoff, ...)
{
@@ -174,11 +174,12 @@
invisible(x)
}
-#plot method
-# TODO: same mechanism as for plot.lm: multiplot allowed!
-plot.pcomp <- function (x, which = c("screeplot", "loadings", "correlations", "scores"),
-choices = 1L:2L, col = par("col"), bar.col = "gray", circle.col = "gray",
-ar.length = 0.1, pos = NULL, labels = NULL, cex = par("cex"),
+## plot method
+## TODO: same mechanism as for plot.lm: multiplot allowed!
+plot.pcomp <- function (x,
+which = c("screeplot", "loadings", "correlations", "scores"), choices = 1L:2L,
+col = par("col"), bar.col = "gray", circle.col = "gray", ar.length = 0.1,
+pos = NULL, labels = NULL, cex = par("cex"),
main = paste(deparse(substitute(x)), which, sep = " - "), xlab, ylab, ...)
{
plotScores <- function (x, choices, col, circle.col, labels, cex, main,
@@ -188,7 +189,7 @@
stop("no scores are available: refit with 'scores = TRUE'")
if (is.null(labels)) {
labels <- rownames(x$scores)
- if (is.null(labels)) # If still no labels
+ if (is.null(labels)) # If still no labels
labels <- as.character(1:nrow(x$scores))
} else if (!isTRUE(!as.numeric(labels)))
labels <- as.character(labels)
@@ -202,7 +203,7 @@
which <- match.arg(which)
main <- main[1]
- # Calculate default xlab and ylab
+ ## Calculate default xlab and ylab
labs <- paste(names(x$sdev), " (", round((x$sdev^2 / x$totdev^2) * 100,
digits = 1), "%)", sep = "")
if (missing(xlab)) xlab <- labs[choices[1]] else xlab
@@ -224,7 +225,7 @@
)
}
-#screeplot method (add cumulative variance curve to the plot)
+## screeplot method (add cumulative variance curve to the plot)
screeplot.pcomp <- function (x, npcs = min(10, length(x$sdev)),
type = c("barplot", "lines"), col = "cornsilk", main = deparse(substitute(x)),
...)
@@ -242,10 +243,10 @@
axis(2)
axis(1, at = xp, labels = names(pcs[xp]))
}
- invisible()
+ return(invisible())
}
-#points method
+## points method
# This is supposed to add points to a graph of scores
points.pcomp <- function (x, choices = 1L:2L, type = "p", pch = par("pch"),
col = par("col"), bg = par("bg"), cex = par("cex"), ...)
@@ -256,7 +257,7 @@
cex = cex, ...)
}
-#lines method
+## lines method
# Uses groups to draw either polygons or ellipses for each group
lines.pcomp <- function (x, choices = 1L:2L, groups, type = c("p", "e"),
col = par("col"), border = par("fg"), level = 0.9, ...)
@@ -267,9 +268,10 @@
sc <- na.omit(scores[as.numeric(groups) == i, ])
if (NROW(sc) > 1) {
pts <- chull(sc)
- # Close polygon
+ ## Close polygon
pts <- c(pts, pts[1])
- polygon(sc[pts, 1], sc[pts, 2], col = col[i], border = border[i], ...)
+ polygon(sc[pts, 1], sc[pts, 2], col = col[i],
+ border = border[i], ...)
}
}
}
@@ -298,23 +300,26 @@
border <- rep(border, length.out = n)
type <- match.arg(type)
switch(type,
- p = polygons(scores, groups = groups, n = n, col = col, border = border, ...),
- e = ellipses(scores, groups = groups, n = n, col = col, border = border, level = level, ...),
+ p = polygons(scores, groups = groups, n = n, col = col,
+ border = border, ...),
+ e = ellipses(scores, groups = groups, n = n, col = col,
+ border = border, level = level, ...),
stop("unknown type, currently only 'p' for polygons et 'e' for ellipses")
)
}
-#text method
+## text method
text.pcomp <- function (x, choices = 1L:2L, labels = NULL, col = par("col"),
cex = par("cex"), pos = NULL, ...) {
if (is.null(x$scores))
stop("no scores are available: refit with 'scores = TRUE'")
if (is.null(labels))
labels <- as.character(1:nrow(x$scores))
- text(x$scores[, choices], labels = labels, col = col, cex = cex, pos = pos, ...)
+ text(x$scores[, choices], labels = labels, col = col, cex = cex,
+ pos = pos, ...)
}
-#biplot method (note: it plots loadings, not correlations!)
+## biplot method (note: it plots loadings, not correlations!)
biplot.pcomp <- function (x, choices = 1L:2L, scale = 1, pc.biplot = FALSE, ...)
{
if (length(choices) != 2)
@@ -336,49 +341,50 @@
lam <- lam/sqrt(n)
stats:::biplot.default(t(t(scores[, choices])/lam),
t(t(x$loadings[, choices]) * lam), ...)
- invisible()
+ return(invisible())
}
-#.panel.individuals required by pairs.pcomp
+## .panel.individuals required by pairs.pcomp
.panel.individuals <- function (x, y, ...) {
- # x and y are c(indivs, NaN, vars) => collect indivs
+ ## x and y are c(indivs, NaN, vars) => collect indivs
pos <- 1:(which(is.nan(x))[1] - 1)
points(x[pos], y[pos], ...)
}
-#.panel.variables required by pairs.pcomp
+## .panel.variables required by pairs.pcomp
.panel.variables <- function (x, y, ar.labels, ar.col, ar.cex, labels, col,
cex, ...)
{
- # x and y are c(indivs, NaN, vars) => collect indivs
+ ## x and y are c(indivs, NaN, vars) => collect indivs
pos <- (which(is.nan(x))[1] + 1):length(x)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/sciviews -r 307
More information about the Sciviews-commits
mailing list