diff --git a/NAMESPACE b/NAMESPACE index 8442b94..8b6f174 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -67,6 +67,12 @@ export(mtr_tpr) export(mtr_true_negative_rate) export(mtr_true_positive_rate) export(mtr_youden_index) +export(mtr_mutual_info_score) +export(mtr_adjusted_rand_score) +export(mtr_homogeneity) +export(mtr_completeness) +export(mtr_v_measure) +export(mtr_calinski_harabasz) importFrom(Rcpp,evalCpp) importFrom(stats,complete.cases) importFrom(stats,median) diff --git a/R/clustering.r b/R/clustering.r new file mode 100644 index 0000000..4373f84 --- /dev/null +++ b/R/clustering.r @@ -0,0 +1,192 @@ +##' @title +##' Clustering Metrics Parameters +##' +##' @description +##' Documentation for shared parameters of functions that compute clustering +##' metrics. +##' +##' @param actual \code{[numeric]} The ground truth numeric vector. +##' @param predicted \code{[numeric]} The predicted numeric vector, where each +##' element in the vector is a prediction of the corresponding elements in +##' \code{actual}. +##' @name clustering_params +##' @include helper-functions.r +NULL + + +##' @title +##' Adjusted Mutual Information Score / Mututal Information Score +##' +##' +##' @description +##' +##' \code{mtr_mutual_info_score} measures the similarity, or mutual dependence +##' between two variable. The worst possible score is 0, higher values are +##' better. +##' +##' +##' @inheritParams clustering_params +##' @importFrom stats var +##' @seealso \code{\link{mtr_adjusted_rand_score}} +##' @return A numeric scalar output +##' @author Phuc Nguyen +##' @examples +##' +##' act <- sample(1:10, 100, replace = T) +##' pred <- sample(1:10, 100, replace = T) +##' mtr_mutual_info_score(act, pred) +##' +##' act <- rep(c('a', 'b', 'c'), times = 4) +##' pred <- rep(c('a', 'b', 'c'), each = 4) +##' mtr_mutual_info_score(act, pred) +##' +##' @export +mtr_mutual_info_score <- function(actual, predicted) { + chec_empty_vec(actual) + check_equal_length(actual, predicted) + entropy(actual) + entropy(predicted) - joint_entropy(vec_1 = actual, + vec_2 = predicted) +} + +mtr_normalized_mutual_info_score <- function(actual, predicted) { + mtr_mutual_info_score(actual = actual, predicted = predicted) / + mean(c(entropy(vec = actual), entropy(vec = predicted))) +} + +mtr_adjusted_mutual_info_score <- function(actual, predicted) { + (mtr_mutual_info_score(actual, predicted) - expected_mutual_info(actual, predicted)) / + (mean(c(entropy(actual), entropy(predicted))) - expected_mutual_info(actual, predicted)) +} + +##' @title +##' Adjusted Rand Score +##' +##' +##' @description +##' +##' \code{mtr_adjusted_rand_score} measures the similarity, or mutual dependence +##' between two variable. Perfect score is 1. Score between total random vectors +##' is close to 0. Score can be negative. +##' +##' +##' @inheritParams clustering_params +##' @importFrom base choose +##' @seealso \code{\link{mtr_mutual_info_score}} +##' @return A numeric scalar output +##' @author Phuc Nguyen +##' @examples +##' +##' act <- sample(1:10, 100, replace = T) +##' pred <- sample(1:10, 100, replace = T) +##' mtr_adjusted_rand_score(act, pred) +##' +##' act <- rep(c('a', 'b', 'c'), times = 4) +##' pred <- rep(c('a', 'b', 'c'), each = 4) +##' mtr_adjusted_rand_score(act, pred) +##' +##' @export + +mtr_adjusted_rand_score <- function(actual, predicted) { + check_equal_length(actual, predicted) + N = length(actual) + a = sum(choose(table(actual, predicted), 2)) + b = sum(choose(table(actual), 2)) * sum(choose(table(predicted), 2)) / choose(N, 2) + c = 1/2 * (sum(choose(table(actual), 2)) + sum(choose(table(predicted), 2))) + (a - b) / (c - b) +} + +##' @title +##' Homogeneity, Completeness, V-measure +##' +##' +##' @description +##' +##' \code{mtr_homogeneity} and \code{mtr_completeness} measures an aspect of the +##' quality of clustering algorithm, as the former measures how similar the +##' elements within each cluster to each other, and the later measures +##' the degree a cluster has cover elements of same labels. +##' Both scores are in range of 0 to 1, as worst to best. +##' \code{mtr_v_measure} is harmonic mean of homogeneity score and completeness +##' score. +##' +##' @inheritParams clustering_params +##' @return A numeric scalar output +##' @author Phuc Nguyen +##' @examples +##' +##' act <- sample(1:10, 100, replace = T) +##' pred <- sample(1:10, 100, replace = T) +##' mtr_homogeneity(act, pred) +##' +##' act <- sample(1:10, 100, replace = T) +##' pred <- sample(1:10, 100, replace = T) +##' mtr_completeness(act, pred) +##' +##' act <- sample(1:10, 100, replace = T) +##' pred <- sample(1:10, 100, replace = T) +##' mtr_v_measure(act, pred) +##' +##' @export + +mtr_homogeneity <- function(actual, predicted) { + 1 - conditional_entropy(actual, predicted) / entropy(actual) +} + +mtr_completeness <- function(actual, predicted) { + 1 - conditional_entropy(predicted, actual) / entropy(predicted) +} + +mtr_v_measure <- function(actual, predicted) { + h = mtr_homogeneity(actual, predicted) + c = mtr_completeness(actual, predicted) + 2 * h * c / (h + c) +} + +##' @title +##' Calinski-Harabasz Score (Variance Ratio Criterion) +##' +##' +##' @description +##' +##' \code{mtr_calinski_harabasz} measure the 'goodness' of clustering model +##' output, in case ground truth is unknown. Higher score mean cluster are dense +##' and well separated. +##' +##' @inheritParams clustering_params +##' @return A numeric scalar output +##' @author Phuc Nguyen +##' @examples +##' dt <- iris[,-5] +##' pred <- c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, +##' 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, +##' 1, 1, 1, 1, 1, 1, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, +##' 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, +##' 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 2, 2, 2, 2, 0, 2, 2, 2, +##' 2, 2, 2, 0, 0, 2, 2, 2, 2, 0, 2, 0, 2, 0, 2, 2, 0, 0, 2, 2, 2, 2, +##' 2, 0, 2, 2, 2, 2, 0, 2, 2, 2, 0, 2, 2, 2, 0, 2, 2, 0) +##' mtr_calinski_harabasz(dt, pred) +##' +##' @export + +mtr_calinski_harabasz <- function(matrix_feature, predicted) { + check_equal_cluster_length(matrix_feature, predicted) + dt_center = apply(matrix_feature, 2, FUN = mean) + N = length(predicted) + num_cluster = length(unique(predicted)) + + check_number_of_labels(n_labels = num_cluster, n_samples = N) + + dispersion_between_cluster = 0 + dispersion_within_cluster = 0 + + for (cluster_val in unique(predicted)) { + size_cluster = length(which(predicted == cluster_val)) + dt_cluster = matrix_feature[which(predicted == cluster_val),] + cluster_center = apply(dt_cluster, 2, FUN = mean) + + dispersion_between_cluster = dispersion_between_cluster + size_cluster * sum((t(cluster_center) - dt_center) ^ 2) + dispersion_within_cluster = dispersion_within_cluster + sum((t(dt_cluster) - cluster_center) ^ 2) + } + + (dispersion_between_cluster / dispersion_within_cluster) * ((N - num_cluster) / (num_cluster - 1)) +} diff --git a/R/helper-functions.r b/R/helper-functions.r index 12d9585..6b1a94e 100644 --- a/R/helper-functions.r +++ b/R/helper-functions.r @@ -1,5 +1,11 @@ - +chec_empty_vec <- function(vec) { + if (length(vec) == 0) { + stop("vector must have positive length.", call. = FALSE) + } + + invisible() +} check_equal_length <- function(actual, predicted) { @@ -28,6 +34,15 @@ check_binary <- function(actual) { invisible() } +check_number_of_labels <- function(n_labels, n_samples) { + + if (! (1 < n_labels & n_labels < n_samples)) { + stop("Number of labels is invalid. Valid value are 2 to n_samples - 1", call. = FALSE) + } + + invisible() +} + clip <- function(x, mi, ma) { clip_(x, mi, ma) } @@ -60,3 +75,74 @@ trapezoid <- function(x, y) { sum(dx * height) } + +class_prob <- function(vec, class) { + chec_empty_vec(vec) + length(which(vec == class)) / length(vec) +} + +entropy <- function(vec) { + chec_empty_vec(vec) + li = c() + for (cl in unique(vec)) { + m = class_prob(vec = vec, class = cl) + li = c(li, -1 * m * log(m)) + } + etp = sum(li, na.rm = TRUE) + etp +} + +joint_class_prob <- function(vec_1, vec_2, class_1, class_2) { + chec_empty_vec(vec_1) + check_equal_length(vec_1, vec_2) + length(which(vec_1 == class_1 & vec_2 == class_2)) / length(vec_1) +} + +joint_entropy <- function(vec_1, vec_2) { + check_equal_length(vec_1, vec_2) + li = c() + for(cl_1 in unique(vec_1)) { + for(cl_2 in unique(vec_2)) { + m = joint_class_prob(vec_1 = vec_1, vec_2 = vec_2, + class_1 = cl_1, class_2 = cl_2) + li = c(li, - 1 * m * log(m)) + } + } + joint_etp = sum(li, na.rm = TRUE) + joint_etp +} + +expected_mutual_info <- function(vec_1, vec_2) { + check_equal_length(vec_1, vec_2) + N = length(vec_1) + li = c() + for (i in unique(vec_1)) { + a = length(which(vec_1 == i)) + for (j in unique(vec_2)) { + b = length(which(vec_2 == j)) + for (nij in max(a + b - N, 0, na.rm = TRUE): min(a, b, na.rm = TRUE)) { + li = c(li, (nij / N) * + log((N * nij) / (a * b)) * + (factorial(a) * factorial(b) * factorial(N - a) * factorial(N - b)) / + (factorial(N) * factorial(nij) * factorial(a - nij) * factorial(b - nij) * factorial(N - a - b + nij))) + } + } + } + emi = sum(li, na.rm = TRUE) + emi +} + +conditional_entropy <- function(vec_1, vec_2) { + check_equal_length(vec_1, vec_2) + N = length(vec_1) + li = c() + for (i in unique(vec_1)) { + for (j in unique(vec_2)) { + b = length(which(vec_2 == j)) + nij = length(which(vec_1 == i & vec_2 == j)) + li = c(li, - nij / N * log(nij / b)) + } + } + cond_entropy = sum(li, na.rm = TRUE) + cond_entropy +} diff --git a/TODO.org b/TODO.org index 760e065..871286c 100644 --- a/TODO.org +++ b/TODO.org @@ -1,4 +1,4 @@ - + * List of performance metrics @@ -23,6 +23,8 @@ Metrics that built around confusion matrix: - [X] Balanced Accuracy +- [ ] Balanced Error Rate + - [X] Positive Predicted Value (PPV) / Precision - [ ] Average Precision @@ -31,12 +33,18 @@ Metrics that built around confusion matrix: - [X] False Omission Rate (FOR) +- [ ] Positive Likelihood + +- [ ] Negative Likelihood + - [X] Prevalence - [X] F1 Score - [X] Matthews Correlation Coefficient (MCC) +- [ ] Discriminant Power + - [X] Informedness (Bookmaker Informedness - BM) / Youden Index (Youden's J Statistic) - [X] Markedness (MK) @@ -77,28 +85,40 @@ Proper scoring rule: - [X] Mean Squared Error +- [ ] Normalized Mean Squared Error + - [X] Root Mean Squared Error - [X] Mean Squared Logarithmic Error - [X] Median Absolute Error +- [ ] Mean Absolute Percentage Error + +- [ ] Mean Absolute Scaled Error + +- [ ] Median Squared Error + - [X] R2 Score +- [ ] Adjusted R2 Score + +- [ ] M-Estimators + ** Clustering tasks - [ ] Adjusted Mututal Information Score / Mutual Information Score -- [ ] Adjusted Rand Score +- [X] Adjusted Rand Score -- [ ] Calinski-Harabasz Score +- [X] Calinski-Harabasz Score - [ ] Davies-Bouldin Score -- [ ] Completeness Metric +- [X] Completeness Metric -- [ ] V-Measure Score +- [X] V-Measure Score -- [ ] Homogeneity Score +- [X] Homogeneity Score - [ ] Mean Silhouette Coefficient / Silhouette Coefficient diff --git a/inst/tinytest/test-clustering.r b/inst/tinytest/test-clustering.r new file mode 100644 index 0000000..49f5e5a --- /dev/null +++ b/inst/tinytest/test-clustering.r @@ -0,0 +1,67 @@ + +## test correctness ------------------------------------------------------------ + +vec_a = c(0, 1, 2, 0, 3, 4, 5, 1) +vec_b = c(1, 1, 0, 0, 2, 2, 2, 2) +data(iris) + +tinytest::expect_equal( + mtr_mutual_info_score(vec_a, vec_b), + target = 0.693147180559945, + tol = 1e-7 +) + +tinytest::expect_equal( + mtr_normalized_mutual_info_score(vec_a, vec_b), + target = 0.5163977794943221, + tol = 1e-7 +) + +tinytest::expect_equal( + mtr_adjusted_mutual_info_score(vec_a, vec_b), + target = -0.10526315789473674, + tol = 1e-7 +) + +tinytest::expect_equal( + mtr_adjusted_rand_score(vec_a, vec_b), + target = -0.12903225806451613, + tol = 1e-7 +) + +tinytest::expect_equal( + mtr_homogeneity(vec_a, vec_b), + target = 0.3999999999999998, + tol = 1e-7 +) + +tinytest::expect_equal( + mtr_completeness(vec_a, vec_b), + target = 0.6666666666666665, + tol = 1e-7 +) + +tinytest::expect_equal( + mtr_v_measure(vec_a, vec_b), + target = 0.4999999999999998, + tol = 1e-7 +) + +tinytest::expect_equal( + mtr_calinski_harabasz(iris[,-5], + predicted = c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 2, 2, 2, 2, 0, 2, 2, 2, + 2, 2, 2, 0, 0, 2, 2, 2, 2, 0, 2, 0, 2, 0, 2, 2, 0, 0, 2, 2, 2, 2, + 2, 0, 2, 2, 2, 2, 0, 2, 2, 2, 0, 2, 2, 2, 0, 2, 2, 0)), + target = 560.3999242466402, + tol = 1e-2 + # numerical calculation outcome between python and R return large small + # difference, hence relatively large tolerance level +) + + + +