Merge pull request #162 from tidymodels/native-ordering

Author: EmilHvitfeldt

DESCRIPTION

@@ -39,6 +39,7 @@ Suggests:
     ClusterR,
     clustMixType (>= 0.3-5),
     covr,
+    klaR,
     knitr,
     modeldata (>= 1.0.0),
     RcppHungarian,

NAMESPACE

@@ -65,6 +65,8 @@ S3method(update,k_means)
 export("%>%")
 export(.hier_clust_fit_stats)
 export(.k_means_fit_ClusterR)
+export(.k_means_fit_clustMixType)
+export(.k_means_fit_klaR)
 export(.k_means_fit_stats)
 export(augment)
 export(cluster_metric_set)

NEWS.md

@@ -18,6 +18,8 @@
 
 * The klaR engine as been added to `k_means()`. This engine allows fitting of k-modes models. (#63)
 
+* Cluster reordering is now done at the fitting time, not the extraction and prediction time. (#154)
+
 # tidyclust 0.1.2
 
 * The cluster specification methods for `generics::tune_args()` and `generics::tunable()` are now registered unconditionally (#115).

R/extract_fit_summary.R

@@ -46,23 +46,21 @@ extract_fit_summary.workflow <- function(object, ...) {
 
 #' @export
 extract_fit_summary.kmeans <- function(object, ..., prefix = "Cluster_") {
-  reorder_clusts <- order(unique(object$cluster))
-  names <- paste0(prefix, seq_len(nrow(object$centers)))
+  names <- paste0(prefix, seq_along(object$size))
   names <- factor(names)
 
   cluster_asignments <- factor(
-    names[reorder_clusts][object$cluster],
+    names[object$cluster],
     levels = levels(names)
   )
 
-  centroids <- object$centers[reorder_clusts, , drop = FALSE]
-  centroids <- tibble::as_tibble(centroids)
+  centroids <- tibble::as_tibble(object$centers)
 
   list(
     cluster_names = names,
     centroids = centroids,
-    n_members = object$size[unique(object$cluster)],
-    sse_within_total_total = object$withinss[unique(object$cluster)],
+    n_members = object$size,
+    sse_within_total_total = object$withinss,
     sse_total = object$totss,
     orig_labels = unname(object$cluster),
     cluster_assignments = cluster_asignments
@@ -73,23 +71,21 @@ extract_fit_summary.kmeans <- function(object, ..., prefix = "Cluster_") {
 extract_fit_summary.KMeansCluster <- function(object,
                                               ...,
                                               prefix = "Cluster_") {
-  reorder_clusts <- order(unique(object$cluster))
   names <- paste0(prefix, seq_len(nrow(object$centroids)))
   names <- factor(names)
 
   cluster_asignments <- factor(
-    names[reorder_clusts][object$clusters],
+    names[object$clusters],
     levels = levels(names)
   )
 
-  centroids <- object$centroids[reorder_clusts, , drop = FALSE]
-  centroids <- tibble::as_tibble(centroids)
+  centroids <- tibble::as_tibble(object$centroids)
 
   list(
     cluster_names = names,
     centroids = centroids,
-    n_members = as.integer(object$obs_per_cluster[unique(object$cluster)]),
-    sse_within_total_total = object$WCSS_per_cluster[unique(object$cluster)],
+    n_members = as.integer(object$obs_per_cluster),
+    sse_within_total_total = as.numeric(object$WCSS_per_cluster),
     sse_total = object$total_SSE,
     orig_labels = object$clusters,
     cluster_assignments = cluster_asignments
@@ -100,23 +96,21 @@ extract_fit_summary.KMeansCluster <- function(object,
 extract_fit_summary.kproto <- function(object,
                                        ...,
                                        prefix = "Cluster_") {
-  reorder_clusts <- order(unique(object$cluster))
   names <- paste0(prefix, seq_len(nrow(object$centers)))
   names <- factor(names)
 
   cluster_asignments <- factor(
-    names[reorder_clusts][object$cluster],
+    names[object$cluster],
     levels = levels(names)
   )
 
-  centroids <- object$centers[reorder_clusts, , drop = FALSE]
-  centroids <- tibble::as_tibble(centroids)
+  centroids <- tibble::as_tibble(object$centers)
 
   list(
     cluster_names = names,
     centroids = centroids,
-    n_members = as.integer(object$size[unique(object$cluster)]),
-    sse_within_total_total = object$withinss[unique(object$cluster)],
+    n_members = as.integer(object$size),
+    sse_within_total_total = object$withinss,
     sse_total = object$tot.withinss,
     orig_labels = seq_len(length(table(object$cluster))),
     cluster_assignments = cluster_asignments
@@ -127,23 +121,21 @@ extract_fit_summary.kproto <- function(object,
 extract_fit_summary.kmodes <- function(object,
                                        ...,
                                        prefix = "Cluster_") {
-  reorder_clusts <- order(unique(object$cluster))
   names <- paste0(prefix, seq_len(nrow(object$modes)))
   names <- factor(names)
 
   cluster_asignments <- factor(
-    names[reorder_clusts][object$cluster],
+    names[object$cluster],
     levels = levels(names)
   )
 
-  centroids <- object$modes[reorder_clusts, , drop = FALSE]
-  centroids <- tibble::as_tibble(centroids)
+  centroids <- tibble::as_tibble(object$modes)
 
   list(
     cluster_names = names,
     centroids = centroids,
-    n_members = as.integer(object$size[unique(object$cluster)]),
-    sse_within_total_total = object$withinss[unique(object$cluster)],
+    n_members = as.integer(object$size),
+    sse_within_total_total = object$withinss,
     sse_total = object$tot.withinss,
     orig_labels = seq_len(length(table(object$cluster))),
     cluster_assignments = cluster_asignments

R/k_means.R

@@ -131,8 +131,8 @@ check_args.k_means <- function(object) {
 
 #' Simple Wrapper around ClusterR kmeans
 #'
-#' This wrapper runs `ClusterR::KMeans_rcpp` and adds column names to the
-#' `centroids` field.
+#' This wrapper runs `ClusterR::KMeans_rcpp()` and adds column names to the
+#' `centroids` field. And reorders the clusters.
 #'
 #' @param data matrix or data frame
 #' @param clusters the number of clusters
@@ -160,7 +160,8 @@ check_args.k_means <- function(object) {
 #'   obs_per_cluster, between.SS_DIV_total.SS
 #' @keywords internal
 #' @export
-.k_means_fit_ClusterR <- function(data, clusters,
+.k_means_fit_ClusterR <- function(data,
+                                  clusters,
                                   num_init = 1,
                                   max_iters = 100,
                                   initializer = "kmeans++",
@@ -190,14 +191,21 @@ check_args.k_means <- function(object) {
     tol_optimal_init = tol_optimal_init,
     seed = seed
   )
+
   colnames(res$centroids) <- colnames(data)
+
+  new_order <- unique(res$clusters)
+  res$clusters <- order(new_order)[res$clusters]
+  res$centroids <- res$centroids[new_order, , drop = FALSE]
+  res$WCSS_per_cluster <- res$WCSS_per_cluster[, new_order, drop = FALSE]
+  res$obs_per_cluster <- res$obs_per_cluster[, new_order, drop = FALSE]
   res
 }
 
 #' Simple Wrapper around stats kmeans
 #'
-#' This wrapper runs `stats::kmeans` and adds a check that `centers` is
-#' specified
+#' This wrapper runs `stats::kmeans()` and adds a check that `centers` is
+#' specified. And reorders the clusters.
 #'
 #' @inheritParams stats::kmeans
 #' @param ... Other arguments passed to `stats::kmeans()`
@@ -213,5 +221,52 @@ check_args.k_means <- function(object) {
     )
   }
 
-  stats::kmeans(data, centers, ...)
+  res <- stats::kmeans(data, centers, ...)
+  new_order <- unique(res$cluster)
+  res$cluster <- set_names(order(new_order)[res$cluster], names(res$cluster))
+  res$centers <- res$centers[new_order, , drop = FALSE]
+  res$withinss <- res$withinss[new_order]
+  res$size <- res$size[new_order]
+  res
+}
+
+#' Simple Wrapper around clustMixType kmeans
+#'
+#' This wrapper runs `clustMixType::kproto()` and reorders the clusters.
+#'
+#' @inheritParams clustMixType::kproto
+#' @param ... Other arguments passed to `clustMixType::kproto()`
+#'
+#' @return Result from `clustMixType::kproto()`
+#' @keywords internal
+#' @export
+.k_means_fit_clustMixType <- function(x, k, ...) {
+  res <- clustMixType::kproto(x, k, ...)
+  new_order <- unique(res$cluster)
+  res$cluster <- order(new_order)[res$cluster]
+  res$centers <- res$centers[new_order, , drop = FALSE]
+  res$withinss <- res$withinss[new_order]
+  res$dists <- res$dists[, new_order, drop = FALSE]
+  res$size <- res$size[new_order]
+  res
+}
+
+#' Simple Wrapper around klaR kmeans
+#'
+#' This wrapper runs `klaR::kmodes()` and reorders the clusters.
+#'
+#' @inheritParams klaR::kmodes
+#' @param ... Other arguments passed to `klaR::kmodes()`
+#'
+#' @return Result from `klaR::kmodes()`
+#' @keywords internal
+#' @export
+.k_means_fit_klaR <- function(data, modes, ...) {
+  res <- klaR::kmodes(data, modes, ...)
+  new_order <- unique(res$cluster)
+  res$cluster <- order(new_order)[res$cluster]
+  res$size <- res$size[new_order]
+  res$modes <- res$modes[new_order, , drop = FALSE]
+  res$withindiff <- res$withindiff[new_order]
+  res
 }

R/k_means_data.R

@@ -163,7 +163,7 @@ make_k_means <- function() {
       interface = "data.frame",
       data = c(x = "x"),
       protect = c("x", "k", "keep.data"),
-      func = c(pkg = "clustMixType", fun = "kproto"),
+      func = c(pkg = "tidyclust", fun = ".k_means_fit_clustMixType"),
       defaults = list(keep.data = TRUE, verbose = FALSE)
     )
   )
@@ -230,7 +230,7 @@ make_k_means <- function() {
       interface = "data.frame",
       data = c(x = "data"),
       protect = c("data", "modes"),
-      func = c(pkg = "klaR", fun = "kmodes"),
+      func = c(pkg = "tidyclust", fun = ".k_means_fit_klaR"),
       defaults = list()
     )
   )

R/predict_helpers.R

@@ -1,31 +1,28 @@
+make_predictions <- function(x, prefix, n_clusters) {
+  levels <- seq_len(n_clusters)
+  factor(x, levels = levels, labels = paste0(prefix, levels))
+}
+
 .k_means_predict_stats <- function(object, new_data, prefix = "Cluster_") {
-  res <- object$centers[unique(object$cluster), , drop = FALSE]
+  res <- object$centers
   res <- flexclust::dist2(res, new_data)
   res <- apply(res, 2, which.min)
-  res <- paste0(prefix, res)
-  factor(res)
+
+  make_predictions(res, prefix, length(object$size))
 }
 
 .k_means_predict_ClusterR <- function(object, new_data, prefix = "Cluster_") {
   clusters <- predict(object, new_data)
   n_clusters <- length(object$obs_per_cluster)
 
-  reorder_clusts <- order(union(unique(clusters), seq_len(n_clusters)))
-  names <- paste0(prefix, seq_len(n_clusters))
-  res <- names[reorder_clusts][clusters]
-
-  factor(res)
+  make_predictions(clusters, prefix, n_clusters)
 }
 
 .k_means_predict_clustMixType <- function(object, new_data, prefix = "Cluster_") {
   clusters <- predict(object, new_data)$cluster
   n_clusters <- length(object$size)
 
-  reorder_clusts <- order(union(unique(clusters), seq_len(n_clusters)))
-  names <- paste0(prefix, seq_len(n_clusters))
-  res <- names[reorder_clusts][clusters]
-
-  factor(res)
+  make_predictions(clusters, prefix, n_clusters)
 }
 
 .k_means_predict_klaR <- function(object, new_data, prefix = "Cluster_",
@@ -58,9 +55,7 @@
     }
   }
 
-  names <- paste0(prefix, seq_len(n_modes))
-
-  factor(names[clusters], levels = names)
+  make_predictions(clusters, prefix, n_modes)
 }
 
 .hier_clust_predict_stats <- function(object, new_data, ..., prefix = "Cluster_") {