Ejemplo: Red Neuronal para la función XOR

En este ejemplo aplicaremos retropropagación para entrenar una red neuronal capaz de aproximar la función XOR.
La red tendrá:

Trabajaremos con un único conjunto de entrenamiento tomado de la tabla XOR: Entrada (x1=0, x2=1) → Salida esperada y=1.

Tabla de la función XOR
Fila x1 x2 y
1 0 0 0
2 0 1 1
3 1 1 0
4 1 0 1
Fila usada en el entrenamiento
Fila x1 x2 y
2 0 1 1

Grafo de la red neuronal

## Warning: package 'DiagrammeR' was built under R version 4.4.3

Pesos y sesgos iniciales:

  • w1 = 0.1
  • w2 = 0.5
  • w3 = 0.7
  • w4 = 0.3
  • w5 = 0.2
  • w6 = 0.4
  • b1 = 0
  • b2 = 0
  • b3 = 0
# ---------- 1) Funciones base ----------
sigmoid     <- function(z) 1/(1 + exp(-z))
dsigmoid_y  <- function(y) y*(1 - y)   # derivada usando la salida de la sigmoide

# Paquete de pesos/sesgos en una lista con nombres claros
make_params <- function(w1,w2,w3,w4,w5,w6,b1=0,b2=0,b3=0) {
  list(w1=w1,w2=w2,w3=w3,w4=w4,w5=w5,w6=w6,b1=b1,b2=b2,b3=b3)
}

# ---------- 2) Forward ----------
forward_pass <- function(p, x) {
  # x es un named vector c(x1=?, x2=?)
  z1 <- p$w1*x["x1"] + p$w3*x["x2"] + p$b1
  a1 <- sigmoid(z1)
  z2 <- p$w2*x["x1"] + p$w4*x["x2"] + p$b2
  a2 <- sigmoid(z2)
  z3 <- p$w5*a1        + p$w6*a2        + p$b3
  y  <- sigmoid(z3)
  list(z1=z1,a1=a1,z2=z2,a2=a2,z3=z3,y=y)
}

# ---------- 3) Backprop: gradientes ----------
backprop_grads <- function(p, x, t, fp=NULL) {
  if (is.null(fp)) fp <- forward_pass(p, x)
  y <- fp$y
  
  # Error y delta de salida
  E      <- 0.5*(t - y)^2
  delta3 <- (y - t) * dsigmoid_y(y)
  
  # Gradientes capa de salida
  dE_dw5 <- fp$a1 * delta3
  dE_dw6 <- fp$a2 * delta3
  dE_db3 <- delta3
  
  # Deltas en ocultas (usando los pesos ACTUALES w5, w6 del forward)
  delta1 <- (p$w5 * delta3) * dsigmoid_y(fp$a1)
  delta2 <- (p$w6 * delta3) * dsigmoid_y(fp$a2)
  
  # Gradientes capa oculta
  dE_dw1 <- x["x1"] * delta1
  dE_dw3 <- x["x2"] * delta1
  dE_db1 <- delta1
  
  dE_dw2 <- x["x1"] * delta2
  dE_dw4 <- x["x2"] * delta2
  dE_db2 <- delta2
  
  list(
    E=E, fp=fp, delta3=delta3, delta1=delta1, delta2=delta2,
    grads=list(
      w1=dE_dw1, w2=dE_dw2, w3=dE_dw3, w4=dE_dw4, w5=dE_dw5, w6=dE_dw6,
      b1=dE_db1, b2=dE_db2, b3=dE_db3
    )
  )
}

# ---------- 4) Paso de actualización ----------
apply_update <- function(p, grads, lr) {
  p$w1 <- p$w1 - lr*grads$w1
  p$w2 <- p$w2 - lr*grads$w2
  p$w3 <- p$w3 - lr*grads$w3
  p$w4 <- p$w4 - lr*grads$w4
  p$w5 <- p$w5 - lr*grads$w5
  p$w6 <- p$w6 - lr*grads$w6
  p$b1 <- p$b1 - lr*grads$b1
  p$b2 <- p$b2 - lr*grads$b2
  p$b3 <- p$b3 - lr*grads$b3
  p
}

# ---------- 5) Una época (forward -> gradientes -> actualización simultánea) ----------
one_epoch <- function(p, x, t, lr, epoch_id=1) {
  fp    <- forward_pass(p, x)
  bk    <- backprop_grads(p, x, t, fp)
  p_new <- apply_update(p, bk$grads, lr)
  
  # Registro ordenado con z, activaciones, deltas, gradientes y nuevos pesos
  row <- data.frame(
    epoch   = epoch_id,
    # forward
    z1=fp$z1, a1=fp$a1, z2=fp$z2, a2=fp$a2, z3=fp$z3, y=fp$y,
    # error y deltas
    loss=bk$E, delta3=bk$delta3, delta1=bk$delta1, delta2=bk$delta2,
    # gradientes capa salida
    dE_dw5=bk$grads$w5, dE_dw6=bk$grads$w6, dE_db3=bk$grads$b3,
    # gradientes capa oculta
    dE_dw1=bk$grads$w1, dE_dw3=bk$grads$w3, dE_db1=bk$grads$b1,
    dE_dw2=bk$grads$w2, dE_dw4=bk$grads$w4, dE_db2=bk$grads$b2,
    # pesos nuevos (post-actualización)
    w1_new=p_new$w1, w2_new=p_new$w2, w3_new=p_new$w3, w4_new=p_new$w4,
    w5_new=p_new$w5, w6_new=p_new$w6, b1_new=p_new$b1, b2_new=p_new$b2, b3_new=p_new$b3
  )
  list(pars=p_new, log=row)
}

# ---------- 6) Parámetros y datos ----------
x <- c(x1=0, x2=1)  # entrada
t <- 1              # etiqueta/objetivo
alpha <- 0.25       # tasa de aprendizaje exacta de tu proceso

# Pesos/sesgos iniciales como en tu desarrollo a mano
p0 <- make_params(
  w1=0.1, w2=0.5, w3=-0.7, w4=0.3, w5=0.2, w6=0.4,
  b1=0, b2=0, b3=0
)

# ---------- 7) Entrenamiento por 2 épocas ----------
logs <- list()
state <- p0
for (e in 1:2) {
  step  <- one_epoch(state, x, t, alpha, epoch_id=e)
  state <- step$pars
  logs[[e]] <- step$log
}
results <- do.call(rbind, logs)

# tabla 
core <- results[, c("epoch","y","loss",
                    "w1_new","w2_new","w3_new","w4_new","w5_new","w6_new",
                    "b1_new","b2_new","b3_new")]
names(core) <- c("Época","ŷ","Error",
                 "w1","w2","w3","w4","w5","w6","b1","b2","b3")

core %>%
  round(6) %>%
  kbl(caption = "Predicción (ŷ), error total y parámetros actualizados por época") %>%
  kable_classic(full_width = FALSE, html_font = "Calibri") %>%
  row_spec(0, bold = TRUE, background = "#dce6f1") %>%   
  column_spec(2:3, bold = TRUE, color = "darkred")
Predicción (ŷ), error total y parámetros actualizados por época
Época ŷ Error w1 w2 w3 w4 w5 w6 b1 b2 b3
x1 1 0.573499 0.090952 0.1 0.5 -0.698844 0.302550 0.208654 0.414982 0.001156 0.002550 0.026080
x11 2 0.582811 0.087024 0.1 0.5 -0.697669 0.305121 0.217081 0.429581 0.002331 0.005121 0.051439