diff --git a/R/CLUSTERING-ddist2.R b/R/CLUSTERING-ddist2.R index 7beddeaf..114c87d5 100644 --- 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 index 18f32cac..35899fbc 100644 --- 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 index 273be06a..79589164 100644 --- 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)