Getting updates
getting-updates-bayesianrvfl.Rmd0 - Packages and data
library(learningmachine)## Loading required package: randtoolbox## Loading required package: rngWELL## This is randtoolbox. For an overview, type 'help("randtoolbox")'.## Loading required package: tseries## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoo## Loading required package: memoise## Loading required package: foreach## Loading required package: skimr## Loading required package: snow## Loading required package: doSNOW## Loading required package: iterators## Loading required package: ggplot2## Loading required package: lattice
library(mlbench)
library(palmerpenguins)
X <- as.matrix(mtcars[,-1])
y <- mtcars$mpg
set.seed(123)
(index_train <- base::sample.int(n = nrow(X),
size = floor(0.6*nrow(X)),
replace = FALSE))## [1] 31 15 19 14 3 10 18 22 11 5 20 29 23 30 9 28 8 27 7
X_train <- X[index_train, ]
y_train <- y[index_train]
X_test <- X[-index_train, ]
y_test <- y[-index_train]
dim(X_train)## [1] 19 10
dim(X_test)## [1] 13 10
obj_GCV <- bayesianrvfl::fit_rvfl(x = X_train, y = y_train)
(best_lambda <- obj_GCV$lambda[which.min(obj_GCV$GCV)])## [1] 12.91551 - RVFL regression updates
obj <- learningmachine::Regressor$new(method = "bayesianrvfl",
nb_hidden = 5L)
obj$get_type()## [1] "regression"
obj$get_name()## [1] "Regressor"
t0 <- proc.time()[3]
obj$fit(X_train, y_train, reg_lambda = best_lambda)
cat("Elapsed: ", proc.time()[3] - t0, "s \n")## Elapsed: 0.009 s
print(obj$predict(X_test))## $preds
## Mazda RX4 Mazda RX4 Wag Hornet 4 Drive Valiant
## 21.72647 21.30147 20.57339 20.40433
## Merc 450SE Merc 450SL Lincoln Continental Chrysler Imperial
## 15.07106 15.57730 11.43328 11.71555
## Toyota Corona Camaro Z28 Pontiac Firebird Fiat X1-9
## 24.78543 14.45203 15.12042 29.35087
## Volvo 142E
## 25.97273
##
## $lower
## Mazda RX4 Mazda RX4 Wag Hornet 4 Drive Valiant
## 14.067816 13.655095 12.741795 12.509024
## Merc 450SE Merc 450SL Lincoln Continental Chrysler Imperial
## 7.489889 8.045126 3.350443 3.760876
## Toyota Corona Camaro Z28 Pontiac Firebird Fiat X1-9
## 16.733640 6.546520 7.059589 21.433047
## Volvo 142E
## 18.456205
##
## $upper
## Mazda RX4 Mazda RX4 Wag Hornet 4 Drive Valiant
## 29.38513 28.94784 28.40499 28.29964
## Merc 450SE Merc 450SL Lincoln Continental Chrysler Imperial
## 22.65223 23.10947 19.51612 19.67022
## Toyota Corona Camaro Z28 Pontiac Firebird Fiat X1-9
## 32.83723 22.35754 23.18125 37.26870
## Volvo 142E
## 33.48926
##
## $simulate
## function (n)
## MASS::mvrnorm(n = n, mu = res, Sigma = Sigma_newx)
## <bytecode: 0x7fa8dd57e388>
## <environment: 0x7fa8dd57d780>
obj$summary(X_test, y=y_test, show_progress=FALSE)## $R_squared
## [1] 0.6714261
##
## $R_squared_adj
## [1] -0.9714435
##
## $Residuals
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -4.5727 -2.0509 -0.7265 -0.3449 1.3289 4.0796
##
## $Coverage_rate
## [1] 100
##
## $citests
## estimate lower upper p-value signif
## cyl -43.7544698 -46.5047867 -41.0041528 2.118540e-13 ***
## disp -0.6263908 -0.7184442 -0.5343375 4.440630e-09 ***
## hp -1.0357395 -1.2469270 -0.8245521 1.741273e-07 ***
## drat 91.6790411 80.7865309 102.5715514 3.830077e-10 ***
## wt -173.5883607 -192.9498209 -154.2269004 1.835870e-10 ***
## qsec 21.3008188 15.5157279 27.0859097 3.653604e-06 ***
## vs 105.8540687 83.6069779 128.1011595 2.422756e-07 ***
## am 204.1534474 176.7091659 231.5977289 1.598086e-09 ***
## gear 47.2993146 39.4986036 55.1000256 1.645027e-08 ***
## carb -58.9820744 -68.7040650 -49.2600838 1.634624e-08 ***
##
## $signif_codes
## [1] "Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1"
##
## $effects
## ── Data Summary ────────────────────────
## Values
## Name effects
## Number of rows 13
## Number of columns 10
## _______________________
## Column type frequency:
## numeric 10
## ________________________
## Group variables None
##
## ── Variable type: numeric ──────────────────────────────────────────────────────
## skim_variable mean sd p0 p25 p50 p75 p100
## 1 cyl -43.8 4.55 -48.4 -48.4 -40.5 -40.2 -36.7
## 2 disp -0.626 0.152 -0.945 -0.635 -0.560 -0.560 -0.410
## 3 hp -1.04 0.349 -1.52 -1.43 -0.930 -0.725 -0.725
## 4 drat 91.7 18.0 67.5 78.8 95.5 95.5 130.
## 5 wt -174. 32.0 -224. -200. -193. -141. -141.
## 6 qsec 21.3 9.57 13.0 13.0 20.7 26.6 36.6
## 7 vs 106. 36.8 74.3 74.3 103. 145. 166.
## 8 am 204. 45.4 160. 160. 197. 251. 253.
## 9 gear 47.3 12.9 29.9 38.1 50.0 50.0 74.8
## 10 carb -59.0 16.1 -84.1 -72.2 -68.7 -42.7 -42.7
## hist
## 1 ▇▁▁▇▁
## 2 ▂▁▃▇▁
## 3 ▇▁▁▂▇
## 4 ▇▁▇▁▁
## 5 ▁▇▁▁▇
## 6 ▇▃▁▁▃
## 7 ▇▃▁▂▂
## 8 ▇▁▁▁▇
## 9 ▇▁▇▁▁
## 10 ▁▇▁▁▇## Elapsed: 0.171 s
obj$set_level(95)
res <- obj$predict(X = X_test)
plot(c(y_train, res$preds), type='l',
main="",
ylab="",
ylim = c(min(c(res$upper, res$lower, y)),
max(c(res$upper, res$lower, y))))
lines(c(y_train, res$upper), col="gray60")
lines(c(y_train, res$lower), col="gray60")
lines(c(y_train, res$preds), col = "red")
lines(c(y_train, y_test), col = "blue")
abline(v = length(y_train), lty=2, col="black")
mean((y_test >= as.numeric(res$lower)) * (y_test <= as.numeric(res$upper)))## [1] 0update RVFL model
previous_coefs <- drop(obj$model$coef)
newx <- X_test[1, ]
newy <- y_test[1]
new_X_test <- X_test[-1, ]
new_y_test <- y_test[-1]
t0 <- proc.time()[3]
obj$update(newx, newy)
cat("Elapsed: ", proc.time()[3] - t0, "s \n")## Elapsed: 0.017 s
summary(previous_coefs)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -10.0323 -2.1730 0.4918 0.3695 2.1039 15.5515## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -4.7221 -2.3221 0.1890 -0.1018 1.7974 4.4465
obj$summary(new_X_test, y=new_y_test, show_progress=FALSE)## $R_squared
## [1] 0.2612556
##
## $R_squared_adj
## [1] -7.126189
##
## $Residuals
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -4.5397 0.1801 3.2930 2.2180 3.9011 6.9500
##
## $Coverage_rate
## [1] 0
##
## $citests
## estimate lower upper p-value signif
## cyl 257.2611892 222.8492699 291.673109 4.286598e-09 ***
## disp 0.8668335 -0.3027658 2.036433 1.311135e-01
## hp -10.3185447 -12.3192739 -8.317815 2.055072e-07 ***
## drat -102.1189660 -274.9945471 70.756615 2.201352e-01
## wt -719.6788248 -893.9055286 -545.452121 1.898188e-06 ***
## qsec 17.5909087 -60.8711749 96.052992 6.313966e-01
## vs -194.0447449 -441.9795954 53.890106 1.129218e-01
## am -571.2955807 -888.7015171 -253.889644 2.228206e-03 **
## gear 736.7448821 610.9718511 862.517913 5.544994e-08 ***
## carb 43.5006025 -43.3757615 130.376966 2.939585e-01
##
## $signif_codes
## [1] "Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1"
##
## $effects
## ── Data Summary ────────────────────────
## Values
## Name effects
## Number of rows 12
## Number of columns 10
## _______________________
## Column type frequency:
## numeric 10
## ________________________
## Group variables None
##
## ── Variable type: numeric ──────────────────────────────────────────────────────
## skim_variable mean sd p0 p25 p50 p75 p100
## 1 cyl 257. 54.2 206. 206. 253. 310. 324.
## 2 disp 0.867 1.84 -2.50 0.236 1.84 1.84 3.64
## 3 hp -10.3 3.15 -14.6 -14.4 -8.85 -7.69 -7.69
## 4 drat -102. 272. -471. -310. 54.5 54.5 367.
## 5 wt -720. 274. -1046. -945. -689. -461. -461.
## 6 qsec 17.6 123. -74.7 -74.7 -40.0 57.5 223.
## 7 vs -194. 390. -512. -401. -401. -214. 617.
## 8 am -571. 500. -1001. -1001. -901. -22.8 11.5
## 9 gear 737. 198. 472. 585. 850. 850. 1078.
## 10 carb 43.5 137. -120. -68.6 58.6 173. 173.
## hist
## 1 ▇▁▁▂▅
## 2 ▂▁▃▇▁
## 3 ▅▁▁▂▇
## 4 ▃▂▁▇▁
## 5 ▃▃▁▁▇
## 6 ▇▃▁▁▃
## 7 ▇▃▁▁▂
## 8 ▇▁▁▁▆
## 9 ▃▂▁▇▁
## 10 ▃▃▁▁▇
res <- obj$predict(X = new_X_test)
new_y_train <- c(y_train, newy)
plot(c(new_y_train, res$preds), type='l',
main="",
ylab="",
ylim = c(min(c(res$upper, res$lower, y)),
max(c(res$upper, res$lower, y))))
lines(c(new_y_train, res$upper), col="gray60")
lines(c(new_y_train, res$lower), col="gray60")
lines(c(new_y_train, res$preds), col = "red")
lines(c(new_y_train, new_y_test), col = "blue")
abline(v = length(y_train), lty=2, col="black")
mean((new_y_test >= as.numeric(res$lower)) * (new_y_test <= as.numeric(res$upper)))## [1] 0update RVFL model (Pt.2)
newx <- X_test[2, ]
newy <- y_test[2]
new_X_test <- X_test[-c(1, 2), ]
new_y_test <- y_test[-c(1, 2)]## Elapsed: 0.008 s
obj$summary(new_X_test, y=new_y_test, show_progress=FALSE)## $R_squared
## [1] 0.2969718
##
## $R_squared_adj
## [1] -Inf
##
## $Residuals
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -4.4618 0.3053 2.4757 2.1086 3.8532 7.8192
##
## $Coverage_rate
## [1] 0
##
## $citests
## estimate lower upper p-value signif
## cyl 211.376998 187.5805099 235.173486 2.377085e-09 ***
## disp 1.283873 0.4366073 2.131139 7.045993e-03 **
## hp -9.188437 -10.8210558 -7.555817 1.929063e-07 ***
## drat -163.110337 -282.6556152 -43.565058 1.245994e-02 *
## wt -694.905581 -831.5318555 -558.279307 4.993959e-07 ***
## qsec 49.295847 -23.7814092 122.373104 1.637342e-01
## vs -60.444278 -261.4668672 140.578311 5.180505e-01
## am -247.967120 -513.2391500 17.304909 6.389820e-02 .
## gear 558.406428 471.6174663 645.195390 5.397869e-08 ***
## carb 73.070711 5.3182381 140.823183 3.712251e-02 *
##
## $signif_codes
## [1] "Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1"
##
## $effects
## ── Data Summary ────────────────────────
## Values
## Name effects
## Number of rows 11
## Number of columns 10
## _______________________
## Column type frequency:
## numeric 10
## ________________________
## Group variables None
##
## ── Variable type: numeric ──────────────────────────────────────────────────────
## skim_variable mean sd p0 p25 p50 p75 p100 hist
## 1 cyl 211. 35.4 181. 181. 181. 246. 252. ▇▁▁▁▇
## 2 disp 1.28 1.26 -1.12 1.19 2.13 2.13 2.13 ▂▁▁▃▇
## 3 hp -9.19 2.43 -12.8 -11.0 -7.39 -7.39 -7.39 ▃▁▁▂▇
## 4 drat -163. 178. -402. -324. -14.8 -14.8 -14.8 ▃▂▁▁▇
## 5 wt -695. 203. -960. -868. -520. -520. -520. ▂▃▁▁▇
## 6 qsec 49.3 109. -28.6 -28.6 -28.6 118. 220. ▇▂▁▁▃
## 7 vs -60.4 299. -208. -208. -208. -169. 544. ▇▁▁▁▂
## 8 am -248. 395. -592. -592. -592. 162. 172. ▇▁▁▁▇
## 9 gear 558. 129. 386. 440. 666. 666. 666. ▃▂▁▁▇
## 10 carb 73.1 101. -58.5 -12.6 160. 160. 160. ▂▃▁▁▇
res <- obj$predict(X = new_X_test)
new_y_train <- c(y_train, y_test[c(1, 2)])
plot(c(new_y_train, res$preds), type='l',
main="",
ylab="",
ylim = c(min(c(res$upper, res$lower, y)),
max(c(res$upper, res$lower, y))))
lines(c(new_y_train, res$upper), col="gray60")
lines(c(new_y_train, res$lower), col="gray60")
lines(c(new_y_train, res$preds), col = "red")
lines(c(new_y_train, new_y_test), col = "blue")
abline(v = length(y_train), lty=2, col="black")
mean((new_y_test >= as.numeric(res$lower)) * (new_y_test <= as.numeric(res$upper)))## [1] 02 - update RVFL model using Polyak averaging
obj <- learningmachine::Regressor$new(method = "bayesianrvfl",
nb_hidden = 5L)
obj$get_type()## [1] "regression"
obj$get_name()## [1] "Regressor"
obj_GCV <- bayesianrvfl::fit_rvfl(x = X_train, y = y_train)
(best_lambda <- obj_GCV$lambda[which.min(obj_GCV$GCV)])## [1] 12.9155
t0 <- proc.time()[3]
obj$fit(X_train, y_train, reg_lambda = best_lambda)
cat("Elapsed: ", proc.time()[3] - t0, "s \n")## Elapsed: 0.005 s
previous_coefs <- drop(obj$model$coef)
newx <- X_test[1, ]
newy <- y_test[1]
new_X_test <- X_test[-1, ]
new_y_test <- y_test[-1]
t0 <- proc.time()[3]
obj$update(newx, newy, method = "polyak", alpha = 0.6)
cat("Elapsed: ", proc.time()[3] - t0, "s \n")## Elapsed: 0.006 s
summary(previous_coefs)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -0.96778 -0.51401 -0.16335 -0.05234 0.31900 0.98482## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -0.065436 -0.002152 0.027994 0.015974 0.040033 0.058892
obj$summary(new_X_test, y=new_y_test, show_progress=FALSE)## $R_squared
## [1] 0.6692541
##
## $R_squared_adj
## [1] -2.638205
##
## $Residuals
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -4.5014 -2.2111 -0.5532 -0.3928 1.3495 3.9206
##
## $Coverage_rate
## [1] 100
##
## $citests
## estimate lower upper p-value signif
## cyl -41.4815528 -43.6039915 -39.3591140 1.306085e-13 ***
## disp -0.5937584 -0.7014857 -0.4860311 1.040246e-07 ***
## hp -1.0226867 -1.2175471 -0.8278263 1.719172e-07 ***
## drat 84.5859637 73.2987057 95.8732217 4.178658e-09 ***
## wt -169.1047879 -189.5595154 -148.6500603 1.469605e-09 ***
## qsec 22.3026258 15.1341951 29.4710566 2.772362e-05 ***
## vs 113.3209911 88.3101728 138.3318093 7.599984e-07 ***
## am 175.1639102 139.5755741 210.7522464 3.304560e-07 ***
## gear 44.3270639 36.1456398 52.5084881 1.240722e-07 ***
## carb -59.6511203 -69.8576126 -49.4446280 5.677270e-08 ***
##
## $signif_codes
## [1] "Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1"
##
## $effects
## ── Data Summary ────────────────────────
## Values
## Name effects
## Number of rows 12
## Number of columns 10
## _______________________
## Column type frequency:
## numeric 10
## ________________________
## Group variables None
##
## ── Variable type: numeric ──────────────────────────────────────────────────────
## skim_variable mean sd p0 p25 p50 p75 p100
## 1 cyl -41.5 3.34 -43.4 -43.4 -43.3 -41.7 -34.5
## 2 disp -0.594 0.170 -0.916 -0.635 -0.505 -0.505 -0.356
## 3 hp -1.02 0.307 -1.44 -1.40 -0.877 -0.768 -0.768
## 4 drat 84.6 17.8 59.5 76.7 89.5 89.5 128.
## 5 wt -169. 32.2 -204. -199. -166. -138. -138.
## 6 qsec 22.3 11.3 13.3 13.3 17.4 29.2 40.1
## 7 vs 113. 39.4 59.6 94.4 94.4 117. 191.
## 8 am 175. 56.0 124. 124. 153. 226. 245.
## 9 gear 44.3 12.9 26.3 38.7 47.9 47.9 76.0
## 10 carb -59.7 16.1 -77.3 -74.6 -58.2 -44.4 -44.4
## hist
## 1 ▇▁▁▁▂
## 2 ▂▁▃▇▁
## 3 ▅▁▁▂▇
## 4 ▂▃▇▁▁
## 5 ▇▁▁▁▇
## 6 ▇▂▁▁▃
## 7 ▁▇▃▁▂
## 8 ▇▁▁▂▃
## 9 ▂▃▇▁▁
## 10 ▇▁▁▁▇
res <- obj$predict(X = new_X_test)
new_y_train <- c(y_train, newy)
plot(c(new_y_train, res$preds), type='l',
main="",
ylab="",
ylim = c(min(c(res$upper, res$lower, y)),
max(c(res$upper, res$lower, y))))
lines(c(new_y_train, res$upper), col="gray60")
lines(c(new_y_train, res$lower), col="gray60")
lines(c(new_y_train, res$preds), col = "red")
lines(c(new_y_train, new_y_test), col = "blue")
abline(v = length(y_train), lty=2, col="black")
mean((new_y_test >= as.numeric(res$lower)) * (new_y_test <= as.numeric(res$upper)))## [1] 1update RVFL model using Polyak averaging (Pt.2)
newx <- X_test[2, ]
newy <- y_test[2]
new_X_test <- X_test[-c(1, 2), ]
new_y_test <- y_test[-c(1, 2)]
t0 <- proc.time()[3]
obj$update(newx, newy, method = "polyak", alpha = 0.9)
cat("Elapsed: ", proc.time()[3] - t0, "s \n")## Elapsed: 0.005 s
obj$summary(new_X_test, y=new_y_test, show_progress=FALSE)## $R_squared
## [1] 0.6426871
##
## $R_squared_adj
## [1] -Inf
##
## $Residuals
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -4.5686 -2.4084 -1.0397 -0.3897 1.5507 4.0215
##
## $Coverage_rate
## [1] 100
##
## $citests
## estimate lower upper p-value signif
## cyl -42.1261096 -44.5327541 -39.7194651 2.932516e-12 ***
## disp -0.6256505 -0.7347381 -0.5165629 1.613495e-07 ***
## hp -1.0139634 -1.2198651 -0.8080617 6.747693e-07 ***
## drat 82.8645391 74.8033348 90.9257434 5.680663e-10 ***
## wt -170.7891742 -193.1932631 -148.3850853 1.053193e-08 ***
## qsec 22.2365552 13.9564091 30.5167012 1.350094e-04 ***
## vs 119.1784891 94.0163626 144.3406157 9.681321e-07 ***
## am 174.2138307 134.1390652 214.2885963 2.127371e-06 ***
## gear 42.7943293 36.9622907 48.6263678 1.523695e-08 ***
## carb -59.4034661 -70.5135723 -48.2933599 3.127231e-07 ***
##
## $signif_codes
## [1] "Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1"
##
## $effects
## ── Data Summary ────────────────────────
## Values
## Name effects
## Number of rows 11
## Number of columns 10
## _______________________
## Column type frequency:
## numeric 10
## ________________________
## Group variables None
##
## ── Variable type: numeric ──────────────────────────────────────────────────────
## skim_variable mean sd p0 p25 p50 p75 p100
## 1 cyl -42.1 3.58 -44.1 -44.1 -44.1 -43.0 -34.9
## 2 disp -0.626 0.162 -0.933 -0.643 -0.514 -0.514 -0.514
## 3 hp -1.01 0.306 -1.47 -1.24 -0.787 -0.787 -0.787
## 4 drat 82.9 12.0 61.2 79.6 91.7 91.7 91.7
## 5 wt -171. 33.3 -210. -204. -142. -142. -142.
## 6 qsec 22.2 12.3 13.2 13.2 13.2 30.7 41.2
## 7 vs 119. 37.5 96.0 96.0 96.0 117. 193.
## 8 am 174. 59.7 123. 123. 123. 233. 247.
## 9 gear 42.8 8.68 27.1 40.4 49.2 49.2 49.2
## 10 carb -59.4 16.5 -78.8 -76.0 -45.1 -45.1 -45.1
## hist
## 1 ▇▁▁▁▂
## 2 ▂▁▁▃▇
## 3 ▃▁▁▂▇
## 4 ▂▁▁▃▇
## 5 ▇▁▁▁▇
## 6 ▇▂▁▁▃
## 7 ▇▃▁▁▂
## 8 ▇▁▁▂▃
## 9 ▂▁▁▃▇
## 10 ▇▁▁▁▇
res <- obj$predict(X = new_X_test)
new_y_train <- c(y_train, y_test[c(1, 2)])
plot(c(new_y_train, res$preds), type='l',
main="",
ylab="",
ylim = c(min(c(res$upper, res$lower, y)),
max(c(res$upper, res$lower, y))))
lines(c(new_y_train, res$upper), col="gray60")
lines(c(new_y_train, res$lower), col="gray60")
lines(c(new_y_train, res$preds), col = "red")
lines(c(new_y_train, new_y_test), col = "blue")
abline(v = length(y_train), lty=2, col="black")
mean((new_y_test >= as.numeric(res$lower)) * (new_y_test <= as.numeric(res$upper)))## [1] 1