[Analogue-commits] r200 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jan 13 16:54:06 CET 2011
Author: gsimpson
Date: 2011-01-13 16:54:06 +0100 (Thu, 13 Jan 2011)
New Revision: 200
Modified:
pkg/R/cma.R
pkg/R/dissimilarities.R
pkg/R/mat.R
pkg/R/summary.cma.R
Log:
adds cma methods for mat and predict.mat objects
Modified: pkg/R/cma.R
===================================================================
--- pkg/R/cma.R 2011-01-13 15:52:33 UTC (rev 199)
+++ pkg/R/cma.R 2011-01-13 15:54:06 UTC (rev 200)
@@ -22,7 +22,7 @@
cma.analog <- function(object, cutoff, prob = c(0.01, 0.025, 0.05), ...)
{
- if (!inherits(object, "analog"))
+ if (!inherits(object, "analog"))
stop("Use only with \"analog\" objects")
if(missing(cutoff)) {
if(is.null(object$train))
@@ -41,7 +41,7 @@
close <- apply(object$analogs, 2, function(x) {
x <- sort(x)
x <- x[x <= cutoff]})
- if(length(close) == 0)
+ if(length(close) == 0)
close <- vector(mode = "list", length = length(nams))
each.analogs <- sapply(close, length)
names(each.analogs) <- names(close) <- nams
@@ -56,21 +56,135 @@
class = "cma")
}
-print.cma <- function(x,
- digits = min(3, getOption("digits") - 4), ...)
- {
+## First attempt at this method - we want k to select the k closest analogues
+## but also allow cutoff for later when mat will work with a threshold
+`cma.mat` <- function(object, k, cutoff, prob = c(0.01, 0.025, 0.05), ...) {
+ if (!inherits(object, "mat"))
+ stop("Use only with \"mat\" objects")
+ n.samp <- ncol(object$Dij)
+ nams <- colnames(object$Dij)
+ K <- !missing(k)
+ CUT <- !missing(cutoff)
+ if(K && CUT)
+ stop("Only one of \"k\" and \"cutoff\" may be used, not both.")
+ if(!K && !CUT) {
+ k <- getK(object)
+ cutoff <- NULL
+ K <- TRUE
+ }
+ if(K) {
+ FUN <- function(x, ks) {
+ x <- sort(x)
+ x[ks]
+ }
+ close <- vector(mode = "list", length = n.samp)
+ ks <- seq_len(k)
+ for(i in seq_along(close)) {
+ close[[i]] <- FUN(object$Dij[, i], ks)
+ }
+ each.analogs <- sapply(close, length)
+ names(each.analogs) <- names(close) <- nams
+ } else {
+ FUN <- function(x, cutoff) {
+ x <- sort(x)
+ x <- x[x <= cutoff]
+ }
+ close <- apply(object$Dij, 2, FUN, cutoff = cutoff)
+ each.analogs <- sapply(close, length)
+ k <- NULL
+ names(each.analogs) <- names(close) <- nams
+ }
+ if(length(close) == 0) {
+ close <- vector(mode = "list", length = length(nams))
+ names(each.analogs) <- names(close) <- nams
+ }
+ .call <- match.call()
+ .call[[1]] <- as.name("cma")
+ structure(list(close = close,
+ call = .call, cutoff = cutoff, k = k,
+ quant = quantile(dissim(object), probs = prob,
+ na.rm = TRUE),
+ prob = prob,
+ method = object$method,
+ n.analogs = each.analogs),
+ class = "cma")
+}
+## First attempt at this method - we want k to select the k closest analogues
+## but also allow cutoff for later when mat will work with a threshold
+`cma.predict.mat` <- function(object, k, cutoff, prob = c(0.01, 0.025, 0.05),
+ ...) {
+ if (!inherits(object, "predict.mat"))
+ stop("Use only with \"predict.mat\" objects")
+ n.samp <- ncol(object$Dij)
+ nams <- colnames(object$Dij)
+ K <- !missing(k)
+ CUT <- !missing(cutoff)
+ if(K && CUT)
+ stop("Only one of \"k\" and \"cutoff\" may be used, not both.")
+ if(!K && !CUT) {
+ k <- getK(object)
+ cutoff <- NULL
+ K <- TRUE
+ }
+ if(K) {
+ FUN <- function(x, ks) {
+ x <- sort(x)
+ x[ks]
+ }
+ close <- vector(mode = "list", length = n.samp)
+ ks <- seq_len(k)
+ for(i in seq_along(close)) {
+ close[[i]] <- FUN(object$Dij[, i], ks)
+ }
+ each.analogs <- sapply(close, length)
+ names(each.analogs) <- names(close) <- nams
+ } else {
+ FUN <- function(x, cutoff) {
+ x <- sort(x)
+ x <- x[x <= cutoff]
+ }
+ close <- apply(object$Dij, 2, FUN, cutoff = cutoff)
+ each.analogs <- sapply(close, length)
+ k <- NULL
+ names(each.analogs) <- names(close) <- nams
+ }
+ if(length(close) == 0) {
+ close <- vector(mode = "list", length = length(nams))
+ names(each.analogs) <- names(close) <- nams
+ }
+ .call <- match.call()
+ .call[[1]] <- as.name("cma")
+ structure(list(close = close,
+ call = .call, cutoff = cutoff, k = k,
+ quant = NULL,
+ prob = prob,
+ method = object$method,
+ n.analogs = each.analogs),
+ class = "cma")
+}
+
+print.cma <- function(x, digits = min(3, getOption("digits") - 4), ...) {
method <- x$method
.call <- deparse(x$call)
cat("\n")
writeLines(strwrap("Close modern analogues of fossil samples",
prefix = "\t"))
cat(paste("\nCall:", .call, "\n"))
- cat(paste("\nDissimilarity:", method, "\n"))
- cat(paste("Cutoff:", round(x$cutoff, digits), "\n\n"))
+ cat(paste("\nDissimilarity:", method, "\n\n"))
+ if(is.null(x$k)) {
+ cat(" k: Not supplied\n\n")
+ } else {
+ cat(paste(" k:", x$k[1], "\n"))
+ }
+ if(is.null(x$cutoff)) {
+ cat("Cutoff: Not supplied\n\n")
+ } else {
+ cat(paste("Cutoff:", round(x$cutoff, digits), "\n\n"))
+ }
writeLines(strwrap("Number of analogues per fossil sample:",
prefix = "\t"))
cat("\n")
print(x$n.analogs, digits = digits)
cat("\n")
invisible(x)
- }
+}
Modified: pkg/R/dissimilarities.R
===================================================================
--- pkg/R/dissimilarities.R 2011-01-13 15:52:33 UTC (rev 199)
+++ pkg/R/dissimilarities.R 2011-01-13 15:54:06 UTC (rev 200)
@@ -28,3 +28,9 @@
class(retval) <- "dissimilarities"
retval
}
+
+`dissimilarities.mat` <- function(object, ...) {
+ retval <- as.vector(object$analogs)
+ class(retval) <- "dissimilarities"
+ retval
+}
Modified: pkg/R/mat.R
===================================================================
--- pkg/R/mat.R 2011-01-13 15:52:33 UTC (rev 199)
+++ pkg/R/mat.R 2011-01-13 15:54:06 UTC (rev 200)
@@ -31,8 +31,9 @@
method <- match.arg(method)
dis <- distance(x, method = method, ...) # calculate the distances
## new speed-ups might leave dimnames on dis
- dimnames(dis) <- NULL
+ ##dimnames(dis) <- NULL
x <- as.matrix(x) # convert to matrix for speed (?)
+ nams <- dimnames(x)
dimnames(x) <- NULL # clear the dimnames for speed (?)
## insure sample under test is not chosen as analogue for itself
diag(dis) <- NA
@@ -58,6 +59,7 @@
colnames(Werror) <- colnames(error) <- site.nams
rownames(Wmeans) <- rownames(means) <- 1:(dims[1] -1)
rownames(Werror) <- rownames(error) <- 1:(dims[1] -1)
+ dimnames(x) <- nams
## return results
retval <- structure(list(standard = list(est = means, resid = error,
rmsep = RMSE, avg.bias = bias, max.bias = max.bias,
Modified: pkg/R/summary.cma.R
===================================================================
--- pkg/R/summary.cma.R 2011-01-13 15:52:33 UTC (rev 199)
+++ pkg/R/summary.cma.R 2011-01-13 15:54:06 UTC (rev 200)
@@ -1,36 +1,28 @@
###########################################################################
## ##
-## cma - extracts and formats close modern analogues ##
+## summary.cma - extracts and formats close modern analogues ##
## ##
-## Created : 27-May-2006 ##
-## Author : Gavin Simpson ##
-## Version : 0.1 ##
-## Last modified : 27-May-2006 ##
+## Author : Gavin L. Simpson ##
## ##
-## ARGUMENTS: ##
-## object - object for method dispatch. Only class 'analog'. ##
-## ##
###########################################################################
-summary.cma <- function(object, ...)
- {
+summary.cma <- function(object, ...) {
close <- lapply(object$close, function(x) {
- if(length(x) == 0) {
- res <- NA
- names(res) <- "None"
- return(res)
- } else {
- return(x)}
+ if(length(x) == 0) {
+ res <- NA
+ names(res) <- "None"
+ return(res)
+ } else {
+ return(x)}
})
each.analogs <- sapply(close, length)
max.analogs <- max(each.analogs)
samples <- distances <- matrix(NA, nrow = max.analogs,
- ncol = length(close))
- for (i in seq(along = close))
- {
+ ncol = length(close))
+ for (i in seq(along = close)) {
len <- each.analogs[i]
distances[1:len,i] <- close[[i]]
samples[1:len,i] <- names(close[[i]])
- }
+ }
rownames(distances) <- rownames(samples) <- 1:max.analogs
colnames(distances) <- colnames(samples) <- names(close)
object <- list(close = object$close,
@@ -42,12 +34,11 @@
samples = samples)
class(object) <- "summary.cma"
return(object)
- }
+}
print.summary.cma <- function(x,
- digits = min(3, getOption("digits") - 4),
- ...)
- {
+ digits = min(3, getOption("digits") - 4),
+ ...) {
class(x) <- "cma"
print(x)
cat("\nDistances:\n\n")
@@ -55,4 +46,4 @@
cat("\nSamples:\n\n")
print(x$samples, quote = FALSE, right = TRUE, na.print = "")
invisible(x)
- }
+}
More information about the Analogue-commits
mailing list