31  Modeling with PCA - Diab_Pop

31.1 SET UP


Attaching package: 'data.table'
The following object is masked from 'package:base':

    %notin%
── 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::between()     masks data.table::between()
✖ dplyr::filter()      masks stats::filter()
✖ dplyr::first()       masks data.table::first()
✖ lubridate::hour()    masks data.table::hour()
✖ lubridate::isoweek() masks data.table::isoweek()
✖ lubridate::isoyear() masks data.table::isoyear()
✖ dplyr::lag()         masks stats::lag()
✖ dplyr::last()        masks data.table::last()
✖ lubridate::mday()    masks data.table::mday()
✖ lubridate::minute()  masks data.table::minute()
✖ lubridate::month()   masks data.table::month()
✖ lubridate::quarter() masks data.table::quarter()
✖ lubridate::second()  masks data.table::second()
✖ purrr::transpose()   masks data.table::transpose()
✖ lubridate::wday()    masks data.table::wday()
✖ lubridate::week()    masks data.table::week()
✖ lubridate::yday()    masks data.table::yday()
✖ lubridate::year()    masks data.table::year()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
Loading required package: lattice

Attaching package: 'caret'

The following object is masked from 'package:purrr':

    lift
diab_pop <- readRDS(here::here('DATA/diab_pop.RDS')) %>%
  na.omit() 

numeric_features <- diab_pop %>%
  select_if(is.numeric) %>%
  select(-seqn) %>%
  colnames()

numeric_features
[1] "ridageyr" "bmxbmi"   "lbxglu"

31.2 Split Data

TrainInd <- createDataPartition(diab_pop$diq010,
                                p=.7,
                                list=FALSE)

TRAIN <- diab_pop[TrainInd,]
pP.TRAIN <- preProcess(TRAIN, c('center','scale'))

31.2.1 How many Clusters should we make ?

TRAIN_scaled <- predict(pP.TRAIN, TRAIN)

TRAIN.PCA_Model <- prcomp(TRAIN_scaled %>% select(bmxbmi, lbxglu, ridageyr))

summary(TRAIN.PCA_Model)
Importance of components:
                         PC1    PC2    PC3
Standard deviation     1.140 0.9763 0.8647
Proportion of Variance 0.433 0.3177 0.2492
Cumulative Proportion  0.433 0.7508 1.0000
ggbiplot(TRAIN.PCA_Model)

32 How can we determine the number of principal components?

We aim to find the components with the maximum variance so we can retain as much information about the original dataset as possible.

To determine the number of principal components to retain in our analysis we need to compute the proportion of variance explained.

We can plot the cumulative proportion of variance explained in a scree plot to determine the number of principal components to retain.

# Pull SD
sd.TRAIN <- TRAIN.PCA_Model$sdev

# Compute variance
var.TRAIN <- sd.TRAIN^2

# Proportion of variance explained
prop.TRAIN <- var.TRAIN/sum(var.TRAIN)

# Plot the cumulative proportion of variance explained
plot(cumsum(prop.TRAIN), 
     xlab='Principal components', 
     ylab='Proportion of variance explained', 
     type='b')

TRAIN.PCA <- cbind(TRAIN, predict(TRAIN.PCA_Model, predict(pP.TRAIN, TRAIN)))


glimpse(TRAIN.PCA) 
Rows: 1,314
Columns: 13
$ seqn     <dbl> 83733, 83734, 83750, 83754, 83755, 83757, 83761, 83787, 83799…
$ riagendr <fct> Male, Male, Male, Female, Male, Female, Female, Female, Femal…
$ ridageyr <dbl> 53, 78, 45, 67, 67, 57, 24, 68, 37, 20, 24, 80, 70, 20, 29, 3…
$ ridreth1 <fct> Non-Hispanic White, Non-Hispanic White, Other, Other Hispanic…
$ dmdeduc2 <fct> High school graduate/GED, High school graduate/GED, Grades 9-…
$ dmdmartl <fct> Divorced, Married, Never married, Married, Widowed, Separated…
$ indhhin2 <fct> "$15,000-$19,999", "$20,000-$24,999", "$65,000-$74,999", "$25…
$ bmxbmi   <dbl> 30.8, 28.8, 24.1, 43.7, 28.8, 35.4, 25.3, 33.5, 25.5, 26.2, 2…
$ diq010   <fct> No Diabetes, Diabetes, No Diabetes, No Diabetes, Diabetes, Di…
$ lbxglu   <dbl> 101, 84, 84, 130, 284, 398, 95, 111, 100, 94, 105, 119, 94, 8…
$ PC1      <dbl> 0.003342041, -0.393979942, 1.000373419, -1.810381033, -3.2768…
$ PC2      <dbl> 0.05922484, -1.05276414, -0.38863554, 0.97567471, -0.84133409…
$ PC3      <dbl> 0.384223799, 1.361394311, 0.045480236, 1.057760075, -2.513758…
features <- colnames(TRAIN.PCA)[!colnames(TRAIN.PCA) %in% c('seqn', 'diq010', 'PC3')] 

features
 [1] "riagendr" "ridageyr" "ridreth1" "dmdeduc2" "dmdmartl" "indhhin2"
 [7] "bmxbmi"   "lbxglu"   "PC1"      "PC2"     
paste0('diq010 ~ ', paste( features , collapse = " + " ))
[1] "diq010 ~ riagendr + ridageyr + ridreth1 + dmdeduc2 + dmdmartl + indhhin2 + bmxbmi + lbxglu + PC1 + PC2"
formula1 <- as.formula('diq010 ~ PC1 + PC2')

formula2 <- as.formula('diq010 ~ bmxbmi + lbxglu + ridageyr')
  
formula3 <- as.formula(paste0('diq010 ~ ', paste( features , collapse = " + " )))
train_ctrl <- trainControl(method="boot", # type of resampling, in this case bootstrap
                                number = 5, # number of resamplings     
                                search = "random" # we are performing a "random" search
                                )

model_boot_glm_1 <- train(formula1,
                         data = TRAIN.PCA,
                         method = "glm", 
                         trControl = train_ctrl,
                         # options to be passed to glm
                         family = 'binomial',
                         preProcess = c('center','scale')
                         )

model_boot_glm_2 <- train(formula2,
                         data = TRAIN.PCA,
                         method = "glm", 
                         trControl = train_ctrl,
                         # options to be passed to glm
                         family = 'binomial',
                         preProcess = c('center','scale'))

model_boot_glm_3 <- train(formula3,
                         data = TRAIN.PCA,
                         method = "glm", 
                         trControl = train_ctrl,
                         # options to be passed to glm
                         family = 'binomial',
                         preProcess = c('center','scale'))
Warning in preProcess.default(thresh = 0.95, k = 5, freqCut = 19, uniqueCut =
10, : These variables have zero variances: indhhin2$35,000-$44,999,
indhhin2$55,000-$64,999
Warning in preProcess.default(thresh = 0.95, k = 5, freqCut = 19, uniqueCut =
10, : These variables have zero variances: indhhin2$35,000-$44,999,
indhhin2$55,000-$64,999
Warning in preProcess.default(thresh = 0.95, k = 5, freqCut = 19, uniqueCut =
10, : These variables have zero variances: indhhin2$35,000-$44,999,
indhhin2$55,000-$64,999
Warning in preProcess.default(thresh = 0.95, k = 5, freqCut = 19, uniqueCut =
10, : These variables have zero variances: indhhin2$35,000-$44,999,
indhhin2$55,000-$64,999
Warning in preProcess.default(thresh = 0.95, k = 5, freqCut = 19, uniqueCut =
10, : These variables have zero variances: indhhin2$35,000-$44,999,
indhhin2$55,000-$64,999
Warning in preProcess.default(thresh = 0.95, k = 5, freqCut = 19, uniqueCut =
10, : These variables have zero variances: indhhin2$35,000-$44,999,
indhhin2$55,000-$64,999

32.1 Dealing with the Test data

saveRDS(model_boot_glm_1,'model_boot_glm_1.RDS')
saveRDS(pP.TRAIN,'pP.TRAIN.RDS')
saveRDS(TRAIN.PCA_Model,'TRAIN.PCA_Model.RDS')

rm(model_boot_glm_1)
rm(pP.TRAIN)
rm(TRAIN.PCA_Model)
model_boot_glm_1
Error:
! object 'model_boot_glm_1' not found
model_boot_glm_1 <- readRDS('model_boot_glm_1.RDS')
pP.TRAIN <- readRDS('pP.TRAIN.RDS')
TRAIN.PCA_Model <- readRDS('TRAIN.PCA_Model.RDS')

TEST <- diab_pop[-TrainInd,]

# this should be right 
str( predict(TRAIN.PCA_Model, predict(pP.TRAIN, TEST)) , 1 )
 num [1:562, 1:3] -0.5582 -0.8334 -4.447 0.0454 0.5681 ...
 - attr(*, "dimnames")=List of 2
str( TEST %>% predict(pP.TRAIN, .) %>% predict(TRAIN.PCA_Model, . ) , 1)
 num [1:562, 1:3] -0.5582 -0.8334 -4.447 0.0454 0.5681 ...
 - attr(*, "dimnames")=List of 2
#
# this should be wrong 
predict(pP.TRAIN, predict(TRAIN.PCA_Model, TEST))
Error in `newdata[, object$method$center, drop = FALSE]`:
! subscript out of bounds
TEST.PCA <- cbind(TEST , predict(TRAIN.PCA_Model, predict(pP.TRAIN, TEST)))

glimpse(TEST.PCA)
Rows: 562
Columns: 13
$ seqn     <dbl> 83737, 83789, 83790, 83849, 83851, 83920, 83925, 83932, 83934…
$ riagendr <fct> Female, Male, Male, Male, Female, Female, Female, Female, Fem…
$ ridageyr <dbl> 72, 66, 56, 71, 37, 68, 74, 80, 27, 47, 63, 68, 68, 27, 29, 6…
$ ridreth1 <fct> MexicanAmerican, Non-Hispanic White, Non-Hispanic White, Othe…
$ dmdeduc2 <fct> Grades 9-11th, College grad or above, Less than 9th grade, So…
$ dmdmartl <fct> Separated, Living with partner, Married, Married, Married, Ma…
$ indhhin2 <fct> "$75,000-$99,999", "$65,000-$74,999", "$15,000-$19,999", "$25…
$ bmxbmi   <dbl> 28.6, 34.0, 24.4, 27.6, 35.3, 35.2, 24.4, 26.9, 17.2, 22.7, 2…
$ diq010   <fct> No Diabetes, No Diabetes, No Diabetes, Diabetes, No Diabetes,…
$ lbxglu   <dbl> 107, 113, 397, 76, 79, 145, 100, 110, 89, 95, 100, 139, 94, 1…
$ PC1      <dbl> -0.55817181, -0.83335928, -4.44696298, 0.04538282, 0.56805813…
$ PC2      <dbl> -0.879866615, -0.062072264, -1.043305630, -0.927258672, 1.163…
$ PC3      <dbl> 0.7541938, 0.7685007, -5.1076766, 1.2116569, 0.5236037, 0.336…

32.1.1 Predicting on the TEST data

TEST_1 <- TEST.PCA

TEST_1$estimate <- predict(model_boot_glm_1, TEST.PCA, 'raw')
TEST_1$Diabetes <- predict(model_boot_glm_1, TEST.PCA, 'prob')$Diabetes

TEST_2 <- TEST.PCA

TEST_2$estimate <- predict(model_boot_glm_2, TEST.PCA, 'raw')
TEST_2$Diabetes <- predict(model_boot_glm_2, TEST.PCA, 'prob')$Diabetes

TEST_3 <- TEST.PCA

TEST_3$estimate <- predict(model_boot_glm_3, TEST.PCA, 'raw')
TEST_3$Diabetes <- predict(model_boot_glm_3, TEST.PCA, 'prob')$Diabetes



TEST.stacked <- bind_rows(TEST_1 %>% mutate(model = 'w_PCAs_only'),
                          TEST_2 %>% mutate(model = 'w_nums'),
                          TEST_3 %>% mutate(model = "full_model")
                          )
library('yardstick')

Attaching package: 'yardstick'
The following objects are masked from 'package:caret':

    precision, recall, sensitivity, specificity
The following object is masked from 'package:readr':

    spec
library('glue')


Aucs <- TEST.stacked %>%
  group_by(model) %>%
  roc_auc(truth = diq010, Diabetes) %>%
  arrange(-.estimate) %>%
  glue_data("{model} AUC : {round(.estimate, 3)}") 
  


TEST.stacked %>%
  group_by(model) %>%
  roc_curve(truth = diq010, Diabetes) %>%
  autoplot() +
  labs(caption  = paste(Aucs, collapse = " \n "))