DATA 624 HW8
Benson T
2025-04-05
7.2
7.2. Friedman (1991) introduced several benchmark data sets create by simulation. One of these simulations used the following nonlinear equation to create data: y = 10sin(πx1x2)+20(x3−0.5)2 +10x4 +5x5 +N(0,σ2) where the x values are random variables uniformly distributed between [0, 1] (there are also 5 other non-informative variables also created in the simulation). The package mlbench contains a function called mlbench.friedman1 that simulates these data:
library(mlbench)
set.seed(721)
trainingData <- mlbench.friedman1(200, sd = 1)
## We convert the 'x' data from a matrix to a data frame
## One reason is that this will give the columns names.
trainingData$x <- data.frame(trainingData$x)
## Look at the data using
featurePlot(trainingData$x, trainingData$y)
## or other methods.
## This creates a list with a vector 'y' and a matrix
## of predictors 'x'. Also simulate a large test set to
## estimate the true error rate with good precision:
testData <- mlbench.friedman1(5000, sd = 1)
testData$x <- data.frame(testData$x)knnModel <- train(x = trainingData$x,
y = trainingData$y,
method = "knn",
preProc = c("center", "scale"),
tuneLength = 10)
knnModel## k-Nearest Neighbors
##
## 200 samples
## 10 predictor
##
## Pre-processing: centered (10), scaled (10)
## Resampling: Bootstrapped (25 reps)
## Summary of sample sizes: 200, 200, 200, 200, 200, 200, ...
## Resampling results across tuning parameters:
##
## k RMSE Rsquared MAE
## 5 3.706009 0.4505291 2.949240
## 7 3.622687 0.4821010 2.890209
## 9 3.593104 0.5042039 2.862705
## 11 3.568090 0.5279902 2.854404
## 13 3.573969 0.5389483 2.867143
## 15 3.586538 0.5478154 2.877913
## 17 3.602665 0.5558344 2.882442
## 19 3.635492 0.5617699 2.907682
## 21 3.641255 0.5718312 2.908622
## 23 3.676812 0.5704722 2.934032
##
## RMSE was used to select the optimal model using the smallest value.
## The final value used for the model was k = 11.knnPred <- predict(knnModel, newdata = testData$x)
## The function 'postResample' can be used to get the test set
## perforamnce values
postResample(pred = knnPred, obs = testData$y)## RMSE Rsquared MAE
## 3.5237062 0.5969245 2.8169073Which models appear to give the best performance?
- MARS model give best performance compare to Knn. The RMSE is lower, Higher R^2, and lower MAE.
Does MARS select the informative predictors (those named X1–X5)?
- Yes, MARS selects all informative predictors (X1, X2, X3, X4, X5)
- Each appears in at least one basis function, and their roles align with the true model
marsModel <- train(
x = trainingData$x,
y = trainingData$y,
method = "earth",
preProc = c("center", "scale"),
tuneGrid = expand.grid(
nprune = seq(5, 25, by = 5),
degree = 1:2
),
trControl = trainControl(method = "cv", number = 10)
)## Loading required package: earth## Loading required package: Formula## Loading required package: plotmo## Loading required package: plotrixmarsModel## Multivariate Adaptive Regression Spline
##
## 200 samples
## 10 predictor
##
## Pre-processing: centered (10), scaled (10)
## Resampling: Cross-Validated (10 fold)
## Summary of sample sizes: 180, 180, 180, 180, 180, 180, ...
## Resampling results across tuning parameters:
##
## degree nprune RMSE Rsquared MAE
## 1 5 2.578411 0.7220219 2.1145280
## 1 10 1.774223 0.8668396 1.4562196
## 1 15 1.698866 0.8778902 1.4163723
## 1 20 1.675905 0.8825781 1.3848450
## 1 25 1.675905 0.8825781 1.3848450
## 2 5 2.618711 0.7163649 2.1077099
## 2 10 1.541482 0.8964935 1.2694412
## 2 15 1.217784 0.9367029 0.9919940
## 2 20 1.223870 0.9376425 0.9996359
## 2 25 1.223870 0.9376425 0.9996359
##
## RMSE was used to select the optimal model using the smallest value.
## The final values used for the model were nprune = 15 and degree = 2.marsPred <- predict(marsModel, newdata = testData$x)
postResample(pred = marsPred, obs = testData$y)## RMSE Rsquared MAE
## 1.2800648 0.9345949 1.0188134summary(marsModel$finalModel)## Call: earth(x=data.frame[200,10], y=c(12.14,13.27,1...), keepxy=TRUE, degree=2,
## nprune=15)
##
## coefficients
## (Intercept) 18.0456444
## h(0.995595-X1) -3.8725832
## h(0.208463-X2) -4.1282503
## h(X2-0.208463) 3.4306528
## h(-0.54401-X3) 4.2977260
## h(X3-0.916446) 3.8881565
## h(-0.635109-X4) -3.0767993
## h(X4- -0.635109) 2.8095039
## h(0.197796-X5) -2.6984955
## h(-0.232645-X1) * h(X2-0.208463) -2.4378418
## h(X1- -0.232645) * h(X2-0.208463) -5.1576014
## h(0.135706-X1) * h(0.208463-X2) 1.8992060
## h(X1-0.135706) * h(0.208463-X2) -1.4139227
## h(X3- -0.54401) * h(X5-0.883003) 3.0059030
## h(X3- -0.54401) * h(0.883003-X5) 0.4886681
##
## Selected 15 of 20 terms, and 5 of 10 predictors (nprune=15)
## Termination condition: Reached nk 21
## Importance: X4, X2, X1, X3, X5, X6-unused, X7-unused, X8-unused, X9-unused, ...
## Number of terms at each degree of interaction: 1 8 6
## GCV 1.549125 RSS 208.3263 GRSq 0.9354093 RSq 0.95613167.5
Exercise 6.3 describes data for a chemical manufacturing process. Use the same data imputation, data splitting, and pre-processing steps as before and train several nonlinear regression models.
library(AppliedPredictiveModeling)
#data(package = "AppliedPredictiveModeling")
data(ChemicalManufacturingProcess)
dim(ChemicalManufacturingProcess)## [1] 176 58processPredictors <- ChemicalManufacturingProcess[, 2:58]
imputation_model <- preProcess(processPredictors, method = "knnImpute")
processPredictors_imputed <- predict(imputation_model, processPredictors)
ChemicalManufacturingProcess_imputed <- data.frame(Yield = ChemicalManufacturingProcess[, 1], processPredictors_imputed)
sum(is.na(processPredictors_imputed))## [1] 0set.seed(633)
trainIndex <- createDataPartition(ChemicalManufacturingProcess$Yield, p = 0.7, list = FALSE)
trainData <- ChemicalManufacturingProcess[trainIndex, ]
testData <- ChemicalManufacturingProcess[-trainIndex, ]
trainPredictors <- trainData[, 2:58]
trainYield <- trainData[, 1]
testPredictors <- testData[, 2:58]
testYield <- testData[, 1]
preProc <- preProcess(trainPredictors, method = c("knnImpute", "center", "scale","nzv"))
trainPredictorsProc <- predict(preProc, trainPredictors)
testPredictorsProc <- predict(preProc, testPredictors)
trainDataProc <- data.frame(Yield = trainYield, trainPredictorsProc)
testDataProc <- data.frame(Yield = testYield, testPredictorsProc)
tuneGrid <- expand.grid(mtry = seq(5, 25, by = 5))
rfModel <- train(Yield ~ .,
data = trainDataProc,
method = "rf",
trControl = trainControl(method = "cv", number = 5),
tuneGrid = tuneGrid,
ntree = 500)
print(rfModel)## Random Forest
##
## 124 samples
## 56 predictor
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 100, 99, 100, 99, 98
## Resampling results across tuning parameters:
##
## mtry RMSE Rsquared MAE
## 5 1.249309 0.6161581 0.9725708
## 10 1.213800 0.6340294 0.9319809
## 15 1.191960 0.6407472 0.9064890
## 20 1.200466 0.6316641 0.9111240
## 25 1.197815 0.6310883 0.9140329
##
## RMSE was used to select the optimal model using the smallest value.
## The final value used for the model was mtry = 15.testPredictions <- predict(rfModel, newdata = testDataProc)
testRMSE <- sqrt(mean((testYield - testPredictions)^2))
cat("Test Set RMSE:", testRMSE, "\n")## Test Set RMSE: 1.106367optimalRMSE <- min(rfModel$results$RMSE)
cat("Optimal Cross-Validated RMSE:", optimalRMSE, "\n")## Optimal Cross-Validated RMSE: 1.19196resampledRMSE <- min(rfModel$results$RMSE)
cat("Resampled RMSE from Training Set (5-fold CV):", resampledRMSE, "\n")## Resampled RMSE from Training Set (5-fold CV): 1.19196testPredictions <- predict(rfModel, newdata = testDataProc)
testRMSE <- sqrt(mean((testYield - testPredictions)^2))
cat("Test Set RMSE:", testRMSE, "\n")## Test Set RMSE: 1.106367difference <- testRMSE - resampledRMSE
cat("Difference (Test RMSE - Resampled RMSE):", difference, "\n")## Difference (Test RMSE - Resampled RMSE): -0.08559258- Which nonlinear regression model gives the optimal resampling and test set performance?
The Random Forest model (mtry = 25) gives the optimal resampling performance (CV RMSE = 1.19313) and test set performance (Test RMSE = 1.088043).
ctrl <- trainControl(method = "cv", number = 5)
# F
tuneGrid_rf <- expand.grid(mtry = seq(5, 25, by = 5))
rfModel <- train(Yield ~ .,
data = trainDataProc,
method = "rf",
trControl = ctrl,
tuneGrid = tuneGrid_rf,
ntree = 500)
print(rfModel)## Random Forest
##
## 124 samples
## 56 predictor
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 100, 98, 100, 99, 99
## Resampling results across tuning parameters:
##
## mtry RMSE Rsquared MAE
## 5 1.244590 0.6140717 0.9709461
## 10 1.218753 0.6126613 0.9298302
## 15 1.198058 0.6236879 0.9092800
## 20 1.206864 0.6121420 0.9105705
## 25 1.207406 0.6055513 0.9084004
##
## RMSE was used to select the optimal model using the smallest value.
## The final value used for the model was mtry = 15.#SVM
tuneGrid_svm <- expand.grid(sigma = c(0.01, 0.05, 0.1), C = c(0.5, 1, 2))
svmModel <- train(Yield ~ .,
data = trainDataProc,
method = "svmRadial",
trControl = ctrl,
tuneGrid = tuneGrid_svm)
print(svmModel)## Support Vector Machines with Radial Basis Function Kernel
##
## 124 samples
## 56 predictor
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 100, 100, 99, 98, 99
## Resampling results across tuning parameters:
##
## sigma C RMSE Rsquared MAE
## 0.01 0.5 1.327882 0.5252058 1.0401258
## 0.01 1.0 1.247132 0.5769094 0.9602485
## 0.01 2.0 1.179468 0.6214044 0.9073022
## 0.05 0.5 1.594248 0.3833918 1.2535528
## 0.05 1.0 1.519222 0.4332197 1.1864243
## 0.05 2.0 1.482373 0.4658189 1.1601251
## 0.10 0.5 1.784483 0.2752033 1.4412105
## 0.10 1.0 1.735166 0.2907547 1.4049837
## 0.10 2.0 1.717766 0.3128269 1.3961935
##
## RMSE was used to select the optimal model using the smallest value.
## The final values used for the model were sigma = 0.01 and C = 2.#NN
tuneGrid_nn <- expand.grid(size = c(5, 10, 15), decay = c(0, 0.1, 0.01))
nnModel <- train(Yield ~ .,
data = trainDataProc,
method = "nnet",
trControl = ctrl,
tuneGrid = tuneGrid_nn,
linout = TRUE, trace = FALSE)
print(nnModel)## Neural Network
##
## 124 samples
## 56 predictor
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 100, 98, 99, 99, 100
## Resampling results across tuning parameters:
##
## size decay RMSE Rsquared MAE
## 5 0.00 4.114260 0.12252761 2.867536
## 5 0.01 2.776162 0.22881774 2.188245
## 5 0.10 3.146272 0.16952466 2.363709
## 10 0.00 3.867237 0.27332011 2.915173
## 10 0.01 4.051138 0.13466544 3.071753
## 10 0.10 5.657624 0.20364495 3.649740
## 15 0.00 11.923086 0.10210983 7.238255
## 15 0.01 12.670800 0.07916649 8.009502
## 15 0.10 12.105154 0.10711062 6.083075
##
## RMSE was used to select the optimal model using the smallest value.
## The final values used for the model were size = 5 and decay = 0.01.#MARS
tuneGrid_mars <- expand.grid(degree = 1:2, nprune = seq(10, 30, by = 10))
marsModel <- train(Yield ~ .,
data = trainDataProc,
method = "earth",
trControl = ctrl,
tuneGrid = tuneGrid_mars)
print(marsModel)## Multivariate Adaptive Regression Spline
##
## 124 samples
## 56 predictor
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 100, 97, 99, 100, 100
## Resampling results across tuning parameters:
##
## degree nprune RMSE Rsquared MAE
## 1 10 3.390595 0.4583162 1.524032
## 1 20 3.433925 0.4376110 1.563542
## 1 30 3.433925 0.4376110 1.563542
## 2 10 1.385550 0.4868444 1.057996
## 2 20 1.445331 0.4607554 1.085965
## 2 30 1.445331 0.4607554 1.085965
##
## RMSE was used to select the optimal model using the smallest value.
## The final values used for the model were nprune = 10 and degree = 2.calc_test_rmse <- function(model, test_data, actual) {
preds <- predict(model, newdata = test_data)
sqrt(mean((actual - preds)^2))
}
test_rmse_rf <- calc_test_rmse(rfModel, testDataProc, testDataProc$Yield)
test_rmse_svm <- calc_test_rmse(svmModel, testDataProc, testDataProc$Yield)
test_rmse_nn <- calc_test_rmse(nnModel, testDataProc, testDataProc$Yield)
test_rmse_mars <- calc_test_rmse(marsModel, testDataProc, testDataProc$Yield)
cv_rmse_rf <- min(rfModel$results$RMSE)
cat("RF - CV RMSE:", cv_rmse_rf, " Test RMSE:", test_rmse_rf, "\n")## RF - CV RMSE: 1.198058 Test RMSE: 1.113055cv_rmse_svm <- min(svmModel$results$RMSE)
cat("SVM - CV RMSE:", cv_rmse_svm, " Test RMSE:", test_rmse_svm, "\n")## SVM - CV RMSE: 1.179468 Test RMSE: 1.258914cv_rmse_nn <- min(nnModel$results$RMSE)
cat("NN - CV RMSE:", cv_rmse_nn, " Test RMSE:", test_rmse_nn, "\n")## NN - CV RMSE: 2.776162 Test RMSE: 3.18143cv_rmse_mars <- min(marsModel$results$RMSE)
cat("MARS - CV RMSE:", cv_rmse_mars, " Test RMSE:", test_rmse_mars, "\n")## MARS - CV RMSE: 1.38555 Test RMSE: 1.425111cv_rmses <- c(cv_rmse_rf, cv_rmse_svm, cv_rmse_nn, cv_rmse_mars)
test_rmses <- c(test_rmse_rf, test_rmse_svm, test_rmse_nn, test_rmse_mars)
models <- c("RF", "SVM", "NN", "MARS")
best_cv <- models[which.min(cv_rmses)]
best_test <- models[which.min(test_rmses)]
cat("Best Resampling Model:", best_cv, "with CV RMSE:", min(cv_rmses), "\n")## Best Resampling Model: SVM with CV RMSE: 1.179468cat("Best Test Set Model:", best_test, "with Test RMSE:", min(test_rmses), "\n")## Best Test Set Model: RF with Test RMSE: 1.113055- Which predictors are most important in the optimal nonlinear regression model? Do either the biological or process variables dominate the list? How do the top ten important predictors compare to the top ten predictors from the optimal linear model?
- Most Important in RF are ManufacturingProcess32, ManufacturingProcess13, and BiologicalMaterial03.
- No dominance—biological 5 each.
- 8 overlapping predictors, with minor differences in rankings and two unique predictors per model, reflecting the nonlinear vs linear modeling approaches.
rf_importance <- varImp(rfModel, scale = FALSE)
top10_rf <- rf_importance$importance
top10_rf <- data.frame(Predictor = rownames(top10_rf), Importance = top10_rf$Overall)
top10_rf <- top10_rf[order(top10_rf$Importance, decreasing = TRUE), ][1:10, ]
cat("Top 10 Predictors in RF Model:\n")## Top 10 Predictors in RF Model:print(top10_rf)## Predictor Importance
## 43 ManufacturingProcess32 57.528789
## 24 ManufacturingProcess13 41.995656
## 3 BiologicalMaterial03 36.740239
## 11 BiologicalMaterial12 33.411240
## 6 BiologicalMaterial06 25.203156
## 20 ManufacturingProcess09 20.326449
## 28 ManufacturingProcess17 18.310859
## 2 BiologicalMaterial02 12.784815
## 10 BiologicalMaterial11 11.410544
## 42 ManufacturingProcess31 9.957337biological <- grep("Biological", top10_rf$Predictor, value = TRUE)
process <- grep("Manufacturing", top10_rf$Predictor, value = TRUE)
cat("Biological Predictors in Top 10:", length(biological), "\n")## Biological Predictors in Top 10: 5cat("Process Predictors in Top 10:", length(process), "\n")## Process Predictors in Top 10: 5plsModel <- train(Yield ~ .,
data = trainDataProc,
method = "pls",
trControl = ctrl,
tuneGrid = expand.grid(ncomp = 1:10))
pls_importance <- varImp(plsModel, scale = FALSE)##
## Attaching package: 'pls'## The following object is masked from 'package:caret':
##
## R2## The following object is masked from 'package:stats':
##
## loadingstop10_pls <- pls_importance$importance
top10_pls <- data.frame(Predictor = rownames(top10_pls), Importance = top10_pls$Overall)
top10_pls <- top10_pls[order(top10_pls$Importance, decreasing = TRUE), ][1:10, ]
cat("Top 10 Predictors in PLS Model:\n")## Top 10 Predictors in PLS Model:print(top10_pls)## Predictor Importance
## 24 ManufacturingProcess13 0.11750627
## 20 ManufacturingProcess09 0.11453566
## 43 ManufacturingProcess32 0.11355576
## 28 ManufacturingProcess17 0.11235193
## 3 BiologicalMaterial03 0.09338363
## 6 BiologicalMaterial06 0.09256927
## 47 ManufacturingProcess36 0.09043238
## 2 BiologicalMaterial02 0.09010460
## 23 ManufacturingProcess12 0.08591522
## 11 BiologicalMaterial12 0.08198661overlap <- intersect(top10_rf$Predictor, top10_pls$Predictor)
cat("Overlap between RF and PLS Top 10:", length(overlap), "\n")## Overlap between RF and PLS Top 10: 8print(overlap)## [1] "ManufacturingProcess32" "ManufacturingProcess13" "BiologicalMaterial03"
## [4] "BiologicalMaterial12" "BiologicalMaterial06" "ManufacturingProcess09"
## [7] "ManufacturingProcess17" "BiologicalMaterial02"- Explore the relationships between the top predictors and the response for the predictors that are unique to the optimal nonlinear regression model. Do these plots reveal intuition about the biological or process predictors and their relationship with yield
The BiologicalMaterial11 plots show a big jump in Yield from purple to yellow when both predictors are high. This explains that BiologicalMaterial11 and BiologicalMaterial03 are likely ingredients that work best when paired.
The ManufacturingProcess31 plots show a clear drop in Yield from yellow to purple. However, when ManufacturingProcess31 is low, and ManufacturingProcess32 is optimal, it shows a small boost in yield. RF notices this specific range that works between ManufacturingProcess31 and ManufacturingProcess32
pdp_bm11 <- partial(rfModel, pred.var = "BiologicalMaterial11", train = trainDataProc)
plotPartial(pdp_bm11, xlab = "BiologicalMaterial11", ylab = "Predicted Yield")
pdp_mp31 <- partial(rfModel, pred.var = "ManufacturingProcess31", train = trainDataProc)
plotPartial(pdp_mp31, xlab = "ManufacturingProcess31", ylab = "Predicted Yield")
pdp_bm11_bm03 <- partial(rfModel,
pred.var = c("BiologicalMaterial11", "BiologicalMaterial03"),
train = trainDataProc,
grid.resolution = 20)
plotPartial(pdp_bm11_bm03,
levelplot = TRUE,
xlab = "BiologicalMaterial11",
ylab = "BiologicalMaterial03",
zlab = "Predicted Yield")
pdp_mp31_mp32 <- partial(rfModel,
pred.var = c("ManufacturingProcess31", "ManufacturingProcess32"),
train = trainDataProc,
grid.resolution = 20)
plotPartial(pdp_mp31_mp32,
levelplot = TRUE,
xlab = "ManufacturingProcess31",
ylab = "ManufacturingProcess32",
zlab = "Predicted Yield")