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

Instalar paquetes y llamar librerías

#install.packages("neuralnet")
library(neuralnet)
#install.packages("tidyverse") #Manejo de datos
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.4     ✔ tidyr     1.3.1
## ✔ purrr     1.0.4     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::compute() masks neuralnet::compute()
## ✖ dplyr::filter()  masks stats::filter()
## ✖ dplyr::lag()     masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
#install.packages("caret") #Entrenamiento de datos
library(caret)
## Loading required package: lattice
## 
## Attaching package: 'caret'
## 
## The following object is masked from 'package:purrr':
## 
##     lift
#install.packages("e1071") #Matriz de confusión
library(e1071)

Importar la base de datos

boston_borrador <- read.csv("C:\\Users\\lenovo\\Downloads\\BostonHousing.csv")
boston <- scale(boston_borrador)

Entender la base de datos

summary(boston)
##       crim                 zn               indus              chas        
##  Min.   :-0.419367   Min.   :-0.48724   Min.   :-1.5563   Min.   :-0.2723  
##  1st Qu.:-0.410563   1st Qu.:-0.48724   1st Qu.:-0.8668   1st Qu.:-0.2723  
##  Median :-0.390280   Median :-0.48724   Median :-0.2109   Median :-0.2723  
##  Mean   : 0.000000   Mean   : 0.00000   Mean   : 0.0000   Mean   : 0.0000  
##  3rd Qu.: 0.007389   3rd Qu.: 0.04872   3rd Qu.: 1.0150   3rd Qu.:-0.2723  
##  Max.   : 9.924110   Max.   : 3.80047   Max.   : 2.4202   Max.   : 3.6648  
##       nox                rm               age               dis         
##  Min.   :-1.4644   Min.   :-3.8764   Min.   :-2.3331   Min.   :-1.2658  
##  1st Qu.:-0.9121   1st Qu.:-0.5681   1st Qu.:-0.8366   1st Qu.:-0.8049  
##  Median :-0.1441   Median :-0.1084   Median : 0.3171   Median :-0.2790  
##  Mean   : 0.0000   Mean   : 0.0000   Mean   : 0.0000   Mean   : 0.0000  
##  3rd Qu.: 0.5981   3rd Qu.: 0.4823   3rd Qu.: 0.9059   3rd Qu.: 0.6617  
##  Max.   : 2.7296   Max.   : 3.5515   Max.   : 1.1164   Max.   : 3.9566  
##       rad               tax             ptratio              b          
##  Min.   :-0.9819   Min.   :-1.3127   Min.   :-2.7047   Min.   :-3.9033  
##  1st Qu.:-0.6373   1st Qu.:-0.7668   1st Qu.:-0.4876   1st Qu.: 0.2049  
##  Median :-0.5225   Median :-0.4642   Median : 0.2746   Median : 0.3808  
##  Mean   : 0.0000   Mean   : 0.0000   Mean   : 0.0000   Mean   : 0.0000  
##  3rd Qu.: 1.6596   3rd Qu.: 1.5294   3rd Qu.: 0.8058   3rd Qu.: 0.4332  
##  Max.   : 1.6596   Max.   : 1.7964   Max.   : 1.6372   Max.   : 0.4406  
##      lstat              medv        
##  Min.   :-1.5296   Min.   :-1.9063  
##  1st Qu.:-0.7986   1st Qu.:-0.5989  
##  Median :-0.1811   Median :-0.1449  
##  Mean   : 0.0000   Mean   : 0.0000  
##  3rd Qu.: 0.6024   3rd Qu.: 0.2683  
##  Max.   : 3.5453   Max.   : 2.9865
str(boston)
##  num [1:506, 1:14] -0.419 -0.417 -0.417 -0.416 -0.412 ...
##  - attr(*, "dimnames")=List of 2
##   ..$ : NULL
##   ..$ : chr [1:14] "crim" "zn" "indus" "chas" ...
##  - attr(*, "scaled:center")= Named num [1:14] 3.6135 11.3636 11.1368 0.0692 0.5547 ...
##   ..- attr(*, "names")= chr [1:14] "crim" "zn" "indus" "chas" ...
##  - attr(*, "scaled:scale")= Named num [1:14] 8.602 23.322 6.86 0.254 0.116 ...
##   ..- attr(*, "names")= chr [1:14] "crim" "zn" "indus" "chas" ...
head(boston)
##            crim         zn      indus       chas        nox        rm
## [1,] -0.4193669  0.2845483 -1.2866362 -0.2723291 -0.1440749 0.4132629
## [2,] -0.4169267 -0.4872402 -0.5927944 -0.2723291 -0.7395304 0.1940824
## [3,] -0.4169290 -0.4872402 -0.5927944 -0.2723291 -0.7395304 1.2814456
## [4,] -0.4163384 -0.4872402 -1.3055857 -0.2723291 -0.8344581 1.0152978
## [5,] -0.4120741 -0.4872402 -1.3055857 -0.2723291 -0.8344581 1.2273620
## [6,] -0.4166314 -0.4872402 -1.3055857 -0.2723291 -0.8344581 0.2068916
##             age      dis        rad        tax    ptratio         b      lstat
## [1,] -0.1198948 0.140075 -0.9818712 -0.6659492 -1.4575580 0.4406159 -1.0744990
## [2,]  0.3668034 0.556609 -0.8670245 -0.9863534 -0.3027945 0.4406159 -0.4919525
## [3,] -0.2655490 0.556609 -0.8670245 -0.9863534 -0.3027945 0.3960351 -1.2075324
## [4,] -0.8090878 1.076671 -0.7521778 -1.1050216  0.1129203 0.4157514 -1.3601708
## [5,] -0.5106743 1.076671 -0.7521778 -1.1050216  0.1129203 0.4406159 -1.0254866
## [6,] -0.3508100 1.076671 -0.7521778 -1.1050216  0.1129203 0.4101651 -1.0422909
##            medv
## [1,]  0.1595278
## [2,] -0.1014239
## [3,]  1.3229375
## [4,]  1.1815886
## [5,]  1.4860323
## [6,]  0.6705582

Partir la base de datos

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

Generar el modelo

modelo_boston <-neuralnet(medv ~ ., data=entrenamiento_boston, linear.output=TRUE, stepmax=1e6)
plot(modelo_boston)

Predecir con la red neuronal

#prediccion <- compute(modelo_boston, prueba_boston[, -which(names(prueba_boston) == "medv")])$net.result
#real <- prueba_boston$medv
  
#boston_resultados <- data.frame(Real = real, Predicción = prediccion)

#ggplot(boston_resultados, aes(x=Real, y=Predicción)) +
  #geom_point(color="blue") +
  #geom_abline(slope=1, intercept=0, color="red") +
  #theme_minimal() +
  #ggtitle("Predicción vs. Valores Reales")
LS0tDQp0aXRsZTogIkJvc3RvbiINCmF1dGhvcjogIk5hbmN5IE1hcnJvcXXDrW4gLSBBMDExOTg1NTMiDQpkYXRlOiAiMjAyNS0wMi0yNiINCm91dHB1dDogDQogIGh0bWxfZG9jdW1lbnQ6DQogICAgdG9jOiBUUlVFDQogICAgdG9jX2Zsb2F0OiBUUlVFDQogICAgY29kZV9kb3dubG9hZDogVFJVRQ0KICAgIHRoZW06IGx1bWVuDQogICAgaGlnaGxpZ2h0OiBoYWRkb2NrDQotLS0NCg0KDQohW10oIkM6XFxVc2Vyc1xcbGVub3ZvXFxEb3dubG9hZHNcXGJvc3Rvbi1jaXR5LXNreWxpbmUtYmFkZ2UtMDAzZWNkLndlYnAiKQ0KIyA8c3BhbiBzdHlsZT0gImNvbG9yOiByZWQ7Ij5UZW9yw61hPC9zcGFuPg0KVW5hICoqUmVkIE5ldXJvbmFsIEFydGlmaWNpYWwgKEFOTikqKiBtb2RlbGEgbGEgcmVsYWNpw7NuIGVudHJlIHVuIGNvbmp1bnRvIGRlIGVudHJhZGFzIHkgdW5hIHNhbGlkYSwgcmVzb2x2aWRvIHVuIHByb2JsZW1hIGRlIGFwcmVuZGl6YWplLg0KDQojIDxzcGFuIHN0eWxlPSAiY29sb3I6IHJlZDsiPkluc3RhbGFyIHBhcXVldGVzIHkgbGxhbWFyIGxpYnJlcsOtYXM8L3NwYW4+DQpgYGB7cn0NCiNpbnN0YWxsLnBhY2thZ2VzKCJuZXVyYWxuZXQiKQ0KbGlicmFyeShuZXVyYWxuZXQpDQojaW5zdGFsbC5wYWNrYWdlcygidGlkeXZlcnNlIikgI01hbmVqbyBkZSBkYXRvcw0KbGlicmFyeSh0aWR5dmVyc2UpDQojaW5zdGFsbC5wYWNrYWdlcygiY2FyZXQiKSAjRW50cmVuYW1pZW50byBkZSBkYXRvcw0KbGlicmFyeShjYXJldCkNCiNpbnN0YWxsLnBhY2thZ2VzKCJlMTA3MSIpICNNYXRyaXogZGUgY29uZnVzacOzbg0KbGlicmFyeShlMTA3MSkNCmBgYA0KIyA8c3BhbiBzdHlsZT0gImNvbG9yOiByZWQ7Ij5JbXBvcnRhciBsYSBiYXNlIGRlIGRhdG9zPC9zcGFuPg0KYGBge3J9DQpib3N0b25fYm9ycmFkb3IgPC0gcmVhZC5jc3YoIkM6XFxVc2Vyc1xcbGVub3ZvXFxEb3dubG9hZHNcXEJvc3RvbkhvdXNpbmcuY3N2IikNCmJvc3RvbiA8LSBzY2FsZShib3N0b25fYm9ycmFkb3IpDQpgYGANCg0KIyA8c3BhbiBzdHlsZT0gImNvbG9yOiByZWQ7Ij5FbnRlbmRlciBsYSBiYXNlIGRlIGRhdG9zPC9zcGFuPg0KYGBge3J9DQpzdW1tYXJ5KGJvc3RvbikNCnN0cihib3N0b24pDQpoZWFkKGJvc3RvbikNCmBgYA0KIyA8c3BhbiBzdHlsZT0gImNvbG9yOiByZWQ7Ij5QYXJ0aXIgbGEgYmFzZSBkZSBkYXRvczwvc3Bhbj4NCmBgYHtyfQ0Kc2V0LnNlZWQoMTIzKQ0KcmVuZ2xvbmVzX2VudHJlbmFtaWVudG9fYm9zdG9uIDwtIGNyZWF0ZURhdGFQYXJ0aXRpb24oYm9zdG9uX2JvcnJhZG9yJG1lZHYsIHA9MC44LCBsaXN0PUZBTFNFKQ0KZW50cmVuYW1pZW50b19ib3N0b24gPC0gYm9zdG9uW3Jlbmdsb25lc19lbnRyZW5hbWllbnRvX2Jvc3RvbiwgXQ0KcHJ1ZWJhX2Jvc3RvbiA8LSBib3N0b25bLXJlbmdsb25lc19lbnRyZW5hbWllbnRvX2Jvc3RvbiwgXQ0KYGBgDQoNCiMgPHNwYW4gc3R5bGU9ICJjb2xvcjogcmVkOyI+R2VuZXJhciBlbCBtb2RlbG88L3NwYW4+DQpgYGB7cn0NCm1vZGVsb19ib3N0b24gPC1uZXVyYWxuZXQobWVkdiB+IC4sIGRhdGE9ZW50cmVuYW1pZW50b19ib3N0b24sIGxpbmVhci5vdXRwdXQ9VFJVRSwgc3RlcG1heD0xZTYpDQpwbG90KG1vZGVsb19ib3N0b24pDQpgYGANCg0KIyA8c3BhbiBzdHlsZT0gImNvbG9yOiByZWQ7Ij5QcmVkZWNpciBjb24gbGEgcmVkIG5ldXJvbmFsPC9zcGFuPg0KYGBge3J9DQojcHJlZGljY2lvbiA8LSBjb21wdXRlKG1vZGVsb19ib3N0b24sIHBydWViYV9ib3N0b25bLCAtd2hpY2gobmFtZXMocHJ1ZWJhX2Jvc3RvbikgPT0gIm1lZHYiKV0pJG5ldC5yZXN1bHQNCiNyZWFsIDwtIHBydWViYV9ib3N0b24kbWVkdg0KICANCiNib3N0b25fcmVzdWx0YWRvcyA8LSBkYXRhLmZyYW1lKFJlYWwgPSByZWFsLCBQcmVkaWNjacOzbiA9IHByZWRpY2Npb24pDQoNCiNnZ3Bsb3QoYm9zdG9uX3Jlc3VsdGFkb3MsIGFlcyh4PVJlYWwsIHk9UHJlZGljY2nDs24pKSArDQogICNnZW9tX3BvaW50KGNvbG9yPSJibHVlIikgKw0KICAjZ2VvbV9hYmxpbmUoc2xvcGU9MSwgaW50ZXJjZXB0PTAsIGNvbG9yPSJyZWQiKSArDQogICN0aGVtZV9taW5pbWFsKCkgKw0KICAjZ2d0aXRsZSgiUHJlZGljY2nDs24gdnMuIFZhbG9yZXMgUmVhbGVzIikNCmBgYA0KDQo=