Ordinal Regression

Load Data

data <- read.csv("D:/Youtube/Regresi/Logistic Regression/ordinal.csv")
head(data)

##   No Jam.Belajar Kehadiran  Metode  Nilai
## 1  1           6        85  Online Sedang
## 2  2          14        72 Offline Sedang
## 3  3          10        90  Online Sedang
## 4  4           8        76 Offline Rendah
## 5  5          15        88  Online Tinggi
## 6  6          12        70 Offline Sedang

Ubah ke Format Ordinal

X1 <- data$Jam.Belajar
X2 <- data$Kehadiran
# Variabel kategorik
X3 <- as.factor(data$Metode)

# Variabel ordinal
Y <- factor(data$Nilai,
                 levels = c("Rendah","Sedang","Tinggi"),
                 ordered = TRUE)
str(Y)

##  Ord.factor w/ 3 levels "Rendah"<"Sedang"<..: 2 2 2 1 3 2 3 3 2 3 ...

Pemodelan

library(ordinal)
model_ord <- clm(Y ~ X1 + X2 + X3, data = data)

summary(model_ord)

## formula: Y ~ X1 + X2 + X3
## data:    data
## 
##  link  threshold nobs logLik AIC   niter max.grad cond.H 
##  logit flexible  50   -9.80  29.61 9(0)  3.29e-11 1.6e+07
## 
## Coefficients:
##          Estimate Std. Error z value Pr(>|z|)   
## X1         1.5937     0.5502   2.897  0.00377 **
## X2         0.5110     0.1830   2.792  0.00524 **
## X3Online   1.6486     1.6290   1.012  0.31150   
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Threshold coefficients:
##               Estimate Std. Error z value
## Rendah|Sedang    52.25      18.24   2.865
## Sedang|Tinggi    63.92      21.72   2.942

Persamaan 1 (Rendah vs lainnya)

\[logit(P(Y≤Rendah))=52.25−(1.5937X1+0.5110X2+1.6486X3)\]

Persamaan 2 (Sedang vs Tinggi)

\[logit(P(Y≤Rendah))=63.92−(1.5937X1+0.5110X2+1.6486X3)\]

Jam Belajar (X₁) memiliki koefisien sebesar 1.5937 dengan nilai p-value 0.00377
Kehadiran (X₂) memiliki koefisien sebesar 0.5110 dengan p-value 0.00524
Metode Belajar (X₃) memiliki koefisien sebesar 1.6486, namun tidak signifikan (p-value = 0.31150

Odds Ratio

exp(coef(model_ord))

## Rendah|Sedang Sedang|Tinggi            X1            X2      X3Online 
##  4.918390e+22  5.757429e+27  4.921952e+00  1.667034e+00  5.199859e+00

X1 Jam Belajar = 4.92 artinya setiap kenaikan 1 unit jam belajar meningkatkan peluang mahasiswa berada pada kategori nilai yang lebih tinggi sebesar 4.92 kali
X2 Kehadiran = 1.67 artinya setiap kenaikan meningkatkan peluang masuk kategori lebih tinggi sebesar 1.67 kali
X3 Metode Online = 5.20 Mahasiswa dengan metode online memiliki peluang sekitas 5.20 kali untuk berada pada kategori lebih tinggi dibanding offline

Prediksi

pred <- predict(model_ord, type = "class")
pred$fit

##  [1] Sedang Sedang Sedang Rendah Tinggi Sedang Sedang Tinggi Sedang Tinggi
## [11] Sedang Tinggi Rendah Tinggi Tinggi Rendah Sedang Tinggi Sedang Tinggi
## [21] Sedang Sedang Tinggi Rendah Tinggi Sedang Tinggi Tinggi Sedang Sedang
## [31] Tinggi Rendah Tinggi Sedang Sedang Tinggi Sedang Sedang Tinggi Sedang
## [41] Tinggi Rendah Tinggi Sedang Rendah Tinggi Tinggi Rendah Tinggi Tinggi
## Levels: Rendah Sedang Tinggi

Confusion Matrix

Y <- factor(Y,levels = c("Rendah","Sedang","Tinggi"))

pred <- factor(pred$fit,levels = levels(Y))

library(caret)

## Loading required package: ggplot2

## Loading required package: lattice

confusionMatrix(pred, Y)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction Rendah Sedang Tinggi
##     Rendah      8      0      0
##     Sedang      0     18      2
##     Tinggi      0      1     21
## 
## Overall Statistics
##                                           
##                Accuracy : 0.94            
##                  95% CI : (0.8345, 0.9875)
##     No Information Rate : 0.46            
##     P-Value [Acc > NIR] : 4.596e-13       
##                                           
##                   Kappa : 0.9032          
##                                           
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: Rendah Class: Sedang Class: Tinggi
## Sensitivity                   1.00        0.9474        0.9130
## Specificity                   1.00        0.9355        0.9630
## Pos Pred Value                1.00        0.9000        0.9545
## Neg Pred Value                1.00        0.9667        0.9286
## Prevalence                    0.16        0.3800        0.4600
## Detection Rate                0.16        0.3600        0.4200
## Detection Prevalence          0.16        0.4000        0.4400
## Balanced Accuracy             1.00        0.9414        0.9380

Model klasifikasi menunjukkan performa yang sangat baik dengan akurasi sebesar 94%

Nagelkerke Pseudo R²

1. Model Penuh

model_ord

## formula: Y ~ X1 + X2 + X3
## data:    data
## 
##  link  threshold nobs logLik AIC   niter max.grad cond.H 
##  logit flexible  50   -9.80  29.61 9(0)  3.29e-11 1.6e+07
## 
## Coefficients:
##       X1       X2 X3Online 
##    1.594    0.511    1.649 
## 
## Threshold coefficients:
## Rendah|Sedang Sedang|Tinggi 
##         52.25         63.92

2. Model Null

model_null <- clm(Y ~ 1)

3. Ambil log-likelihood

LL_full <- logLik(model_ord)
LL_null <- logLik(model_null)

n <- nrow(data)

4. Hitung Nagelkerke R²

R2_nagelkerke <- (1 - exp((2/n)*(LL_null - LL_full))) /
                 (1 - exp((2/n)*LL_null))

R2_nagelkerke

## 'log Lik.' 0.9279301 (df=2)

Model mampu menjelaskan sekitar 92.8% variasi dalam kategori nilai Ini menunjukkan bahwa model memiliki daya jelaskan yang sangat kuat