[Archetypes-commits] r68 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Apr 9 16:57:31 CEST 2014
Author: manuel
Date: 2014-04-09 16:57:30 +0200 (Wed, 09 Apr 2014)
New Revision: 68
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/archetypes-class.R
pkg/R/archetypes-kit-blocks.R
pkg/R/archetypes-step.R
pkg/R/skeletonplot.R
pkg/man/archetypes-generics.Rd
pkg/man/archetypes.Rd
pkg/man/archetypesFamily.Rd
pkg/man/archmap.Rd
pkg/man/archmap_projections.Rd
pkg/man/as.archetypes.Rd
pkg/man/barplot.archetypes.Rd
pkg/man/bestModel.Rd
pkg/man/coef.Rd
pkg/man/extract.Rd
pkg/man/fitted.Rd
pkg/man/kappa.Rd
pkg/man/movieplot.Rd
pkg/man/nparameters.Rd
pkg/man/panorama.archetypes.Rd
pkg/man/parameters.Rd
pkg/man/pcplot.Rd
pkg/man/pcplot.archetypes.Rd
pkg/man/pcplot.default.Rd
pkg/man/predict.Rd
pkg/man/residuals.Rd
pkg/man/robustArchetypes.Rd
pkg/man/rss.Rd
pkg/man/screeplot.stepArchetypes.Rd
pkg/man/simplexplot.Rd
pkg/man/skeletonplot.Rd
pkg/man/stepArchetypes.Rd
pkg/man/summary.Rd
pkg/man/weightedArchetypes.Rd
pkg/man/weights.Rd
pkg/man/xyplot.Rd
pkg/man/xyplot.archetypes.Rd
pkg/man/xyplot.robustArchetypes.Rd
pkg/man/xyplot.stepArchetypes.Rd
pkg/man/xyplot.weightedArchetypes.Rd
Log:
sp
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/DESCRIPTION 2014-04-09 14:57:30 UTC (rev 68)
@@ -28,6 +28,7 @@
'archetypes-class.R'
'archetypes-kit-blocks.R'
'archetypes-kit.R'
+ 'archetypes-map.R'
'archetypes-movie.R'
'archetypes-panorama.R'
'pcplot.R'
@@ -38,6 +39,5 @@
'archetypes-weighted.R'
'archetypes-xyplot.R'
'memento.R'
+ 'simplex-pot.R'
'skeletonplot.R'
- 'archetypes-map.R'
- 'simplex-pot.R'
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/NAMESPACE 2014-04-09 14:57:30 UTC (rev 68)
@@ -49,6 +49,8 @@
export(weightedArchetypes)
export(xyplot)
exportMethods(parameters)
+import(methods)
+import(nnls)
importFrom(graphics,barplot)
importFrom(modeltools,parameters)
importFrom(stats,coef)
Modified: pkg/R/archetypes-class.R
===================================================================
--- pkg/R/archetypes-class.R 2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/R/archetypes-class.R 2014-04-09 14:57:30 UTC (rev 68)
@@ -1,251 +1,253 @@
-#' @include generics.R
-{}
-
-
-
-#' Archetypes object constructor
-#'
-#' @param object The archetypes; a \eqn{p \times m} matrix, see
-#' \code{\link{parameters}}.
-#' @param k The number of archetypes;
-#' @param alphas The coefficients; a \eqn{n \times p} matrix, see
-#' \code{\link{coef}}.
-#' @param rss The residual sum of squares; see \code{\link{rss.archetypes}}.
-#' @param iters The number of iterations to the convergence.
-#' @param call The call of the \code{\link{archetypes}} function.
-#' @param history If \code{saveHistory} set then an environment with the
-#' archetypes object for each execution step;
-#' @param kappas The kappas for each system of linear equations.
-#' @param betas The data coefficients; a \eqn{p \times n} matrix.
-#' @param zas The temporary archetypes.
-#' @param family The archetypes family.
-#' @param familyArgs Additional arguments for family blocks.
-#' @param residuals The residuals.
-#' @param weights The data weights.
-#' @param reweights The data reweights.
-#' @param scaling The scaling parameters of the data.
-#'
-#' @return A list with an element for each parameter and class attribute
-#' \code{archetypes}.
-#'
-#' @family archetypes
-#'
-#' @export
-as.archetypes <- function(object, k, alphas, rss, iters = NULL, call = NULL,
- history = NULL, kappas = NULL, betas = NULL, zas = NULL,
- family = NULL, familyArgs = NULL, residuals = NULL,
- weights = NULL, reweights = NULL, scaling = NULL) {
-
- return(structure(list(archetypes = object,
- k = k,
- alphas = alphas,
- rss = rss,
- iters = iters,
- kappas = kappas,
- betas = betas,
- zas = zas,
- call = call,
- history = history,
- family = family,
- familyArgs = familyArgs,
- residuals = residuals,
- weights = weights,
- reweights = reweights,
- scaling = scaling),
- class = c(family$class, 'archetypes')))
-}
-
-
-
-setOldClass(c("archetypes"))
-
-
-#' @S3method print archetypes
-print.archetypes <- function(x, full = TRUE, ...) {
- if ( full ) {
- cat('Archetypes object\n\n')
- cat(paste(deparse(x$call), collapse = '\n'), '\n\n')
- }
-
- cat('Convergence after', x$iters, 'iterations\n')
- cat('with RSS = ', rss(x), '.\n', sep = '')
-}
-
-
-
-#' Return fitted data
-#'
-#' Returns the approximated data.
-#'
-#' @param object An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Matrix with approximated data.
-#' @method fitted archetypes
-#' @rdname fitted
-#'
-#' @importFrom stats fitted
-#' @S3method fitted archetypes
-fitted.archetypes <- function(object, ...) {
- t(t(object$archetypes) %*% t(object$alphas))
-}
-
-
-
-#' Return fitted archetypes
-#'
-#' @param object An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Matrix with \eqn{k} archetypes.
-#'
-#' @aliases parameters-methods
-#' @aliases parameters,archetypes-method
-#'
-#' @importFrom modeltools parameters
-#' @exportMethod parameters
-setMethod('parameters', signature = c(object = 'archetypes'),
-function(object, ...) {
- object$archetypes
-})
-
-
-
-#' Return coefficients
-#'
-#' @param object An \code{archetypes} object.
-#' @param type Return alpha or beta coefficients.
-#' @param ... Ignored.
-#' @return Coefficient matrix.
-#' @method coef archetypes
-#' @rdname coef
-#'
-#' @importFrom stats coef
-#' @S3method coef archetypes
-coef.archetypes <- function(object, type = c('alphas', 'betas'), ...) {
- type <- match.arg(type)
- object[[type]]
-}
-
-
-
-#' Return residuals
-#'
-#' @param object An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Matrix with residuals.
-#' @method residuals archetypes
-#' @rdname residuals
-#'
-#' @importFrom stats residuals
-#' @S3method residuals archetypes
-residuals.archetypes <- function(object, ...) {
- object$residuals
-}
-
-
-
-#' Return residual sum of squares
-#'
-#' @param object An \code{archetypes} object.
-#' @param type Return scaled, single or global RSS.
-#' @param ... Ignored.
-#' @return Residual sum of squares.
-#' @method rss archetypes
-#' @rdname rss
-#'
-#' @S3method rss archetypes
-rss.archetypes <- function(object, type = c('scaled', 'single', 'global'), ...) {
- type <- match.arg(type)
- resid <- residuals(object)
-
- switch(type,
- scaled = object$rss,
- single = apply(resid, 1, object$family$normfn),
- global = object$family$normfn(resid) / nrow(resid))
-}
-
-
-
-#' Return weights
-#'
-#' @param object An \code{archetypes} object.
-#' @param type Return global weights (weighted archetypes) or
-#' weights calculated during the iterations (robust archetypes).
-#' @param ... Ignored.
-#' @return Vector of weights.
-#' @method weights archetypes
-#' @rdname weights
-#'
-#' @importFrom stats weights
-#' @S3method weights archetypes
-weights.archetypes <- function(object, type = c('weights', 'reweights'), ...) {
- type <- match.arg(type)
- object[[type]]
-}
-
-
-
-#' Return kappa
-#'
-#' @param z An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return A vector of kappas.
-#' @rdname kappa
-#'
-#' @method kappa archetypes
-#' @S3method kappa archetypes
-kappa.archetypes <- function(z, ...) {
- return(z$kappas)
-}
-
-
-
-#' Return number of archetypes
-#'
-#' @param object An \code{archetypes} object.
-#' @param ... Ignored.
-#' @return Number of archetypes.
-#' @rdname nparameters
-#'
-#' @method nparameters archetypes
-#' @S3method nparameters archetypes
-nparameters.archetypes <- function(object, ...) {
- return(object$k)
-}
-
-
-
-#' Predict method for archetypal analysis fits
-#'
-#' This method produces predicted alpha coefficients for new data.
-#'
-#' @param object An \code{archetypes} object; currently only
-#' \code{\link[=archetypesFamily]{original}}-family objects.
-#' @param newdata A data frame with data for which to
-#' predict the alpha coefficients.
-#' @param ... Ignored.
-#' @return The predict alpha coefficients.
-#' @rdname predict
-#'
-#' @method predict archetypes
-#' @S3method predict archetypes
-predict.archetypes <- function(object, newdata, ...) {
- stopifnot(object$family$which == "original")
-
- scale <- object$scaling
-
- ## HACK: use blocks!
- x <- t(newdata)
- x <- x - scale$mean
- x <- x / scale$sd
- x <- object$family$dummyfn(x, ...)
-
- zs <- t(parameters(object))
- zs <- zs - scale$mean
- zs <- zs / scale$sd
- zs <- rbind(zs, 200)
-
- alphas <- matrix(NA, ncol = ncol(x), nrow = ncol(coef(object)))
- alphas <- object$family$alphasfn(alphas, zs, x)
-
- t(alphas)
-}
+#' @include generics.R
+{}
+
+
+
+#' Archetypes object constructor
+#'
+#' @param object The archetypes; a \eqn{p \times m} matrix, see
+#' \code{\link{parameters}}.
+#' @param k The number of archetypes;
+#' @param alphas The coefficients; a \eqn{n \times p} matrix, see
+#' \code{\link{coef}}.
+#' @param rss The residual sum of squares; see \code{\link{rss.archetypes}}.
+#' @param iters The number of iterations to the convergence.
+#' @param call The call of the \code{\link{archetypes}} function.
+#' @param history If \code{saveHistory} set then an environment with the
+#' archetypes object for each execution step;
+#' @param kappas The kappas for each system of linear equations.
+#' @param betas The data coefficients; a \eqn{p \times n} matrix.
+#' @param zas The temporary archetypes.
+#' @param family The archetypes family.
+#' @param familyArgs Additional arguments for family blocks.
+#' @param residuals The residuals.
+#' @param weights The data weights.
+#' @param reweights The data reweights.
+#' @param scaling The scaling parameters of the data.
+#'
+#' @return A list with an element for each parameter and class attribute
+#' \code{archetypes}.
+#'
+#' @family archetypes
+#'
+#' @export
+as.archetypes <- function(object, k, alphas, rss, iters = NULL, call = NULL,
+ history = NULL, kappas = NULL, betas = NULL, zas = NULL,
+ family = NULL, familyArgs = NULL, residuals = NULL,
+ weights = NULL, reweights = NULL, scaling = NULL) {
+
+ return(structure(list(archetypes = object,
+ k = k,
+ alphas = alphas,
+ rss = rss,
+ iters = iters,
+ kappas = kappas,
+ betas = betas,
+ zas = zas,
+ call = call,
+ history = history,
+ family = family,
+ familyArgs = familyArgs,
+ residuals = residuals,
+ weights = weights,
+ reweights = reweights,
+ scaling = scaling),
+ class = c(family$class, 'archetypes')))
+}
+
+
+
+setOldClass(c("archetypes"))
+
+
+#' @S3method print archetypes
+print.archetypes <- function(x, full = TRUE, ...) {
+ if ( full ) {
+ cat('Archetypes object\n\n')
+ cat(paste(deparse(x$call), collapse = '\n'), '\n\n')
+ }
+
+ cat('Convergence after', x$iters, 'iterations\n')
+ cat('with RSS = ', rss(x), '.\n', sep = '')
+}
+
+
+
+#' Return fitted data
+#'
+#' Returns the approximated data.
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with approximated data.
+#' @method fitted archetypes
+#' @rdname fitted
+#'
+#' @importFrom stats fitted
+#' @S3method fitted archetypes
+fitted.archetypes <- function(object, ...) {
+ t(t(object$archetypes) %*% t(object$alphas))
+}
+
+
+
+#' Return fitted archetypes
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with \eqn{k} archetypes.
+#'
+#' @aliases parameters-methods
+#' @aliases parameters,archetypes-method
+#'
+#' @import methods
+#' @importFrom modeltools parameters
+#' @exportMethod parameters
+#' @rdname parameters
+setMethod('parameters', signature = c(object = 'archetypes'),
+function(object, ...) {
+ object$archetypes
+})
+
+
+
+#' Return coefficients
+#'
+#' @param object An \code{archetypes} object.
+#' @param type Return alpha or beta coefficients.
+#' @param ... Ignored.
+#' @return Coefficient matrix.
+#' @method coef archetypes
+#' @rdname coef
+#'
+#' @importFrom stats coef
+#' @S3method coef archetypes
+coef.archetypes <- function(object, type = c('alphas', 'betas'), ...) {
+ type <- match.arg(type)
+ object[[type]]
+}
+
+
+
+#' Return residuals
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Matrix with residuals.
+#' @method residuals archetypes
+#' @rdname residuals
+#'
+#' @importFrom stats residuals
+#' @S3method residuals archetypes
+residuals.archetypes <- function(object, ...) {
+ object$residuals
+}
+
+
+
+#' Return residual sum of squares
+#'
+#' @param object An \code{archetypes} object.
+#' @param type Return scaled, single or global RSS.
+#' @param ... Ignored.
+#' @return Residual sum of squares.
+#' @method rss archetypes
+#' @rdname rss
+#'
+#' @S3method rss archetypes
+rss.archetypes <- function(object, type = c('scaled', 'single', 'global'), ...) {
+ type <- match.arg(type)
+ resid <- residuals(object)
+
+ switch(type,
+ scaled = object$rss,
+ single = apply(resid, 1, object$family$normfn),
+ global = object$family$normfn(resid) / nrow(resid))
+}
+
+
+
+#' Return weights
+#'
+#' @param object An \code{archetypes} object.
+#' @param type Return global weights (weighted archetypes) or
+#' weights calculated during the iterations (robust archetypes).
+#' @param ... Ignored.
+#' @return Vector of weights.
+#' @method weights archetypes
+#' @rdname weights
+#'
+#' @importFrom stats weights
+#' @S3method weights archetypes
+weights.archetypes <- function(object, type = c('weights', 'reweights'), ...) {
+ type <- match.arg(type)
+ object[[type]]
+}
+
+
+
+#' Return kappa
+#'
+#' @param z An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return A vector of kappas.
+#' @rdname kappa
+#'
+#' @method kappa archetypes
+#' @S3method kappa archetypes
+kappa.archetypes <- function(z, ...) {
+ return(z$kappas)
+}
+
+
+
+#' Return number of archetypes
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored.
+#' @return Number of archetypes.
+#' @rdname nparameters
+#'
+#' @method nparameters archetypes
+#' @S3method nparameters archetypes
+nparameters.archetypes <- function(object, ...) {
+ return(object$k)
+}
+
+
+
+#' Predict method for archetypal analysis fits
+#'
+#' This method produces predicted alpha coefficients for new data.
+#'
+#' @param object An \code{archetypes} object; currently only
+#' \code{\link[=archetypesFamily]{original}}-family objects.
+#' @param newdata A data frame with data for which to
+#' predict the alpha coefficients.
+#' @param ... Ignored.
+#' @return The predict alpha coefficients.
+#' @rdname predict
+#'
+#' @method predict archetypes
+#' @S3method predict archetypes
+predict.archetypes <- function(object, newdata, ...) {
+ stopifnot(object$family$which == "original")
+
+ scale <- object$scaling
+
+ ## HACK: use blocks!
+ x <- t(newdata)
+ x <- x - scale$mean
+ x <- x / scale$sd
+ x <- object$family$dummyfn(x, ...)
+
+ zs <- t(parameters(object))
+ zs <- zs - scale$mean
+ zs <- zs / scale$sd
+ zs <- rbind(zs, 200)
+
+ alphas <- matrix(NA, ncol = ncol(x), nrow = ncol(coef(object)))
+ alphas <- object$family$alphasfn(alphas, zs, x)
+
+ t(alphas)
+}
Modified: pkg/R/archetypes-kit-blocks.R
===================================================================
--- pkg/R/archetypes-kit-blocks.R 2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/R/archetypes-kit-blocks.R 2014-04-09 14:57:30 UTC (rev 68)
@@ -168,6 +168,7 @@
#' @param C The archetypes matrix.
#' @param d The data matrix.
#' @return Recalculated alpha.
+#' @import nnls
#' @noRd
nnls.alphasfn <- function(coefs, C, d, ...) {
#require(nnls)
@@ -185,6 +186,7 @@
#' @param C The archetypes matrix.
#' @param d The data matrix.
#' @return Recalculated alpha.
+#' @import nnls
#' @noRd
snnls.alphasfn <- function(coefs, C, d, ...) {
#require(nnls)
@@ -214,6 +216,7 @@
#' @param C The data matrix.
#' @param d The archetypes matrix.
#' @return Recalculated beta.
+#' @import nnls
#' @noRd
nnls.betasfn <- nnls.alphasfn
@@ -224,6 +227,7 @@
#' @param C The data matrix.
#' @param d The archetypes matrix.
#' @return Recalculated beta.
+#' @import nnls
#' @noRd
snnls.betasfn <- snnls.alphasfn
Modified: pkg/R/archetypes-step.R
===================================================================
--- pkg/R/archetypes-step.R 2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/R/archetypes-step.R 2014-04-09 14:57:30 UTC (rev 68)
@@ -1,229 +1,230 @@
-#' @include archetypes-class.R
-{}
-
-
-#' Run archetypes algorithm repeatedly
-#'
-#' @param ... Passed to the specific archetype function.
-#' @param k A vector of integers passed in turn to the k argument of
-#' \code{\link{archetypes}}.
-#' @param nrep For each value of \code{k} run \code{\link{archetypes}}
-#' \code{nrep} times.
-#' @param method Archetypes function to use, typically
-#' \code{\link{archetypes}}, \code{\link{weightedArchetypes}} or
-#' \code{\link{robustArchetypes}},
-#' @param verbose Show progress during exection.
-#'
-#' @return A list with \code{k} elements and class attribute
-#' \code{stepArchetypes}. Each element is a list of class
-#' \code{repArchetypes} with \code{nrep} elements; only for internal
-#' usage.
-#'
-#' @seealso \code{\link{archetypes}}
-#'
-#' @examples
-#' \dontrun{
-#' data(skel)
-#' skel2 <- subset(skel, select=-Gender)
-#' as <- stepArchetypes(skel2, k=1:5, verbose=FALSE)
-#'
-#' ## Residual sum of squares curve:
-#' screeplot(as)
-#'
-#' ## Select three archetypes and from that the best
-#' ## recurrence:
-#' a3 <- bestModel(as[[3]])
-#' }
-#'
-#' @export
-stepArchetypes <- function(..., k, nrep = 3, method = archetypes, verbose = TRUE) {
-
- mycall <- match.call()
- as <- list()
-
- for ( i in 1:length(k) ) {
- as[[i]] <- list()
- class(as[[i]]) <- 'repArchetypes'
-
- for ( j in seq_len(nrep) ) {
- if ( verbose )
- cat('\n*** k=', k[i], ', rep=', j, ':\n', sep='')
-
- as[[i]][[j]] <- method(..., k=k[i])
- }
- }
-
- return(structure(as, class='stepArchetypes', call=mycall))
-}
-
-
-
-setOldClass('repArchetypes')
-setOldClass('stepArchetypes')
-
-
-
-#' Extract method
-#'
-#' An extraction on a \code{stepArchetypes} object returns again a
-#' \code{stepArchetypes} object.
-#'
-#' @param x A \code{stepArchetypes} object.
-#' @param i The indizes to extract.
-#' @return A \code{stepArchetypes} object containing only the parts
-#' defined in \code{i}.
-#' @method [ stepArchetypes
-#' @rdname extract
-#'
-#' @S3method "[" stepArchetypes
-`[.stepArchetypes` <- function(x, i) {
- y <- unclass(x)[i]
- attributes(y) <- attributes(x)
-
- return(y)
-}
-
-
-
-#' @S3method print stepArchetypes
-print.stepArchetypes <- function(x, ...) {
- cat('StepArchetypes object\n\n')
- cat(deparse(attr(x, 'call')), '\n')
-}
-
-
-
-#' 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)
- }
-}
-
-
-
-#' @aliases parameters,stepArchetypes-method
-#' @rdname parameters
-#' @importFrom modeltools parameters
-#' @exportMethod parameters
-setMethod('parameters', signature = c(object = 'stepArchetypes'),
-function(object, ...) {
- lapply(object, parameters)
-})
-
-
-
-#' @rdname nparameters
-#' @method nparameters stepArchetypes
-#'
-#' @S3method nparameters stepArchetypes
-nparameters.stepArchetypes <- function(object, ...) {
- return(sapply(object, nparameters))
-}
-
-
-
-#' @rdname rss
-#' @method rss stepArchetypes
-#'
-#' @S3method rss stepArchetypes
-rss.stepArchetypes <- function(object, ...) {
- ret <- t(sapply(object, rss))
- rownames(ret) <- paste('k', nparameters(object), sep='')
- return(ret)
-}
-
-
-
-#' Return best model
-#'
-#' @param object An \code{archetypes} object.
-#' @param ... Ignored
-#'
-#' @rdname bestModel
-#' @method bestModel stepArchetypes
-#'
-#' @S3method bestModel stepArchetypes
-bestModel.stepArchetypes <- function(object, ...) {
- zsmin <- lapply(object, bestModel)
-
- if ( length(zsmin) == 1 )
- return(zsmin[[1]])
- else
- return(zsmin)
-}
-
-
-
-#' @S3method print repArchetypes
-print.repArchetypes <- function(x, ...) {
- for ( i in seq_along(x) )
- print(x[[i]], ...)
-
- invisible(x)
-}
-
-
-
-#' @aliases parameters,repArchetypes-method
-#' @rdname parameters
-#' @importFrom modeltools parameters
-#' @exportMethod parameters
-setMethod('parameters', signature = signature(object = 'repArchetypes'),
-function(object, ...) {
- lapply(object, parameters)
-})
-
-
-
-#' @rdname rss
-#' @method rss repArchetypes
-#'
-#' @S3method rss repArchetypes
-rss.repArchetypes <- function(object, ...) {
- ret <- sapply(object, rss)
- names(ret) <- paste('r', seq_along(ret), sep='')
-
- return(ret)
-}
-
-
-
-#' @rdname nparameters
-#' @method nparameters repArchetypes
-#'
-#' @S3method nparameters repArchetypes
-nparameters.repArchetypes <- function(object, ...) {
- nparameters(object[[1]])
-}
-
-
-
-#' @rdname bestModel
-#' @method bestModel repArchetypes
-#'
-#' @S3method bestModel repArchetypes
-bestModel.repArchetypes <- function(object, ...) {
- m <- which.min(rss(object))
-
- if ( length(m) == 0 )
- return(object[[1]])
- else
- return(object[[m]])
-}
-
-
+#' @include archetypes-class.R
+{}
+
+
+#' Run archetypes algorithm repeatedly
+#'
+#' @param ... Passed to the specific archetype function.
+#' @param k A vector of integers passed in turn to the k argument of
+#' \code{\link{archetypes}}.
+#' @param nrep For each value of \code{k} run \code{\link{archetypes}}
+#' \code{nrep} times.
+#' @param method Archetypes function to use, typically
+#' \code{\link{archetypes}}, \code{\link{weightedArchetypes}} or
+#' \code{\link{robustArchetypes}},
+#' @param verbose Show progress during exection.
+#'
+#' @return A list with \code{k} elements and class attribute
+#' \code{stepArchetypes}. Each element is a list of class
+#' \code{repArchetypes} with \code{nrep} elements; only for internal
+#' usage.
+#'
+#' @seealso \code{\link{archetypes}}
+#'
+#' @examples
+#' \dontrun{
+#' data(skel)
+#' skel2 <- subset(skel, select=-Gender)
+#' as <- stepArchetypes(skel2, k=1:5, verbose=FALSE)
+#'
+#' ## Residual sum of squares curve:
+#' screeplot(as)
+#'
+#' ## Select three archetypes and from that the best
+#' ## recurrence:
+#' a3 <- bestModel(as[[3]])
+#' }
+#'
+#' @export
+stepArchetypes <- function(..., k, nrep = 3, method = archetypes, verbose = TRUE) {
+
+ mycall <- match.call()
+ as <- list()
+
+ for ( i in 1:length(k) ) {
+ as[[i]] <- list()
+ class(as[[i]]) <- 'repArchetypes'
+
+ for ( j in seq_len(nrep) ) {
+ if ( verbose )
+ cat('\n*** k=', k[i], ', rep=', j, ':\n', sep='')
+
+ as[[i]][[j]] <- method(..., k=k[i])
+ }
+ }
+
+ return(structure(as, class='stepArchetypes', call=mycall))
+}
+
+
+#' @import methods
+setOldClass('repArchetypes')
+setOldClass('stepArchetypes')
+
+
+
+#' Extract method
+#'
+#' An extraction on a \code{stepArchetypes} object returns again a
+#' \code{stepArchetypes} object.
+#'
+#' @param x A \code{stepArchetypes} object.
+#' @param i The indizes to extract.
+#' @return A \code{stepArchetypes} object containing only the parts
+#' defined in \code{i}.
+#' @method [ stepArchetypes
+#' @rdname extract
+#'
+#' @S3method "[" stepArchetypes
+`[.stepArchetypes` <- function(x, i) {
+ y <- unclass(x)[i]
+ attributes(y) <- attributes(x)
+
+ return(y)
+}
+
+
+
+#' @S3method print stepArchetypes
+print.stepArchetypes <- function(x, ...) {
+ cat('StepArchetypes object\n\n')
+ cat(deparse(attr(x, 'call')), '\n')
+}
+
+
+
+#' 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)
+ }
+}
+
+
+
+#' @rdname parameters
+#' @aliases parameters,stepArchetypes-method
+#' @importFrom modeltools parameters
+#' @import methods
+#' @exportMethod parameters
+setMethod('parameters', signature = c(object = 'stepArchetypes'),
+function(object, ...) {
+ lapply(object, parameters)
+})
+
+
+
+#' @rdname nparameters
+#' @method nparameters stepArchetypes
+#'
+#' @S3method nparameters stepArchetypes
+nparameters.stepArchetypes <- function(object, ...) {
+ return(sapply(object, nparameters))
+}
+
+
+
+#' @rdname rss
+#' @method rss stepArchetypes
+#'
+#' @S3method rss stepArchetypes
+rss.stepArchetypes <- function(object, ...) {
+ ret <- t(sapply(object, rss))
+ rownames(ret) <- paste('k', nparameters(object), sep='')
+ return(ret)
+}
+
+
+
+#' Return best model
+#'
+#' @param object An \code{archetypes} object.
+#' @param ... Ignored
+#'
+#' @rdname bestModel
+#' @method bestModel stepArchetypes
+#'
+#' @S3method bestModel stepArchetypes
+bestModel.stepArchetypes <- function(object, ...) {
+ zsmin <- lapply(object, bestModel)
+
+ if ( length(zsmin) == 1 )
+ return(zsmin[[1]])
+ else
+ return(zsmin)
+}
+
+
+
+#' @S3method print repArchetypes
+print.repArchetypes <- function(x, ...) {
+ for ( i in seq_along(x) )
+ print(x[[i]], ...)
+
+ invisible(x)
+}
+
+
+
+#' @rdname parameters
+#' @aliases parameters,repArchetypes-method
+#' @importFrom modeltools parameters
+#' @exportMethod parameters
+setMethod('parameters', signature = signature(object = 'repArchetypes'),
+function(object, ...) {
+ lapply(object, parameters)
+})
+
+
+
+#' @rdname rss
+#' @method rss repArchetypes
+#'
+#' @S3method rss repArchetypes
+rss.repArchetypes <- function(object, ...) {
+ ret <- sapply(object, rss)
+ names(ret) <- paste('r', seq_along(ret), sep='')
+
+ return(ret)
+}
+
+
+
+#' @rdname nparameters
+#' @method nparameters repArchetypes
+#'
+#' @S3method nparameters repArchetypes
+nparameters.repArchetypes <- function(object, ...) {
+ nparameters(object[[1]])
+}
+
+
+
+#' @rdname bestModel
+#' @method bestModel repArchetypes
+#'
+#' @S3method bestModel repArchetypes
+bestModel.repArchetypes <- function(object, ...) {
+ m <- which.min(rss(object))
+
+ if ( length(m) == 0 )
+ return(object[[1]])
+ else
+ return(object[[m]])
+}
+
+
Modified: pkg/R/skeletonplot.R
===================================================================
--- pkg/R/skeletonplot.R 2014-04-09 13:27:05 UTC (rev 67)
+++ pkg/R/skeletonplot.R 2014-04-09 14:57:30 UTC (rev 68)
@@ -1,221 +1,224 @@
-
-
-#' Skeleton plot.
-#'
-#' Displays a schematic representation of skeleton data as available
-#' in dataset \code{\link{skel}}.
-#'
-#' @param x Matrix or data.frame of skeleton data.
-#' @param skel.width Reference width for instance calculation.
-#' @param skel.height Reference height for instance calculation.
-#' @param base.radius Base radius for points.
-#' @param xlab The x label of the plot.
-#' @param ylab The y label of the plot.
-#' @param xlim Numeric of length 2 giving the x limits for the plot.
-#' @param ylim Numeric of length 2 giving the y limits for the plot.
-#' @param col Color of the different parts of the skeleton.
-#' @param mtext Label archetypes.
-#' @param skel.lwd Line width of skeleton.
-#' @param ... Passed to underlying canvas plot function.
-#' @return List of skeleton instances.
-#' @export
-#' @seealso \code{\link{skel}}
-skeletonplot <- function(x, skel.width = 100, skel.height = 200,
- ylab = 'Height (cm)', base.radius = 2, xlab = '',
- xlim = (nrow(x)*c(0,skel.width)), ylim = c(0, skel.height),
- col = c(hipbase = 1, hip = 1, shoulderbase = 1, shoulder = 1,
- head = 1, elbow = 2, wrist = 3, knee = 4, ankle = 5,
- chest = 'purple1', pelvis = 6),
- mtext = TRUE, skel.lwd = 1, ...) {
-
- if ( is.data.frame(x) )
- x <- as.matrix(x)
-
- ### Skeleton model (see human-modelling.vsd):
- model.y <- c(ankle=0, knee=7, wrist=12, hip=13, hipbase=15, pelvis=16,
- waist=17, elbow=20, chest=24, shoulder=26,
- shoulderbase=27, head=30, top=32) / 32
-
- model.x.leg <- c(hip=1, knee=1.5, ankle=1)
- model.x.spine <- c(hipbase=0, pelvis=0, waist=0, chest=0, shoulderbase=0, head=0, top=0)
- model.x.arm <- c(shoulder=1, elbow=5/3, wrist=5/3)
-
-
- ### One skeleton instance:
- one.skeleton <- function(x, x0=0) {
-
- # Calculate instance:
- skel.y <- model.y * x['Height']
-
- skel.x.leg <- model.x.leg * (x['Bitro'] / 2)
- skel.x.spine <- model.x.spine
- skel.x.arm <- model.x.arm * (x['Biac'] / 2)
- skel.x <- c(skel.x.leg, skel.x.spine, skel.x.arm)
-
- skel.circles <- base.radius + c(hipbase=0, hip=0, shoulderbase=0,
- shoulder=0, head=0,
- elbow=unname(x['ElbowDiam'])/2,
- wrist=unname(x['WristDiam'])/2,
- knee=unname(x['KneeDiam'])/2,
- ankle=unname(x['AnkleDiam'])/2) / 2
-
- skel.rectangles <- rbind(chest=c(width=unname(x['ChestDiam']),
- height=unname(x['ChestDp'])),
- pelvis=c(width=unname(x['Biil']), height=0))
-
-
- # Plot it:
- lines(x0 + skel.x.spine, skel.y[names(skel.x.spine)],
- lwd=skel.lwd, ...)
-
- lines(x0 + c(skel.x.spine['hipbase'], skel.x.leg),
- c(skel.y['hipbase'], skel.y[names(skel.x.leg)]),
- lwd=skel.lwd, ...)
- lines(x0 + c(skel.x.spine['hipbase'], -skel.x.leg),
- c(skel.y['hipbase'], skel.y[names(skel.x.leg)]),
- lwd=skel.lwd, ...)
-
- lines(x0 + c(skel.x.spine['shoulderbase'], skel.x.arm),
- c(skel.y['shoulderbase'], skel.y[names(skel.x.arm)]),
- lwd=skel.lwd, ...)
- lines(x0 + c(skel.x.spine['shoulderbase'], -skel.x.arm),
- c(skel.y['shoulderbase'], skel.y[names(skel.x.arm)]),
- lwd=skel.lwd, ...)
-
- d <- names(skel.circles)
- symbols(x0 + c(skel.x[d], -skel.x[d]), rep(skel.y[d], 2),
- circles=rep(skel.circles[d], 2), fg=col[d], bg=col[d],
- xlim=xlim, ylim=ylim, inches=FALSE, add=TRUE)
-
- d <- rownames(skel.rectangles)
- symbols(rep(x0, length(d)), skel.y[d],
- rectangles=skel.rectangles, fg=col[d],
- xlim=xlim, ylim=ylim, inches=FALSE, add=TRUE, lwd=2)
-
- return(list(x0=x0, x=skel.x, y=skel.y,
- circles=skel.circles, rectangles=skel.rectangles))
- }
-
-
- ### Plot:
- nskels <- nrow(x)
-
- yticks <- seq(ylim[1], ylim[2], by=20)
- xticks <- seq(xlim[1], xlim[2], by=50)
-
- # Canvas:
- plot(1, xlim=xlim, ylim=ylim, type='n', xlab=xlab, ylab=ylab, axes=FALSE, ...)
- axis(1, at=xticks)
- axis(2, at=yticks)
- box()
-
- # Gridlines:
- abline(v=xticks, col='lightgray', lty='dotted', lwd=1)
- abline(h=yticks, col='lightgray', lty='dotted', lwd=1)
-
- # Skeletons:
- skels <- list()
-
- for ( i in 1:nskels ) {
- x0 <- (i-1) * skel.width + (skel.width/2)
-
- skels[[i]] <- one.skeleton(x[i,], x0=x0)
-
- if ( mtext )
- mtext(paste('Archetype', i), side=3, line=0, at=x0)
- }
-
-
- invisible(skels)
-}
-
-
-
-#' Annotated skeleton plot.
-#'
-#' Displays a generic skeleton with annotations explaining the
-#' measurements available in data set \code{\link{skel}}.
-#'
-#' @return Generic skeleton instance.
-#' @rdname skeletonplot
-#'
-#' @export
-jd <- function() {
- jd <- rbind(c(AnkleDiam=13.9, KneeDiam=18.8, WristDiam=10.5, Bitro=32.0,
- Biil=27.8, ElbowDiam=13.4, ChestDiam=28.0, ChestDp=15,
- Biac=38.8, Height=171.1))
-
- s <- skeletonplot(jd, skel.height=190,
- mtext=FALSE, xlim=c(-100,200), skel.lwd=1)[[1]]
-
-
- ### Annotate JD:
- acol <- gray(0.5)
-
- annotation1 <- function(text, x, y, alen=10) {
- ws <- 0
-
- arrows(x, y, x+alen, y,
- length=0.1, code=1, col=acol, lwd=1)
-
- text(labels=text,
- x=x+alen+ws, y=y, pos=ifelse(alen<0,2,4), col=acol)
- }
-
- annotation2 <- function(text, xb, xd, y, offset, alen=-30) {
- x0 <- xb - xd
- x1 <- xb + xd
-
- lines(c(x0, x0), c(y, y+offset), col=acol)
- lines(c(x1, x1), c(y, y+offset), col=acol)
-
- arrows(x0, y+offset, x1, y+offset,
- code=3, length=0.1, col=acol)
-
- lines(c(x0, x0+alen), c(y+offset, y+offset), col=acol)
-
- text(labels=text, x=x0+alen, y=y+offset, pos=2, col=acol)
- }
-
-
- annotation1('Diameter of ankle',
- s$x0 + s$x['ankle'] + s$circles['ankle'],
- s$y['ankle'])
-
- annotation1('Diameter of knee',
- s$x0 + s$x['knee'] + s$circles['knee'],
- s$y['knee'])
-
- annotation1('Diameter of wrist',
- s$x0 + s$x['wrist'] + s$circles['wrist'],
- s$y['wrist'])
-
- annotation1('Diameter of pelvis\n(biiliac)',
- s$x0 + s$x['pelvis'] + s$rectangles['pelvis','width']/2,
- s$y['pelvis'], alen=25)
-
- annotation1('Diameter of elbow',
- s$x0 + s$x['elbow'] + s$circles['elbow'],
- s$y['elbow'])
-
- annotation1('Height',
- s$x0 + s$x['top'],
- s$y['top'])
-
- annotation2('Diameter between\nhips (bitrochanteric)',
- s$x0, s$x['hip'], s$y['hip'] - s$circles['hip'], -15)
-
- annotation2('Diameter between\nshoulders (biacromial)',
- s$x0, s$x['shoulder'], s$y['shoulder'] + s$circles['shoulder'], 10)
-
- annotation2('Diameter of chest',
- s$x0, s$rectangles['chest','width']/2,
- s$y['chest'] - s$rectangles['chest','height']/2, -5)
-
- annotation1('Depth of chest',
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/archetypes -r 68
More information about the Archetypes-commits
mailing list