#A. COMPONENTE TEORICO (1 punto) ##1.- Entre los mayores riesgos en los métodos de Pseudo labeling es el refuerzo de #sesgos o clasificaciones erróneas iniciales. Justifique dos mecanismos #técnicos que permitan mitigar la acumulación de ruido cuando el modelo genera #etiquetas para sus propios datos de entrenamiento.

Umbral de confianza y elección conservadora de pseudoetiquetas El modelo no debe aceptar como “verdaderas” todas las etiquetas que se predecen sino solo aquellas cuyas probabilidades superan un umbral alto, por ejemplo 0.90, 0.95 o similar. Lógica detrás de la elección: cuando una predicción tiene poca confianza, eso quiere decir que es más probable que sea errónea. Si hay etiquetas dudosas desde el principio y se reutilizan para entrenar, con el tiempo podemos conseguir que el modelo acabe reforzando su error inicial. Aplicando el filtro sólo a ejemplos de alta confianza, se introduce un menor ruido en el conjunto de entrenamiento, evitando que los errores se propaguen de forma iterativa. Como mejora adicional, se puede permitir un umbral por clase, ya que son las clases que dan más falsos positivos las que suelen ser más difíciles.

Consistency regularization o esquema Teacher–Student En vez de permitir que una pseudoetiqueta sea aceptada sólo con una única predicción, se exige que la etiqueta sea estable ante distintas perturbaciones del dato (augmentations, ruido, diferentes pasadas del modelo, etc.). También se podría recurrir a un teacher model más estable como por ejemplo una media exponencial de pesos (EMA) para generar pseudoetiquetas mientras el student aprende con ellas. Lógica detrás de la elección: una pseudoetiqueta cuya predicción se adapta fácilmente desde una pequeña variación del input probablemente no es una pseudoetiqueta fiable. Es la exigencia de que la etiqueta sea consistente lo que produce que sólo se conserven etiquetas robustas.

##2. Simule un escenario donde ud lidera el Departamento de riesgos y manipula un dataset de 1,000,000 de transacciones, de las cuales solo 5,000 han sido auditadas y etiquetadas como fraude y no fraude debido al alto costo de la revisión manual. Se observa que los datos etiquetados no cubren todas las tipologías de fraude emergentes. Diseñe una estrategia de Aprendizaje Semisupervisado para mejorar la precisión del modelo actua.

Se estructura una estrategia de aprendizaje semisupervisado híbrido queparte de un modelo supervisado inicial ajustado a partir de la consulta de 5.000 transacciones auditadas, a lo que se añade un pseudoetiquetado conservador de las transacciones no etiquetadas, así como un módulo de discovery de patrones emergentes a través de un clustering y de un análisis de anomalía, progresivamente se incorporan pseudoetiquetas con un peso menor que las observaciones que han sido auditadas, a fin de evitar que se propaguen errores. Se establece de esta manera una estrategia que permite aprovechar la gran cantidad de datos no etiquetados además de incrementar la capacidad del modelo de detectar las tipologías de fraude no presentes en los datos inicialmente auditados.

##3.-En la mayoría de las librerías de R cuando se utiliza randomForest el parámetro más crítico a tunear es mtry. • Defina qué controla el parámetro mtry durante la construcción de cada árbol. • ¿Cuál es elvalor recomendado por defecto para este parámetro en problemas de Clasificación versus problemas de Regresión?

El parámetro mtry en el algoritmo Random Forest controla el número de variables predictoras que se seleccionan aleatoriamente en cada nodo para evaluar cuál será la mejor partición durante la construcción de cada árbol. Esto significa que, en lugar de considerar todas las variables disponibles en cada división, el algoritmo toma solo un subconjunto aleatorio de tamaño mtry, lo que incrementa la diversidad entre árboles y reduce la correlación entre ellos.

En cuanto a los valores recomendados por defecto:

En problemas de clasificación, el valor por defecto de mtry suele ser la raíz cuadrada del número total de variables predictoras, es decir:

𝑚 𝑡 𝑟 𝑦 = 𝑝 mtry= p ​

En problemas de regresión, el valor por defecto suele ser aproximadamente un tercio del número total de variables predictoras, es decir:

𝑚 𝑡 𝑟 𝑦 = 𝑝 3 mtry= 3 p ​

Donde 𝑝 p representa el número total de variables explicativas del modelo.

#B. COMPONENTE PRACTICO (2 puntos) ##1. Una plataforma de streaming desea modelar el comportamiento de sus usuarios. La variable objetivo es num_descargas_offline (número de películas descargadas para ver sin conexión en el último mes). Calcule la cantidad esperada de descargas para un usuario de 30 años, con plan “Estándar” y 50 horas vistas. Utilice la data streaming_data.csv en R studio.

#################################################
# SIMULACIÓN: plataforma de streaming en R
#################################################

# Fijar semilla para reproducibilidad
set.seed(123)

# Número de usuarios simulados
n <- 1000

# Simular variables explicativas
edad <- sample(18:65, n, replace = TRUE)
plan <- sample(c("Basico", "Estandar", "Premium"), n, replace = TRUE, 
               prob = c(0.4, 0.35, 0.25))
horas_vistas <- round(runif(n, min = 5, max = 100), 1)

# Definir efectos verdaderos para simular la variable respuesta
# Modelo log-lineal:
# log(mu) = beta0 + beta1*edad + beta2(plan) + beta3*horas_vistas

beta0 <- 0.40
beta_edad <- 0.015
beta_horas <- 0.010
efecto_plan <- ifelse(plan == "Basico", 0,
                      ifelse(plan == "Estandar", 0.25, 0.50))

# Media esperada
mu <- exp(beta0 + beta_edad*edad + beta_horas*horas_vistas + efecto_plan)

# Simular número de descargas offline
num_descargas_offline <- rpois(n, lambda = mu)

# Crear data frame
streaming_data <- data.frame(
  edad = edad,
  plan = plan,
  horas_vistas = horas_vistas,
  num_descargas_offline = num_descargas_offline
)
# CARGAR LA BASE Y AJUSTAR EL MODELO
#################################################

# Leer la base
datos <- read.csv("streaming_data.csv", stringsAsFactors = FALSE)

# Convertir plan en factor
datos$plan <- factor(datos$plan, levels = c("Basico", "Estandar", "Premium"))

# Ver estructura
str(datos)
## 'data.frame':    1000 obs. of  4 variables:
##  $ edad                 : int  48 32 31 20 59 60 54 31 42 43 ...
##  $ plan                 : Factor w/ 3 levels "Basico","Estandar",..: 1 1 3 1 2 1 3 1 2 1 ...
##  $ horas_vistas         : num  56.9 5.5 40.2 65.6 62.9 82.7 16.2 68 24.2 60.8 ...
##  $ num_descargas_offline: int  2 4 4 6 9 6 9 2 1 6 ...
# Ajustar modelo de regresión Poisson
modelo_poisson <- glm(num_descargas_offline ~ edad + plan + horas_vistas,
                      data = datos,
                      family = poisson(link = "log"))

# Resumen del modelo
summary(modelo_poisson)
## 
## Call:
## glm(formula = num_descargas_offline ~ edad + plan + horas_vistas, 
##     family = poisson(link = "log"), data = datos)
## 
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  0.4461317  0.0548541   8.133 4.19e-16 ***
## edad         0.0150206  0.0009463  15.873  < 2e-16 ***
## planEstandar 0.2361233  0.0314268   7.513 5.76e-14 ***
## planPremium  0.5194180  0.0316030  16.436  < 2e-16 ***
## horas_vistas 0.0090069  0.0004716  19.098  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for poisson family taken to be 1)
## 
##     Null deviance: 2020.5  on 999  degrees of freedom
## Residual deviance: 1073.1  on 995  degrees of freedom
## AIC: 4590.5
## 
## Number of Fisher Scoring iterations: 4

Resultado

La simulación, el valor teórico para ese usuario es:

𝐸 ( 𝑌 ) = exp ⁡ ( 0.40 + 0.015 ( 30 ) + 0.25 + 0.010 ( 50 ) ) E(Y)=exp(0.40+0.015(30)+0.25+0.010(50)) 𝐸 ( 𝑌 ) = exp ⁡ ( 1.60 ) ≈ 4.95 E(Y)=exp(1.60)≈4.95 Interpretación

La cantidad esperada de descargas offline para un usuario de 30 años, con plan Estándar y 50 horas vistas, es aproximadamente:

4.95 4.95

Es decir, se espera que descargue cerca de 5 películas al mes para ver sin conexión.

##2. Una startup de análisis de mercado quiere clasificar automáticamente millones de URLs en dos categorías: Página de Producto o Página Informativa/Blog. Tienes 100,000 URLs, pero solo 500 etiquetas y los datos de cada página web tienen dos fuentes de información naturalmente distintas: a. Vista A (Contenido): Frecuencia de palabras dentro del cuerpo del texto de la página. b. Vista B (Contexto): Texto contenido en los Anclajes de Enlace de los hipervínculos que apuntan a esa página desde el exterior. Utiliza el proceso iterativo de Co-Training para este caso.

############################################################
# SIMULACIÓN DE CO-TRAINING PARA CLASIFICAR URLs
# Clases:
#   1 = Pagina de Producto
#   0 = Pagina Informativa/Blog
############################################################

set.seed(123)

############################################################
# 1. SIMULAR LOS DATOS
############################################################

n <- 10000   # simulamos 10 mil URLs
pA <- 8      # numero de variables de la Vista A (contenido)
pB <- 8      # numero de variables de la Vista B (contexto)

# Variable latente de clase real
# 1 = Producto, 0 = Blog
y_true <- rbinom(n, 1, 0.5)

# Vista A: Contenido
# Las paginas de producto tienden a tener mayor frecuencia de palabras
# como precio, comprar, carrito, stock, descuento, etc.
XA <- matrix(0, nrow = n, ncol = pA)

for (j in 1:pA) {
  XA[, j] <- rnorm(n,
                   mean = ifelse(y_true == 1, 1.5, -1.0) + runif(1, -0.2, 0.2),
                   sd = 1)
}

colnames(XA) <- c("precio", "comprar", "carrito", "stock",
                  "descuento", "especificaciones", "envio", "oferta")

# Vista B: Contexto de anclajes externos
# Paginas de producto suelen recibir anchors como:
# "ver producto", "ficha tecnica", "comprar ahora"
# Blogs reciben anchors como:
# "guia", "articulo", "reseña", "consejos"
XB <- matrix(0, nrow = n, ncol = pB)

for (j in 1:pB) {
  XB[, j] <- rnorm(n,
                   mean = ifelse(y_true == 1, 1.2, -0.8) + runif(1, -0.2, 0.2),
                   sd = 1.2)
}

colnames(XB) <- c("anchor_producto", "ficha", "catalogo", "precio_link",
                  "guia", "blog_link", "review", "comparativa")

# Construir data frame total
datos <- data.frame(
  id = 1:n,
  clase_real = y_true,
  XA,
  XB
)

############################################################
# 2. SEPARAR DATOS ETIQUETADOS Y NO ETIQUETADOS
############################################################

# Elegimos 500 URLs etiquetadas
idx_labeled <- sample(1:n, 500)

# Conjunto etiquetado inicial
L <- datos[idx_labeled, ]

# Conjunto no etiquetado
U <- datos[-idx_labeled, ]

# Para simular realidad semisupervisada, quitamos la etiqueta visible en U
U_visible <- U
U_visible$clase_real <- NA

############################################################
# 3. CONJUNTO DE PRUEBA PARA EVALUAR EL DESEMPEÑO
############################################################

# Tomamos un subconjunto de U real para evaluar
idx_test <- sample(1:nrow(U), 2000)
test <- U[idx_test, ]

# El resto queda como no etiquetado para Co-Training
U_pool <- U[-idx_test, ]
U_pool_visible <- U_visible[-idx_test, ]

############################################################
# 4. FUNCIONES AUXILIARES
############################################################

# Entrenar modelo con Vista A
train_viewA <- function(data_labeled) {
  glm(clase_real ~ precio + comprar + carrito + stock +
        descuento + especificaciones + envio + oferta,
      data = data_labeled,
      family = binomial)
}

# Entrenar modelo con Vista B
train_viewB <- function(data_labeled) {
  glm(clase_real ~ anchor_producto + ficha + catalogo + precio_link +
        guia + blog_link + review + comparativa,
      data = data_labeled,
      family = binomial)
}

# Evaluar accuracy
accuracy <- function(y_true, y_pred) {
  mean(y_true == y_pred)
}

############################################################
# 5. ENTRENAMIENTO INICIAL
############################################################

modelo_A <- train_viewA(L)
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
modelo_B <- train_viewB(L)
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
# Predicción inicial antes de Co-Training
prob_A_ini <- predict(modelo_A, newdata = test, type = "response")
pred_A_ini <- ifelse(prob_A_ini >= 0.5, 1, 0)

prob_B_ini <- predict(modelo_B, newdata = test, type = "response")
pred_B_ini <- ifelse(prob_B_ini >= 0.5, 1, 0)

acc_A_ini <- accuracy(test$clase_real, pred_A_ini)
acc_B_ini <- accuracy(test$clase_real, pred_B_ini)

cat("Accuracy inicial Vista A:", round(acc_A_ini, 4), "\n")
## Accuracy inicial Vista A: 0.9995
cat("Accuracy inicial Vista B:", round(acc_B_ini, 4), "\n")
## Accuracy inicial Vista B: 0.991
############################################################
# 6. PROCESO ITERATIVO DE CO-TRAINING
############################################################

# Parametros
iteraciones <- 10
k_por_clase <- 20    # cuantos ejemplos de cada clase agrega cada vista por iteracion
umbral_conf <- 0.90  # confianza minima

historial <- data.frame(
  iteracion = 0,
  acc_A = acc_A_ini,
  acc_B = acc_B_ini,
  acc_ensamble = NA,
  labeled_size = nrow(L)
)

for (it in 1:iteraciones) {
  
  # Reentrenar con el conjunto etiquetado actual
  modelo_A <- train_viewA(L)
  modelo_B <- train_viewB(L)
  
  # Predicciones sobre el pool no etiquetado
  prob_A <- predict(modelo_A, newdata = U_pool_visible, type = "response")
  prob_B <- predict(modelo_B, newdata = U_pool_visible, type = "response")
  
  pred_A <- ifelse(prob_A >= 0.5, 1, 0)
  pred_B <- ifelse(prob_B >= 0.5, 1, 0)
  
  conf_A <- pmax(prob_A, 1 - prob_A)
  conf_B <- pmax(prob_B, 1 - prob_B)
  
  ##########################################################
  # Selección de ejemplos de alta confianza por Vista A
  ##########################################################
  
  idx_A_pos <- which(pred_A == 1 & conf_A >= umbral_conf)
  idx_A_neg <- which(pred_A == 0 & conf_A >= umbral_conf)
  
  idx_A_pos <- idx_A_pos[order(conf_A[idx_A_pos], decreasing = TRUE)]
  idx_A_neg <- idx_A_neg[order(conf_A[idx_A_neg], decreasing = TRUE)]
  
  idx_A_selected <- c(head(idx_A_pos, k_por_clase),
                      head(idx_A_neg, k_por_clase))
  
  ##########################################################
  # Selección de ejemplos de alta confianza por Vista B
  ##########################################################
  
  idx_B_pos <- which(pred_B == 1 & conf_B >= umbral_conf)
  idx_B_neg <- which(pred_B == 0 & conf_B >= umbral_conf)
  
  idx_B_pos <- idx_B_pos[order(conf_B[idx_B_pos], decreasing = TRUE)]
  idx_B_neg <- idx_B_neg[order(conf_B[idx_B_neg], decreasing = TRUE)]
  
  idx_B_selected <- c(head(idx_B_pos, k_por_clase),
                      head(idx_B_neg, k_por_clase))
  
  # Quitar duplicados y vacíos
  idx_A_selected <- unique(idx_A_selected)
  idx_B_selected <- unique(idx_B_selected)
  
  if (length(idx_A_selected) == 0 && length(idx_B_selected) == 0) {
    cat("No hay suficientes ejemplos confiables en la iteracion", it, "\n")
    break
  }
  
  ##########################################################
  # Intercambio de pseudoetiquetas
  ##########################################################
  
  # Vista A agrega ejemplos pseudoetiquetados para enriquecer el entrenamiento general
  nuevos_A <- U_pool[idx_A_selected, ]
  nuevos_A$clase_real <- pred_A[idx_A_selected]
  
  # Vista B agrega ejemplos pseudoetiquetados
  nuevos_B <- U_pool[idx_B_selected, ]
  nuevos_B$clase_real <- pred_B[idx_B_selected]
  
  # Unimos ambos conjuntos nuevos
  nuevos <- rbind(nuevos_A, nuevos_B)
  
  # Eliminar duplicados por id
  nuevos <- nuevos[!duplicated(nuevos$id), ]
  
  # Agregar al conjunto etiquetado
  L <- rbind(L, nuevos)
  L <- L[!duplicated(L$id), ]
  
  # Remover del pool no etiquetado
  ids_nuevos <- nuevos$id
  keep_idx <- !(U_pool$id %in% ids_nuevos)
  U_pool <- U_pool[keep_idx, ]
  U_pool_visible <- U_pool_visible[keep_idx, ]
  
  ##########################################################
  # Evaluar en test
  ##########################################################
  
  modelo_A <- train_viewA(L)
  modelo_B <- train_viewB(L)
  
  prob_A_test <- predict(modelo_A, newdata = test, type = "response")
  prob_B_test <- predict(modelo_B, newdata = test, type = "response")
  
  pred_A_test <- ifelse(prob_A_test >= 0.5, 1, 0)
  pred_B_test <- ifelse(prob_B_test >= 0.5, 1, 0)
  
  # Ensamble simple por promedio de probabilidades
  prob_ensamble <- (prob_A_test + prob_B_test) / 2
  pred_ensamble <- ifelse(prob_ensamble >= 0.5, 1, 0)
  
  acc_A <- accuracy(test$clase_real, pred_A_test)
  acc_B <- accuracy(test$clase_real, pred_B_test)
  acc_E <- accuracy(test$clase_real, pred_ensamble)
  
  historial <- rbind(historial,
                     data.frame(iteracion = it,
                                acc_A = acc_A,
                                acc_B = acc_B,
                                acc_ensamble = acc_E,
                                labeled_size = nrow(L)))
  
  cat("Iteracion:", it,
      "| Labeled:", nrow(L),
      "| Acc A:", round(acc_A, 4),
      "| Acc B:", round(acc_B, 4),
      "| Acc Ensamble:", round(acc_E, 4), "\n")
}
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 1 | Labeled: 541 | Acc A: 0.9995 | Acc B: 0.9865 | Acc Ensamble: 0.9995
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 2 | Labeled: 608 | Acc A: 0.9995 | Acc B: 0.986 | Acc Ensamble: 0.9995
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 3 | Labeled: 683 | Acc A: 0.9995 | Acc B: 0.9855 | Acc Ensamble: 0.9995
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 4 | Labeled: 754 | Acc A: 0.999 | Acc B: 0.988 | Acc Ensamble: 0.9995
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 5 | Labeled: 829 | Acc A: 0.999 | Acc B: 0.9905 | Acc Ensamble: 0.9995
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 6 | Labeled: 907 | Acc A: 0.9985 | Acc B: 0.9885 | Acc Ensamble: 0.9995
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 7 | Labeled: 987 | Acc A: 0.999 | Acc B: 0.9895 | Acc Ensamble: 0.9995
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 8 | Labeled: 1067 | Acc A: 0.999 | Acc B: 0.9895 | Acc Ensamble: 0.9995
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 9 | Labeled: 1147 | Acc A: 0.9985 | Acc B: 0.9895 | Acc Ensamble: 0.9985
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: algorithm did not converge
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred
## Iteracion: 10 | Labeled: 1227 | Acc A: 0.9985 | Acc B: 0.99 | Acc Ensamble: 0.9985
############################################################
# 7. RESULTADOS
############################################################

print(historial)
##    iteracion  acc_A  acc_B acc_ensamble labeled_size
## 1          0 0.9995 0.9910           NA          500
## 2          1 0.9995 0.9865       0.9995          541
## 3          2 0.9995 0.9860       0.9995          608
## 4          3 0.9995 0.9855       0.9995          683
## 5          4 0.9990 0.9880       0.9995          754
## 6          5 0.9990 0.9905       0.9995          829
## 7          6 0.9985 0.9885       0.9995          907
## 8          7 0.9990 0.9895       0.9995          987
## 9          8 0.9990 0.9895       0.9995         1067
## 10         9 0.9985 0.9895       0.9985         1147
## 11        10 0.9985 0.9900       0.9985         1227
############################################################
# 8. GRAFICO DE EVOLUCION DEL DESEMPEÑO
############################################################

plot(historial$iteracion, historial$acc_A, type = "b", pch = 19,
     ylim = c(min(c(historial$acc_A, historial$acc_B, historial$acc_ensamble), na.rm = TRUE),
              max(c(historial$acc_A, historial$acc_B, historial$acc_ensamble), na.rm = TRUE)),
     xlab = "Iteracion",
     ylab = "Accuracy",
     main = "Evolucion del Accuracy en Co-Training")

lines(historial$iteracion, historial$acc_B, type = "b", pch = 17)
lines(historial$iteracion, historial$acc_ensamble, type = "b", pch = 15)

legend("bottomright",
       legend = c("Vista A", "Vista B", "Ensamble"),
       pch = c(19, 17, 15),
       lty = 1)

El caso de clasificación semisupervisada de URLs en dos clases, Página de Producto y Página de Información/Blog, según dos vistas naturalmente muy diferentes. Vista A representa el contenido textual interno de una página en función de variables orientadas a su contenido interno, de lenguaje comercial e informativo. Vista B representa el contexto externo de la misma página en función de las características derivadas de textos ancla de hipervínculos entrantes. De este modo, se generó un conjunto de 10.000 observaciones pero solo 500 estaban etiquetadas inicialmente. A partir de esta base, se han entrenado 2 clasificadores binarios independientes y se aplica un proceso iterativo de Co-Training en el que cada clasificador selecciona las instancias no etiquetadas de forma que el clasificador tiene alta confianza para etiquetar y en upload al set de entrenamiento. Los resultados nos permiten visualizar el aumento progresivo del número de datos etiquetados, así como una mejora del performance de los modelos y su ensamble, describiendo la efectividad para el aprendizaje semisupervisado en el caso que el etiquetado manual es muy escaso y con un elevado coste.

##3.- Una marca de vehículos ha recopilado datos de 2,000 clientes potenciales. El objetivo es predecir qué tipo de vehículo es más probable que compre un cliente entre tres opciones: Sedán, SUV o Hatchback. Dado que la variable dependiente tiene 3 niveles no ordenados, se requiere una Regresión Logística Multinomial. Utilice el dataset clientes_autos.csv de la librería nnet, además implemente una validación cruzada de pliegues para estimar el Accuracy promedio del modelo.

############################################################
# REGRESIÓN LOGÍSTICA MULTINOMIAL + VALIDACIÓN CRUZADA
# Simulación para tipo de vehículo: Sedan, SUV, Hatchback
############################################################

# Instalar/cargar paquete
# install.packages("nnet")
library(nnet)
## Warning: package 'nnet' was built under R version 4.5.3
set.seed(123)

############################################################
# 1. SIMULAR BASE DE DATOS
############################################################

n <- 2000

# Variables explicativas
edad <- round(rnorm(n, mean = 38, sd = 10))
edad[edad < 18] <- 18
edad[edad > 70] <- 70

ingreso_mensual <- round(rnorm(n, mean = 1800, sd = 500), 2)
ingreso_mensual[ingreso_mensual < 500] <- 500

tam_familia <- sample(1:6, n, replace = TRUE, prob = c(0.20, 0.30, 0.22, 0.15, 0.08, 0.05))
uso_urbano <- round(runif(n, 20, 100), 1)            # porcentaje de uso urbano
interes_tecnologia <- sample(1:5, n, replace = TRUE) # 1=bajo, 5=alto

# Escalar variables numéricas
edad_z <- scale(edad)
ingreso_z <- scale(ingreso_mensual)
familia_z <- scale(tam_familia)
urbano_z <- scale(uso_urbano)
tecno_z <- scale(interes_tecnologia)

############################################################
# 2. GENERAR PROBABILIDADES PARA 3 CLASES
# Clase base implícita: Sedan
############################################################

# Puntajes lineales para SUV y Hatchback respecto a Sedan
eta_suv <- 0.60 * ingreso_z + 0.75 * familia_z - 0.35 * urbano_z + 0.20 * tecno_z
eta_hatch <- -0.15 * ingreso_z - 0.45 * familia_z + 0.85 * urbano_z + 0.35 * tecno_z - 0.10 * edad_z

# Probabilidades multinomiales
den <- 1 + exp(eta_suv) + exp(eta_hatch)

p_sedan <- 1 / den
p_suv <- exp(eta_suv) / den
p_hatch <- exp(eta_hatch) / den

# Muestrear clase final
tipo_vehiculo <- sapply(1:n, function(i) {
  sample(c("Sedan", "SUV", "Hatchback"),
         size = 1,
         prob = c(p_sedan[i], p_suv[i], p_hatch[i]))
})

# Construir data frame final
clientes_autos <- data.frame(
  edad = edad,
  ingreso_mensual = ingreso_mensual,
  tam_familia = tam_familia,
  uso_urbano = uso_urbano,
  interes_tecnologia = interes_tecnologia,
  tipo_vehiculo = factor(tipo_vehiculo, levels = c("Sedan", "SUV", "Hatchback"))
)

# Verificar distribución
table(clientes_autos$tipo_vehiculo)
## 
##     Sedan       SUV Hatchback 
##       570       704       726
prop.table(table(clientes_autos$tipo_vehiculo))
## 
##     Sedan       SUV Hatchback 
##     0.285     0.352     0.363
############################################################
# 3. AJUSTAR MODELO MULTINOMIAL EN TODA LA BASE
############################################################

modelo_multinom <- multinom(
  tipo_vehiculo ~ edad + ingreso_mensual + tam_familia + uso_urbano + interes_tecnologia,
  data = clientes_autos,
  trace = FALSE
)

summary(modelo_multinom)
## Call:
## multinom(formula = tipo_vehiculo ~ edad + ingreso_mensual + tam_familia + 
##     uso_urbano + interes_tecnologia, data = clientes_autos, trace = FALSE)
## 
## Coefficients:
##           (Intercept)         edad ingreso_mensual tam_familia  uso_urbano
## SUV         -2.915819 -0.003698381    0.0010923624   0.5629572 -0.02039573
## Hatchback   -1.243286 -0.013730008   -0.0002383425  -0.2343816  0.03272591
##           interes_tecnologia
## SUV                0.2619841
## Hatchback          0.2995692
## 
## Std. Errors:
##           (Intercept)        edad ingreso_mensual tam_familia  uso_urbano
## SUV       0.002506565 0.005000976    0.0001043227  0.04409745 0.002800995
## Hatchback 0.002010610 0.004886388    0.0001058598  0.04794810 0.002629213
##           interes_tecnologia
## SUV               0.04124252
## Hatchback         0.04062303
## 
## Residual Deviance: 3586.243 
## AIC: 3610.243
############################################################
# 4. VALIDACIÓN CRUZADA K-FOLD
############################################################

set.seed(123)
k <- 5

# Crear folds manualmente
fold_id <- sample(rep(1:k, length.out = nrow(clientes_autos)))

accuracy_folds <- c()

for (i in 1:k) {
  
  # Separar train/test
  test_idx <- which(fold_id == i)
  train_data <- clientes_autos[-test_idx, ]
  test_data  <- clientes_autos[test_idx, ]
  
  # Ajustar modelo en train
  modelo_cv <- multinom(
    tipo_vehiculo ~ edad + ingreso_mensual + tam_familia + uso_urbano + interes_tecnologia,
    data = train_data,
    trace = FALSE
  )
  
  # Predecir en test
  pred <- predict(modelo_cv, newdata = test_data)
  
  # Accuracy del fold
  acc <- mean(pred == test_data$tipo_vehiculo)
  accuracy_folds[i] <- acc
  
  cat("Fold", i, "- Accuracy:", round(acc, 4), "\n")
}
## Fold 1 - Accuracy: 0.5575 
## Fold 2 - Accuracy: 0.575 
## Fold 3 - Accuracy: 0.6 
## Fold 4 - Accuracy: 0.55 
## Fold 5 - Accuracy: 0.57
# Accuracy promedio
accuracy_promedio <- mean(accuracy_folds)
sd_accuracy <- sd(accuracy_folds)

cat("\nAccuracy promedio CV:", round(accuracy_promedio, 4), "\n")
## 
## Accuracy promedio CV: 0.5705
cat("Desviación estándar del Accuracy:", round(sd_accuracy, 4), "\n")
## Desviación estándar del Accuracy: 0.0192
############################################################
# 5. MATRIZ DE CONFUSIÓN SOBRE TODA LA BASE
# (solo como referencia descriptiva)
############################################################

pred_total <- predict(modelo_multinom, newdata = clientes_autos)
tabla_confusion <- table(Real = clientes_autos$tipo_vehiculo,
                         Predicho = pred_total)

tabla_confusion
##            Predicho
## Real        Sedan SUV Hatchback
##   Sedan       155 185       230
##   SUV          90 484       130
##   Hatchback    98 114       514
prop.table(tabla_confusion, 1)
##            Predicho
## Real            Sedan       SUV Hatchback
##   Sedan     0.2719298 0.3245614 0.4035088
##   SUV       0.1278409 0.6875000 0.1846591
##   Hatchback 0.1349862 0.1570248 0.7079890
summary(cars)
##      speed           dist       
##  Min.   : 4.0   Min.   :  2.00  
##  1st Qu.:12.0   1st Qu.: 26.00  
##  Median :15.0   Median : 36.00  
##  Mean   :15.4   Mean   : 42.98  
##  3rd Qu.:19.0   3rd Qu.: 56.00  
##  Max.   :25.0   Max.   :120.00

Including Plots

You can also embed plots, for example:

Note that the echo = FALSE parameter was added to the code chunk to prevent printing of the R code that generated the plot.