Revision 9fbfbef539cfc60884f6828c62f0aa328335a0b1 authored by Toni Giorgino on 08 January 2008, 00:00:00 UTC, committed by Gabor Csardi on 08 January 2008, 00:00:00 UTC
1 parent da02fed
dtw.R
###############################################################
#                                                             #
#   (c) Toni Giorgino <toni.giorgino@gmail.com>           #
#       Laboratory for Biomedical Informatics                 #
#       University of Pavia - Italy                           #
#       www.labmedinfo.org                                    #
#                                                             #
#   $Id: dtw.R 83 2008-01-04 00:25:00Z tonig$
#                                                             #
###############################################################

##
## Frontend stuff, including coercing shorthand types
##

dtw <-
function(x, y=NULL,
dist.method="Euclidean",
step.pattern="s",
window.type="none",
keep.internals=FALSE,
distance.only=FALSE,
... ) {

lm <- NULL;

## if matrix given
if(is.null(y)) {
if(!is.matrix(x))
stop("Single argument requires a global cost matrix");

lm <- x;
} else {
## two ts. given TODO handle multivariate
## as.numeric handles ts, but not multivariates
lm <- proxy::dist(x,y,method=dist.method);
}

## Now we have a function
wfun<-.canonicalizeWindowFunction(window.type);

## Now we have a step pattern
dir<-.canonicalizeStepPattern(step.pattern);

## shorthand names
n <- nrow(lm);
m <- ncol(lm);

## perform the computation
gcm <- globalCostMatrix(lm, step.matrix=dir,
window.function=wfun, ...);

jmin <- m;

## remember size
gcm$N <- n; gcm$M <- m;

## store call
gcm$call <- match.call(); ## result: distance (add to existing list gcm?) gcm$distance <- gcmcostMatrix[n,jmin]; ## alignment valid? if(is.na(gcmdistance))
stop("No warping paths exists that is allowed by costraints");

if(!distance.only) {
## perform the backtrack
mapping <- backtrack(jmin,gcm);

## append to existing list gcm, for now
## perhaps replace by attr()
gcm$index1 <- mapping$index1;
gcm$index2 <- mapping$index2;
}

## delete sizey intermediate steps
if(!keep.internals) {
gcm$costMatrix<-NULL; gcm$directionMatrix<-NULL;
} else {
gcm\$localCostMatrix <- lm;
}

## if a dtw object is to be sponsored:
class(gcm) <- "dtw";

return(gcm);
}

##############################
## OO class check
is.dtw <- function(d) {
return(inherits(d,"dtw"));
}

## Replace  char window.type  with appropriate
## windowing FUNCTION

.canonicalizeWindowFunction <- function(w) {
if(is.function(w)) {
return(w);
}

# else
wt<-pmatch(w,c("none","sakoechiba","itakura","slantedband"));
if(is.na(wt)) {
stop("Ambiguous or unsupported char argument for window.type");
}

wfun<-switch(wt,
noWindow,
sakoeChibaWindow,
itakuraWindow,
slantedBandWindow);

return(wfun);
}

## Replace char step.pattern with matrix equivalent
## Step patterns: \delta i, \delta j, cost
##                                      ...
## all deltas MUST be positive (otherwise we violate monotonicity)

.canonicalizeStepPattern <- function(step.pattern) {
if(is.stepPattern(step.pattern))
return(step.pattern);

# else
sp<-pmatch(step.pattern,c("symmetric","asymmetric"));
if(is.na(sp))
stop("Ambiguous or unsupported char argument for step.pattern");

dir<-switch(sp,
symmetric1,
asymmetric);

return(dir);
}



Computing file changes ...