Fix hierarchical clustering

asardaes · Jul 2, 2024 · ff5202b · ff5202b
1 parent 67fe7b3
commit ff5202b
Show file tree

Hide file tree

Showing 3 changed files with 18 additions and 8 deletions.
diff --git a/R/CLUSTERING-ddist2.R b/R/CLUSTERING-ddist2.R
@@ -188,7 +188,7 @@ ddist2 <- function(distance, control, lower_triangular_only = FALSE) {
                 return(ret(dm, class = "pairdist"))
             }
             else if (lower_triangular_only && inherits(dm, "dist")) {
-                return(ret(dm, class = "dist", Size = length(x)))
+                return(ret(dm, class = "dist"))
             }
             else {
                 return(ret(base::as.matrix(dm), class = "crossdist"))
@@ -245,7 +245,7 @@ ddist2 <- function(distance, control, lower_triangular_only = FALSE) {
                 )
 
                 if (lower_triangular_only && inherits(dm, "dist")) {
-                    return(ret(dm, class = "dist", Size = length(x)))
+                    return(ret(dm, class = "dist"))
                 }
                 else {
                     return(ret(base::as.matrix(dm), class = "crossdist"))

diff --git a/R/CLUSTERING-tsclust.R b/R/CLUSTERING-tsclust.R
@@ -608,10 +608,10 @@ tsclust <- function(series = NULL, type = "partitional", k = 2L, ...,
 
             # Take advantage of the function I defined for the partitional methods
             # Which can do calculations in parallel if appropriate
-            distfun <- ddist2(distance = distance, control = control)
+            distfun <- ddist2(distance = distance, control = control, control$symmetric)
 
             if (!is.null(distmat)) {
-                if (nrow(distmat) != length(series) || ncol(distmat) != length(series))
+                if (inherits(distmat, "matrix") && nrow(distmat) != length(series) || ncol(distmat) != length(series))
                     stop("Dimensions of provided cross-distance matrix don't correspond to ",
                          "length of provided data")
                 if (trace) cat("\nDistance matrix provided...\n")
@@ -631,10 +631,11 @@ tsclust <- function(series = NULL, type = "partitional", k = 2L, ...,
             # --------------------------------------------------------------------------------------
 
             if (trace) cat("Performing hierarchical clustering...\n")
-            if (!base::isSymmetric(base::as.matrix(distmat)))
+            if (inherits(distmat, "matrix") && !base::isSymmetric(base::as.matrix(distmat)))
                 warning("Distance matrix is not symmetric, ",
                         "and hierarchical clustering assumes it is ",
                         "(it ignores the upper triangular).")
+
             if (is.character(method)) {
                 # Using hclust
                 hc <- lapply(method, function(method) {
@@ -652,6 +653,9 @@ tsclust <- function(series = NULL, type = "partitional", k = 2L, ...,
             # --------------------------------------------------------------------------------------
 
             if (trace) cat("Extracting centroids...\n\n")
+
+            distmat <- methods::as(distmat, "Distmat")
+
             RET <- lapply(k, function(k) {
                 lapply(hc, function(hc) {
                     # cutree and corresponding centroids
@@ -696,7 +700,7 @@ tsclust <- function(series = NULL, type = "partitional", k = 2L, ...,
                                  k = as.integer(k),
                                  cluster = cluster,
                                  centroids = centroids,
-                                 distmat = distmat,
+                                 distmat = distmat$distmat,
 
                                  dots = dots,
                                  args = args,

diff --git a/R/S4-DistmatLowerTriangular.R b/R/S4-DistmatLowerTriangular.R
@@ -69,6 +69,10 @@ NULL
 #'
 setMethod("show", "DistmatLowerTriangular", function(object) { methods::show(object$distmat) }) # nocov
 
+lti <- function(i) {
+    if (is.logical(i)) which(i) else i
+}
+
 #' @rdname DistmatLowerTriangular-generics
 #' @aliases [,DistmatLowerTriangular,ANY,ANY,ANY
 #'
@@ -80,11 +84,13 @@ setMethod("show", "DistmatLowerTriangular", function(object) { methods::show(obj
 setMethod(`[`, "DistmatLowerTriangular", function(x, i, j, ...) {
     if (missing(j)) {
         stopifnot(inherits(i, "matrix"), ncol(i) == 2L)
-        j <- i[, 2L]
-        i <- i[, 1L]
+        j <- lti(i[, 2L])
+        i <- lti(i[, 1L])
         drop <- TRUE
     }
     else {
+        i <- lti(i)
+        j <- lti(j)
         out_dim <- c(length(i), length(j))
         out_dimnames <- list(i, j)
         combinations <- expand.grid(i = i, j = j)