TDA-Project/TDA_ML_Paper_Results.R at main · TheoAnim/TDA-Project · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
# library(tidyverse)
# library(furrr)
# library(future)
# library(ripserr)
# library(ranger)
# library(scales)
#
# set.seed(9743650)
# plan(multisession, workers = availableCores() - 1)
# mnist <- readRDS("mnist_dataset")
#
# persistent_entropy <- function(dgm) {
#   if (nrow(dgm) == 0) {
#     return(0)
#   }
#
#   persistence <- dgm$death - dgm$birth
#   total_persistence <- sum(persistence)
#
#   if (total_persistence == 0) {
#     return(0)
#   }
#
#   p <- persistence / total_persistence
#   p <- p[p > 0]
#
#   -sum(p * log(p))
# }
#
# get_topological_features <- function(image_matrix) {
#   # Binarize the image for cubical homology
#   # binary_image <- ifelse(image_matrix > 0.4, 1, 0)
#
#   directions <- list(
#     c(1, 0), c(-1, 0), c(0, 1), c(0, -1),
#     c(1, 1), c(1, -1), c(-1, 1), c(-1, -1)
#   )
#
#   features <- map_dfc(directions, \(dir) {
#     # Create the height filtration
#     dgm <- cubical(image_matrix, direction = dir, dim = 1) |>
#       as_tibble() |>
#       filter(is.finite(death))
#
#     pe0 <- persistent_entropy(filter(dgm, dimension == 0))
#     pe1 <- persistent_entropy(filter(dgm, dimension == 1))
#
#     col_name_pe0 <- paste0("pe0_", dir[1], "_", dir[2]) |> gsub("-", "n", x = _)
#     col_name_pe1 <- paste0("pe1_", dir[1], "_", dir[2]) |> gsub("-", "n", x = _)
#
#     tibble(
#       !!col_name_pe0 := pe0,
#       !!col_name_pe1 := pe1
#     )
#   })
#
#   return(features)
# }
#
# train_indices <- 1:100
# test_indices <- 1:100
#
# train_features <- future_map_dfr(
#   train_indices,
#   ~ get_topological_features(matrix(mnist$train$images[.x, ], nrow = 28)),
#   .progress = TRUE,
#   .options = furrr_options(seed = TRUE)
# )
#
# train_data <- train_features |>
#   mutate(label = factor(mnist$train$labels[train_indices]))
#
# model <- ranger(
#   formula = label ~ .,
#   data = train_data,
#   num.trees = 500,
#   importance = "impurity"
# )
#
#
# test_features <- future_map_dfr(
#   test_indices,
#   ~ get_topological_features(matrix(mnist$test$images[.x, ], nrow = 28)),
#   .progress = TRUE,
#   .options = furrr_options(seed = TRUE)
# )
#
# predictions <- predict(model, data = test_features)
#
# results <- tibble(
#   true_label = factor(mnist$test$labels[test_indices]),
#   predicted_label = predictions$predictions
# )
#
# accuracy <- mean(results$true_label == results$predicted_label, na.rm = TRUE)
# print(paste("Feature-Based TDA Accuracy:", percent(accuracy, accuracy = 0.1)))
#
# plan(sequential)