The R Project SVN R-packages

library(cluster)
options(digits = 6)
data(votes.repub)

## IGNORE_RDIFF_BEGIN
source(system.file("test-tools.R", package = "cluster"), keep.source = FALSE)
## IGNORE_RDIFF_END
## -> showProc.time() ...  & doExtras

agn1 <- agnes(votes.repub, metric = "manhattan", stand = TRUE)
summary(agn1)
Dvr <- daisy(votes.repub)
agn2 <- agnes(Dvr, method = "complete")
summary(agn2)
## almost same:
(ag2. <- agnes(Dvr, method= "complete", keep.diss=FALSE))
ag22  <- agnes(votes.repub, method= "complete", keep.diss=FALSE,keep.data=FALSE)
stopifnot(identical(agn2[-5:-6], ag2.[-5:-6]),
          identical(Dvr, daisy(votes.repub)), # DUP=FALSE (!)
          identical(ag2.[-6], ag22[-6])
         )

data(agriculture)
summary(agnes(agriculture))

data(ruspini)
summary(ar0 <- agnes(ruspini, keep.diss=FALSE, keep.data=FALSE))
summary(ar1 <- agnes(ruspini, metric = "manhattan"))
str(ar1)

showProc.time()

summary(ar2 <- agnes(ruspini, metric="manhattan", method = "weighted"))
print  (ar3 <- agnes(ruspini, metric="manhattan", method = "flexible",
                     par.method = 0.5))
stopifnot(all.equal(ar2[1:4], ar3[1:4], tol=1e-12))

showProc.time()

## Small example, testing "flexible" vs "single"
i8 <- -c(1:2, 9:10)
dim(agr8 <- agriculture[i8, ])
i5 <- -c(1:2, 8:12)
dim(agr5 <- agriculture[i5, ])

##' Check equivalence of method "flexible" (par=...)  with one
##' of ("single", "complete", "weighted")
chk <- function(d, method=c("single", "complete", "weighted"),
                trace.lev = 1,
                iC = -(6:7), # <- not using 'call' and 'method' for comparisons
                doplot = FALSE, tol = 1e-12)
{
    if(!inherits(d, "dist")) d <- daisy(d, "manhattan")
    method <- match.arg(method)
    par.meth <- list("single" =  c(.5, .5, 0, -.5),
                     "complete"= c(.5, .5, 0, +.5),
                     "weighted"= c(0.5))
    a.s <- agnes(d, method=method, trace.lev=trace.lev)
    ## From theory, this should give the same, but it does not --- why ???
    a.f <- agnes(d, method="flex", par.method = par.meth[[method]], trace.lev=trace.lev)

    if(doplot) {
    op <- par(mfrow = c(2,2), mgp = c(1.6, 0.6, 0), mar = .1 + c(4,4,2,1))
        on.exit(par(op))
        plot(a.s)
        plot(a.f)
    }
    structure(all.equal(a.s[iC], a.f[iC], tolerance = tol),
              fits = list(s = a.s, f = a.f))
}

chk(agr5, trace = 3)

stopifnot(chk(agr5), chk(agr5, "complete", trace = 2), chk(agr5, "weighted"),
          chk(agr8), chk(agr8, "complete"), chk(agr8, "weighted", trace.lev=2),
          chk(agriculture), chk(agriculture, "complete"),
          chk(ruspini), chk(ruspini, "complete"), chk(ruspini, "weighted"))

showProc.time()

## an invalid "flexible" case - now must give error early:
x <- rbind(c( -6, -9), c(  0, 13),
           c(-15,  6), c(-14,  0), c(12,-10))
(dx <- daisy(x, "manhattan"))
a.x <- tryCatch(agnes(dx, method="flexible", par = -.2),
                error = function(e)e)
##  agnes(method=6, par.method=*) lead to invalid merge; step 4, D(.,.)=-26.1216
if(!inherits(a.x, "error")) stop("invalid 'par' in \"flexible\" did not give error")
if(!all(vapply(c("par[.]method", "merge"), grepl, NA, x=a.x$message)))
   stop("error message did not contain expected words")