[Archetypes-commits] r53 - in pkg: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Nov 4 13:23:02 CET 2011
Author: manuel
Date: 2011-11-04 13:23:02 +0100 (Fri, 04 Nov 2011)
New Revision: 53
Added:
pkg/R/plot.R
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/archetypes-class.R
pkg/R/archetypes-step.R
pkg/R/generics.R
pkg/R/panorama.R
pkg/R/profile.R
Log:
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2011-10-28 15:07:32 UTC (rev 52)
+++ pkg/DESCRIPTION 2011-11-04 12:23:02 UTC (rev 53)
@@ -39,4 +39,4 @@
'skeletonplot.R'
'panorama.R'
'profile.R'
- 'parameters.R'
+ 'plot.R'
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2011-10-28 15:07:32 UTC (rev 52)
+++ pkg/NAMESPACE 2011-11-04 12:23:02 UTC (rev 53)
@@ -26,30 +26,30 @@
importFrom(stats,screeplot)
importFrom(stats,weights)
S3method("[",stepArchetypes)
-S3method(bestModel,repArchetypes)
+S3method(barplot,atypes_parameters)
+S3method(barplot,atypes_profile)
S3method(bestModel,stepArchetypes)
S3method(coef,archetypes)
S3method(fitted,archetypes)
S3method(kappa,archetypes)
S3method(nparameters,archetypes)
-S3method(nparameters,repArchetypes)
S3method(nparameters,stepArchetypes)
S3method(panorama,archetypes)
S3method(pcplot,archetypes)
S3method(pcplot,default)
-S3method(plot,atypes_panorama)
S3method(plot,atypes_profile)
+S3method(plot,stepArchetypes)
+S3method(plot,stepArchetypes_parameters)
+S3method(plot,stepArchetypes_profile)
S3method(print,archetypes)
-S3method(print,repArchetypes)
S3method(print,stepArchetypes)
S3method(residuals,archetypes)
S3method(rss,archetypes)
-S3method(rss,repArchetypes)
S3method(rss,stepArchetypes)
S3method(screeplot,stepArchetypes)
-S3method(summary,stepArchetypes)
S3method(weights,archetypes)
S3method(xyplot,archetypes)
+S3method(xyplot,atypes_panorama)
S3method(xyplot,robustArchetypes)
S3method(xyplot,stepArchetypes)
S3method(xyplot,weightedArchetypes)
Modified: pkg/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R 2011-10-28 15:07:32 UTC (rev 52)
+++ pkg/R/archetypes-class.R 2011-11-04 12:23:02 UTC (rev 53)
@@ -100,55 +100,13 @@
#'
#' @importFrom stats coef
#' @S3method coef archetypes
-coef.archetypes <- function(object, type = c('alphas', 'betas'), ...) {
+coef.archetypes <- function(object, type = c("alphas", "betas"), ...) {
type <- match.arg(type)
object[[type]]
}
-#' Fitted archetypes
-#'
-#' @param object An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Matrix (with class \code{atypes_parameters}) with \eqn{k}
-#' archetypes.
-#'
-#' @aliases parameters-methods
-#' @aliases parameters,archetypes-method
-#'
-#' @seealso \code{\link{profile,archetypes-method}}
-#'
-#' @importFrom modeltools parameters
-#' @exportMethod parameters
-setMethod('parameters', signature = c(object = 'archetypes'),
-function(object, ...) {
- parameters <- object$archetypes
-
- if ( is.null(parameters) )
- return(parameters)
-
-
- rownames(parameters) <- sprintf("Archetype %s",
- seq(length = object$k))
-
- subclass(parameters, "atypes_parameters")
-})
-
-
-
-#' @rdname parameters
-#' @method plot atypes_parameters
-#' @S3method plot atypes_parameters
-plot.atypes_parameters <- function(x, y = NULL, ...) {
- p <- ggplot(melt(x), aes(X2, value))
- p <- p + geom_bar(stat = "identity") + facet_grid(X1 ~ .)
- p <- p + xlab("Variable") + ylab("Value")
- p
-}
-
-
-
#' Return number of archetypes
#'
#' @param object An \code{archetypes} object.
@@ -236,10 +194,64 @@
+#' Fitted archetypes
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix (with class \code{atypes_parameters}) with \eqn{k}
+#' archetypes.
+#'
+#' @aliases parameters-methods
+#' @aliases parameters,archetypes-method
+#'
+#' @seealso \code{\link{profile,archetypes-method}}
+#'
+#' @importFrom modeltools parameters
+#' @exportMethod parameters
+setMethod('parameters', signature = c(object = 'archetypes'),
+function(object, ...) {
+ parameters <- object$archetypes
+
+ if ( is.null(parameters) )
+ return(parameters)
+
+
+ rownames(parameters) <- sprintf("Archetype %s",
+ seq(length = object$k))
+
+ subclass(parameters, "atypes_parameters")
+})
+
+
+
+#' @param height An \code{atypes_parameters} object.
+#' @rdname parameters
+#' @method barplot atypes_parameters
+#' @S3method barplot atypes_parameters
+barplot.atypes_parameters <- function(height, ...) {
+ p <- ggplot(melt(height), aes(X2, value))
+ p <- p + geom_bar(stat = "identity") + facet_grid(X1 ~ .)
+ p <- p + xlab("Variable") + ylab("Value")
+ p
+}
+
+
+
+#' @param x An \code{atypes_parameters} object.
+#' @param y Ignored.
+#' @rdname parameters
+#' @method plot atypes_profile
+#' @S3method plot atypes_profile
+plot.atypes_parameters <- function(x, y = NULL, ...) {
+ barplot.atypes_parameters(x, ...)
+}
+
+
+
### Not implemented yet: #############################################
predict.archetypes <- function(object, newdata = NULL,
- type = c('alphas', 'data'), ...) {
+ typxe = c('alphas', 'data'), ...) {
type <- match.arg(type)
if ( is.null(newdata) )
Modified: pkg/R/archetypes-step.R
===================================================================
--- pkg/R/archetypes-step.R 2011-10-28 15:07:32 UTC (rev 52)
+++ pkg/R/archetypes-step.R 2011-11-04 12:23:02 UTC (rev 53)
@@ -1,5 +1,4 @@
#' @include archetypes-class.R
-#' @include archetypes-rep.R
{}
@@ -23,6 +22,7 @@
#' \code{stepArchetypes}.
#'
#' @family archetypes
+#' @seealso \code{\link{bestModel}}
#'
#' @examples
#' \dontrun{
@@ -43,7 +43,7 @@
stopifnot(nrep > 0)
as <- list()
- as$call <- match.call()
+ as$call <- match.call(expand.dots = TRUE)
as$nrep <- nrep
as$k <- k
as$models <- list()
@@ -66,35 +66,14 @@
#' @S3method print stepArchetypes
print.stepArchetypes <- function(x, ...) {
- cat('stepArchetypes object\n\n')
- cat(deparse(attr(x, 'call')), '\n')
+ cat("stepArchetypes object\n\n")
+ cat(deparse(x$call), "\n\n")
+ cat("Residual sum of squares:\n")
+ print(round(rss(x), 2))
}
-#' Summary method for stepArchetypes object
-#'
-#' @param object A \code{stepArchetypes} object.
-#' @param ... Ignored.
-#' @return Undefined.
-#'
-#' @method summary stepArchetypes
-#' @rdname summary
-#'
-#' @S3method summary stepArchetypes
-summary.stepArchetypes <- function(object, ...) {
- print(object)
-
- ps <- nparameters(object)
-
- for ( i in seq_along(object) ) {
- cat('\nk=', ps[i], ':\n', sep='')
- print(object[[i]], full=FALSE)
- }
-}
-
-
-
#' Extract method
#'
#' An extraction on a \code{stepArchetypes} object returns again a
@@ -124,33 +103,49 @@
rss.stepArchetypes <- function(object, ...) {
ret <- lapply(object$models, rss)
ret <- do.call(rbind, ret)
- ret <- data.frame(Archetypes = nparameters(as), ret)
+ ret <- data.frame(Archetypes = nparameters(object), ret)
subclass(ret, "stepArchetypes_rss")
}
+#' @param x A \code{stepArchetypes_rss} object
+#' @param y Ignored.
+#' @rdname rss
+#' @method plot stepArchetypes
+#'
+#' @S3method plot stepArchetypes
plot.stepArchetypes_rss <- function(x, y = NULL, ...) {
p <- ggplot(melt(x, "Archetypes"),
- aes(ordered(Archetypes), value, group = variable))
+ aes(ordered(Archetypes), value, group = variable,
+ colour = variable))
p <- p + geom_line()
+ p <- p + geom_point()
p <- p + xlab("Number of archetypes") + ylab("RSS")
p
}
-#' Return best model
+#' Return best model per step
#'
#' @param object An \code{archetypes} object.
+#' @param reduced Reduce list to valid objects; i.e., remove step if
+#' no replication was successfull.
#' @param ... Ignored
#'
#' @rdname bestModel
#' @method bestModel stepArchetypes
#'
#' @S3method bestModel stepArchetypes
-bestModel.stepArchetypes <- function(object, ...) {
- object$models <- lapply(object$models, bestModel)
+bestModel.stepArchetypes <- function(object, reduced = TRUE, ...) {
+ best <- lapply(object$models, bestModel, reduced = reduced)
+
+ if ( reduced )
+ best <- best[sapply(best, Negate(is.null))]
+
+ object$models <- best
+ object$k <- sapply(best, sapply, "[[", "k")
object$nrep <- 1
object
}
@@ -163,11 +158,42 @@
#' @exportMethod parameters
setMethod('parameters', signature = c(object = 'stepArchetypes'),
function(object, ...) {
- subclass(lapply(object, parameters), "stepArchetypes_parameters")
+ subclass(lapply(object$models, parameters), "stepArchetypes_parameters")
})
+#' @param transpose Transpose plots arrangement.
+#' @rdname parameters
+#' @method plot stepArchetypes_parameters
+#' @S3method plot stepArchetypes_parameters
+plot.stepArchetypes_parameters <- function(x, y = NULL, transpose = FALSE, ...) {
+ params_plot(x, transpose)
+}
+
+
+
+#' @aliases profile,stepArchetypes-method
+#' @rdname profile
+#' @importFrom stats profile
+#' @exportMethod profile
+setMethod('profile', signature = c(fitted = 'stepArchetypes'),
+function(fitted, data, type = percentiles, ...) {
+ subclass(lapply(fitted$models, profile, data, type), "stepArchetypes_profile")
+})
+
+
+
+#' @param transpose Transpose plots arrangement.
+#' @rdname profile
+#' @method plot stepArchetypes_profile
+#' @S3method plot stepArchetypes_profile
+plot.stepArchetypes_profile <- function(x, y = NULL, transpose = FALSE, ...) {
+ params_plot(x, transpose)
+}
+
+
+
#' @rdname nparameters
#' @method nparameters stepArchetypes
#'
@@ -178,7 +204,10 @@
+### Step utility functions: ##########################################
+setOldClass(c("step", "list"))
+
step <- function() {
structure(list(), class = c("step", "list"))
}
@@ -193,8 +222,24 @@
sapply(object, nparameters)[1]
}
-bestModel.step <- function(object, ...) {
+bestModel.step <- function(object, reduced = TRUE, ...) {
which <- which.min(rss(object))
+
+ if ( length(which) == 0 )
+ if ( reduced )
+ return(NULL)
+ else
+ which <- 1
+
subclass(list(object[[which]]), "step")
}
+setMethod('parameters', signature = c(object = 'step'),
+function(object, ...) {
+ lapply(object, parameters)
+})
+
+setMethod('profile', signature = c(fitted = 'step'),
+function(fitted, data, type = percentiles, ...) {
+ lapply(fitted, profile, data, type)
+})
Modified: pkg/R/generics.R
===================================================================
--- pkg/R/generics.R 2011-10-28 15:07:32 UTC (rev 52)
+++ pkg/R/generics.R 2011-11-04 12:23:02 UTC (rev 53)
@@ -77,3 +77,54 @@
subclass <- function(x, subclass) {
structure(x, class = c(subclass, class(x)))
}
+
+
+
+## http://gettinggeneticsdone.blogspot.com/2010/03/arrange-multiple-ggplot2-plots-in-same.html
+vp.layout <- function(x, y) viewport(layout.pos.row=x, layout.pos.col=y)
+arrange <- function(..., nrow=NULL, ncol=NULL, as.table=FALSE) {
+ dots <- list(...)
+ n <- length(dots)
+ if(is.null(nrow) & is.null(ncol)) { nrow = floor(n/2) ; ncol = ceiling(n/nrow)}
+ if(is.null(nrow)) { nrow = ceiling(n/ncol)}
+ if(is.null(ncol)) { ncol = ceiling(n/nrow)}
+ ## NOTE see n2mfrow in grDevices for possible alternative
+grid.newpage()
+pushViewport(viewport(layout=grid.layout(nrow,ncol) ) )
+ ii.p <- 1
+ for(ii.row in seq(1, nrow)){
+ ii.table.row <- ii.row
+ if(as.table) {ii.table.row <- nrow - ii.table.row + 1}
+ for(ii.col in seq(1, ncol)){
+ ii.table <- ii.p
+ if(ii.p > n) break
+ print(dots[[ii.table]], vp=vp.layout(ii.table.row, ii.col))
+ ii.p <- ii.p + 1
+ }
+ }
+}
+
+
+
+params_plot <- function(x, transpose = FALSE) {
+ nullplot <- function(p) {
+ if ( is.null(p) )
+ NULL
+ else
+ plot(p)
+ }
+
+ plots <- lapply(unlist(x, recursive = FALSE), nullplot)
+
+ dim <- c(ncol = max(sapply(x, length)),
+ nrow = length(x))
+
+ if ( transpose ) {
+ dim <- rev(dim)
+ order <- as.numeric(t(matrix(seq(along = plots), nrow = dim[2])))
+ plots <- plots[order]
+ }
+
+ do.call(arrange, c(plots, list(nrow = dim[2], ncol = dim[1])))
+}
+
Modified: pkg/R/panorama.R
===================================================================
--- pkg/R/panorama.R 2011-10-28 15:07:32 UTC (rev 52)
+++ pkg/R/panorama.R 2011-11-04 12:23:02 UTC (rev 53)
@@ -71,10 +71,11 @@
+#' @param x An \code{atypes_panorama} object.
#' @rdname panorama
-#' @method plot atypes_panorama
-#' @S3method plot atypes_panorama
-plot.atypes_panorama <- function(x, y = NULL, ...) {
+#' @method xyplot atypes_panorama
+#' @S3method xyplot atypes_panorama
+xyplot.atypes_panorama <- function(x, ...) {
x0 <- melt(x)
x1 <- subset(x0, Archetype != "Data point")
@@ -97,6 +98,16 @@
+#' @param y Ignored.
+#' @rdname panorama
+#' @method plot atypes_profile
+#' @S3method plot atypes_profile
+plot.atypes_panorama <- function(x, y = NULL, ...) {
+ xyplot.atypes_panorama(x, ...)
+}
+
+
+
distEuclidean <- function (x, centers) {
if (ncol(x) != ncol(centers)) {
stop(sQuote("x"), " and ", sQuote("centers"),
Added: pkg/R/plot.R
===================================================================
--- pkg/R/plot.R (rev 0)
+++ pkg/R/plot.R 2011-11-04 12:23:02 UTC (rev 53)
@@ -0,0 +1,93 @@
+#' @include generics.R
+{}
+
+
+
+xyplot.archetypes <- function(x, data = NULL, atypes.args = list(colour = "red"),
+ chull = NULL,
+ chull.args = list(colour = "gray"),
+ ahull.show = FALSE, ahull.args = atypes.args,
+ adata.show = FALSE, adata.args = list(colour = "green"),
+ data.args = list(), ...) {
+
+ atypes <- as.data.frame(parameters(x))
+
+ stopifnot(ncol(atypes) == 2)
+
+ xlab <- colnames(atypes)[1]
+ ylab <- colnames(atypes)[2]
+
+
+ ## Archetypes:
+ p <- ggplot(atypes, aes_string(x = xlab, y = ylab))
+
+
+ ## Data, convex hull:
+ if ( !is.null(data) ) {
+ data <- as.data.frame(data)
+
+ p <- p + do.call(geom_point, c(list(data = data), data.args))
+
+ if ( !is.null(chull) ) {
+ chull <- data[c(chull, chull[1]), ]
+
+ p <- p + do.call(geom_point, c(list(data = chull), chull.args))
+ p <- p + do.call(geom_path, c(list(data = chull), chull.args))
+ }
+ }
+
+
+ ## Approximated data:
+ if ( adata.show ) {
+ adata <- as.data.frame(fitted(x))
+
+ p <- p + do.call(geom_point, c(list(data = adata), adata.args))
+
+ if ( !is.null(data) ) {
+ colnames(adata) <- sprintf("fitted.%s", colnames(adata))
+
+ xlab_adata <- colnames(adata)[1]
+ ylab_adata <- colnames(adata)[2]
+
+ adata <- cbind(data, adata)
+
+ p <- p + do.call(geom_segment,
+ c(list(data = adata,
+ mapping = aes_string(xend = xlab_adata,
+ yend = ylab_adata)),
+ adata.args))
+ }
+ }
+
+
+ ## Approximated convex hull:
+ if ( ahull.show ) {
+ ahull <- atypes[ahull(atypes), ]
+
+ p <- p + do.call(geom_path, c(list(data = ahull), ahull.args))
+ }
+
+
+ ## The archetypes should be plotted on top:
+ p <- p + do.call(geom_point, atypes.args)
+
+
+ p
+}
+
+
+
+ahull <- function(a) {
+ xc <- a[,1]; xm <- mean(xc)
+ yc <- a[,2]; ym <- mean(yc)
+
+ real <- xc - xm
+ imag <- yc - ym
+ angle <- atan2(imag, real)
+
+ index <- order(angle)
+
+ return(c(index, index[1]))
+}
+
+
Property changes on: pkg/R/plot.R
___________________________________________________________________
Added: svn:keywords
+ Date Revision Author URL Id Header
Added: svn:eol-style
+ native
Modified: pkg/R/profile.R
===================================================================
--- pkg/R/profile.R 2011-10-28 15:07:32 UTC (rev 52)
+++ pkg/R/profile.R 2011-11-04 12:23:02 UTC (rev 53)
@@ -1,6 +1,4 @@
#' @include archetypes-class.R
-#' @include archetypes-step.R
-#' @include archetypes-rep.R
{}
@@ -34,6 +32,9 @@
function(fitted, data, type = percentiles, ...) {
stopifnot(!is.null(data))
+ if ( is.na(rss(fitted)) )
+ return(NULL)
+
profile <- parameters(fitted)
profile <- sapply(seq(length = ncol(data)),
function(i) percentiles(profile[, i], data[, i]))
@@ -60,16 +61,25 @@
+#' @param height An \code{atypes_profile} object.
+#' @param ... Ignored.
+#' @rdname profile
+#' @method barplot atypes_profile
+#' @S3method barplot atypes_profile
+barplot.atypes_profile <- function(height, ...) {
+ p <- ggplot(melt(height), aes(X2, value))
+ p <- p + geom_bar(stat = "identity") + facet_grid(X1 ~ .)
+ p <- p + ylim(c(0, 100)) + xlab("Variable") + ylab("Percentile")
+ p
+}
+
+
+
#' @param x An \code{atypes_profile} object.
#' @param y Ignored.
-#' @param ... Ignored.
#' @rdname profile
#' @method plot atypes_profile
#' @S3method plot atypes_profile
plot.atypes_profile <- function(x, y = NULL, ...) {
- p <- ggplot(melt(x), aes(X2, value))
- p <- p + geom_bar(stat = "identity") + facet_grid(X1 ~ .)
- p <- p + ylim(c(0, 100)) + xlab("Variable") + ylab("Percentile")
- p
+ barplot.atypes_profile(x, ...)
}
-
More information about the Archetypes-commits
mailing list