# R/CLUSTERING-partitional-fuzzy.R In dtwclust: Time Series Clustering Along with Optimizations for the Dynamic Time Warping Distance

#### Defines functions fuzzy_objective

```# ==================================================================================================
# Fuzzy objective function
# ==================================================================================================

fuzzy_objective <- function(u, distmat, m) { sum(u^m * distmat^2) }

# ==================================================================================================
# Partitional/fuzzy clustering
# ==================================================================================================

#' @importFrom stats runif
#'
pfclust <- function (x, k, family, control, fuzzy = FALSE, cent, trace = FALSE, args) {
N <- length(x)
k <- as.integer(k)
if (is.null(control\$version)) control\$version <- 2L # nocov

if (fuzzy && cent == "fcm") {
cluster <- matrix(0, N, k)
cluster[, -1L] <- stats::runif(N * (k - 1L)) / (k - 1L)
cluster[, 1L] <- 1 - apply(cluster[, -1L, drop = FALSE], 1L, sum)
centroids <- quoted_call(
family@allcent,
x = x,
cl_id = cluster,
k = k,
cl_old = cluster,
dots = subset_dots(args\$cent, family@allcent)
)
}
else {
id_cent <- sample(N, k)
centroids <- x[id_cent]
if (inherits(control\$distmat, "Distmat")) control\$distmat\$id_cent <- id_cent
cluster <- integer(N)
}

iter <- 1L
clustold <- cluster
objective_old <- Inf
dmi <- cbind(1L:N, integer(N))
while (iter <= control\$iter.max) {
distmat <- quoted_call(family@dist, x = x, centroids = centroids, dots = args\$dist)
cluster <- family@cluster(distmat = distmat, m = control\$fuzziness)
if (control\$version < 2L) { # nocov start
centroids <- quoted_call(
family@allcent,
x = x,
cl_id = cluster,
k = k,
cent = centroids,
cl_old = clustold,
dots = subset_dots(args\$cent, family@allcent)
)
} # nocov end

# NOTE: a custom fuzzy centroid function that doesn't want to rely on the usual fuzzy
# objective would not be able to customize this convergence criterion...
if (fuzzy && cent != "fcmdd") {
objective <- fuzzy_objective(cluster, distmat = distmat, m = control\$fuzziness)
if (trace) {
cat("Iteration ", iter, ": ",
"Objective = ",
formatC(objective, width = 6, format = "f"),
"\n", sep = "")
}
if (abs(objective - objective_old) < control\$delta) {
if (trace) cat("\n")
break
}
objective_old <- objective
}
else {
dmi[, 2L] <- if (cent != "fcmdd") cluster else apply(cluster, 1L, which.max)
changes <- sum(dmi[, 2L] != clustold)
if (trace) {
td <- sum(distmat[dmi])
txt <- paste(changes, format(td), sep = " / ")
cat("Iteration ", iter, ": ",
"Changes / Distsum = ",
formatC(txt, width = 12, format = "f"),
"\n", sep = "")
}
if (changes == 0L) {
if (trace) cat("\n")
break
}
}
iter <- iter + 1L
if (control\$version > 1L)
centroids <- quoted_call(
family@allcent,
x = x,
cl_id = cluster,
k = k,
cent = centroids,
cl_old = clustold,
dots = subset_dots(args\$cent, family@allcent)
)

clustold <- dmi[, 2L]
}

if (iter > control\$iter.max) {
if (trace) cat("\n") # nocov
converged <- FALSE
iter <- control\$iter.max
}
else {
converged <- TRUE
}

if (control\$version < 2L) { # nocov start
distmat <- quoted_call(family@dist, x = x, centroids = centroids, dots = args\$dist)
cluster <- family@cluster(distmat = distmat, m = control\$fuzziness)
} # nocov end

if (fuzzy) {
fcluster <- cluster
cluster <- max.col(-distmat, "first")
rownames(fcluster) <- names(x)
colnames(fcluster) <- paste0("cluster_", 1L:k)
}
else {
fcluster <- matrix(NA_real_)
}

cldist <- base::as.matrix(distmat[cbind(1L:N, cluster)])
clusinfo <- compute_clusinfo(k, cluster, cldist) # UTILS-utils.R

names(centroids) <- NULL
if (inherits(control\$distmat, "Distmat")) {
attr(centroids, "series_id") <- base::unname(control\$distmat\$id_cent)
}

# return
list(k = k,
cluster = cluster,
fcluster = fcluster,
centroids = centroids,
clusinfo = clusinfo,
cldist = cldist,
iter = iter,
converged = converged)
}
```

## Try the dtwclust package in your browser

Any scripts or data that you put into this service are public.

dtwclust documentation built on March 7, 2023, 7:49 p.m.