Planteamiento de la funcion

El operador XOR genera una salida binaria a partir de dos entradas binarias. Su tabla de verdad es:

tab_xor <- data.frame(
  x1 = c(0,0,1,1),
  x2 = c(0,1,0,1),
  y  = c(0,1,1,0)
)
knitr::kable(tab_xor, caption = "Tabla de verdad de la función XOR")
Tabla de verdad de la función XOR
x1 x2 y
0 0 0
0 1 1
1 0 1
1 1 0

En esta actividad entrenaremos una red neuronal 2–2–1 (dos entradas, dos neuronas ocultas, una salida) desde cero, con activación sigmoide en todas las capas y tres épocas de entrenamiento sobre una fila específica de la tabla. Luego mostraremos la evolución de los pesos y del error.

Configuración inicial de la red

Definimos la activación, los parámetros iniciales y el dato de entrenamiento que usaremos (fila 2: x1=0, x2=1, cuyo XOR es 1).

# --- Activación sigmoide y su derivada (en función del valor activado 'a') ---
sigmoid  <- function(z) 1/(1 + exp(-z))
dsigmoid <- function(a) a * (1 - a)

# --- Dato de entrenamiento ---
entrada  <- c(x1 = 0, x2 = 1)  # fila 2 de la tabla
objetivo <- 1                  # XOR(0,1) = 1

# --- Parámetros iniciales  ---
# Red: capa oculta con 2 neuronas (a1, a2) y salida y_hat
# Conexiones:
#   z1 = w1*x1 + w3*x2 + b1
#   z2 = w2*x1 + w4*x2 + b2
#   z3 = w5*a1 + w6*a2 + b3
#   y_hat = sigmoid(z3)
param <- list(
  w1 = 0.1,  w2 = 0.5,   # pesos hacia neurona oculta 1 y 2 desde x1
  w3 = -0.7, w4 = 0.3,   # pesos hacia neurona oculta 1 y 2 desde x2
  w5 = 0.2,  w6 = 0.4,   # pesos desde ocultas (a1, a2) hacia la salida
  b1 = 0,    b2 = 0,     b3 = 0
)

# --- Tasa de aprendizaje  ---
tasa_aprendizaje <- 0.2

Propagación directa (forward pass)

Calcula las activaciones de la capa oculta y la salida.

forward_pass <- function(p, x){
  # tolerante a que x venga sin nombres o como character
  x1 <- if (!is.null(names(x)) && "x1" %in% names(x)) as.numeric(x[["x1"]]) else as.numeric(x[1])
  x2 <- if (!is.null(names(x)) && "x2" %in% names(x)) as.numeric(x[["x2"]]) else as.numeric(x[2])

  z1 <- p$w1 * x1 + p$w3 * x2 + p$b1
  a1 <- sigmoid(z1)

  z2 <- p$w2 * x1 + p$w4 * x2 + p$b2
  a2 <- sigmoid(z2)

  z3 <- p$w5 * a1 + p$w6 * a2 + p$b3
  y_hat <- sigmoid(z3)

  list(a1 = a1, a2 = a2, y_hat = y_hat, z1 = z1, z2 = z2, z3 = z3)
}

Retropropagación (backpropagation)

Calcula los gradientes de cada parámetro usando MSE: \(E=\tfrac12(y-\hat y)^2\).

backprop <- function(p, x, y, cache){
  # Error escalar (MSE/2)
  error  <- 0.5 * (y - cache$y_hat)^2

  # Delta en la salida: dE/dz3 = (y_hat - y) * dsigmoid(y_hat)
  delta3 <- (cache$y_hat - y) * (cache$y_hat * (1 - cache$y_hat))

  # Gradientes capa de salida
  dE_dw5 <- cache$a1 * delta3
  dE_dw6 <- cache$a2 * delta3
  dE_db3 <- delta3

  # Propagación hacia atrás a la capa oculta
  delta1 <- (p$w5 * delta3) * (cache$a1 * (1 - cache$a1))
  delta2 <- (p$w6 * delta3) * (cache$a2 * (1 - cache$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(
    error = error,
    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
    )
  )
}

Actualización de parámetros

update_params <- function(p, grads, lr){
  for (g in names(grads)) {
    p[[g]] <- p[[g]] - lr * grads[[g]]
  }
  p
}

Entrenamiento (3 épocas)

Se observa la evolución de la salida, el error y los pesos.

historial <- data.frame()
estado    <- param  # viene de la sección anterior (configuración)

for (epoca in 1:3) {
  # 1) Forward en la observación (x1=0, x2=1)
  fwd <- forward_pass(estado, entrada)

  # 2) Backprop con objetivo = 1
  bck <- backprop(estado, entrada, objetivo, fwd)

  # 3) Actualización por descenso de gradiente
  estado <- update_params(estado, bck$grads, tasa_aprendizaje)

  # 4) Registro de resultados por época
  registro <- data.frame(
    Época   = epoca,
    Salida  = round(as.numeric(fwd$y_hat), 4),
    w1 = round(estado$w1, 6), w2 = round(estado$w2, 6),
    w3 = round(estado$w3, 6), w4 = round(estado$w4, 6),
    w5 = round(estado$w5, 6), w6 = round(estado$w6, 6),
    b1 = round(estado$b1, 6), b2 = round(estado$b2, 6), b3 = round(estado$b3, 6),
    Error   = round(as.numeric(bck$error), 5)
  )
  historial <- rbind(historial, registro)
}

Resultados

knitr::kable(historial, caption = "Evolución por época (3 épocas)")
Evolución por época (3 épocas)
Época Salida w1 w2 w3 w4 w5 w6 b1 b2 b3 Error
x1 1 0.5735 0.1 0.5 -0.699075 0.302040 0.206923 0.411985 0.000925 0.002040 0.020864 0.09095
x11 2 0.5810 0.1 0.5 -0.698138 0.304094 0.213701 0.423726 0.001862 0.004094 0.041267 0.08780
x12 3 0.5882 0.1 0.5 -0.697192 0.306158 0.220337 0.435225 0.002808 0.006158 0.061216 0.08478

Entrenamiento con las 4 filas

Ahora entrenamos sobre toda la tabla de verdad (4 ejemplos) usando descenso de gradiente estocástico.
En cada época recorremos las 4 filas

# Datos completos con nombres de columnas
X_all <- as.data.frame(tab_xor[, c("x1","x2")]) 
y_all <- tab_xor$y

barajar <- FALSE
estado2 <- param
historial_full <- data.frame()

for (epoca in 1:3) {
  idx <- 1:nrow(X_all)
  if (barajar) idx <- sample(idx)

  for (i in idx) {
    # Extraer fila con nombres
    x_i <- c(x1 = X_all$x1[i], x2 = X_all$x2[i])
    y_i <- y_all[i]

    # 1) Forward
    fwd <- forward_pass(estado2, x_i)

    # 2) Backprop
    bck <- backprop(estado2, x_i, y_i, fwd)

    # 3) Actualizar
    estado2 <- update_params(estado2, bck$grads, tasa_aprendizaje)

    # 4) Registro
    registro <- data.frame(
      Época   = epoca,
      Muestra = i,
      x1 = x_i[1], x2 = x_i[2], y = y_i,
      y_hat = round(as.numeric(fwd$y_hat), 4),
      Error = round(as.numeric(bck$error), 6),
      w1 = round(estado2$w1,6), w2 = round(estado2$w2,6),
      w3 = round(estado2$w3,6), w4 = round(estado2$w4,6),
      w5 = round(estado2$w5,6), w6 = round(estado2$w6,6),
      b1 = round(estado2$b1,6), b2 = round(estado2$b2,6), b3 = round(estado2$b3,6)
    )
    historial_full <- rbind(historial_full, registro)
  }
}

Resumen por época (error medio)

library(dplyr)
resumen_epoca <- historial_full |>
  group_by(Época) |>
  summarise(Error_medio = round(mean(Error), 6))
knitr::kable(resumen_epoca, caption = "Error medio por época (sobre las 4 muestras)")
Error medio por época (sobre las 4 muestras)
Época Error_medio
1 0.130340
2 0.129936
3 0.129586

Evaluación final en las 4 combinaciones

# Asegura que X_all sea matriz numérica
X_all_mat <- as.matrix(tab_xor[, c("x1","x2")])
storage.mode(X_all_mat) <- "numeric"
y_all <- tab_xor$y

pred_final <- apply(X_all_mat, 1, function(row) {
  # row llega como numérico; igual convertimos explícitamente
  r1 <- as.numeric(row[1]); r2 <- as.numeric(row[2])
  as.numeric(forward_pass(estado2, c(r1, r2))$y_hat)
})

eval_final <- data.frame(
  x1 = X_all_mat[,1],
  x2 = X_all_mat[,2],
  y  = y_all,
  y_hat = round(pred_final, 4),
  y_pred = as.integer(pred_final >= 0.5)
)

acc <- mean(eval_final$y_pred == eval_final$y)

knitr::kable(eval_final, caption = "Predicciones finales tras 3 épocas (umbral 0.5)")
Predicciones finales tras 3 épocas (umbral 0.5)
x1 x2 y y_hat y_pred
0 0 0 0.5587 1
0 1 1 0.5580 1
1 0 1 0.5711 1
1 1 0 0.5696 1 
cat(sprintf("\n**Exactitud final**: %.2f\n", acc))
## 
## **Exactitud final**: 0.50