Implementar y evaluar un modelo de clasificación por medio del algoritmo regresión logística multinomial para predecir el comportamiento de compra de los clientes, si lo hará en la tienda, por internet en línea o ambas.
Del portal de kagle.com de esta dirección url https://www.kaggle.com/datasets/shree0910/online-vs-in-store-shopping-behaviour-dataset, se descargó este conjunto de datos que también se puede descargar de la dirección url personal de github.com https://github.com/rpizarrog/machine_learning_r_python_casos_de_estudio/blob/main/datos/online%20vs%20store%20shopping%20dataset.csv.
Ahora bien, el contexto de los datos sería algo como lo siguiente: se trata de información de comportamiento de compras de los clientes en un modelo híbrido desde los que lo hace a través de comercio electrónico como de los que tradicionalmente lo hacen acudiendo a la tienda.
Este conjunto de datos simula el comportamiento del consumidor en el mundo real combinando información del tipo demográfico, hábitos digitales, patrones de compra, preferencias logísticas y factores psicológicos.
Es un conjunto de datos estructurado de 11789 registros y 25 columnas que pueden ser analizadas mediante posibles modelos de clasificación del aprendizaje automático.
Se sugiere incluir los atributos del conjunto de datos, por ejemplo:
• La edad del cliente en años cumplidos, • Los ingresos mensuales, • Horas de uso diarias en internet u horas en línea por día, • Años con el uso con su teléfono celular , • Horas diarias en redes sociales, • Valor numérico de la confianza del cliente en hacer sus pagos, • Puntuación de nivel de comodidad con el uso de la tecnología refiriéndose al uso de aplicaciones en línea, • Número de pedidos en línea por mes, • Número de visitas a tienda por mes, • Promedio de compras en línea, • Promedio de visitas al mes a la tienda, entre otros…
Se cargan paquetes previa instalación en R studio; con comentarios el uso de cada paquete, la instalaciópn son se hace una vez por eso los comentarios antes de # install.packages().
# install.packages("readr")
# install.packages("ggplot2")
# install.packages("caret")
# install.packages("dplyr")
# install.packages("flextable")
# install.packages("nnet")
library(readr) # Para cargar datos
library(ggplot2) # Para visualizar datos
library(caret) # Para evaluar modelos de clasificación
library(dplyr) # Para filtrar datos
library(flextable) # Para generar tablas para word
library(nnet) # Para implementar un modelo de regresión logística para clasificaciónSe preparan funciones que sirven para la correcta ejecución del caso.
f_cargar_datos <- function(ruta_archivo) {
#------------------------------------------------------------
# Importar datos desde un archivo CSV.
# Argumentos:
# ruta_archivo: ruta del archivo a cargar.
# Retorna:
# Un data.frame listo para análisis.
#------------------------------------------------------------
datos <- read_csv(ruta_archivo)
return(datos)
}
f_visualizar_head_tail_reducido_word <- function(datos, n = 10) {
#------------------------------------------------------------
# f_visualizar_head_tail_reducido_word()
# Objetivo:
# Mostrar primeros n y últimos n registros en una misma tabla,
# visualizando únicamente:
# - Los primeros 4 atributos
# - Los últimos 3 atributos
# Insertando una fila con "..." como separador.
#
# Nota:
# Para evitar conflictos de tipos (numérico vs texto),
# se convierte a character SOLO para la tabla de visualización.
#
# Argumentos:
# datos : data.frame
# n : número de registros a mostrar (default = 10)
#
# Retorna:
# Objeto flextable compatible con Word.
#
# Requiere:
# library(dplyr)
# library(flextable)
#------------------------------------------------------------
total_columnas <- ncol(datos)
# Índices: primeras 4 y últimas 3 (sin duplicar si hay pocas columnas)
idx_prim <- 1:min(4, total_columnas)
idx_ult <- max(total_columnas - 2, 1):total_columnas
columnas_seleccionadas <- unique(c(idx_prim, idx_ult))
# Subconjunto reducido
datos_reducidos <- datos[, columnas_seleccionadas, drop = FALSE]
# Head y tail
head_datos <- head(datos_reducidos, n)
tail_datos <- tail(datos_reducidos, n)
# Convertir a character SOLO para evitar choque de tipos en bind_rows()
head_chr <- as.data.frame(lapply(head_datos, as.character), stringsAsFactors = FALSE)
tail_chr <- as.data.frame(lapply(tail_datos, as.character), stringsAsFactors = FALSE)
# Fila separadora "..."
fila_puntos <- as.data.frame(
matrix("...", nrow = 1, ncol = ncol(head_chr)),
stringsAsFactors = FALSE
)
colnames(fila_puntos) <- colnames(head_chr)
# Concatenar
tabla_final <- bind_rows(head_chr, fila_puntos, tail_chr)
# Flextable para Word
tabla <- flextable(tabla_final)
tabla <- autofit(tabla)
return(tabla)
}
f_describir_datos <- function(datos) {
#------------------------------------------------------------
# f_describir_datos()
# Objetivo:
# Generar estadísticas descriptivas básicas.
# Uso:
# res <- f_describir_datos(datos)
# res$summary # resumen
# res$structure # estructura
#------------------------------------------------------------
res_summary <- summary(datos)
# Capturar la estructura como texto (sin imprimir)
res_str <- paste(capture.output(str(datos)), collapse = "\n")
# Devolver ambos para reutilización
return(list(summary = res_summary, structure = res_str))
}
f_transformar_factor <- function(datos) {
#------------------------------------------------------------
# f_transformar_factor()
# Objetivo:
# Convertir todas las variables tipo character
# en variables tipo factor.
#
# Argumentos:
# datos : data.frame
#
# Retorna:
# data.frame con variables character convertidas a factor.
#
# Nota:
# No modifica variables numéricas ni factores existentes.
#------------------------------------------------------------
# Identificar columnas tipo character
columnas_character <- sapply(datos, is.character)
# Convertir a factor
datos[columnas_character] <- lapply(datos[columnas_character], as.factor)
return(datos)
}
f_balancear_clases_undersamplig <- function(datos, variable_objetivo) {
#------------------------------------------------------------
# f_balancear_clases()
#
# Objetivo:
# Generar un subconjunto balanceado del conjunto de datos
# mediante undersampling (submuestreo) de la clase dominante.
#
# Descripción metodológica:
# Cuando existe desbalance severo entre clases, el modelo
# tiende a favorecer la clase mayoritaria. Esta función
# equilibra el número de observaciones por clase tomando
# aleatoriamente el mismo número de registros que la clase
# minoritaria.
#
# Argumentos:
# datos : data.frame original
# variable_objetivo : nombre de la variable dependiente (string)
#
# Retorna:
# data.frame balanceado con igual número de observaciones
# por cada clase.
#
# Método:
# 1. Identifica la frecuencia mínima entre clases.
# 2. Toma una muestra aleatoria sin reemplazo de tamaño igual
# a la clase más pequeña.
#
# Nota:
# Este procedimiento reduce el tamaño total del dataset,
# por lo que puede implicar pérdida de información.
#
# Requiere:
# library(dplyr)
#------------------------------------------------------------
# Semilla para reproducibilidad
set.seed(2026)
# Paso 1: Calcular el tamaño de la clase minoritaria
min_n <- datos %>%
count(!!sym(variable_objetivo)) %>% # Cuenta frecuencia por clase
summarise(min(n)) %>% # Obtiene el mínimo
pull() # Extrae el valor numérico
# Paso 2: Generar muestra balanceada
datos_balanceados <- datos %>%
group_by(!!sym(variable_objetivo)) %>% # Agrupa por clase
sample_n(min_n) %>% # Toma min_n observaciones por grupo
ungroup() # Elimina agrupación
return(datos_balanceados)
}
f_particionar_datos <- function(datos, proporcion_entrenamiento = 0.7) {
#------------------------------------------------------------
# f_particionar_datos()
#
# Objetivo:
# Dividir un conjunto de datos previamente preparado
# en dos subconjuntos: entrenamiento y validación.
#
# Descripción:
# La función realiza una partición aleatoria del dataset.
# El subconjunto de entrenamiento se utiliza para ajustar
# el modelo, mientras que el subconjunto de validación
# permite evaluar el desempeño del modelo en datos no
# utilizados durante el entrenamiento.
#
# Argumentos:
# datos : data.frame con los datos preparados
# proporcion_entrenamiento : proporción destinada al
# entrenamiento (default = 0.70)
#
# Retorna:
# Lista con:
# $datos_entrenamiento
# $datos_validacion
#
# Reproducibilidad:
# Se fija la semilla en 2026, correspondiente al año de
# edición del libro, garantizando resultados replicables.
#------------------------------------------------------------
# Semilla para reproducibilidad
set.seed(2026)
# Número total de observaciones
n <- nrow(datos)
# Número de observaciones para entrenamiento
n_train <- floor(proporcion_entrenamiento * n)
# Selección aleatoria de índices
indices_train <- sample(seq_len(n), size = n_train)
# Generar subconjuntos
datos_entrenamiento <- datos[indices_train, ]
datos_validacion <- datos[-indices_train, ]
# Devolver lista con ambos datasets
return(list(
datos_entrenamiento = datos_entrenamiento,
datos_validacion = datos_validacion
))
}
f_implementar_modelo_RL_multinomial <- function(datos, variable_dependiente, variables_independientes) {
#------------------------------------------------------------
# f_implementar_modelo_RL_multinomial()
#
# Objetivo:
# Ajustar un modelo de Regresión Logística Multinomial en R
# usando nnet::multinom().
#
# Argumentos:
# datos : data.frame / tibble con los datos preparados
# variable_dependiente : nombre (string) de la variable objetivo (factor)
# variables_independientes : vector (character) con nombres de predictores
#
# Retorna:
# Lista con:
# $modelo : modelo entrenado (multinom)
# $resumen : summary(modelo)
# $tabla_coef : tabla con coeficientes, SE, z y p-values
# $aic : AIC del modelo
#
# Notas:
# - La variable dependiente debe ser factor con >= 3 niveles.
# - Los predictores categóricos deben ser factor.
#------------------------------------------------------------
# Verificar paquete
if (!requireNamespace("nnet", quietly = TRUE)) {
stop("Falta instalar el paquete 'nnet'. Instala con install.packages('nnet').")
}
# Validaciones básicas
if (!is.data.frame(datos)) stop("El argumento 'datos' debe ser un data.frame o tibble.")
if (!(variable_dependiente %in% names(datos))) stop("La variable dependiente no existe en 'datos'.")
faltantes <- setdiff(variables_independientes, names(datos))
if (length(faltantes) > 0) stop(paste("Variables independientes no encontradas:", paste(faltantes, collapse = ", ")))
# Asegurar que la dependiente sea factor
datos[[variable_dependiente]] <- as.factor(datos[[variable_dependiente]])
if (nlevels(datos[[variable_dependiente]]) < 3) {
stop("La variable dependiente debe tener al menos 3 niveles para multinomial.")
}
# Fórmula del modelo
formula_modelo <- stats::as.formula(
paste(variable_dependiente, paste(variables_independientes, collapse = " + "), sep = " ~ ")
)
# Ajustar modelo (semilla editorial)
set.seed(2026)
modelo <- nnet::multinom(formula_modelo, data = datos, trace = FALSE)
# Resumen
res <- summary(modelo)
# Construir tabla de coeficientes con pruebas Wald (aprox.)
coefs <- res$coefficients
ses <- res$standard.errors
zval <- coefs / ses
pval <- 2 * (1 - stats::pnorm(abs(zval)))
# Convertir a tabla larga ordenada
tabla_coef <- data.frame(
Clase = rep(rownames(coefs), each = ncol(coefs)),
Variable = rep(colnames(coefs), times = nrow(coefs)),
Coef = as.vector(t(coefs)),
SE = as.vector(t(ses)),
Z = as.vector(t(zval)),
p_value = as.vector(t(pval)),
row.names = NULL
)
return(list(
modelo = modelo,
resumen = res,
tabla_coef = tabla_coef,
aic = stats::AIC(modelo)
))
}
f_tabla_coeficientes <- function(tabla_coef, decimales = 4) {
#------------------------------------------------------------
# f_tabla_coeficientes()
#
# Objetivo:
# Convertir una tabla de coeficientes (data.frame) en una
# tabla profesional para Word usando flextable.
#
# Argumentos:
# tabla_coef : data.frame con columnas:
# Clase, Variable, Coef, SE, Z, p_value
# decimales : número de decimales para columnas numéricas
#
# Retorna:
# Objeto flextable compatible con Word (officer).
#
# Requiere:
# library(dplyr)
# library(flextable)
#------------------------------------------------------------
if (!requireNamespace("flextable", quietly = TRUE)) {
stop("Falta instalar 'flextable'. Instala con install.packages('flextable').")
}
if (!requireNamespace("dplyr", quietly = TRUE)) {
stop("Falta instalar 'dplyr'. Instala con install.packages('dplyr').")
}
library(dplyr)
library(flextable)
# Validación mínima de columnas esperadas
cols_req <- c("Clase", "Variable", "Coef", "SE", "Z", "p_value")
faltan <- setdiff(cols_req, names(tabla_coef))
if (length(faltan) > 0) {
stop(paste("Faltan columnas en tabla_coef:", paste(faltan, collapse = ", ")))
}
# Ordenar para salida más legible
tabla_out <- tabla_coef %>%
arrange(Clase, Variable)
# Crear flextable
ft <- flextable(tabla_out)
# Etiquetas más "de libro"
ft <- set_header_labels(
ft,
Clase = "Clase",
Variable = "Variable",
Coef = "Coeficiente",
SE = "Error estándar",
Z = "Z",
p_value = "p-valor"
)
# Formateo numérico
ft <- colformat_num(ft, j = c("Coef", "SE", "Z"), digits = decimales)
ft <- colformat_num(ft, j = "p_value", digits = decimales)
# Estilo recomendado para Word
ft <- autofit(ft)
ft <- theme_booktabs(ft)
ft <- align(ft, align = "center", part = "all")
ft <- align(ft, j = c("Clase", "Variable"), align = "left", part = "all")
return(ft)
}ruta <- "https://raw.githubusercontent.com/rpizarrog/machine_learning_r_python_casos_de_estudio/refs/heads/main/datos/online%20vs%20store%20shopping%20dataset.csv"
datos <- f_cargar_datos(ruta)Al visualizar los datos en modo de tabla, solo se muestran los primeros y últimos 10 registros así como los primeros atributos y últimos tres atributos, esto para generar una vista confortable para este documento.
f_visualizar_head_tail_reducido_word(datos, 10)age | monthly_income | daily_internet_hours | smartphone_usage_years | gender | city_tier | shopping_preference |
|---|---|---|---|---|---|---|
56 | 221111 | 6.5 | 12 | Other | Tier 3 | Store |
69 | 96029 | 8.2 | 13 | Male | Tier 3 | Hybrid |
46 | 19055 | 6.4 | 4 | Female | Tier 3 | Store |
32 | 53170 | 6.4 | 11 | Female | Tier 1 | Store |
60 | 244016 | 6 | 5 | Male | Tier 3 | Store |
25 | 114976 | 7.6 | 6 | Other | Tier 2 | Store |
78 | 43251 | 4.9 | 6 | Other | Tier 2 | Hybrid |
38 | 150604 | 3.1 | 10 | Other | Tier 2 | Store |
56 | 150996 | 7.3 | 2 | Female | Tier 3 | Store |
75 | 63037 | 6.8 | 4 | Female | Tier 3 | Store |
... | ... | ... | ... | ... | ... | ... |
79 | 205268 | 5.7 | 7 | Other | Tier 2 | Store |
29 | 169125 | 6.4 | 10 | Male | Tier 2 | Store |
52 | 246500 | 2.7 | 13 | Male | Tier 3 | Store |
66 | 144022 | 6.1 | 11 | Male | Tier 1 | Store |
38 | 229292 | 5.5 | 1 | Other | Tier 1 | Store |
67 | 151087 | 10.4 | 4 | Other | Tier 1 | Store |
60 | 243273 | 6.1 | 10 | Female | Tier 2 | Store |
53 | 154729 | 4.6 | 13 | Female | Tier 2 | Store |
65 | 66116 | 6.2 | 3 | Other | Tier 1 | Store |
34 | 168023 | 4.7 | 11 | Female | Tier 1 | Store |
Se muestran los tipos de datos y su estructura.
resumen <- f_describir_datos(datos)
cat(resumen$structure)## spc_tbl_ [11,789 × 25] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
## $ age : num [1:11789] 56 69 46 32 60 25 78 38 56 75 ...
## $ monthly_income : num [1:11789] 221111 96029 19055 53170 244016 ...
## $ daily_internet_hours : num [1:11789] 6.5 8.2 6.4 6.4 6 7.6 4.9 3.1 7.3 6.8 ...
## $ smartphone_usage_years : num [1:11789] 12 13 4 11 5 6 6 10 2 4 ...
## $ social_media_hours : num [1:11789] 0.7 2.7 2.1 0.7 0.7 4 3.2 3.7 1.1 2.9 ...
## $ online_payment_trust_score : num [1:11789] 1 6 10 2 2 1 1 4 5 4 ...
## $ tech_savvy_score : num [1:11789] 6 9 8 10 5 7 8 9 3 8 ...
## $ monthly_online_orders : num [1:11789] 16 14 2 20 18 31 10 17 28 2 ...
## $ monthly_store_visits : num [1:11789] 16 1 0 3 16 6 4 7 0 9 ...
## $ avg_online_spend : num [1:11789] 28551 124056 81939 35901 131971 ...
## $ avg_store_spend : num [1:11789] 144092 28421 128229 134650 34122 ...
## $ discount_sensitivity : num [1:11789] 2 4 9 7 5 2 9 2 7 10 ...
## $ return_frequency : num [1:11789] 3 7 4 0 9 8 5 1 6 0 ...
## $ avg_delivery_days : num [1:11789] 2 4 5 3 2 3 5 2 4 2 ...
## $ delivery_fee_sensitivity : num [1:11789] 6 1 3 3 4 5 5 10 5 2 ...
## $ free_return_importance : num [1:11789] 7 3 4 10 2 10 2 10 2 9 ...
## $ product_availability_online: num [1:11789] 7 4 10 2 5 6 8 8 9 6 ...
## $ impulse_buying_score : num [1:11789] 1 9 1 4 8 6 9 8 8 9 ...
## $ need_touch_feel_score : num [1:11789] 3 6 1 8 9 3 4 9 2 1 ...
## $ brand_loyalty_score : num [1:11789] 6 8 3 2 7 4 9 6 6 5 ...
## $ environmental_awareness : num [1:11789] 5 1 3 6 1 4 9 1 6 1 ...
## $ time_pressure_level : num [1:11789] 2 7 3 6 6 8 8 4 4 7 ...
## $ gender : chr [1:11789] "Other" "Male" "Female" "Female" ...
## $ city_tier : chr [1:11789] "Tier 3" "Tier 3" "Tier 3" "Tier 1" ...
## $ shopping_preference : chr [1:11789] "Store" "Hybrid" "Store" "Store" ...
## - attr(*, "spec")=
## .. cols(
## .. age = col_double(),
## .. monthly_income = col_double(),
## .. daily_internet_hours = col_double(),
## .. smartphone_usage_years = col_double(),
## .. social_media_hours = col_double(),
## .. online_payment_trust_score = col_double(),
## .. tech_savvy_score = col_double(),
## .. monthly_online_orders = col_double(),
## .. monthly_store_visits = col_double(),
## .. avg_online_spend = col_double(),
## .. avg_store_spend = col_double(),
## .. discount_sensitivity = col_double(),
## .. return_frequency = col_double(),
## .. avg_delivery_days = col_double(),
## .. delivery_fee_sensitivity = col_double(),
## .. free_return_importance = col_double(),
## .. product_availability_online = col_double(),
## .. impulse_buying_score = col_double(),
## .. need_touch_feel_score = col_double(),
## .. brand_loyalty_score = col_double(),
## .. environmental_awareness = col_double(),
## .. time_pressure_level = col_double(),
## .. gender = col_character(),
## .. city_tier = col_character(),
## .. shopping_preference = col_character()
## .. )
## - attr(*, "problems")=<externalptr>Ahora el análisis descriptivo de los datos
resumen$summary## age monthly_income daily_internet_hours smartphone_usage_years
## Min. :18.00 Min. : 15005 Min. : 1.000 Min. : 1.000
## 1st Qu.:33.00 1st Qu.: 72450 1st Qu.: 4.600 1st Qu.: 4.000
## Median :49.00 Median :131916 Median : 6.000 Median : 8.000
## Mean :48.73 Mean :131704 Mean : 6.011 Mean : 7.598
## 3rd Qu.:64.00 3rd Qu.:190505 3rd Qu.: 7.400 3rd Qu.:11.000
## Max. :79.00 Max. :249989 Max. :12.000 Max. :14.000
## social_media_hours online_payment_trust_score tech_savvy_score
## Min. :0.000 Min. : 1.000 Min. : 1.000
## 1st Qu.:1.600 1st Qu.: 3.000 1st Qu.: 3.000
## Median :2.500 Median : 5.000 Median : 6.000
## Mean :2.514 Mean : 5.499 Mean : 5.534
## 3rd Qu.:3.400 3rd Qu.: 8.000 3rd Qu.: 8.000
## Max. :6.000 Max. :10.000 Max. :10.000
## monthly_online_orders monthly_store_visits avg_online_spend avg_store_spend
## Min. : 0.00 Min. : 0.000 Min. : 523 Min. : 542
## 1st Qu.:12.00 1st Qu.: 5.000 1st Qu.: 36797 1st Qu.: 37724
## Median :25.00 Median : 9.000 Median : 74859 Median : 75936
## Mean :24.68 Mean : 9.482 Mean : 74555 Mean : 75662
## 3rd Qu.:37.00 3rd Qu.:14.000 3rd Qu.:112134 3rd Qu.:113313
## Max. :49.00 Max. :19.000 Max. :149996 Max. :149972
## discount_sensitivity return_frequency avg_delivery_days
## Min. : 1.000 Min. :0.000 Min. :1
## 1st Qu.: 3.000 1st Qu.:2.000 1st Qu.:2
## Median : 6.000 Median :4.000 Median :4
## Mean : 5.499 Mean :4.467 Mean :4
## 3rd Qu.: 8.000 3rd Qu.:7.000 3rd Qu.:6
## Max. :10.000 Max. :9.000 Max. :7
## delivery_fee_sensitivity free_return_importance product_availability_online
## Min. : 1.000 Min. : 1.000 Min. : 1.000
## 1st Qu.: 3.000 1st Qu.: 3.000 1st Qu.: 3.000
## Median : 5.000 Median : 5.000 Median : 6.000
## Mean : 5.469 Mean : 5.462 Mean : 5.519
## 3rd Qu.: 8.000 3rd Qu.: 8.000 3rd Qu.: 8.000
## Max. :10.000 Max. :10.000 Max. :10.000
## impulse_buying_score need_touch_feel_score brand_loyalty_score
## Min. : 1.000 Min. : 1.000 Min. : 1.000
## 1st Qu.: 3.000 1st Qu.: 3.000 1st Qu.: 3.000
## Median : 5.000 Median : 5.000 Median : 6.000
## Mean : 5.486 Mean : 5.485 Mean : 5.532
## 3rd Qu.: 8.000 3rd Qu.: 8.000 3rd Qu.: 8.000
## Max. :10.000 Max. :10.000 Max. :10.000
## environmental_awareness time_pressure_level gender
## Min. : 1.000 Min. : 1.000 Length:11789
## 1st Qu.: 3.000 1st Qu.: 3.000 Class :character
## Median : 5.000 Median : 6.000 Mode :character
## Mean : 5.449 Mean : 5.504
## 3rd Qu.: 8.000 3rd Qu.: 8.000
## Max. :10.000 Max. :10.000
## city_tier shopping_preference
## Length:11789 Length:11789
## Class :character Class :character
## Mode :character Mode :character
##
##
## Aquí la ejecución de la función f_transformar_factor(datos), solo se transforman los atributos tipo character a tipo factor para que sirvirán para aplicarlo en modelos de clasificación. sólo se muestran los atributos gender, city_tier y shopping_preference.
datos <- f_transformar_factor(datos)
resumen_transformado <- f_describir_datos(datos)
cat(resumen_transformado$structure)## spc_tbl_ [11,789 × 25] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
## $ age : num [1:11789] 56 69 46 32 60 25 78 38 56 75 ...
## $ monthly_income : num [1:11789] 221111 96029 19055 53170 244016 ...
## $ daily_internet_hours : num [1:11789] 6.5 8.2 6.4 6.4 6 7.6 4.9 3.1 7.3 6.8 ...
## $ smartphone_usage_years : num [1:11789] 12 13 4 11 5 6 6 10 2 4 ...
## $ social_media_hours : num [1:11789] 0.7 2.7 2.1 0.7 0.7 4 3.2 3.7 1.1 2.9 ...
## $ online_payment_trust_score : num [1:11789] 1 6 10 2 2 1 1 4 5 4 ...
## $ tech_savvy_score : num [1:11789] 6 9 8 10 5 7 8 9 3 8 ...
## $ monthly_online_orders : num [1:11789] 16 14 2 20 18 31 10 17 28 2 ...
## $ monthly_store_visits : num [1:11789] 16 1 0 3 16 6 4 7 0 9 ...
## $ avg_online_spend : num [1:11789] 28551 124056 81939 35901 131971 ...
## $ avg_store_spend : num [1:11789] 144092 28421 128229 134650 34122 ...
## $ discount_sensitivity : num [1:11789] 2 4 9 7 5 2 9 2 7 10 ...
## $ return_frequency : num [1:11789] 3 7 4 0 9 8 5 1 6 0 ...
## $ avg_delivery_days : num [1:11789] 2 4 5 3 2 3 5 2 4 2 ...
## $ delivery_fee_sensitivity : num [1:11789] 6 1 3 3 4 5 5 10 5 2 ...
## $ free_return_importance : num [1:11789] 7 3 4 10 2 10 2 10 2 9 ...
## $ product_availability_online: num [1:11789] 7 4 10 2 5 6 8 8 9 6 ...
## $ impulse_buying_score : num [1:11789] 1 9 1 4 8 6 9 8 8 9 ...
## $ need_touch_feel_score : num [1:11789] 3 6 1 8 9 3 4 9 2 1 ...
## $ brand_loyalty_score : num [1:11789] 6 8 3 2 7 4 9 6 6 5 ...
## $ environmental_awareness : num [1:11789] 5 1 3 6 1 4 9 1 6 1 ...
## $ time_pressure_level : num [1:11789] 2 7 3 6 6 8 8 4 4 7 ...
## $ gender : Factor w/ 3 levels "Female","Male",..: 3 2 1 1 2 3 3 3 1 1 ...
## $ city_tier : Factor w/ 3 levels "Tier 1","Tier 2",..: 3 3 3 1 3 2 2 2 3 3 ...
## $ shopping_preference : Factor w/ 3 levels "Hybrid","Online",..: 3 1 3 3 3 3 1 3 3 3 ...
## - attr(*, "spec")=
## .. cols(
## .. age = col_double(),
## .. monthly_income = col_double(),
## .. daily_internet_hours = col_double(),
## .. smartphone_usage_years = col_double(),
## .. social_media_hours = col_double(),
## .. online_payment_trust_score = col_double(),
## .. tech_savvy_score = col_double(),
## .. monthly_online_orders = col_double(),
## .. monthly_store_visits = col_double(),
## .. avg_online_spend = col_double(),
## .. avg_store_spend = col_double(),
## .. discount_sensitivity = col_double(),
## .. return_frequency = col_double(),
## .. avg_delivery_days = col_double(),
## .. delivery_fee_sensitivity = col_double(),
## .. free_return_importance = col_double(),
## .. product_availability_online = col_double(),
## .. impulse_buying_score = col_double(),
## .. need_touch_feel_score = col_double(),
## .. brand_loyalty_score = col_double(),
## .. environmental_awareness = col_double(),
## .. time_pressure_level = col_double(),
## .. gender = col_character(),
## .. city_tier = col_character(),
## .. shopping_preference = col_character()
## .. )
## - attr(*, "problems")=<externalptr>resumen_transformado$summary[,c(23, 24, 25)] # solo las columnas que se necesitan## gender city_tier shopping_preference
## Female:3931 Tier 1:3982 Hybrid: 369
## Male :3966 Tier 2:3858 Online: 1176
## Other :3892 Tier 3:3949 Store :10244
##
##
## Unsersamplig significa obtener una muestra con valores de frecuencia de clase de la variable dependiente con valores equilibrados.
Aquí la ejecución de la función f_balancear_clases_undersamplig() previamente codificada, el resultado son un conjunto de datos con registros balanceados con similares frecuncias, sin embargo hubo pérdida de información que no sería tan recomendable.
datos_balanceados <- f_balancear_clases_undersamplig(datos, "shopping_preference")
table(datos_balanceados$shopping_preference)##
## Hybrid Online Store
## 369 369 369Se crean dos conjuntos de datos el 70% para datos de entrenamiento y el 30% para datos de validación.
particion <- f_particionar_datos(datos_balanceados)
datos_entrenamiento <- particion$datos_entrenamiento
datos_validacion <- particion$datos_validacionAquí los datos de entrenamiento
f_visualizar_head_tail_reducido_word(datos_entrenamiento, n=6)age | monthly_income | daily_internet_hours | smartphone_usage_years | gender | city_tier | shopping_preference |
|---|---|---|---|---|---|---|
27 | 133209 | 4.8 | 2 | Male | Tier 1 | Online |
25 | 235084 | 6.9 | 3 | Female | Tier 3 | Store |
18 | 27699 | 7.3 | 11 | Other | Tier 3 | Hybrid |
24 | 101623 | 4.3 | 7 | Other | Tier 2 | Hybrid |
26 | 22273 | 5.7 | 11 | Male | Tier 2 | Online |
31 | 136685 | 7.2 | 2 | Male | Tier 1 | Hybrid |
... | ... | ... | ... | ... | ... | ... |
45 | 206494 | 6.7 | 8 | Other | Tier 3 | Store |
30 | 242603 | 4.1 | 5 | Female | Tier 2 | Store |
32 | 95145 | 8 | 8 | Male | Tier 1 | Online |
51 | 120494 | 5.5 | 4 | Female | Tier 1 | Hybrid |
78 | 68546 | 6.9 | 3 | Female | Tier 3 | Hybrid |
36 | 51558 | 6.1 | 12 | Female | Tier 2 | Store |
Aquí los datos de validación que deben ser excluyentes.
f_visualizar_head_tail_reducido_word(datos_validacion, n=6)age | monthly_income | daily_internet_hours | smartphone_usage_years | gender | city_tier | shopping_preference |
|---|---|---|---|---|---|---|
70 | 197296 | 8.6 | 13 | Male | Tier 2 | Hybrid |
59 | 51787 | 7.2 | 2 | Male | Tier 2 | Hybrid |
29 | 75840 | 2.3 | 14 | Male | Tier 2 | Hybrid |
43 | 161708 | 7.8 | 14 | Male | Tier 1 | Hybrid |
38 | 215798 | 6.8 | 11 | Other | Tier 3 | Hybrid |
25 | 135334 | 6.3 | 6 | Other | Tier 1 | Hybrid |
... | ... | ... | ... | ... | ... | ... |
52 | 43582 | 4.5 | 4 | Other | Tier 3 | Store |
55 | 36173 | 3.2 | 1 | Male | Tier 3 | Store |
25 | 122779 | 5.1 | 13 | Other | Tier 1 | Store |
43 | 182606 | 5.2 | 4 | Female | Tier 2 | Store |
30 | 52851 | 4 | 5 | Male | Tier 3 | Store |
62 | 97971 | 7.4 | 5 | Female | Tier 3 | Store |
Se implementa un modelo de regresión loística multinomial con la función llamada f_implementar_modelo_RL_multinomial () previamente preparada.
Mandar llamar la función que construye el modelo de regresión logística con los datos de entrenamiento y mandar llamar la función para observar la salida de los coeficientes consola.
v_dependiente <- "shopping_preference"
v_independientes <- setdiff(names(datos_entrenamiento), v_dependiente)
resultado <- f_implementar_modelo_RL_multinomial(
datos = datos_entrenamiento,
variable_dependiente = v_dependiente,
variables_independientes = v_independientes
)
print(resultado$tabla_coef, width = 200)## Clase Variable Coef SE Z p_value
## 1 Online (Intercept) -2.874676e+02 2.536561e-06 -1.133296e+08 0.0000000
## 2 Online age -5.154600e-01 2.670773e-04 -1.930003e+03 0.0000000
## 3 Online monthly_income 2.474522e-04 2.186312e-02 1.131825e-02 0.9909695
## 4 Online daily_internet_hours 1.360142e+02 6.021557e-05 2.258787e+06 0.0000000
## 5 Online smartphone_usage_years 4.306641e+00 6.326054e-05 6.807784e+04 0.0000000
## 6 Online social_media_hours 8.053809e+00 4.531561e-05 1.777270e+05 0.0000000
## 7 Online online_payment_trust_score 9.380885e+01 1.257533e-04 7.459753e+05 0.0000000
## 8 Online tech_savvy_score 1.768306e+02 1.545921e-04 1.143853e+06 0.0000000
## 9 Online monthly_online_orders 2.994965e+01 3.111594e-04 9.625178e+04 0.0000000
## 10 Online monthly_store_visits -6.387067e+01 2.663272e-04 -2.398203e+05 0.0000000
## 11 Online avg_online_spend -2.763410e-04 4.117890e-02 -6.710743e-03 0.9946456
## 12 Online avg_store_spend -1.003629e-01 1.832960e-01 -5.475452e-01 0.5840042
## 13 Online discount_sensitivity 3.407696e+00 7.684348e-05 4.434594e+04 0.0000000
## 14 Online return_frequency 2.338544e+00 1.321700e-05 1.769346e+05 0.0000000
## 15 Online avg_delivery_days 3.175492e+00 2.555066e-05 1.242822e+05 0.0000000
## 16 Online delivery_fee_sensitivity 4.631437e+00 6.279266e-06 7.375761e+05 0.0000000
## 17 Online free_return_importance -8.092997e-01 6.483750e-06 -1.248197e+05 0.0000000
## 18 Online product_availability_online 7.979686e+01 6.963771e-05 1.145886e+06 0.0000000
## 19 Online impulse_buying_score 9.438627e-01 1.569387e-05 6.014213e+04 0.0000000
## 20 Online need_touch_feel_score -2.046017e+02 1.286416e-04 -1.590478e+06 0.0000000
## 21 Online brand_loyalty_score -8.410928e-01 4.422431e-05 -1.901879e+04 0.0000000
## 22 Online environmental_awareness -1.697487e+00 2.088825e-05 -8.126514e+04 0.0000000
## 23 Online time_pressure_level -1.152261e+00 8.102696e-05 -1.422071e+04 0.0000000
## 24 Online genderMale -1.240903e+00 4.392817e-06 -2.824845e+05 0.0000000
## 25 Online genderOther 2.742280e+00 1.005893e-06 2.726215e+06 0.0000000
## 26 Online city_tierTier 2 -3.282261e+01 1.539574e-05 -2.131928e+06 0.0000000
## 27 Online city_tierTier 3 -8.221837e+01 5.664700e-11 -1.451416e+12 0.0000000
## 28 Store (Intercept) -1.453205e+02 9.211706e-05 -1.577564e+06 0.0000000
## 29 Store age 1.424170e+00 8.170720e-03 1.743017e+02 0.0000000
## 30 Store monthly_income -1.660146e-03 1.190090e-01 -1.394974e-02 0.9888701
## 31 Store daily_internet_hours -8.782473e+01 1.171871e-03 -7.494404e+04 0.0000000
## 32 Store smartphone_usage_years -1.221478e+01 9.584414e-05 -1.274442e+05 0.0000000
## 33 Store social_media_hours -1.863344e+00 1.575587e-04 -1.182635e+04 0.0000000
## 34 Store online_payment_trust_score -6.946297e+01 3.324116e-04 -2.089667e+05 0.0000000
## 35 Store tech_savvy_score -9.710349e+01 7.878193e-04 -1.232560e+05 0.0000000
## 36 Store monthly_online_orders -1.511785e+01 4.320219e-04 -3.499325e+04 0.0000000
## 37 Store monthly_store_visits 2.970240e+01 1.160304e-03 2.559882e+04 0.0000000
## 38 Store avg_online_spend -5.626877e-04 6.513041e-01 -8.639402e-04 0.9993107
## 39 Store avg_store_spend 5.537741e-02 1.750993e+00 3.162628e-02 0.9747701
## 40 Store discount_sensitivity 3.605478e+00 4.812752e-04 7.491510e+03 0.0000000
## 41 Store return_frequency 1.120195e+01 6.778570e-04 1.652554e+04 0.0000000
## 42 Store avg_delivery_days 1.492670e+01 4.207130e-04 3.547954e+04 0.0000000
## 43 Store delivery_fee_sensitivity -1.629546e+01 8.836798e-04 -1.844046e+04 0.0000000
## 44 Store free_return_importance 1.476000e+01 1.209598e-03 1.220241e+04 0.0000000
## 45 Store product_availability_online -4.562531e+01 5.242943e-04 -8.702232e+04 0.0000000
## 46 Store impulse_buying_score -1.244499e+01 8.668911e-05 -1.435589e+05 0.0000000
## 47 Store need_touch_feel_score 8.905526e+01 4.405350e-04 2.021525e+05 0.0000000
## 48 Store brand_loyalty_score 2.308823e+01 2.658463e-04 8.684805e+04 0.0000000
## 49 Store environmental_awareness 3.401189e+00 1.995083e-04 1.704786e+04 0.0000000
## 50 Store time_pressure_level 1.646759e+01 1.003648e-03 1.640774e+04 0.0000000
## 51 Store genderMale 1.175781e+02 3.586633e-05 3.278230e+06 0.0000000
## 52 Store genderOther 1.629011e+02 1.279810e-04 1.272853e+06 0.0000000
## 53 Store city_tierTier 2 -6.480110e+01 8.178363e-05 -7.923480e+05 0.0000000
## 54 Store city_tierTier 3 -9.959389e+01 4.592075e-05 -2.168821e+06 0.0000000Se ejecuta la función f_evaluar_modelo():
f_evaluar_modelo <- function(modelo, datos_validacion) {
#------------------------------------------------------------
# f_evaluar_modelo()
#
# Objetivo:
# Evaluar un modelo de clasificación (p.ej. multinomial)
# usando los datos de validación, calculando la matriz de
# confusión y métricas derivadas.
#
# Criterio de aceptación (definido por el usuario):
# - Si Accuracy >= 0.70 => modelo aceptado (en términos de exactitud)
# - Si Accuracy < 0.70 => modelo no aceptado
#
# Argumentos:
# modelo : modelo entrenado (ej. nnet::multinom)
# datos_validacion: data.frame/tibble con variables predictoras
# y la variable objetivo.
#
# Retorna:
# Lista con:
# $matriz_confusion : tabla (conteos)
# $accuracy : exactitud global
# $accuracy_por_clase : (vector) sensibilidad/recall por clase
# $precision_por_clase : (vector) precision por clase
# $f1_por_clase : (vector) F1 por clase
# $macro_f1 : promedio simple de F1 por clase
# $decision : "ACEPTAR" / "NO ACEPTAR"
# $predicciones : factor de clases predichas
#
# Requiere:
# (base R) + stats
#------------------------------------------------------------
# Ajusta aquí si tu variable objetivo tiene otro nombre
variable_objetivo <- "shopping_preference"
if (!(variable_objetivo %in% names(datos_validacion))) {
stop(paste("No existe la variable objetivo", variable_objetivo, "en datos_validacion."))
}
# Asegurar que sea factor y que sus niveles estén presentes
y_true <- as.factor(datos_validacion[[variable_objetivo]])
# Predicciones (clase)
y_pred <- predict(modelo, newdata = datos_validacion, type = "class")
y_pred <- as.factor(y_pred)
# Alinear niveles (importante para tabla consistente)
niveles <- union(levels(y_true), levels(y_pred))
y_true <- factor(y_true, levels = niveles)
y_pred <- factor(y_pred, levels = niveles)
# Matriz de confusión (conteos)
cm <- table(Real = y_true, Predicho = y_pred)
# Accuracy global
accuracy <- sum(diag(cm)) / sum(cm)
# Métricas por clase:
# Recall/Sensibilidad = TP / (TP + FN) = diag / rowSums
recall <- diag(cm) / rowSums(cm)
# Precision = TP / (TP + FP) = diag / colSums
precision <- diag(cm) / colSums(cm)
# F1 = 2 * (P*R)/(P+R)
f1 <- 2 * (precision * recall) / (precision + recall)
# Manejar NaN (puede ocurrir si una clase no se predijo o no aparece)
recall[is.na(recall)] <- 0
precision[is.na(precision)] <- 0
f1[is.na(f1)] <- 0
macro_f1 <- mean(f1)
# Decisión según tu criterio
decision <- ifelse(accuracy >= 0.70, "ACEPTAR", "NO ACEPTAR")
return(list(
matriz_confusion = cm,
accuracy = accuracy,
recall_por_clase = recall,
precision_por_clase = precision,
f1_por_clase = f1,
macro_f1 = macro_f1,
decision = decision,
predicciones = y_pred
))
}Aquí el resultado de la evaluación del modelo, por el momento, solo el valor del estadístico accuracy:
evaluacion <- f_evaluar_modelo(modelo = resultado$modelo, datos_validacion = datos_validacion)
evaluacion$matriz_confusion## Predicho
## Real Hybrid Online Store
## Hybrid 95 10 3
## Online 2 104 0
## Store 3 0 116evaluacion$accuracy## [1] 0.9459459El modelo se acepta en término de solo exactitud global dado que modelo acierta en el 94% de los registros del conjunto de datos, que significa que para un nuevo, hay una probabilidad de tener certeza en un 94%.
Que significa este 94% depende del contexto de los datos si son de salud hay que buscar modelos muy exactos tal vez 99%, si es industria o servicios tal vez 95% si es en términos sociológicos tal vez 90%, si no hay tanto trigo tal ve un 80% o hasta el 70% de solo exactitud habiendo recfreado predicciones y evaluado con la matriz de confusión.
Con programación R, el caso siguió la metodología sugerida, se declaró el objetivo; se describieron los datos; se incluyó el desarrollo y la interpretación del mismo.
Para el correcto funcionamiento del caso, se presentó la carga de librerías y se indicaron las funciones necesarias; se cargaron, transformaron y prepararon los datos; se utilizó un modelo de regresión logística para cumplir con el objetivo de resolver una tarea de predicción; se utilizó la técnica de matriz de confusión para solo evaluar mediante el estadístico accuracy o exactitud del modelo predictivo.
La evaluación del modelo fue que este acierta en el 94% de los compradores es decir que hay una probabilidad de que el modelo acierte al 94% una predicción de si es comprador de tienda, en línea o ambas.