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 Tiktok

  • Determinar el número o letra escrito a mano

Calificaciones: Ejemplo Clase

Instalar paquetes y llamar librerías

# install.packages("neuralnet")
library(neuralnet)
# install.packages("caret") # Algortimos de aprendizaje automático
library(caret)

Alimentar con ejemplos

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")

Predecir la Red Neuronal

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

Cáncer de mama

Importar la base de datos: cancer_de_mama

df1 <- read.csv("/Users/ximenabbm/Downloads/cancer_de_mama.csv")
df1 <- data.frame(df1)
df1$diagnosis <- ifelse(df1$diagnosis == "M", 1, 0)
df1_scaled <- as.data.frame(scale(df1[ , !names(df1) %in% "diagnosis"]))
df1_scaled$diagnosis <- df1$diagnosis

Generar la Red Neuronal

red_neuronal <- neuralnet(df1_scaled$diagnosis ~ ., data=df1_scaled, 
                          hidden=c(10,5), linear.output=FALSE)
plot(red_neuronal, rep="best")

Predecir la Red Neuronal

set.seed(123)
renglones_entrenamiento <- createDataPartition(df1_scaled$diagnosis, p=0.8, list=FALSE) 
entrenamiento <- df1_scaled[renglones_entrenamiento, ]
prueba <- df1_scaled[-renglones_entrenamiento, ]
prediccion <- compute(red_neuronal, prueba[,-1])  
probabilidad <- prediccion$net.result             
resultado <- ifelse(probabilidad > 0.4, 1, 0) 
resultado
##     [,1]
## 1      1
## 9      1
## 15     1
## 17     1
## 18     1
## 28     1
## 35     1
## 44     1
## 46     1
## 56     0
## 58     1
## 60     0
## 65     1
## 68     0
## 71     1
## 79     1
## 82     1
## 86     1
## 95     1
## 99     0
## 101    1
## 109    1
## 124    0
## 133    1
## 138    0
## 140    0
## 142    1
## 157    1
## 162    1
## 171    0
## 173    1
## 183    1
## 188    0
## 189    0
## 193    0
## 201    1
## 203    1
## 206    0
## 207    0
## 216    1
## 220    1
## 227    0
## 233    0
## 240    1
## 242    0
## 247    0
## 251    1
## 256    1
## 259    1
## 261    1
## 262    1
## 275    1
## 284    1
## 293    0
## 296    0
## 303    1
## 305    0
## 317    0
## 318    1
## 320    0
## 323    0
## 329    1
## 332    0
## 340    1
## 341    0
## 352    1
## 354    1
## 358    0
## 359    0
## 369    1
## 370    1
## 371    1
## 375    0
## 386    1
## 387    0
## 394    1
## 400    0
## 405    0
## 407    0
## 412    0
## 417    1
## 418    1
## 429    0
## 432    0
## 434    1
## 437    0
## 453    1
## 454    0
## 466    0
## 481    0
## 484    0
## 487    0
## 492    0
## 510    1
## 515    0
## 518    1
## 520    0
## 522    1
## 529    0
## 531    1
## 532    1
## 541    0
## 545    0
## 547    0
## 551    0
## 554    0
## 556    1
## 557    0
## 558    1
## 560    1
## 561    1
## 562    0
## 564    1

Matriz de Confusión

mcrp <- confusionMatrix(
  as.factor(resultado),       
  as.factor(prueba$diagnosis) 
)

mcrp
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  0  1
##          0 50  2
##          1 10 51
##                                           
##                Accuracy : 0.8938          
##                  95% CI : (0.8218, 0.9439)
##     No Information Rate : 0.531           
##     P-Value [Acc > NIR] : < 2e-16         
##                                           
##                   Kappa : 0.7887          
##                                           
##  Mcnemar's Test P-Value : 0.04331         
##                                           
##             Sensitivity : 0.8333          
##             Specificity : 0.9623          
##          Pos Pred Value : 0.9615          
##          Neg Pred Value : 0.8361          
##              Prevalence : 0.5310          
##          Detection Rate : 0.4425          
##    Detection Prevalence : 0.4602          
##       Balanced Accuracy : 0.8978          
##                                           
##        'Positive' Class : 0               
## 
LS0tCnRpdGxlOiAiUmVkZXMgbmV1cm9uYWxlcyIKYXV0aG9yOiAiWGltZW5hIEJvbGHDsW9zIgpkYXRlOiAiMjAyNS0wOC0yNSIKb3V0cHV0OgogIGh0bWxfZG9jdW1lbnQ6IAogICAgdG9jOiBUUlVFCiAgICB0b2NfZmxvYXQ6IFRSVUUKICAgIGNvZGVfZG93bmxvYWQ6IFRSVUUgCiAgICB0aGVtZTogInNwYWNlbGFiIgotLS0KCiFbXShodHRwczovL3dlYi5taXQuZWR1L2ZpbGVzL2ltYWdlcy8yMDIyMTEvTUlULU5ldXJhbC1OZXR3b3Jrcy1TTC5naWYpCjwvY2VudGVyPgoKIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZSI+IFRlb3LDrWEgPC9zcGFuPgpVbmEgKipSZWQgTmV1cm9uYWwgQXJ0aWZpY2lhbCAoQU5OKSoqIG1vZGVsYSBsYSByZWxhY2nDs24gZW50cmUgdW4gY29uanVudG8gCmRlIGVudHJhZGFzIHkgdW5hIHNhbGlkYSwgcmVzb2x2aWVuZG8gdW4gcHJvYmxlbWEgZGUgYXByZW5kaXphamUuCgpFamVtcGxvcyBwcsOhY3RpY29zIGRlIGFwbGljYWNpw7NuIGRlIFJlZGVzIE5ldXJvbmFsZXMgc29uOgoKKiBMYSByZWNvbWVuZGFjacOzbiBkZSBjb250ZW5pZG8gZGUgTmV0ZmxpeAoKKiBFbCBmZWVkIGRlIEluc3RhZ3JhbSBvIFRpa3RvawoKKiBEZXRlcm1pbmFyIGVsIG7Dum1lcm8gbyBsZXRyYSBlc2NyaXRvIGEgbWFubwoKIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZTsiPiBDYWxpZmljYWNpb25lczogRWplbXBsbyBDbGFzZSA8L3NwYW4+CgojIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZSI+IEluc3RhbGFyIHBhcXVldGVzIHkgbGxhbWFyIGxpYnJlcsOtYXMgPC9zcGFuPgpgYGB7ciBtZXNzYWdlPUZBTFNFLCB3YXJuaW5nPUZBTFNFfQojIGluc3RhbGwucGFja2FnZXMoIm5ldXJhbG5ldCIpCmxpYnJhcnkobmV1cmFsbmV0KQojIGluc3RhbGwucGFja2FnZXMoImNhcmV0IikgIyBBbGdvcnRpbW9zIGRlIGFwcmVuZGl6YWplIGF1dG9tw6F0aWNvCmxpYnJhcnkoY2FyZXQpCmBgYAoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOmJsdWUiPiBBbGltZW50YXIgY29uIGVqZW1wbG9zIDwvc3Bhbj4KYGBge3J9CmV4YW1lbiA8LSBjKDIwLDEwLDMwLDIwLDgwLDMwKQpwcm95ZWN0byA8LSBjKDkwLDIwLDQwLDUwLDUwLDgwKQplc3RhdHVzIDwtIGMoMSwwLDAsMCwwLDEpCmRmIDwtIGRhdGEuZnJhbWUoZXhhbWVuLHByb3llY3RvLGVzdGF0dXMpCmBgYAoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOmJsdWUiPiBHZW5lcmFyIGxhIFJlZCBOZXVyb25hbCA8L3NwYW4+CmBgYHtyfQpyZWRfbmV1cm9uYWwgPC0gbmV1cmFsbmV0KGVzdGF0dXN+LiwgZGF0YT1kZikKcGxvdChyZWRfbmV1cm9uYWwsIHJlcD0iYmVzdCIpCmBgYAoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOmJsdWUiPiBQcmVkZWNpciBsYSBSZWQgTmV1cm9uYWwgPC9zcGFuPgpgYGB7cn0KcHJ1ZWJhX2V4YW1lbiA8LSBjKDMwLDQwLDg1KQpwcnVlYmFfcHJveWVjdG8gPC0gYyg4NSw1MCw0MCkKcHJ1ZWJhIDwtIGRhdGEuZnJhbWUocHJ1ZWJhX2V4YW1lbiwgcHJ1ZWJhX3Byb3llY3RvKQpwcmVkaWNjaW9uIDwtIGNvbXB1dGUocmVkX25ldXJvbmFsLCBwcnVlYmEpCnByZWRpY2Npb24kbmV0LnJlc3VsdApwcm9iYWJpbGlkYWQgPC0gcHJlZGljY2lvbiRuZXQucmVzdWx0CnJlc3VsdGFkbyA8LSBpZmVsc2UocHJvYmFiaWxpZGFkPjAuNSwxLDApCnJlc3VsdGFkbwpgYGAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOmJsdWU7Ij4gQ8OhbmNlciBkZSBtYW1hIDwvc3Bhbj4KCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjpibHVlOyI+IEltcG9ydGFyIGxhIGJhc2UgZGUgZGF0b3M6IGNhbmNlcl9kZV9tYW1hIDwvc3Bhbj4KYGBge3J9CmRmMSA8LSByZWFkLmNzdigiL1VzZXJzL3hpbWVuYWJibS9Eb3dubG9hZHMvY2FuY2VyX2RlX21hbWEuY3N2IikKZGYxIDwtIGRhdGEuZnJhbWUoZGYxKQpkZjEkZGlhZ25vc2lzIDwtIGlmZWxzZShkZjEkZGlhZ25vc2lzID09ICJNIiwgMSwgMCkKZGYxX3NjYWxlZCA8LSBhcy5kYXRhLmZyYW1lKHNjYWxlKGRmMVsgLCAhbmFtZXMoZGYxKSAlaW4lICJkaWFnbm9zaXMiXSkpCmRmMV9zY2FsZWQkZGlhZ25vc2lzIDwtIGRmMSRkaWFnbm9zaXMKYGBgCgojIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZSI+IEdlbmVyYXIgbGEgUmVkIE5ldXJvbmFsIDwvc3Bhbj4KYGBge3J9CnJlZF9uZXVyb25hbCA8LSBuZXVyYWxuZXQoZGYxX3NjYWxlZCRkaWFnbm9zaXMgfiAuLCBkYXRhPWRmMV9zY2FsZWQsIAogICAgICAgICAgICAgICAgICAgICAgICAgIGhpZGRlbj1jKDEwLDUpLCBsaW5lYXIub3V0cHV0PUZBTFNFKQpwbG90KHJlZF9uZXVyb25hbCwgcmVwPSJiZXN0IikKYGBgCgojIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZSI+IFByZWRlY2lyIGxhIFJlZCBOZXVyb25hbCA8L3NwYW4+CmBgYHtyfQpzZXQuc2VlZCgxMjMpCnJlbmdsb25lc19lbnRyZW5hbWllbnRvIDwtIGNyZWF0ZURhdGFQYXJ0aXRpb24oZGYxX3NjYWxlZCRkaWFnbm9zaXMsIHA9MC44LCBsaXN0PUZBTFNFKSAKZW50cmVuYW1pZW50byA8LSBkZjFfc2NhbGVkW3Jlbmdsb25lc19lbnRyZW5hbWllbnRvLCBdCnBydWViYSA8LSBkZjFfc2NhbGVkWy1yZW5nbG9uZXNfZW50cmVuYW1pZW50bywgXQpgYGAKCmBgYHtyfQpwcmVkaWNjaW9uIDwtIGNvbXB1dGUocmVkX25ldXJvbmFsLCBwcnVlYmFbLC0xXSkgIApwcm9iYWJpbGlkYWQgPC0gcHJlZGljY2lvbiRuZXQucmVzdWx0ICAgICAgICAgICAgIApyZXN1bHRhZG8gPC0gaWZlbHNlKHByb2JhYmlsaWRhZCA+IDAuNCwgMSwgMCkgCnJlc3VsdGFkbwoKYGBgCgojIyA8c3BhbiBzdHlsZT0iY29sb3I6Ymx1ZSI+IE1hdHJpeiBkZSBDb25mdXNpw7NuIDwvc3Bhbj4KYGBge3J9Cm1jcnAgPC0gY29uZnVzaW9uTWF0cml4KAogIGFzLmZhY3RvcihyZXN1bHRhZG8pLCAgICAgICAKICBhcy5mYWN0b3IocHJ1ZWJhJGRpYWdub3NpcykgCikKCm1jcnAKYGBgCg==