Superunsuper Learning

by Muhammad Nachnoer Novatron Fitra Arss

Awalan

Packages

lapply(c("readxl","readr","rvest","factoextra","hrbrthemes",
         "gridExtra","StatMatch","scales","dplyr","ggradar","ggcorrplot",
         "glmnet","caret"),
       library,character.only=T)[[1]]

## [1] "readxl"    "stats"     "graphics"  "grDevices" "utils"     "datasets" 
## [7] "methods"   "base"

Data

Scrapping Kemendagri

url<-"https://aksi.bangda.kemendagri.go.id/emonev/DashPrev/index/3"
kmd<-read_html(url)
tab<-html_nodes(kmd,".table")[[1]]%>%html_table(dec=".");colnames(tab[-1,])

## [1] "No"                   "Provinsi"             "Jumlah Balita (anak)"
## [4] "Stunting"             "Stunting"             "Prevalensi (%)"

#Hanya mengambil kolom prevalensi stunting
clt<-data.frame(tab[c(-1,-36),c(2,6)]);colnames(clt)[2]<-"Stunting";tibble(clt)

## # A tibble: 34 × 2
##    Provinsi                  Stunting
##    <chr>                     <chr>   
##  1 ACEH                      12.1    
##  2 SUMATERA UTARA            6.7     
##  3 SUMATERA BARAT            15.1    
##  4 RIAU                      6.0     
##  5 JAMBI                     3.0     
##  6 SUMATERA SELATAN          4.4     
##  7 BENGKULU                  6.3     
##  8 LAMPUNG                   6.1     
##  9 KEPULAUAN BANGKA BELITUNG 5.9     
## 10 KEPULAUAN RIAU            7.6     
## # … with 24 more rows

#Newdata
write.csv(clt,"stunt.csv")

Gabungan data prevalensi stunting hasil scrapping dengan 2 subset data lainnya (Jumlah Perokok berusia > 15 tahun dan kebutuhan KB yang belum terpenuhi (Unmet Need))

setwd("C:/Users/falco/Documents/R/BARU")
Provinsi<-data.frame(read_csv("stunt.csv"))$Provinsi
Stunting<- data.frame(read_csv("stunt.csv"))$Stunting
Merokok<-as.numeric(read_excel("merokok.xlsx")$`Merokok (%)`)
Unmet.Need<-as.numeric(read_excel("merokok.xlsx")$`Unmet Need (%)`)
kesehatan<-data.frame(Stunting,Merokok,Unmet.Need);rownames(kesehatan)<-Provinsi

Data Final

kesehatan

##                           Stunting Merokok Unmet.Need
## ACEH                          12.1   28.30       4.29
## SUMATERA UTARA                 6.7   27.24       3.83
## SUMATERA BARAT                15.1   30.50       3.26
## RIAU                           6.0   28.34       3.20
## JAMBI                          3.0   27.47       3.85
## SUMATERA SELATAN               4.4   30.65       3.32
## BENGKULU                       6.3   33.17       4.49
## LAMPUNG                        6.1   34.07       3.89
## KEPULAUAN BANGKA BELITUNG      5.9   28.16       3.36
## KEPULAUAN RIAU                 7.6   26.17       2.25
## DKI JAKARTA                    3.2   24.44       2.61
## JAWA BARAT                     8.3   32.68       3.86
## JAWA TENGAH                    9.0   28.24       8.28
## DI YOGYAKARTA                 10.6   24.54       3.02
## JAWA TIMUR                    10.7   28.53       6.75
## BANTEN                         6.7   31.76       4.29
## BALI                           5.0   19.58       2.42
## NUSA TENGGARA BARAT           21.7   32.71       8.49
## NUSA TENGGARA TIMUR           22.6   27.22       7.37
## KALIMANTAN BARAT              21.0   27.93       4.48
## KALIMANTAN TENGAH             10.8   29.33       4.18
## KALIMANTAN SELATAN            10.4   24.51       6.46
## KALIMANTAN TIMUR              11.8   23.37       2.61
## KALIMANTAN UTARA              18.5   27.46       3.73
## SULAWESI UTARA                 3.0   27.87       3.19
## SULAWESI TENGAH               13.2   29.77       6.25
## SULAWESI SELATAN              10.4   24.91       4.22
## SULAWESI TENGGARA             18.5   25.85       7.59
## GORONTALO                      8.5   30.50       6.45
## SULAWESI BARAT                19.3   27.17       6.98
## MALUKU                         6.8   27.90       4.45
## MALUKU UTARA                  13.0   29.84       5.41
## PAPUA BARAT                   13.2   27.07       2.78
## PAPUA                         10.1   24.91       2.95

Clustering

Penggunaan Jarak Mahalanobis

m<-as.dist(mahalanobis.dist(kesehatan));fviz_dist(m)

Pemilihan Jumlah Klaster Optimum Menggunakan Ward Linkage (Hirarki vs K-means)

h<-hclust(m,method="ward.D2")
f1<-fviz_nbclust(kesehatan,hcut,"wss",diss=m)
f2<-fviz_nbclust(kesehatan,kmeans,"wss")
grid.arrange(f1,f2,nrow=2)

Interpretasi:Gambar 1 merupakan screeplot dengan algoritma hierarchical clustering, sedangkan gambar 2 merupakan screeplot dengan algoritma k-means. Dapat disaksikan, bahwa keduanya bersiku di klaster 2, tetapi wss nya masih cenderung tinggi, sehingga diambil jumlah klaster yang memiliki wss lebih kecil tetapi patah pola yang menyebabkan pola setelahnya menurun. Hal ini tercermin pada jumlah klaster 5. Sehingga, jumlah klaster optimumnya 5. Kemudian dibandingkan antara k-means dengan hierarchical. Terlihat bahwa wss hiearchical yang kisaran ratusan sampai ribuan jauh lebih kecil dari k-means yang kisarannya 100 ke bawah. Maka, yang digunakan adalah metode hierarchical clustering

Perbandingan Linkage Hierarchical Clustering

#Ward Linkage
f1<-fviz_dend(hclust(m,method="ward.D2"),k=5,lwd=1.1,
              ggtheme = theme_ipsum_rc(grid=F)+
                theme(plot.title = element_text(hjust=0.5),
                      axis.text.y.left = element_blank(),
                      axis.title.y.left = element_blank()),
              main="Ward Linkage",
              k_colors = RColorBrewer::brewer.pal(11,"Blues")[3:9])
#Complete Linkage
f2<- fviz_dend(hclust(m,method="complete"),k=5,lwd=1.1,
               ggtheme = theme_ipsum_rc(grid=F)+
                 theme(plot.title = element_text(hjust=0.5),
                       axis.text.y.left = element_blank(),
                       axis.title.y.left = element_blank()),
               main="Complete Linkage",
               k_colors = RColorBrewer::brewer.pal(11,"Blues")[3:9])

#Average Linkage
f3<- fviz_dend(hclust(m,method="average"),k=5,lwd=1.1,
               ggtheme = theme_ipsum_rc(grid=F)+
                 theme(plot.title = element_text(hjust=0.5),
                       axis.text.y.left = element_blank(),
                       axis.title.y.left = element_blank()),
               main="Average Linkage",
               k_colors = RColorBrewer::brewer.pal(11,"Blues")[3:9])

#Single Linkage
f4<- fviz_dend(hclust(m,method="single"),k=5,lwd=1.1,
               ggtheme = theme_ipsum_rc(grid=F)+
                 theme(plot.title = element_text(hjust=0.5),
                       axis.text.y.left = element_blank(),
                       axis.title.y.left = element_blank()),
               main="Single Linkage",
               k_colors = RColorBrewer::brewer.pal(11,"Blues")[3:9])

#Centroid Linkage
f5<-fviz_dend(hclust(m,method="centroid"),k=5,lwd=1.1,
              ggtheme = theme_ipsum_rc(grid=F)+
                theme(plot.title = element_text(hjust=0.5),
                      axis.text.y.left = element_blank(),
                      axis.title.y.left = element_blank()), 
              main="Centroid Linkage",
              k_colors = RColorBrewer::brewer.pal(11,"Blues")[3:9])
#Perbandingan Linkage Method pada Hierarchical Clustering dengan jarak yang digunakan adalah Jarak Mahalanobies dengan jumlah Klaster 7
f1

g1<-grid.arrange(f2,f3,f4,f5,ncol=2)

Interpretasi: Dapat dilihat single dan centroid linkage memiliki hasil pengklasteran yang paling buruk karena pembagian annggota klaster yang cenderung didominasi oleh 1 klaster pada single linkage dan cenderung tidak merata pada centorid linkage. Pada average linkage, terlihat ada 1 klaster yang hanya beranggotakan 1 anggota. Sedangkan, untuk complete dan ward merupakan yang paling baik hasilnya, tetapi pada complete lingkage masih ada 1 klaster yang hanya beranggotakan 2 anggota. Maka, sesuai dengan literatur, bahwa ward linkage adalah linkage yang lebih baik terutama dalam meminimumkan within sum-square

Interpretasi

Visualisasi Klaster

e<-eclust(kesehatan,"hclust",k=5,stand=F,diss=m,graph = T)
fviz_cluster(e,ggtheme=theme_ipsum_rc(grid=F)+
      theme(plot.title = element_text(hjust=0.5,color="white"),
            legend.title = element_text(color="white"),
            legend.text=element_text(color="white"),
            plot.background = element_rect(fill="#000044",color = "#000044"),
            axis.text.y.left = element_blank(),axis.title.y.left = element_blank(),
            axis.text.x.bottom = element_blank(),axis.title.x.bottom = element_blank()))

Data Agregat

a<-aggregate(kesehatan, by=list(cluster=e$cluster), FUN = mean);a

##   cluster Stunting  Merokok Unmet.Need
## 1       1 11.73333 29.12000   5.294444
## 2       2  5.16000 26.78200   3.248000
## 3       3  6.85000 32.92000   4.132500
## 4       4 10.66000 24.44800   3.852000
## 5       5 20.26667 28.05667   6.440000

radar<-a%>%group_by(cluster)%>%ungroup()%>%mutate_at(vars(-cluster), rescale)
radar$cluster<-paste("Klaster",1:5)

Radar Chart

radar%>%ggradar(fill=T,fill.alpha=0.4,background.circle.colour="coral",plot.title="Radar Karakteristik Klaster")+
  theme_ipsum_rc(grid=F)+
  theme(legend.position = c(1,0),
        legend.justification = c(1,0), 
        legend.margin = margin(b=135, r=-35), 
        legend.background = element_blank(),
        legend.key=element_rect(fill=NA, color=NA), 
        legend.text=element_text(colour = "black",size = 12),
        rect = element_rect(fill="transparent"),
        axis.text.y.left = element_blank(),
        axis.text.x.bottom = element_blank(),
        plot.title = element_text(hjust=0.5)
        )

Interpretasi:Sangat jelas terlihat bahwa klaster 3 merupakan klaster dengan jumlah perokok dengan usia > 15 tahun yang paling banyak dibandingkan klaster lainnya. Sedangkan klaster 5 merupakan klaster memiliki persentase tertinggi terkait penderita stunting dan persentase keluarga yang kebutuhan KB-nya belum terpenuhi. Oleh karena itu, kedua klaster ini merupakan klaster prioritas yang perlu ditingkatkan lagi kesehatannya. Berbeda dengan klaser 2 yang merupakan klaster dengan tingkat kesehatan paling baik

RIDGE VS LASSO

Data

dc<-decathlon2[,c(12,1,2,5,6)];glimpse(dc)

## Rows: 27
## Columns: 5
## $ Points       <int> 8217, 8122, 8067, 8036, 8004, 7995, 7802, 7733, 7708, 765…
## $ X100m        <dbl> 11.04, 10.76, 11.02, 11.34, 11.13, 10.83, 11.64, 11.37, 1…
## $ Long.jump    <dbl> 7.58, 7.40, 7.23, 7.09, 7.30, 7.31, 6.81, 7.56, 6.97, 7.2…
## $ X400m        <dbl> 49.81, 49.37, 48.93, 50.42, 48.62, 49.91, 50.14, 51.10, 4…
## $ X110m.hurdle <dbl> 14.69, 14.05, 14.99, 15.31, 14.17, 14.38, 14.93, 15.06, 1…

ggcorrplot(cor(dc),lab = T,colors = c("red","black","steelblue"),
           type="lower",lab_size = 5.2,lab_col = "white")

Interpretasi:Teramati pada anak tangga kedua sampai keempat bahwwa antar peubah bebas berkorelasi tinggi (absolut korelasinya > 0.5) yang menyebabkan multikolinearitas. Oleh karena itu, regresi ridge dan lasso relevan untuk menangani kasus ini. Sedangkan pada anak tangga pertama, menunjukkan hubungan yang kuat antara peubah respon yaitu total poin dengan 3 peubah bebas yang merupakan capaian tiap cabang lomba

Training-Testing

set.seed(14)
i<-sample(1:nrow(dc),0.7*nrow(dc))
tr<-dc[i,];tr

##             Points X100m Long.jump X400m X110m.hurdle
## BARRAS        7708 11.33      6.97 49.48        14.48
## Drews         7926 10.87      7.38 48.51        14.01
## BOURGUIGNON   7313 11.36      6.80 51.16        15.67
## Schwarzl      8102 10.98      7.49 49.76        14.25
## WARNERS       8030 11.11      7.60 48.68        14.23
## Warners       8343 10.62      7.74 47.97        14.01
## Karpov        8725 10.50      7.81 46.81        13.97
## Pogorelov     8084 10.95      7.31 50.79        14.21
## Schoenbeck    8077 10.90      7.30 50.30        14.34
## Macey         8414 10.89      7.47 48.97        14.56
## SEBRLE        8217 11.04      7.58 49.81        14.69
## Nool          8235 10.80      7.53 48.81        14.80
## BERNARD       8067 11.02      7.23 48.93        14.99
## Sebrle        8893 10.85      7.84 48.36        14.05
## ZSIVOCZKY     8004 11.13      7.30 48.62        14.17
## Hernu         8237 10.97      7.19 48.73        14.25
## Zsivoczky     8287 10.91      7.14 49.40        14.95
## NOOL          7651 11.33      7.27 49.20        15.29

ts<-dc[-i,];ts

##           Points X100m Long.jump X400m X110m.hurdle
## CLAY        8122 10.76      7.40 49.37        14.05
## YURKOV      8036 11.34      7.09 50.42        15.31
## McMULLEN    7995 10.83      7.31 49.91        14.38
## MARTINEAU   7802 11.64      6.81 50.14        14.93
## HERNU       7733 11.37      7.56 51.10        15.06
## Clay        8820 10.44      7.96 49.19        14.13
## Bernard     8225 10.69      7.48 49.13        14.17
## Barras      8067 11.14      6.99 49.41        14.37
## KARPOV      8099 11.02      7.30 48.37        14.09

xtr<-as.matrix(tr[,-5]);xts<-as.matrix(ts[,-5])
ytr<-as.matrix(tr$Points);yts<-as.matrix(ts$Points)

Cross-Validation

ridge<-cv.glmnet(xtr,ytr,alpha=0);plot(ridge);ridge$lambda.min#ridge

## Warning: Option grouped=FALSE enforced in cv.glmnet, since < 3 observations per
## fold

## [1] 35.50473

lasso<-cv.glmnet(xtr,ytr,alpha=1);plot(lasso);lasso$lambda.min#lasso

## Warning: Option grouped=FALSE enforced in cv.glmnet, since < 3 observations per
## fold

## [1] 10.34982

Model dengan Lambda Optimum

ridgebest<-glmnet(xtr,ytr,alpha=0,lambda=ridge$lambda.min,standardize = T)
lassobest<-glmnet(xtr,ytr,alpha=1,lambda=lasso$lambda.min,standardize = T)

Fungsi Evaluasi Model

eval_results <- function(true, predicted, df) {
  SSE <- sum((predicted - true)^2)
  SST <- sum((true - mean(true))^2)
  R_square <- 1 - SSE / SST
  RMSE = sqrt(SSE/nrow(df))
  
  # Model performance metrics
  data.frame(RMSE = RMSE,
             Rsquare = R_square)
}

Hasil Evaluasi Model

#Ridge-train
predict.tr.ridge <- predict(ridgebest, s = ridge$lambda.min, newx = xtr )
eval_results(ytr, predict.tr.ridge, tr)

##       RMSE   Rsquare
## 1 46.35606 0.9829533

#Ridge-test
predict.ts.ridge <- predict(ridgebest, s = ridge$lambda.min, newx = xts )
eval_results(yts, predict.ts.ridge, ts)

##      RMSE   Rsquare
## 1 62.0944 0.9551784

#Lasso-train
predict.tr.lasso  <- predict(lassobest, s = lasso$lambda.min, newx = xtr)
eval_results(ytr, predict.tr.lasso, tr)

##       RMSE   Rsquare
## 1 10.34982 0.9991502

#Ridge-test
predict.ts.lasso <- predict(lassobest, s = lasso$lambda.min, newx = xts)
eval_results(yts, predict.ts.lasso, ts)

##       RMSE   Rsquare
## 1 8.590373 0.9991422

Interpretasi: Teramati untuk kedua model memiliki R-square yang sangat tinggi yiatu kisaran 0.95-0.99. Namun, lasso lebih unggul. Sehingga, dalam kasus ini, metode lasso yang tidak mempertahankan semua peubah untuk mereduksi dimensi, memberikan pemodelan yang lebih baik. Hasil training dan testing tidak begitu jauh, artinya tidak ada underfitting ataupun overfitting pada model

Superunsuper Learning

by Muhammad Nachnoer Novatron Fitra Arss

AwalanBack

Packages

Data

Scrapping Kemendagri

Gabungan data prevalensi stunting hasil scrapping dengan 2 subset data lainnya (Jumlah Perokok berusia > 15 tahun dan kebutuhan KB yang belum terpenuhi (Unmet Need))

Data Final

ClusteringBack

Penggunaan Jarak Mahalanobis

Pemilihan Jumlah Klaster Optimum Menggunakan Ward Linkage (Hirarki vs K-means)

Perbandingan Linkage Hierarchical Clustering

InterpretasiBack

Visualisasi Klaster

Data Agregat

Radar Chart

RIDGE VS LASSOBack

Data

Training-Testing

Cross-Validation

Model dengan Lambda Optimum

Fungsi Evaluasi Model

Hasil Evaluasi Model

Awalan

Clustering

Interpretasi

RIDGE VS LASSO