Implementasi Analisis Diskriminan dan Regresi Logistik Ordinal Untuk Klasifikasi Kualitas Potongan Berlian
Eka Aliya (24031554012), Salsabila Alika Seftizianka (24031554117), Atya Azharina Aziz (24031554194)
2026-05-08
Penelitian ini bertujuan untuk menganalisis pengaruh karakteristik fisik berlian terhadap tingkatan kualitas potongan (cut) serta membandingkan performa akurasi antara metode Analisis Diskriminan dan Regresi Logistik Ordinal. Menggunakan dataset Diamonds sebanyak 53.940 observasi, variabel prediktor yang diuji meliputi carat, depth, table, x, y, dan z. Tahapan pra-pemrosesan data dilakukan melalui standarisasi variabel dan pembersihan outlier sebanyak 7,67% berdasarkan kriteria Tukey’s Fences. Meskipun pengujian asumsi menunjukkan adanya pelanggaran pada normalitas multivariat, homogenitas varians-kovarians, serta asumsi parallel lines pada regresi ordinal, kedua model tetap dianalisis untuk melihat ketangguhannya dalam klasifikasi. Hasil penelitian menunjukkan bahwa Analisis Diskriminan (LDA) memberikan tingkat akurasi yang lebih unggul sebesar 67,6%, sementara Regresi Logistik Ordinal hanya mencapai akurasi 53,49%. Rendahnya akurasi pada model ordinal sangat dipengaruhi oleh ketidakkonsistenan peluang kumulatif antar kategori, sedangkan LDA lebih efektif dalam mengidentifikasi perbedaan karakteristik fisik antar kelompok melalui fungsi diskriminan. Dengan demikian, Analisis Diskriminan direkomendasikan sebagai metode yang lebih akurat dan objektif dalam mengklasifikasikan kualitas potongan berlian guna mendukung efisiensi standarisasi dalam industri perhiasan.
Berikut Lampiran Kode-Kode pada Penelitian ini:
1. Library
library(tidyverse) # Untuk pre-processing & ggplot2## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.2.1 ✔ readr 2.2.0
## ✔ forcats 1.0.1 ✔ stringr 1.6.0
## ✔ ggplot2 4.0.3 ✔ tibble 3.3.1
## ✔ lubridate 1.9.5 ✔ tidyr 1.3.2
## ✔ purrr 1.2.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ 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(MASS) # Untuk lda()##
## Attaching package: 'MASS'## The following object is masked from 'package:dplyr':
##
## selectlibrary(ordinal) # Untuk clm()##
## Attaching package: 'ordinal'## The following object is masked from 'package:dplyr':
##
## slicelibrary(car) # Untuk VIF## Loading required package: carData##
## Attaching package: 'car'## The following object is masked from 'package:dplyr':
##
## recode## The following object is masked from 'package:purrr':
##
## somelibrary(biotools) # Untuk Box's M## ---
## biotools version 4.3library(MVN) # Untuk Normalitas Multivariat## Registered S3 method overwritten by 'lme4':
## method from
## na.action.merMod carlibrary(corrplot) #Untuk Korelasi## corrplot 0.95 loadedlibrary(ggplot2) #Untuk Visualisasi2. Load dan Pre Processing Data
data("diamonds")
data_diamond<-diamonds#1. Filter Kolom
diamonds_clean <- data_diamond %>% dplyr::select(cut, carat, depth, table, x, y, z)
print(diamonds_clean)## # A tibble: 53,940 × 7
## cut carat depth table x y z
## <ord> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 Ideal 0.23 61.5 55 3.95 3.98 2.43
## 2 Premium 0.21 59.8 61 3.89 3.84 2.31
## 3 Good 0.23 56.9 65 4.05 4.07 2.31
## 4 Premium 0.29 62.4 58 4.2 4.23 2.63
## 5 Good 0.31 63.3 58 4.34 4.35 2.75
## 6 Very Good 0.24 62.8 57 3.94 3.96 2.48
## 7 Very Good 0.24 62.3 57 3.95 3.98 2.47
## 8 Very Good 0.26 61.9 55 4.07 4.11 2.53
## 9 Fair 0.22 65.1 61 3.87 3.78 2.49
## 10 Very Good 0.23 59.4 61 4 4.05 2.39
## # ℹ 53,930 more rows#2. Cek Missing Value
sum(is.na(diamonds_clean))## [1] 0#3. Cek Duplikasi
diamonds_clean <- diamonds_clean[!duplicated(diamonds_clean), ]#4. Cek Outliers
remove_outliers <- function(x) {
q1 <- quantile(x, 0.25)
q3 <- quantile(x, 0.75)
iqr <- q3 - q1
x >= (q1 - 1.5 * iqr) & x <= (q3 + 1.5 * iqr)
}
diamonds_final <- diamonds_clean %>%
filter(if_all(where(is.numeric), remove_outliers))#Cek Sellisih Jumlah baris
n_awal <- nrow(diamonds_clean)
n_akhir <- nrow(diamonds_final)
data_terbuang <- n_awal - n_akhir
cat("Jumlah data awal:", n_awal, "\n")## Jumlah data awal: 51271cat("Jumlah data setelah outlier dibuang:", n_akhir, "\n")## Jumlah data setelah outlier dibuang: 47340cat("Data yang terbuang:", data_terbuang, "baris (", round(data_terbuang/n_awal*100, 2), "%)\n")## Data yang terbuang: 3931 baris ( 7.67 %)#5. Standarisasi
diamonds_final[, 2:7] <- scale(diamonds_final[, 2:7])
diamonds_final$cut <- factor(diamonds_final$cut,
levels = c("Fair", "Good", "Very Good", "Premium", "Ideal"),
ordered = TRUE)
levels(diamonds_final$cut)## [1] "Fair" "Good" "Very Good" "Premium" "Ideal"#Statistika Deskriptif
summary(diamonds_final)## cut carat depth table
## Fair : 343 Min. :-1.3460 Min. :-2.6439 Min. :-2.8212
## Good : 3796 1st Qu.:-0.8754 1st Qu.:-0.6011 1st Qu.:-0.6575
## Very Good:11349 Median :-0.1694 Median : 0.1094 Median :-0.1657
## Premium :12594 Mean : 0.0000 Mean : 0.0000 Mean : 0.0000
## Ideal :19258 3rd Qu.: 0.6071 3rd Qu.: 0.6423 3rd Qu.: 0.8178
## Max. : 2.9602 Max. : 2.5962 Max. : 3.0307
## x y z
## Min. :-1.855856 Min. :-1.917798 Min. :-3.225464
## 1st Qu.:-0.918038 1st Qu.:-0.917576 1st Qu.:-0.912425
## Median :-0.008639 Median : 0.006439 Median : 0.006663
## Mean : 0.000000 Mean : 0.000000 Mean : 0.000000
## 3rd Qu.: 0.777612 3rd Qu.: 0.778038 3rd Qu.: 0.772570
## Max. : 2.530099 Max. : 2.568911 Max. : 2.733292#Heatmap Korelasi
cor_matrix <- cor(diamonds_final[, 2:7])
corrplot::corrplot(cor_matrix, method = "color", addCoef.col = "black")
3. Uji Asumsi Analisis Diskriminan
#1.Uji Normalitas Multivariat
set.seed(123)
data_sampel <- diamonds_final[sample(nrow(diamonds_final), 1000), 2:7]
hasil <- mvn(data_sampel)
hasil$multivariate_normality## Test Statistic p.value Method MVN
## 1 Henze-Zirkler 10.215 <0.001 asymptotic ✗ Not normal#2.Uji Homogenitas Varians-Kovarians
box_m_test <- boxM(diamonds_final[, 2:7], diamonds_final$cut)
print(box_m_test)##
## Box's M-test for Homogeneity of Covariance Matrices
##
## data: diamonds_final[, 2:7]
## Chi-Sq (approx.) = 23716, df = 84, p-value < 2.2e-164. Uji Asumsi Regresi Logistik Ordinal
- Test of Parallel Lines
data_sampel_ord <- diamonds_final[sample(nrow(diamonds_final), 1000), ]
model_ord_sample <- clm(cut ~ carat + depth + table + x + y + z, data =data_sampel_ord)
uji_asumsi_utama <- nominal_test(model_ord_sample)
print(uji_asumsi_utama)## Tests of nominal effects
##
## formula: cut ~ carat + depth + table + x + y + z
## Df logLik AIC LRT Pr(>Chi)
## <none> -1111.1 2242.3
## carat 3 -1106.5 2239.0 9.294 0.02563 *
## depth 3 -1045.4 2116.9 131.381 < 2e-16 ***
## table 3 -1000.4 2026.9 221.374 < 2e-16 ***
## x 3 -1105.5 2237.1 11.198 0.01070 *
## y 3 -1107.3 2240.7 7.611 0.05479 .
## z 3 -1108.0 2242.1 6.166 0.10380
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1Uji Linearitas
#1. Uji Linearitas plot(data_sampel_ord$carat, as.numeric(data_sampel_ord$cut), main="Cek Tren Karat vs Cut", xlab="Carat (Standardized)", ylab="Cut (Numeric)") abline(lm(as.numeric(data_sampel_ord$cut) ~ data_sampel_ord$carat), col="red")
Uji Independence
Asumsi independensi dilakukan untuk memastikan bahwa setiap observasi pada dataset bersifat saling bebas dan tidak saling memengaruhi. Dalam penelitian ini, setiap observasi merepresentasikan satu unit berlian yang unik yang dicatat secara terpisah, sehingga antar observasi diasumsikan independen (tidak memiliki ketergantungan). Hal ini juga diperkuat dengan dilakukan prosedur pembersihan data (data cleaning) berupa cek duplikasi data untuk menjamin keunikan setiap poin data.
Uji No Multikolinearitas (VIF)
vif_check <- lm(as.numeric(cut) ~ carat + depth + table + x + y + z, data = diamonds_final)
vif(vif_check)## carat depth table x y z
## 31.837846 6.836620 1.117386 529.982554 523.031320 567.954753No Outliers
Uji outlier dilakukan untuk mendeteksi observasi yang memiliki karakteristik sangat berbeda dibandingkan observasi lainnya yang dapat mendistorsi hasil estimasi model. Pada penelitian ini, deteksi outlier dengan kriteria Tukey’s Fences, yaitu metode statistik yang digunakan untuk mendeteksi data pencilan (outliers) berdasarkan rentang antar kuartil (IQR). Berdasarkan hasil pengujian, teridentifikasi sebanyak 3.931 observasi (sekitar 7,67%) yang berada di luar rentang pagar batas atas dan batas bawah. Observasi tersebut kemudian dihapus dari dataset untuk memastikan stabilitas varians dan meningkatkan akurasi klasifikasi.
5. Model Analisis Diskriminan Linear (LDA)
model_lda <- lda(cut ~ carat + depth + table + x + y + z, data = diamonds_final)
print(model_lda)## Call:
## lda(cut ~ carat + depth + table + x + y + z, data = diamonds_final)
##
## Prior probabilities of groups:
## Fair Good Very Good Premium Ideal
## 0.007245458 0.080185889 0.239733840 0.266032953 0.406801859
##
## Group means:
## carat depth table x y
## Fair 0.44648155 1.88235710 0.3459652 0.40535151 0.35131579
## Good 0.11383865 1.12997494 0.3494717 0.06098009 0.07385025
## Very Good 0.02980334 0.10687532 0.2658473 0.01038583 0.03464615
## Premium 0.16731015 -0.38527802 0.6776906 0.18378841 0.15081064
## Ideal -0.15736924 -0.06728476 -0.6748985 -0.14555073 -0.13985592
## z
## Fair 0.57414907
## Good 0.17837910
## Very Good 0.03295895
## Premium 0.12875728
## Ideal -0.14901238
##
## Coefficients of linear discriminants:
## LD1 LD2 LD3 LD4
## carat 0.1157179 -0.1637991 0.4751762 -0.6196664
## depth 0.4229106 1.0260761 -0.5381007 -1.9046843
## table 1.2255897 0.2428743 0.3116431 -0.1017992
## x 5.9827969 -14.7550223 -13.9629025 -10.4255603
## y -5.4660906 15.7065362 14.2759872 -7.2479511
## z -0.5690877 -0.8696218 -0.8661465 18.9740951
##
## Proportion of trace:
## LD1 LD2 LD3 LD4
## 0.5874 0.3437 0.0683 0.0006# Table Confussion Matrix
pred_lda <- predict(model_lda)
tabel_lda <- table(Aktual = diamonds_final$cut, Prediksi = pred_lda$class)
print(tabel_lda)## Prediksi
## Aktual Fair Good Very Good Premium Ideal
## Fair 64 172 8 52 47
## Good 63 1465 929 403 936
## Very Good 1 686 4634 1838 4190
## Premium 2 12 2091 8875 1614
## Ideal 0 17 1326 951 16964akurasi_lda <- sum(diag(tabel_lda)) / sum(tabel_lda)
cat("Akurasi Analisis Diskriminan adalah:", round(akurasi_lda * 100, 2), "%")## Akurasi Analisis Diskriminan adalah: 67.6 %6. Model Regresi Logistik Ordinal
model_ord_final <- clm(cut ~ carat + depth + table + x + y + z, data = diamonds_final)#Tabel Confussion Matrix
pred_ord_final <- predict(model_ord_final, newdata = diamonds_final, type = "class")$fit
tabel_ordinal <- table(Aktual = diamonds_final$cut, Prediksi = pred_ord_final)
print(tabel_ordinal)## Prediksi
## Aktual Fair Good Very Good Premium Ideal
## Fair 0 80 175 31 57
## Good 0 585 2090 534 587
## Very Good 0 367 4988 1891 4103
## Premium 1 54 4652 2755 5132
## Ideal 2 4 614 1646 16992akurasi_ord <- sum(diag(tabel_ordinal), na.rm = TRUE) / sum(tabel_ordinal, na.rm = TRUE)
cat("Total Akurasi Regresi Logistik Ordinal:", round(akurasi_ord * 100, 2), "%")## Total Akurasi Regresi Logistik Ordinal: 53.49 %7. Visualisasi Bar Chart Hit Ratio (Akurasi)
data_perbandingan <- data.frame(
Metode = c("Analisis Diskriminan (LDA)", "Regresi Logistik Ordinal"),
Akurasi = c(67.6, 53.49)
)ggplot(data_perbandingan, aes(x = Metode, y = Akurasi, fill = Metode))+
geom_bar(stat = "identity", width = 0.5, show.legend = FALSE) +
geom_text(aes(label = paste0(Akurasi, "%")), vjust = -0.5, size = 5, fontface = "bold") +
scale_fill_manual(values = c("#2E5984", "#A9A9A9")) +
ylim(0, 100) +
labs(title = "Perbandingan Akurasi Model Klasifikasi",
subtitle = "Kualitas Potongan Berlian (Cut)",
x = "Metode Penelitian",
y = "Akurasi (%)") +
theme_minimal() +
theme(
plot.title = element_text(face = "bold", size = 14),
axis.text = element_text(size = 12, color = "black"),
panel.grid.major.x = element_blank()
)
Kesimpulan
Berdasarkan hasil penelitian yang telah dilakukan, karakteristik fisik berlian seperti carat, depth, table, serta dimensi fisik (x, y, dan z) dapat digunakan untuk mengklasifikasikan kualitas potongan berlian (cut). Variabel-variabel tersebut menunjukkan adanya pengaruh terhadap pembentukan kategori kualitas potongan berlian, meskipun terdapat beberapa pelanggaran asumsi pada model yang digunakan. Hasil perbandingan metode menunjukkan bahwa Analisis Diskriminan memiliki performa klasifikasi yang lebih baik dibandingkan Regresi Logistik Ordinal. Analisis Diskriminan menghasilkan tingkat akurasi sebesar 67,6%, sedangkan Regresi Logistik Ordinal menghasilkan akurasi sebesar 53,49%. Perbedaan performa tersebut dipengaruhi oleh pelanggaran asumsi parallel lines dan adanya multikolinearitas tinggi pada model Regresi Logistik Ordinal. Dengan demikian, Analisis Diskriminan dinilai lebih efektif dalam mengklasifikasikan kualitas potongan berlian pada dataset Diamonds.
Saran
Penelitian selanjutnya disarankan untuk menambahkan variabel lain yang berkaitan dengan kualitas berlian, seperti color, clarity, dan price, agar model klasifikasi dapat menghasilkan performa yang lebih optimal. Selain itu, dapat dilakukan penerapan metode klasifikasi lain berbasis machine learning seperti Random Forest, Support Vector Machine (SVM), atau XGBoost untuk memperoleh perbandingan performa model yang lebih komprehensif. Selain pengembangan metode, penelitian selanjutnya juga dapat mempertimbangkan teknik penanganan multikolinearitas dan ketidakseimbangan kelas data agar hasil klasifikasi menjadi lebih stabil dan akurat. Penggunaan teknik reduksi dimensi maupun metode resampling dapat menjadi alternatif dalam meningkatkan kualitas model klasifikasi.