Merge branch on distances as square matrices

Several functions accept either 'dist' object or raw data from
which they calculate distances. If users supply their distances
as square matrices (or data frames) these may be taken as raw
data and we end up calculateing distances of distances. Most
such functions had a test for symmetric square matrices that
probably hold distances, but now these tests are made more
consistent and robust.

Should fix problems like issue #147

R/adonis2.R

@@ -34,14 +34,17 @@
     TOL <- 1e-7
     Terms <- terms(formula, data = data)
     lhs <- formula[[2]]
-    lhs <- eval(lhs, data, parent.frame()) # to force evaluation
+    lhs <- eval(lhs, .GlobalEnv, environment(formula)) # to force evaluation
     formula[[2]] <- NULL                # to remove the lhs
     rhs.frame <- model.frame(formula, data, drop.unused.levels = TRUE) # to get the data frame of rhs
     rhs <- model.matrix(formula, rhs.frame) # and finally the model.matrix
     rhs <- rhs[,-1, drop=FALSE] # remove the (Intercept) to get rank right
     rhs <- scale(rhs, scale = FALSE, center = TRUE) # center
     qrhs <- qr(rhs)
     ## handle dissimilarities
+    if ((is.matrix(lhs) || is.data.frame(lhs)) &&
+        isSymmetric(unname(as.matrix(lhs))))
+        lhs <- as.dist(lhs)
     if (inherits(lhs, "dist")) {
         if (any(lhs < -TOL))
             stop("dissimilarities must be non-negative")

R/anosim.R

@@ -5,12 +5,13 @@
     EPS <- sqrt(.Machine$double.eps)
     if (inherits(dat, "dist")) 
         x <- dat
-    else if (is.matrix(dat) && nrow(dat) == ncol(dat) && all(dat[lower.tri(dat)] == 
-        t(dat)[lower.tri(dat)])) {
-        x <- dat
+    else if ((is.matrix(dat) || is.data.frame(dat)) &&
+             isSymmetric(unname(as.matrix(dat)))) {
+        x <- as.dist(dat)
         attr(x, "method") <- "user supplied square matrix"
     }
-    else x <- vegdist(dat, method = distance)
+    else
+        x <- vegdist(dat, method = distance)
     if (any(x < -sqrt(.Machine$double.eps)))
         warning("some dissimilarities are negative -- is this intentional?")
     sol <- c(call = match.call())

R/bioenv.default.R

@@ -70,8 +70,8 @@ function (comm, env, method = "spearman", index = "bray", upto = ncol(env),
         index <- attr(comdis, "method")
         if (is.null(index))
             index <- "unspecified"
-    } else if (is.matrix(comm) && nrow(comm) == ncol(comm) &&
-             isTRUE(all.equal(comm, t(comm)))) {
+    } else if ((is.matrix(comm) || is.data.frame(comm)) &&
+               isSymmetric(unname(as.matrix(comm)))) {
         comdis <- as.dist(comm)
         index <- "supplied square matrix"
     } else {

R/dbrda.R

@@ -19,6 +19,9 @@
     ## mysteriously at this point.
     X <- eval(formula[[2]], envir=environment(formula),
               enclos = globalenv())
+    if ((is.matrix(X) || is.data.frame(X)) &&
+               isSymmetric(unname(as.matrix(X))))
+        X <- as.dist(X)
     if (!inherits(X, "dist")) {
         comm <- X
         dfun <- match.fun(dfun)

R/metaMDS.R

@@ -27,8 +27,8 @@
         if (is.null(attr(dis, "method")))
             attr(dis, "method") <- "user supplied"
         wascores <- FALSE
-    } else if (length(dim(comm) == 2) && ncol(comm) == nrow(comm) &&
-                all(comm == t(comm))) {
+    } else if ((is.matrix(comm) || is.data.frame(comm)) &&
+               isSymmetric(unname(as.matrix(comm)))) {
         dis <- as.dist(comm)
         attr(dis, "method") <- "user supplied"
         wascores <- FALSE

R/metaMDSdist.R

@@ -5,8 +5,9 @@
 {
     ## metaMDSdist should get a raw data matrix, but if it gets a
     ## 'dist' object return that unchanged and quit silently.
-    if (inherits(comm, "dist")  || ncol(comm) == nrow(comm) &&
-        all(comm == t(comm)))
+    if (inherits(comm, "dist")  ||
+        ((is.matrix(comm) || is.data.frame(comm)) &&
+             isSymmetric(unname(as.matrix(comm)))))
         return(comm)
     distname <- deparse(substitute(distfun))
     distfun <- match.fun(distfun)

R/monoMDS.R

@@ -6,9 +6,9 @@
              sratmax=0.99999, ...) 
 {
     ## Check that 'dist' are distances or a symmetric square matrix
-    if (!(inherits(dist, "dist") || (is.matrix(dist) || is.data.frame(dist))
-          && ncol(dist) == nrow(dist)
-          && isTRUE(all.equal(dist[lower.tri(dist)], t(dist)[lower.tri(dist)]))))
+    if (!(inherits(dist, "dist") ||
+              ((is.matrix(dist) || is.data.frame(dist)) &&
+                   isSymmetric(unname(as.matrix(dist))))))
         stop("'dist' must be a distance object (class \"dist\") or a symmetric square matrix")
     if (any(dist < -sqrt(.Machine$double.eps), na.rm = TRUE))
         warning("some dissimilarities are negative -- is this intentional?")

R/mrpp.R

@@ -14,8 +14,8 @@
     }
     if (inherits(dat, "dist")) 
         dmat <- dat
-    else if (is.matrix(dat) && nrow(dat) == ncol(dat) && all(dat[lower.tri(dat)] == 
-        t(dat)[lower.tri(dat)])) {
+    else if ((is.matrix(dat) || is.data.frame(dat)) &&
+               isSymmetric(unname(as.matrix(dat)))) {
         dmat <- dat
         attr(dmat, "method") <- "user supplied square matrix"
     }

R/pcnm.R

@@ -1,15 +1,11 @@
 `pcnm` <- function(dis, threshold, w, dist.ret = FALSE) {
-    if (!inherits(dis, "dist")) {
-        dims <- dim(dis)
-        if (length(unique(dims)) >1) {
-            stop("'dis' does not appear to be a square distance matrix.")
-        }
+    ## square matrix to dist
+    if ((is.matrix(dis) || is.data.frame(dis)) &&
+        isSymmetric(unname(as.matrix(dis))))
         dis <- as.dist(dis)
-    }
+    if (!inherits(dis, "dist"))
+        stop("'dis' does not appear to be distances")
     EPS <- sqrt(.Machine$double.eps)
-    wa.old <- options(warn = -1)
-    on.exit(options(wa.old))
-    dis <- as.dist(dis)
     if (missing(threshold)) {
         threshold <- max(spantree(dis)$dist)
     }