Teoría

Una Red Neuronal Artificial (ANN) modela la relación entre un conjunto de entradas y una salida, resolviendo un problema de aprendizaje.

Llamar librerías

#install.packages(neuralnet) 
library(readr)
library(neuralnet)
library(caret)
## Cargando paquete requerido: ggplot2
## Cargando paquete requerido: lattice

Importat la base de datos

boston <- read_csv("BostonHousing.csv")
## Rows: 506 Columns: 14
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## dbl (14): crim, zn, indus, chas, nox, rm, age, dis, rad, tax, ptratio, b, ls...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
#view(boston)

Explorar la base de datos

summary(boston)
##       crim                zn             indus            chas        
##  Min.   : 0.00632   Min.   :  0.00   Min.   : 0.46   Min.   :0.00000  
##  1st Qu.: 0.08205   1st Qu.:  0.00   1st Qu.: 5.19   1st Qu.:0.00000  
##  Median : 0.25651   Median :  0.00   Median : 9.69   Median :0.00000  
##  Mean   : 3.61352   Mean   : 11.36   Mean   :11.14   Mean   :0.06917  
##  3rd Qu.: 3.67708   3rd Qu.: 12.50   3rd Qu.:18.10   3rd Qu.:0.00000  
##  Max.   :88.97620   Max.   :100.00   Max.   :27.74   Max.   :1.00000  
##       nox               rm             age              dis        
##  Min.   :0.3850   Min.   :3.561   Min.   :  2.90   Min.   : 1.130  
##  1st Qu.:0.4490   1st Qu.:5.886   1st Qu.: 45.02   1st Qu.: 2.100  
##  Median :0.5380   Median :6.208   Median : 77.50   Median : 3.207  
##  Mean   :0.5547   Mean   :6.285   Mean   : 68.57   Mean   : 3.795  
##  3rd Qu.:0.6240   3rd Qu.:6.623   3rd Qu.: 94.08   3rd Qu.: 5.188  
##  Max.   :0.8710   Max.   :8.780   Max.   :100.00   Max.   :12.127  
##       rad              tax           ptratio            b         
##  Min.   : 1.000   Min.   :187.0   Min.   :12.60   Min.   :  0.32  
##  1st Qu.: 4.000   1st Qu.:279.0   1st Qu.:17.40   1st Qu.:375.38  
##  Median : 5.000   Median :330.0   Median :19.05   Median :391.44  
##  Mean   : 9.549   Mean   :408.2   Mean   :18.46   Mean   :356.67  
##  3rd Qu.:24.000   3rd Qu.:666.0   3rd Qu.:20.20   3rd Qu.:396.23  
##  Max.   :24.000   Max.   :711.0   Max.   :22.00   Max.   :396.90  
##      lstat            medv      
##  Min.   : 1.73   Min.   : 5.00  
##  1st Qu.: 6.95   1st Qu.:17.02  
##  Median :11.36   Median :21.20  
##  Mean   :12.65   Mean   :22.53  
##  3rd Qu.:16.95   3rd Qu.:25.00  
##  Max.   :37.97   Max.   :50.00
str(boston)
## spc_tbl_ [506 × 14] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
##  $ crim   : num [1:506] 0.00632 0.02731 0.02729 0.03237 0.06905 ...
##  $ zn     : num [1:506] 18 0 0 0 0 0 12.5 12.5 12.5 12.5 ...
##  $ indus  : num [1:506] 2.31 7.07 7.07 2.18 2.18 2.18 7.87 7.87 7.87 7.87 ...
##  $ chas   : num [1:506] 0 0 0 0 0 0 0 0 0 0 ...
##  $ nox    : num [1:506] 0.538 0.469 0.469 0.458 0.458 0.458 0.524 0.524 0.524 0.524 ...
##  $ rm     : num [1:506] 6.58 6.42 7.18 7 7.15 ...
##  $ age    : num [1:506] 65.2 78.9 61.1 45.8 54.2 58.7 66.6 96.1 100 85.9 ...
##  $ dis    : num [1:506] 4.09 4.97 4.97 6.06 6.06 ...
##  $ rad    : num [1:506] 1 2 2 3 3 3 5 5 5 5 ...
##  $ tax    : num [1:506] 296 242 242 222 222 222 311 311 311 311 ...
##  $ ptratio: num [1:506] 15.3 17.8 17.8 18.7 18.7 18.7 15.2 15.2 15.2 15.2 ...
##  $ b      : num [1:506] 397 397 393 395 397 ...
##  $ lstat  : num [1:506] 4.98 9.14 4.03 2.94 5.33 ...
##  $ medv   : num [1:506] 24 21.6 34.7 33.4 36.2 28.7 22.9 27.1 16.5 18.9 ...
##  - attr(*, "spec")=
##   .. cols(
##   ..   crim = col_double(),
##   ..   zn = col_double(),
##   ..   indus = col_double(),
##   ..   chas = col_double(),
##   ..   nox = col_double(),
##   ..   rm = col_double(),
##   ..   age = col_double(),
##   ..   dis = col_double(),
##   ..   rad = col_double(),
##   ..   tax = col_double(),
##   ..   ptratio = col_double(),
##   ..   b = col_double(),
##   ..   lstat = col_double(),
##   ..   medv = col_double()
##   .. )
##  - attr(*, "problems")=<externalptr>
head(boston)
## # A tibble: 6 × 14
##      crim    zn indus  chas   nox    rm   age   dis   rad   tax ptratio     b
##     <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>   <dbl> <dbl>
## 1 0.00632    18  2.31     0 0.538  6.58  65.2  4.09     1   296    15.3  397.
## 2 0.0273      0  7.07     0 0.469  6.42  78.9  4.97     2   242    17.8  397.
## 3 0.0273      0  7.07     0 0.469  7.18  61.1  4.97     2   242    17.8  393.
## 4 0.0324      0  2.18     0 0.458  7.00  45.8  6.06     3   222    18.7  395.
## 5 0.0690      0  2.18     0 0.458  7.15  54.2  6.06     3   222    18.7  397.
## 6 0.0298      0  2.18     0 0.458  6.43  58.7  6.06     3   222    18.7  394.
## # ℹ 2 more variables: lstat <dbl>, medv <dbl>

Partir la base de datos

set.seed(123)
renglones_entrenamiento_boston <- createDataPartition(boston$medv, p=0.8, list=FALSE)
entrenamiento_boston <- boston[renglones_entrenamiento_boston, ]
prueba_boston <- boston[-renglones_entrenamiento_boston, ]

Generar Modelo

modelo_boston <- neuralnet(medv~., data =entrenamiento_boston)
#plot(modelo_boston, rep= "best")

Predecir con la Red Neuronal

prediccion <- compute(modelo_boston, prueba_boston)
prediccion$net.result
##            [,1]
##   [1,] 22.51056
##   [2,] 22.51056
##   [3,] 22.51056
##   [4,] 22.51056
##   [5,] 22.51056
##   [6,] 22.51056
##   [7,] 22.51056
##   [8,] 22.51056
##   [9,] 22.51056
##  [10,] 22.51056
##  [11,] 22.51056
##  [12,] 22.51056
##  [13,] 22.51056
##  [14,] 22.51056
##  [15,] 22.51056
##  [16,] 22.51056
##  [17,] 22.51056
##  [18,] 22.51056
##  [19,] 22.51056
##  [20,] 22.51056
##  [21,] 22.51056
##  [22,] 22.51056
##  [23,] 22.51056
##  [24,] 22.51056
##  [25,] 22.51056
##  [26,] 22.51056
##  [27,] 22.51056
##  [28,] 22.51056
##  [29,] 22.51056
##  [30,] 22.51056
##  [31,] 22.51056
##  [32,] 22.51056
##  [33,] 22.51056
##  [34,] 22.51056
##  [35,] 22.51056
##  [36,] 22.51056
##  [37,] 22.51056
##  [38,] 22.51056
##  [39,] 22.51056
##  [40,] 22.51056
##  [41,] 22.51056
##  [42,] 22.51056
##  [43,] 22.51056
##  [44,] 22.51056
##  [45,] 22.51056
##  [46,] 22.51056
##  [47,] 22.51056
##  [48,] 22.51056
##  [49,] 22.51056
##  [50,] 22.51056
##  [51,] 22.51056
##  [52,] 22.51056
##  [53,] 22.51056
##  [54,] 22.51056
##  [55,] 22.51056
##  [56,] 22.51056
##  [57,] 22.51056
##  [58,] 22.51056
##  [59,] 22.51056
##  [60,] 22.51056
##  [61,] 22.51056
##  [62,] 22.51056
##  [63,] 22.51056
##  [64,] 22.51056
##  [65,] 22.51056
##  [66,] 22.51056
##  [67,] 22.51056
##  [68,] 22.51056
##  [69,] 22.51056
##  [70,] 22.51056
##  [71,] 22.51056
##  [72,] 22.51056
##  [73,] 22.51056
##  [74,] 22.51056
##  [75,] 22.51056
##  [76,] 22.51056
##  [77,] 22.51056
##  [78,] 22.51056
##  [79,] 22.51056
##  [80,] 22.51056
##  [81,] 22.51056
##  [82,] 22.51056
##  [83,] 22.51056
##  [84,] 22.51056
##  [85,] 22.51056
##  [86,] 22.51056
##  [87,] 22.51056
##  [88,] 22.51056
##  [89,] 22.51056
##  [90,] 22.51056
##  [91,] 22.51056
##  [92,] 22.51056
##  [93,] 22.51056
##  [94,] 22.51056
##  [95,] 22.51056
##  [96,] 22.51056
##  [97,] 22.51056
##  [98,] 22.51056
##  [99,] 22.51056
LS0tDQp0aXRsZTogIlJlZGVzX05ldXJvbmFsZXNfQm9zdG9uIg0KYXV0aG9yOiAiU2FtYW50aGEgLSBBMDE0MjI3NDkiDQpkYXRlOiAiMjAyNS0wMi0yNiINCm91dHB1dDogDQogIGh0bWxfZG9jdW1lbnQ6DQogICAgdG9jOiBUUlVFDQogICAgdG9jX2Zsb2F0OiBUUlVFDQogICAgY29kZV9kb3dubG9hZDogVFJVRQ0KICAgIHRoZW1lOiBzaW1wbGUNCiAgICBoaWdobGlnaHQ6IGhhZGRvY2sNCi0tLQ0KDQohW10oQzovVXNlcnMvYWxlamEvUGljdHVyZXMvSW1hZ2VuZXNfdHJhYmFqb3MvQm9zdG9uLmdpZikNCg0KIyA8c3BhbiBzdHlsZT0gImNvbG9yOmluZGlhbnJlZDQgOyI+VGVvcsOtYTwvc3Bhbj4NClVuYSAqKlJlZCBOZXVyb25hbCBBcnRpZmljaWFsIChBTk4pKiogbW9kZWxhIGxhIHJlbGFjacOzbiBlbnRyZSB1biBjb25qdW50byBkZSBlbnRyYWRhcyB5IHVuYSBzYWxpZGEsIHJlc29sdmllbmRvIHVuIHByb2JsZW1hIGRlIGFwcmVuZGl6YWplLg0KDQojIDxzcGFuIHN0eWxlPSAiY29sb3I6cmVkIDsiPkxsYW1hciBsaWJyZXLDrWFzPC9zcGFuPg0KYGBge3J9DQojaW5zdGFsbC5wYWNrYWdlcyhuZXVyYWxuZXQpIA0KbGlicmFyeShyZWFkcikNCmxpYnJhcnkobmV1cmFsbmV0KQ0KbGlicmFyeShjYXJldCkNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSAiY29sb3I6cmVkIDsiPkltcG9ydGF0IGxhIGJhc2UgZGUgZGF0b3M8L3NwYW4+DQpgYGB7cn0NCmJvc3RvbiA8LSByZWFkX2NzdigiQm9zdG9uSG91c2luZy5jc3YiKQ0KI3ZpZXcoYm9zdG9uKQ0KYGBgDQoNCiMgPHNwYW4gc3R5bGU9ICJjb2xvcjpyZWQgOyI+RXhwbG9yYXIgbGEgYmFzZSBkZSBkYXRvczwvc3Bhbj4NCmBgYHtyfQ0Kc3VtbWFyeShib3N0b24pDQpzdHIoYm9zdG9uKQ0KaGVhZChib3N0b24pDQpgYGANCg0KIyA8c3BhbiBzdHlsZT0gImNvbG9yOnJlZCA7Ij5QYXJ0aXIgbGEgYmFzZSBkZSBkYXRvczwvc3Bhbj4NCmBgYHtyfQ0Kc2V0LnNlZWQoMTIzKQ0KcmVuZ2xvbmVzX2VudHJlbmFtaWVudG9fYm9zdG9uIDwtIGNyZWF0ZURhdGFQYXJ0aXRpb24oYm9zdG9uJG1lZHYsIHA9MC44LCBsaXN0PUZBTFNFKQ0KZW50cmVuYW1pZW50b19ib3N0b24gPC0gYm9zdG9uW3Jlbmdsb25lc19lbnRyZW5hbWllbnRvX2Jvc3RvbiwgXQ0KcHJ1ZWJhX2Jvc3RvbiA8LSBib3N0b25bLXJlbmdsb25lc19lbnRyZW5hbWllbnRvX2Jvc3RvbiwgXQ0KYGBgDQoNCiMgPHNwYW4gc3R5bGU9ICJjb2xvcjpyZWQgOyI+R2VuZXJhciBNb2RlbG88L3NwYW4+DQpgYGB7cn0NCm1vZGVsb19ib3N0b24gPC0gbmV1cmFsbmV0KG1lZHZ+LiwgZGF0YSA9ZW50cmVuYW1pZW50b19ib3N0b24pDQojcGxvdChtb2RlbG9fYm9zdG9uLCByZXA9ICJiZXN0IikNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSAiY29sb3I6cmVkIDsiPlByZWRlY2lyIGNvbiBsYSBSZWQgTmV1cm9uYWw8L3NwYW4+DQpgYGB7cn0NCnByZWRpY2Npb24gPC0gY29tcHV0ZShtb2RlbG9fYm9zdG9uLCBwcnVlYmFfYm9zdG9uKQ0KcHJlZGljY2lvbiRuZXQucmVzdWx0DQpgYGANCg0K