Clustering
2023-05-08
Packages
library("kernlab")
library("tidyverse")## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ ggplot2 3.5.1 ✔ tibble 3.2.1
## ✔ lubridate 1.9.3 ✔ tidyr 1.3.1
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ ggplot2::alpha() masks kernlab::alpha()
## ✖ purrr::cross() masks kernlab::cross()
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errorslibrary("factoextra")## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBalibrary("DataExplorer")
library("Rtsne")
library("ggpubr")
library("tictoc")##
## Attaching package: 'tictoc'
##
## The following object is masked from 'package:kernlab':
##
## sizeData
This case requires to develop a customer segmentation to define marketing strategy. The sample Dataset summarizes the usage behavior of about 9000 active credit card holders during the last 6 months. The file is at a customer level with 18 behavioral variables.
Following is the Data Dictionary for Credit Card dataset :-
- CUSTID : Identification of Credit Card holder (Categorical)
- BALANCE : Balance amount left in their account to make purchases (
- BALANCEFREQUENCY : How frequently the Balance is updated, score between 0 and 1 (1 = frequently updated, 0 = not frequently updated)
- PURCHASES : Amount of purchases made from account
- ONEOFFPURCHASES : Maximum purchase amount done in one-go INSTALLMENTSPURCHASES : Amount of purchase done in installment
- CASHADVANCE : Cash in advance given by the user
- PURCHASESFREQUENCY : How frequently the Purchases are being made, score between 0 and 1 (1 = frequently purchased, 0 = not frequently purchased)
- ONEOFFPURCHASESFREQUENCY : How frequently Purchases are happening in one-go (1 = frequently purchased, 0 = not frequently purchased)
- PURCHASESINSTALLMENTSFREQUENCY : How frequently purchases in installments are being done (1 = frequently done, 0 = not frequently done)
- CASHADVANCEFREQUENCY : How frequently the cash in advance being paid
- CASHADVANCETRX : Number of Transactions made with “Cash in Advanced”
- PURCHASESTRX : Numbe of purchase transactions made
- CREDITLIMIT : Limit of Credit Card for user PAYMENTS : Amount of Payment done by user
- MINIMUM_PAYMENTS : Minimum amount of payments made by user
- PRCFULLPAYMENT : Percent of full payment paid by user
- TENURE : Tenure of credit card service for user
dt_cc <- read.csv("/Users/User/Library/CloudStorage/OneDrive-apps.ipb.ac.id/Kuliah/Data/credit card.csv", stringsAsFactors = T)
glimpse(dt_cc)## Rows: 8,950
## Columns: 18
## $ CUST_ID <fct> C10001, C10002, C10003, C10004, C1000…
## $ BALANCE <dbl> 40.90075, 3202.46742, 2495.14886, 166…
## $ BALANCE_FREQUENCY <dbl> 0.818182, 0.909091, 1.000000, 0.63636…
## $ PURCHASES <dbl> 95.40, 0.00, 773.17, 1499.00, 16.00, …
## $ ONEOFF_PURCHASES <dbl> 0.00, 0.00, 773.17, 1499.00, 16.00, 0…
## $ INSTALLMENTS_PURCHASES <dbl> 95.40, 0.00, 0.00, 0.00, 0.00, 1333.2…
## $ CASH_ADVANCE <dbl> 0.0000, 6442.9455, 0.0000, 205.7880, …
## $ PURCHASES_FREQUENCY <dbl> 0.166667, 0.000000, 1.000000, 0.08333…
## $ ONEOFF_PURCHASES_FREQUENCY <dbl> 0.000000, 0.000000, 1.000000, 0.08333…
## $ PURCHASES_INSTALLMENTS_FREQUENCY <dbl> 0.083333, 0.000000, 0.000000, 0.00000…
## $ CASH_ADVANCE_FREQUENCY <dbl> 0.000000, 0.250000, 0.000000, 0.08333…
## $ CASH_ADVANCE_TRX <int> 0, 4, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ PURCHASES_TRX <int> 2, 0, 12, 1, 1, 8, 64, 12, 5, 3, 12, …
## $ CREDIT_LIMIT <dbl> 1000, 7000, 7500, 7500, 1200, 1800, 1…
## $ PAYMENTS <dbl> 201.8021, 4103.0326, 622.0667, 0.0000…
## $ MINIMUM_PAYMENTS <dbl> 139.50979, 1072.34022, 627.28479, NA,…
## $ PRC_FULL_PAYMENT <dbl> 0.000000, 0.222222, 0.000000, 0.00000…
## $ TENURE <int> 12, 12, 12, 12, 12, 12, 12, 12, 12, 1…plot_intro(dt_cc)
dt_cc <- dt_cc %>% na.omit()
glimpse(dt_cc)## Rows: 8,636
## Columns: 18
## $ CUST_ID <fct> C10001, C10002, C10003, C10005, C1000…
## $ BALANCE <dbl> 40.90075, 3202.46742, 2495.14886, 817…
## $ BALANCE_FREQUENCY <dbl> 0.818182, 0.909091, 1.000000, 1.00000…
## $ PURCHASES <dbl> 95.40, 0.00, 773.17, 16.00, 1333.28, …
## $ ONEOFF_PURCHASES <dbl> 0.00, 0.00, 773.17, 16.00, 0.00, 6402…
## $ INSTALLMENTS_PURCHASES <dbl> 95.40, 0.00, 0.00, 0.00, 1333.28, 688…
## $ CASH_ADVANCE <dbl> 0.0000, 6442.9455, 0.0000, 0.0000, 0.…
## $ PURCHASES_FREQUENCY <dbl> 0.166667, 0.000000, 1.000000, 0.08333…
## $ ONEOFF_PURCHASES_FREQUENCY <dbl> 0.000000, 0.000000, 1.000000, 0.08333…
## $ PURCHASES_INSTALLMENTS_FREQUENCY <dbl> 0.083333, 0.000000, 0.000000, 0.00000…
## $ CASH_ADVANCE_FREQUENCY <dbl> 0.000000, 0.250000, 0.000000, 0.00000…
## $ CASH_ADVANCE_TRX <int> 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ PURCHASES_TRX <int> 2, 0, 12, 1, 8, 64, 12, 5, 3, 12, 6, …
## $ CREDIT_LIMIT <dbl> 1000, 7000, 7500, 1200, 1800, 13500, …
## $ PAYMENTS <dbl> 201.8021, 4103.0326, 622.0667, 678.33…
## $ MINIMUM_PAYMENTS <dbl> 139.50979, 1072.34022, 627.28479, 244…
## $ PRC_FULL_PAYMENT <dbl> 0.000000, 0.222222, 0.000000, 0.00000…
## $ TENURE <int> 12, 12, 12, 12, 12, 12, 12, 12, 12, 1…cust_id <- dt_cc %>% select(CUST_ID)
dt_cc <- dt_cc %>% select(-CUST_ID)Standardisasi Peubah
Standarisasi peubah merupakan proses transformasi peubah menjadi peubah yang memiliki rata-rata nol dan simpangan baku satu. Process standarisasi ini dilakukan jika kita melihat perbedanan satuan pengukuran peubah-peubah yang digunakan contoh(umur dan pendapatan). Standarisasi dilakukan karena metode k-means menggunakan konsep jarak antara objek/amatan, yang mana sensitif terhadap satuan pengukuran.
Menentukan Banyak Cluster Terbaik
Metric WSS - Within Sum of Squared
The within-cluster sum of squares is a measure of the variability of the observations within each cluster.
tic()
fviz_nbclust(
x = scale(dt_cc),
FUNcluster = stats::kmeans,
method = "wss",
iter.max = 100,
k.max = 30
)
toc()## 63.956 sec elapsedKoefisien Silhouette
Silhouette Score is a metric to evaluate the performance of clustering algorithm. It uses compactness of individual clusters(intra cluster distance) and separation amongst clusters (inter cluster distance) to measure an overall representative score of how well our clustering algorithm has performed.
tic()
fviz_nbclust( #nbclust menentukan jenis metrics apa yang mau dipakai, ada 30 an
x = scale(dt_cc),
FUNcluster = stats::kmeans,
method = "silhouette",
iter.max = 100,
k.max = 30
)
toc()## 24.036 sec elapsedMenggunakan metode visualisasi
PCA
pca_cc <- prcomp(
x = dt_cc,
center = T,
scale. = T
)
fviz_pca_ind(pca_cc,
geom.ind = "point"
)
Kernel PCA
Sebelum diterapkan PCA/didekomposisi oleh PCA, dipetakan dengan kernel dulu.
Kernel Principal Component Analysis (kernel PCA) adalah teknik reduksi dimensi nonlinear yang dapat digunakan untuk mengekstrak fitur atau pola penting dari suatu dataset dengan memproyeksikannya ke dalam ruang berdimensi lebih rendah. Kernel PCA adalah perluasan dari algoritma PCA tradisional yang dapat menangani hubungan nonlinear antara variabel dalam dataset.
Ide dasar dari PCA adalah untuk mentransformasikan dataset ke dalam sistem koordinat baru dengan mencari arah (komponen utama) yang menangkap sebagian besar varians dalam data. Dalam kasus linear, arah-arah ini adalah vektor eigen dari matriks kovariansi data. Namun, ketika data memiliki struktur nonlinear, PCA linear mungkin tidak mampu menangkap fitur penting dari data.
Kernel PCA mengatasi batasan ini dengan menggunakan fungsi kernel untuk secara implisit memetakan data ke dalam ruang fitur yang berdimensi tinggi di mana hubungan antara variabel mungkin linear. Kemudian, PCA diterapkan pada data yang sudah di-transformasi dalam ruang fitur ini untuk mengekstrak komponen utama.
Fungsi kernel dapat menjadi fungsi positif definit yang memenuhi syarat Mercer, seperti fungsi kernel basis radial (RBF) atau fungsi kernel polinomial. Data yang sudah di-transformasi dapat direpresentasikan sebagai sejumlah kombinasi linear tertimbang dari fungsi kernel yang dievaluasi pada setiap pasangan titik data. Bobot-bobot tersebut sesuai dengan komponen utama, yang dapat diperoleh dengan menyelesaikan masalah dekomposisi eigen pada matriks kernel.
Algoritma kernel PCA dapat diringkas sebagai berikut:
- Hitung matriks kernel K, di mana \(K(i,j)=K(x_{i},x_{j})\) adalah nilai fungsi kernel antara titik data xi dan xj.
- Kurangkan dengan rata-rata setiap kolom dan setiap baris.
- Hitung dekomposisi eigen dari matriks kernel pada langkah (2) untuk memperoleh vektor eigen dan nilai eigen.
- Pilih k vektor eigen teratas yang sesuai dengan nilai eigen terbesar untuk membentuk ruang fitur baru.
- Proyeksikan data asli ke dalam new feature space untuk mendapatkan the reduced-dimensional representation.
set.seed(123)
dt_cc_samp <- as_tibble(scale(dt_cc)) |> slice_sample(n = 4000)tic()
pca_cc2 <- kpca(~., data = dt_cc_samp,
kernel = rbfdot(sigma = 5), features = 2)
toc()## 125.637 sec elapsedprnp_cc2 <- as_tibble(rotated(pca_cc2)) ## Warning: The `x` argument of `as_tibble.matrix()` must have unique column names if
## `.name_repair` is omitted as of tibble 2.0.0.
## ℹ Using compatibility `.name_repair`.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.names(prnp_cc2) <- c("PC1","PC2")ggscatter(prnp_cc2, x = "PC1", y = "PC2")
t-SNE
t-SNE (t-distributed stochastic neighbor embedding) memetakan data berdimensi tinggi ke dalam ruang berdimensi lebih rendah (biasanya 2D atau 3D) dengan tetap menjaga keterhubungan antara titik-titik data. Hal ini dilakukan dengan merepresentasikan setiap titik data berdimensi tinggi sebagai distribusi peluang yang berpusat di sekitar suatu titik dalam ruang berdimensi rendah. Kemudian, algoritma ini mencoba meminimalkan perbedaan antara distribusi dimensi tinggi dan dimensi rendah dengan menggunakan algoritma gradient descent.
Algoritma t-SNE bekerja sebagai berikut:
- Hitung kesamaan berpasangan antara titik data berdimensi tinggi (misalnya, menggunakan jarak Euclidean atau kesamaan kosinus).
- Ubah kemiripan berpasangan menjadi peluang gabungan yang mewakili seberapa besar kemungkinan setiap pasangan titik untuk bertetangga dalam ruang dimensi rendah.
- Inisialisasi titik-titik dimensi rendah secara acak.
- Hitung kemiripan berpasangan antara titik-titik dimensi rendah dan ubah menjadi peluang Bersama.
- Minimalkan perbedaan Kullback-Leibler antara probabilitas gabungan dimensi tinggi dan dimensi rendah menggunakan gradient descent.
- Hasil dari t-SNE adalah scatter plot 2D atau 3D di mana setiap titik mewakili titik data berdimensi tinggi. Jarak antara titik-titik dalam scatter plot mencerminkan kemiripannya dalam ruang dimensi tinggi, sehingga titik-titik yang berdekatan dalam scatter plot mirip satu sama lain dalam ruang dimensi tinggi.
untuk keterangan lebih lanjut tentang t-sne dapat membuka situs berikut: https://distill.pub/2016/misread-tsne/#:~:text=A%20second%20feature%20of%20t-SNE%20is%20a%20tuneable,has%20a%20complex%20effect%20on%20the%20resulting%20pictures
tic()
set.seed(123)
rtsne_cc <- Rtsne(dt_cc_samp, dims = 2,perplexity = 50)
toc()## 17.081 sec elapsedtsne_df <- rtsne_cc$Y %>%
as.data.frame() %>%
rename(
tsne1 = "V1",
tsne2 = "V2"
)ggscatter(tsne_df, x = "tsne1", y = "tsne2")
set.seed(123)
kmean_res <- kmeans(dt_cc, # tanpa standardisasi
centers = 4,
iter.max = 100)kmean_res$centers## BALANCE BALANCE_FREQUENCY PURCHASES ONEOFF_PURCHASES
## 1 864.2852 0.8762134 524.5239 255.0488
## 2 1687.6153 0.9128036 1658.9498 1050.5687
## 3 6214.5340 0.9755254 1098.2421 595.7008
## 4 4836.4058 0.9122158 11391.8362 8160.9452
## INSTALLMENTS_PURCHASES CASH_ADVANCE PURCHASES_FREQUENCY
## 1 269.7790 523.7218 0.4572817
## 2 608.7880 716.8969 0.6080229
## 3 502.6308 4653.7402 0.3922565
## 4 3231.0759 4979.5852 0.7687038
## ONEOFF_PURCHASES_FREQUENCY PURCHASES_INSTALLMENTS_FREQUENCY
## 1 0.1354485 0.3502076
## 2 0.3580816 0.4234512
## 3 0.1873384 0.2980033
## 4 0.6290444 0.6165485
## CASH_ADVANCE_FREQUENCY CASH_ADVANCE_TRX PURCHASES_TRX CREDIT_LIMIT PAYMENTS
## 1 0.1148649 2.432408 9.843259 2302.957 955.8675
## 2 0.1058689 2.382135 22.867102 7658.425 2168.7184
## 3 0.3899201 11.794118 17.207219 9835.233 4015.2936
## 4 0.2096657 8.529412 89.025210 12718.908 18467.9488
## MINIMUM_PAYMENTS PRC_FULL_PAYMENT TENURE
## 1 583.5042 0.15204700 11.40720
## 2 620.7279 0.21077432 11.79041
## 3 3425.9784 0.02491129 11.63369
## 4 2376.7476 0.34521108 11.82353set.seed(123)
kmean_res_std <- kmeans(scale(dt_cc), # standardisasi
centers = 4,
iter.max = 100)
kmean_res_std$centers## BALANCE BALANCE_FREQUENCY PURCHASES ONEOFF_PURCHASES
## 1 -0.2596493 -0.3121714 -0.3302001 -0.2344101
## 2 -0.1273203 0.3667280 0.5780483 0.4132288
## 3 1.5380670 0.3766507 -0.1897072 -0.1338074
## 4 -0.3610076 -0.3608489 -0.2736449 -0.2086418
## INSTALLMENTS_PURCHASES CASH_ADVANCE PURCHASES_FREQUENCY
## 1 -0.3497405 -0.21776739 -0.6458316
## 2 0.6070181 -0.35499461 1.0825484
## 3 -0.2027364 1.77189566 -0.5001745
## 4 -0.2632345 0.02577674 -0.1061808
## ONEOFF_PURCHASES_FREQUENCY PURCHASES_INSTALLMENTS_FREQUENCY
## 1 -0.3748694 -0.5717539
## 2 0.6499571 0.9651283
## 3 -0.2159751 -0.4308311
## 4 -0.2812817 -0.1441407
## CASH_ADVANCE_FREQUENCY CASH_ADVANCE_TRX PURCHASES_TRX CREDIT_LIMIT PAYMENTS
## 1 -0.1636267 -0.18927960 -0.4319162 -0.3151287 -0.2591746
## 2 -0.4689014 -0.35712895 0.7546139 0.2196558 0.1692113
## 3 1.7513685 1.71413995 -0.2384098 0.9185768 0.7379135
## 4 0.2418213 -0.04430031 -0.3671711 -0.5692883 -0.3877017
## MINIMUM_PAYMENTS PRC_FULL_PAYMENT TENURE
## 1 -0.10469509 -0.2129974 0.26747034
## 2 -0.01864834 0.4173833 0.29640425
## 3 0.57660716 -0.4145205 0.08375683
## 4 -0.22153383 0.1025953 -3.11492951table(kmean_res$cluster)##
## 1 2 3 4
## 5474 2295 748 119Interpretasi
dt_cc |>
mutate(cluster=kmean_res$cluster) |>
group_by(cluster) |>
summarise(across(everything(),mean))## # A tibble: 4 × 18
## cluster BALANCE BALANCE_FREQUENCY PURCHASES ONEOFF_PURCHASES
## <int> <dbl> <dbl> <dbl> <dbl>
## 1 1 864. 0.876 525. 255.
## 2 2 1688. 0.913 1659. 1051.
## 3 3 6215. 0.976 1098. 596.
## 4 4 4836. 0.912 11392. 8161.
## # ℹ 13 more variables: INSTALLMENTS_PURCHASES <dbl>, CASH_ADVANCE <dbl>,
## # PURCHASES_FREQUENCY <dbl>, ONEOFF_PURCHASES_FREQUENCY <dbl>,
## # PURCHASES_INSTALLMENTS_FREQUENCY <dbl>, CASH_ADVANCE_FREQUENCY <dbl>,
## # CASH_ADVANCE_TRX <dbl>, PURCHASES_TRX <dbl>, CREDIT_LIMIT <dbl>,
## # PAYMENTS <dbl>, MINIMUM_PAYMENTS <dbl>, PRC_FULL_PAYMENT <dbl>,
## # TENURE <dbl>visualisasi:
set.seed(123)
dt_cc_samp22 <- dt_cc |>
#mutate(cluster = kmean_res$cluster) |>
mutate(cluster = as.character(kmean_res$cluster)) |>
#group_by(cluster) |>
slice_sample(n = 5000)tic()
set.seed(123)
rtsne_cc22 <- Rtsne(dt_cc_samp22 |> select(-cluster), dims = 2, perplexity = 50)
toc()## 22.396 sec elapsedtsne_df22 <- rtsne_cc22$Y %>%
as.data.frame() %>%
rename(
tsne1 = "V1",
tsne2 = "V2"
) |>
mutate(cluster = dt_cc_samp22$cluster)ggscatter(tsne_df22, x = "tsne1", y = "tsne2", color = "cluster")