Teoría

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

Ejemplos prácticos de aplicación de Redes Neuronales son:

La recomendación de contenido de Netflix El feed de Instagram o Tik Tok *Determinar el número o letra escrito a mano.

Ejemplo 1: Examen

Instalar paquetes y llamar librerías 

#install.packages("neuralnet")
#install.packages("caret")
library(neuralnet)
library(caret)
## Loading required package: ggplot2
## Loading required package: lattice
library(readr)
library(ggplot2)

Bases de datos 

examen<-c(20,10,30,20,80,30)
proyecto<-c(90,20,40,50,50,80)
estatus<-c(1,0,0,0,0,1)
df<-data.frame(examen,proyecto,estatus)

Generar la red neuronal 

red_neuronal<-neuralnet(estatus~., data = df)
plot(red_neuronal, rep="best")

prueba_examen<-c(20,40,85)
prueba_proyecto<-c(85,40,50)
prueba<-data.frame(prueba_examen,prueba_proyecto)
prediccion<-compute(red_neuronal,prueba)
prediccion$net.result
##             [,1]
## [1,]  1.03858085
## [2,] -0.01656229
## [3,] -0.01656385
probabilidad<- prediccion$net.result
resultado<-ifelse(probabilidad>0.5,1,0)
resultado
##      [,1]
## [1,]    1
## [2,]    0
## [3,]    0

Ejemplo 2: Cancer de mama 

df1 <- read_csv("~/Documents/cancer_de_mama.csv")
## Rows: 569 Columns: 31
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (1): diagnosis
## dbl (30): radius_mean, texture_mean, perimeter_mean, area_mean, smoothness_m...
## 
## ℹ 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.

Dividir base de datos 

set.seed(123)
renglones_entrenamiento <- createDataPartition(df1$diagnosis,p=0.8, list=FALSE)
entrenamiento <- df1[renglones_entrenamiento,]
prueba <- df1[-renglones_entrenamiento,]

df1$diagnosis <- ifelse(df1$diagnosis=="M",1,0)

Generar red 

red_neuronal <- neuralnet(diagnosis~., data=df1)
plot(red_neuronal, rep = "best")

# Predecir red neuronal

prediccion <- compute(red_neuronal, prueba)
prediccion$net.result
##             [,1]
##   [1,] 0.3725861
##   [2,] 0.3725861
##   [3,] 0.3725861
##   [4,] 0.3725861
##   [5,] 0.3725861
##   [6,] 0.3725861
##   [7,] 0.3725861
##   [8,] 0.3725861
##   [9,] 0.3725861
##  [10,] 0.3725861
##  [11,] 0.3725861
##  [12,] 0.3725861
##  [13,] 0.3725861
##  [14,] 0.3725861
##  [15,] 0.3725861
##  [16,] 0.3725861
##  [17,] 0.3725861
##  [18,] 0.3725861
##  [19,] 0.3725861
##  [20,] 0.3725861
##  [21,] 0.3725861
##  [22,] 0.3725861
##  [23,] 0.3725861
##  [24,] 0.3725861
##  [25,] 0.3725861
##  [26,] 0.3725861
##  [27,] 0.3725861
##  [28,] 0.3725861
##  [29,] 0.3725861
##  [30,] 0.3725861
##  [31,] 0.3725861
##  [32,] 0.3725861
##  [33,] 0.3725861
##  [34,] 0.3725861
##  [35,] 0.3725861
##  [36,] 0.3725861
##  [37,] 0.3725861
##  [38,] 0.3725861
##  [39,] 0.3725861
##  [40,] 0.3725861
##  [41,] 0.3725861
##  [42,] 0.3725861
##  [43,] 0.3725861
##  [44,] 0.3725861
##  [45,] 0.3725861
##  [46,] 0.3725861
##  [47,] 0.3725861
##  [48,] 0.3725861
##  [49,] 0.3725861
##  [50,] 0.3725861
##  [51,] 0.3725861
##  [52,] 0.3725861
##  [53,] 0.3725861
##  [54,] 0.3725861
##  [55,] 0.3725861
##  [56,] 0.3725861
##  [57,] 0.3725861
##  [58,] 0.3725861
##  [59,] 0.3725861
##  [60,] 0.3725861
##  [61,] 0.3725861
##  [62,] 0.3725861
##  [63,] 0.3725861
##  [64,] 0.3725861
##  [65,] 0.3725861
##  [66,] 0.3725861
##  [67,] 0.3725861
##  [68,] 0.3725861
##  [69,] 0.3725861
##  [70,] 0.3725861
##  [71,] 0.3725861
##  [72,] 0.3725861
##  [73,] 0.3725861
##  [74,] 0.3725861
##  [75,] 0.3725861
##  [76,] 0.3725861
##  [77,] 0.3725861
##  [78,] 0.3725861
##  [79,] 0.3725861
##  [80,] 0.3725861
##  [81,] 0.3725861
##  [82,] 0.3725861
##  [83,] 0.3725861
##  [84,] 0.3725861
##  [85,] 0.3725861
##  [86,] 0.3725861
##  [87,] 0.3725861
##  [88,] 0.3725861
##  [89,] 0.3725861
##  [90,] 0.3725861
##  [91,] 0.3725861
##  [92,] 0.3725861
##  [93,] 0.3725861
##  [94,] 0.3725861
##  [95,] 0.3725861
##  [96,] 0.3725861
##  [97,] 0.3725861
##  [98,] 0.3725861
##  [99,] 0.3725861
## [100,] 0.3725861
## [101,] 0.3725861
## [102,] 0.3725861
## [103,] 0.3725861
## [104,] 0.3725861
## [105,] 0.3725861
## [106,] 0.3725861
## [107,] 0.3725861
## [108,] 0.3725861
## [109,] 0.3725861
## [110,] 0.3725861
## [111,] 0.3725861
## [112,] 0.3725861
## [113,] 0.3725861
LS0tCnRpdGxlOiAiUmVkZXMgbmV1cm9uYWxlcyIKYXV0aG9yOiAiRHlhbm4gRXN0ZWZhbmlhIEhlcm5hbmRleiBBeWFsYSBhMDA4MzcxOTEiCmRhdGU6ICIyMDI1LTA4LTI1IgpvdXRwdXQ6IAogIGh0bWxfZG9jdW1lbnQ6CiAgICB0b2M6IFRSVUUKICAgIHRvY19mbG9hdDogVFJVRQogICAgY29kZV9kb3dubG9hZDogVFJVRQogICAgdGhlbWU6IHlldGkKLS0tCgojIDxzcGFuIHN0eWxlPSJjb2xvcjpibHVlOyI+VGVvcsOtYSA8L3NwYW4+ClVuYSBSZWQgTmV1cm9uYWwgQXJ0aWZpY2lhbCAoQU5OKSBtb2RlbGEgbGEgcmVsYWNpw7NuIGVudHJlIHVuIGNvbmp1bnRvIGRlIGVudHJhZGFzIHkgdW5hIHNhbGlkYSwgcmVzb2x2aWVuZG8gdW4gcHJvYmxlbWEgZGUgYXByZW5kaXphamUuCgpFamVtcGxvcyBwcsOhY3RpY29zIGRlIGFwbGljYWNpw7NuIGRlIFJlZGVzIE5ldXJvbmFsZXMgc29uOgoKTGEgcmVjb21lbmRhY2nDs24gZGUgY29udGVuaWRvIGRlIE5ldGZsaXggRWwgZmVlZCBkZSBJbnN0YWdyYW0gbyBUaWsgVG9rICpEZXRlcm1pbmFyIGVsIG7Dum1lcm8gbyBsZXRyYSBlc2NyaXRvIGEgbWFuby4KCiMgPHNwYW4gc3R5bGU9ImNvbG9yOmJsdWU7Ij5FamVtcGxvIDE6IEV4YW1lbiA8L3NwYW4+CiMgPHNwYW4gc3R5bGU9ImNvbG9yOmJsdWU7Ij5JbnN0YWxhciBwYXF1ZXRlcyB5IGxsYW1hciBsaWJyZXLDrWFzIDwvc3Bhbj4KYGBge3J9CiNpbnN0YWxsLnBhY2thZ2VzKCJuZXVyYWxuZXQiKQojaW5zdGFsbC5wYWNrYWdlcygiY2FyZXQiKQpsaWJyYXJ5KG5ldXJhbG5ldCkKbGlicmFyeShjYXJldCkKYGBgCmBgYHtyfQpsaWJyYXJ5KHJlYWRyKQpsaWJyYXJ5KGdncGxvdDIpCmBgYAoKIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZTsiPkJhc2VzIGRlIGRhdG9zIDwvc3Bhbj4KYGBge3J9CmV4YW1lbjwtYygyMCwxMCwzMCwyMCw4MCwzMCkKcHJveWVjdG88LWMoOTAsMjAsNDAsNTAsNTAsODApCmVzdGF0dXM8LWMoMSwwLDAsMCwwLDEpCmRmPC1kYXRhLmZyYW1lKGV4YW1lbixwcm95ZWN0byxlc3RhdHVzKQpgYGAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOmJsdWU7Ij5HZW5lcmFyIGxhIHJlZCBuZXVyb25hbCA8L3NwYW4+CmBgYHtyfQpyZWRfbmV1cm9uYWw8LW5ldXJhbG5ldChlc3RhdHVzfi4sIGRhdGEgPSBkZikKcGxvdChyZWRfbmV1cm9uYWwsIHJlcD0iYmVzdCIpCmBgYApgYGB7cn0KcHJ1ZWJhX2V4YW1lbjwtYygyMCw0MCw4NSkKcHJ1ZWJhX3Byb3llY3RvPC1jKDg1LDQwLDUwKQpwcnVlYmE8LWRhdGEuZnJhbWUocHJ1ZWJhX2V4YW1lbixwcnVlYmFfcHJveWVjdG8pCnByZWRpY2Npb248LWNvbXB1dGUocmVkX25ldXJvbmFsLHBydWViYSkKcHJlZGljY2lvbiRuZXQucmVzdWx0CmBgYApgYGB7cn0KcHJvYmFiaWxpZGFkPC0gcHJlZGljY2lvbiRuZXQucmVzdWx0CnJlc3VsdGFkbzwtaWZlbHNlKHByb2JhYmlsaWRhZD4wLjUsMSwwKQpyZXN1bHRhZG8KYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjpibHVlOyI+RWplbXBsbyAyOiBDYW5jZXIgZGUgbWFtYSA8L3NwYW4+CmBgYHtyfQpkZjEgPC0gcmVhZF9jc3YoIn4vRG9jdW1lbnRzL2NhbmNlcl9kZV9tYW1hLmNzdiIpCmBgYAojIDxzcGFuIHN0eWxlPSJjb2xvcjpibHVlOyI+RGl2aWRpciBiYXNlIGRlIGRhdG9zIDwvc3Bhbj4KYGBge3J9CnNldC5zZWVkKDEyMykKcmVuZ2xvbmVzX2VudHJlbmFtaWVudG8gPC0gY3JlYXRlRGF0YVBhcnRpdGlvbihkZjEkZGlhZ25vc2lzLHA9MC44LCBsaXN0PUZBTFNFKQplbnRyZW5hbWllbnRvIDwtIGRmMVtyZW5nbG9uZXNfZW50cmVuYW1pZW50byxdCnBydWViYSA8LSBkZjFbLXJlbmdsb25lc19lbnRyZW5hbWllbnRvLF0KCmRmMSRkaWFnbm9zaXMgPC0gaWZlbHNlKGRmMSRkaWFnbm9zaXM9PSJNIiwxLDApCmBgYAoKIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZTsiPkdlbmVyYXIgcmVkIDwvc3Bhbj4KYGBge3J9CnJlZF9uZXVyb25hbCA8LSBuZXVyYWxuZXQoZGlhZ25vc2lzfi4sIGRhdGE9ZGYxKQpwbG90KHJlZF9uZXVyb25hbCwgcmVwID0gImJlc3QiKQpgYGAKIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZTsiPlByZWRlY2lyIHJlZCBuZXVyb25hbDwvc3Bhbj4KYGBge3J9CnByZWRpY2Npb24gPC0gY29tcHV0ZShyZWRfbmV1cm9uYWwsIHBydWViYSkKcHJlZGljY2lvbiRuZXQucmVzdWx0CmBgYAoK