PLANTEAMIENTO

En este ejercicio implementamos paso a paso una red neuronal sencilla para la operación booleana XOR. Usaremos una arquitectura 2–2–1 (dos entradas, dos neuronas ocultas y una neurona de salida) con función logística como activación en todas las neuronas. Partimos de pesos y sesgos iniciales fijos y realizamos primero la propagación hacia adelante (forward) y el cálculo del error para un patrón concreto; después (en secciones siguientes) aplicaremos retropropagación para ajustar los parámetros.

Objetivo didáctico: comprender cómo se calculan las entradas netas \(z\), las salidas \(f(z)\), el error y, posteriormente, los gradientes para actualizar pesos y sesgos.

AUTOMATIZACIÓN DEL MODELO

#DATOS
X1 <- 0; X2 <- 1; O1_obj <- 1
num_epocas <- 2
lr <- 0.25

init_params <- list(
  w1=0.1, w2=0.5, w3=-0.7, w4=0.3, w5=0.2, w6=0.4,
  b1=0,   b2=0,   b3=0
)

# ALGUNAS LIBRERÍAS
suppressPackageStartupMessages({ library(ggplot2); library(grid) })

# FUNCIÓN
sigmoid <- function(z) 1/(1+exp(-z))
make_params <- function(w1,w2,w3,w4,w5,w6,b1,b2,b3) list(w1=w1,w2=w2,w3=w3,w4=w4,w5=w5,w6=w6,b1=b1,b2=b2,b3=b3)
round_df <- function(df, digits=6){ num <- sapply(df, is.numeric); df[num] <- lapply(df[num], round, digits); df }

forward <- function(x1,x2,y,p){
  z1 <- p$w1*x1 + p$w3*x2 + p$b1; h1 <- sigmoid(z1)
  z2 <- p$w2*x1 + p$w4*x2 + p$b2; h2 <- sigmoid(z2)
  z3 <- p$w5*h1 + p$w6*h2 + p$b3; o1 <- sigmoid(z3)
  loss <- 0.5*(y - o1)^2                                  
  list(cache=list(x1=x1,x2=x2,z1=z1,h1=h1,z2=z2,h2=h2,z3=z3,o1=o1,y=y), loss=as.numeric(loss))
}

# GRADIENTE
backward <- function(cache, p){
  with(cache, {
    dE_dz3 <- (o1 - y) * (o1*(1 - o1))                
    g_w5 <- dE_dz3 * h1
    g_w6 <- dE_dz3 * h2
    dE_dz1 <- dE_dz3 * p$w5 * (h1*(1 - h1))
    dE_dz2 <- dE_dz3 * p$w6 * (h2*(1 - h2))
    list(
      w1=dE_dz1*x1, w3=dE_dz1*x2,                        
      w2=dE_dz2*x1, w4=dE_dz2*x2,
      w5=g_w5,      w6=g_w6
    )
  })
}

step_update <- function(p, g, lr){
  p$w1 <- p$w1 - lr*g$w1; p$w2 <- p$w2 - lr*g$w2
  p$w3 <- p$w3 - lr*g$w3; p$w4 <- p$w4 - lr*g$w4
  p$w5 <- p$w5 - lr*g$w5; p$w6 <- p$w6 - lr*g$w6
  p
}

trainum_epocas <- function(x1,x2,y,p,lr,num_epocas){
  history <- data.frame()
  for (e in seq_len(num_epocas)){
    fwd_before <- forward(x1,x2,y,p)       
    grads <- backward(fwd_before$cache, p)
    p <- step_update(p, grads, lr)          

    history <- rbind(history, data.frame(
      epoch=e, O1=as.numeric(fwd_before$cache$o1),
      w1=p$w1,w2=p$w2,w3=p$w3,w4=p$w4,w5=p$w5,w6=p$w6,
      b1=p$b1,b2=p$b2,b3=p$b3,
      error=as.numeric(fwd_before$loss)
    ))
  }
  list(params=p, history=history)
}

#GRÁFICO
plot_network <- function(p, x1, x2, y, title="Red neuronal XOR"){
  fwd <- forward(x1,x2,y,p)$cache
  nodes <- data.frame(
    node=c("X1","X2","h1","h2","O1","b1","b2","b3"),
    x=c(-2,-2,0,0,2,-3,-3,1), y=c(1,-1,1,-1,0,2,-2,2),
    tipo=c("entrada","entrada","oculta","oculta","salida","bias","bias","bias"),
    stringsAsFactors=FALSE
  )
  node_lab <- c(sprintf("X1\n%.0f", x1), sprintf("X2\n%.0f", x2),
                sprintf("h1\n%.3f", fwd$h1), sprintf("h2\n%.3f", fwd$h2),
                sprintf("O1\n%.3f", fwd$o1), "1","1","1")
  E <- data.frame(
    from=c("X1","X1","X2","X2","h1","h2","b1","b2","b3"),
    to  =c("h1","h2","h1","h2","O1","O1","h1","h2","O1"),
    label=c(
      paste0("W1=",round(p$w1,6)), paste0("W2=",round(p$w2,6)),
      paste0("W3=",round(p$w3,6)), paste0("W4=",round(p$w4,6)),
      paste0("W5=",round(p$w5,6)), paste0("W6=",round(p$w6,6)),
      paste0("b1=",p$b1), paste0("b2=",p$b2), paste0("b3=",p$b3)
    ),
    stringsAsFactors=FALSE
  )
  idx_from <- match(E$from, nodes$node); idx_to <- match(E$to, nodes$node)
  E$x0 <- nodes$x[idx_from]; E$y0 <- nodes$y[idx_from]
  E$x1 <- nodes$x[idx_to];   E$y1 <- nodes$y[idx_to]
  E$xm <- (E$x0 + E$x1)/2;   E$ym <- (E$y0 + E$y1)/2 + 0.15

  ggplot() +
    geom_segment(data=E, aes(x=x0,y=y0,xend=x1,yend=y1),
                 arrow=arrow(length=unit(0.2,"cm"), type="closed")) +
    geom_text(data=E, aes(x=xm,y=ym,label=label), size=3.2, color="darkgreen") +
    geom_point(data=subset(nodes, tipo!="bias"),
               aes(x=x,y=y, fill=tipo), shape=21, size=13, color="black") +
    geom_point(data=subset(nodes, tipo=="bias"),
               aes(x=x,y=y), shape=24, size=8, fill="grey80", color="black") +
    geom_text(data=nodes, aes(x=x,y=y,label=node_lab), size=4.2, fontface="bold") +
    annotate("text", x=-2, y=-2.5, label="Input Layer in R^2",  size=4) +
    annotate("text", x=  0, y=-2.5, label="Hidden Layer in R^2", size=4) +
    annotate("text", x=  2, y=-2.5, label="Output Layer in R^1", size=4) +
    coord_fixed(xlim=c(-3.5,2.7), ylim=c(-2.9,2.6), expand=FALSE) +
    theme_void() + ggtitle(title)
}

#PRINCIPAL
params0 <- do.call(make_params, init_params)

# INICIO
print(plot_network(params0, X1, X2, O1_obj,
                   title=sprintf("Red inicial (X1=%d, X2=%d, y=%d)", X1, X2, O1_obj)))

# DESARROLLO
train <- trainum_epocas(X1, X2, O1_obj, params0, lr=lr, num_epocas=num_epocas)
paramsF <- train$params

# FINAL
print(plot_network(paramsF, X1, X2, O1_obj,
                   title=sprintf("Red FINAL tras %d epoca(s) (lr=%.2f)", num_epocas, lr)))

# RESUMEN
cat("\n=== Resumen por época (O1 y error ANTES del update; pesos DESPUES) ===\n")
## 
## === Resumen por época (O1 y error ANTES del update; pesos DESPUES) ===
print(round_df(train$history, 6), row.names = FALSE)
##  epoch       O1  w1  w2        w3       w4       w5       w6 b1 b2 b3    error
##      1 0.573499 0.1 0.5 -0.698844 0.302550 0.208654 0.414982  0  0  0 0.090952
##      2 0.576380 0.1 0.5 -0.697647 0.305172 0.217241 0.429852  0  0  0 0.089727