---
title: "Análisis integral avanzado de ventas sector alimentación"
author: "Daniel Villar Rodríguez"
format:
html:
toc: true
toc-location: left
toc-title: "Tabla de contenidos"
number-sections: true
theme:
light: cerulean
code-tools:
caption: "Code"
highlight-style: arrow
page-layout: full
code-link: true
code-line-numbers: true
code-overflow: scroll
code-copy: false
code-block-border-left: true
code-block-bg: true
code-fold: true
link-external-newindow: true
link-external-icon: true
knitr:
opts_chunk:
collapse: true
echo: true
comment: NA
fig.align: 'center'
---
En este proyecto se pretende dar información a un negocio dedicado a la compra-venta de clientes alimentarios y que inició su andadura comercial en Abril de 2020; los últimos datos a analizar son del 05/06/2022.
# ANALISIS DESCRIPTIVO
Se realizarán tareas de ETL, creación de nuevas variables de negocio y visualización de insights.
Vamos a realizar el proceso de ETL directamente en la BBDD de SQL Server.
## Conexión a BBDD
Carga de librerias necesarias
```{r message=FALSE}
if (!require("tidyverse"))
install.packages("tidyverse")
library(tidyverse)
if (!require("kableExtra"))
install.packages("kableExtra")
library(kableExtra)
if (!require("DBI"))
install.packages("DBI")
library(DBI)
if (!require("odbc"))
install.packages("odbc")
library(odbc)
if (!require("ggthemes"))
install.packages("ggthemes")
library(ggthemes)
if (!require("DT"))
install.packages("DT")
library(DT)
if (!require("skimr"))
install.packages("skimr")
library(skimr)
if (!require("sqldf"))
install.packages("sqldf")
library(sqldf)
if (!require("corrplot"))
install.packages("corrplot")
library(corrplot)
if (!require("gtsummary"))
install.packages("gtsummary")
library(gtsummary)
if (!require("cardx"))
install.packages("cardx")
library(cardx)
if (!require("dlookr"))
install.packages("dlookr")
library(dlookr)
if (!require("prettydoc"))
install.packages("prettydoc")
library(prettydoc)
if (!require("flextable"))
install.packages("flextable")
library(flextable)
if (!require("ggpubr"))
install.packages("ggpubr")
library(ggpubr)
if (!require("GGally"))
install.packages("GGally")
library(GGally)
if (!require("broom"))
install.packages("broom")
library(broom)
if (!require("lmtest"))
install.packages("lmtest")
library(lmtest)
if (!require("ggdist"))
install.packages("ggdist")
library(ggdist)
if (!require("MASS"))
install.packages("MASS")
library(MASS)
if (!require("DescTools"))
install.packages("DescTools")
library(DescTools)
if (!require("pROC"))
install.packages("pROC")
library(pROC)
if (!require("scales"))
install.packages("scales")
library(scales)
if (!require("modelsummary"))
install.packages("modelsummary")
library(modelsummary)
if (!require("ggforce"))
install.packages("ggforce")
library(ggforce)
if (!require("cluster"))
install.packages("cluster")
library(cluster)
```
Conexión a la BBDD
```{r}
connect_to_db <- function(driver, server, database) {
connection_string <- paste0("Driver={", driver, "};Server=", server,
";Database=", database, ";Trusted_Connection=yes;
")
dbConnect(odbc::odbc(), .connection_string = connection_string)
}
con <- connect_to_db("ODBC Driver 17 for SQL Server", "LAPTOP-P7645H6F",
"BD_SQL")
```
## Diagnóstico y tratamiento de las tablas de la BBDD
Obtención y visualización de las tablas de la BBDD
```{r}
info_tablas <- dbGetQuery(con, "SELECT TABLE_NAME
FROM INFORMATION_SCHEMA.TABLES
WHERE TABLE_TYPE = 'BASE TABLE'
")
datatable(info_tablas,
options = list(
pageLength = 5,
autoWidth = TRUE,
dom = 'Bfrtip',
buttons = I('colvis'),
stripe = TRUE,
hover = TRUE,
condensed = TRUE,
initComplete = JS(
"function(settings, json) {",
" $(this.api().table().header()).css({",
" 'background-color': 'grey',",
" 'color': 'white'",
" });",
" $(this.api().table().header()).find('th').css('font-weight', 'bold');",
"}"
)
)
)
```
Visualización de la informacion de las tablas de la BBDD para obtener las tablas que necesitamos
```{r echo=FALSE}
tablas <- dbGetQuery(con, "
SELECT TABLE_NAME, COLUMN_NAME, DATA_TYPE, IS_NULLABLE
FROM INFORMATION_SCHEMA.COLUMNS
")
datatable(tablas,
options = list(
pageLength = 5,
autoWidth = TRUE,
dom = 'Bfrtip',
buttons = I('colvis'),
stripe = TRUE,
hover = TRUE,
condensed = TRUE,
initComplete = JS(
"function(settings, json) {",
" $(this.api().table().header()).css({",
" 'background-color': 'grey',",
" 'color': 'white'",
" });",
" $(this.api().table().header()).find('th').css('font-weight', 'bold');",
"}"
)
)
)
```
Después de visualizar las tablas, seleccionamos aquellas que van a ser objeto de análisis y comenzamos a realizar las transformaciones oportunas; para ello usaremos:
- Transformaciones iniciales usando el conector odbc para realizar manipulaciones de tablas directamente desde el servidor.
- Otras transformaciones con las librerias dplyr y sqldf.
Antes de realizar cualquier transformación, realizamos una exploración inicial para observar cualquier incidencia en los datos de cada tabla, como serían posibles valores nulos y valores atípicos:
1- Seleccionamos y almacenamos en variables aquellas tablas que serán objeto de transformaciones posteriores
```{r}
empleados <- dbGetQuery(con, "SELECT * FROM RRHH.empleados" )
proveedores <- dbGetQuery(con, "SELECT * FROM Produccion.Proveedores")
categorias <- dbGetQuery(con, "SELECT * FROM Produccion.Categorias")
productos <- dbGetQuery(con, "SELECT * FROM Produccion.Productos")
clientes <- dbGetQuery(con, "SELECT * FROM Ventas.Clientes")
transportistas <- dbGetQuery(con, "SELECT * FROM Ventas.Transportistas")
pedidos <- dbGetQuery(con, "SELECT * FROM Ventas.Ordenes")
detalle_pdos <- dbGetQuery(con, "SELECT * FROM Ventas.DetalleOrden")
```
2- Comenzamos la fase exploratoria inicial con cada tabla, para ello haremos los mismos pasos con cada tabla, con el objetivo de ver posibles incidencias en las variables, tanto categóricas como numéricas:
**TABLA 'empleados'**
- Diagnóstico variables categóricas
```{r}
skim_summary <- skim(empleados)
# Filtramos las variables no numéricas
non_numeric_vars <- skim_summary %>%
filter(skim_type != "numeric") %>%
pull(skim_variable)
# Creamos un resumen para cada variable no numérica
resumen_no_numericas <- lapply(non_numeric_vars, function(var) {
empleado_var <- empleados[[var]]
skim(data.frame(empleado_var))
})
# Nombramos los resúmenes por variable
names(resumen_no_numericas) <- non_numeric_vars
# Creamos un dataframe solo con las variables no numéricas
empleados_non_numeric <- empleados[ , non_numeric_vars, drop = FALSE]
# Obtenemos el resumen para estas variables
skim_non_numeric_summary <- skim(empleados_non_numeric)
# Impresión de variables
skim_non_numeric_summary
```
Diagnóstico variables numéricas
```{r}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(empleados)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(empleados)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(empleados)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
Repetimos el proceso con el resto de las tablas, con el fin de visualizar los datos clave para la limpieza y transformación de las variables de interés.
**TABLA 'proveedores'**
Variables categóricas
```{r echo=FALSE}
skim_summary <- skim(proveedores)
# Filtramos las variables no numéricas
non_numeric_vars <- skim_summary %>%
filter(skim_type != "numeric") %>%
pull(skim_variable)
# Creamos un resumen para cada variable no numérica
resumen_no_numericas <- lapply(non_numeric_vars, function(var) {
proveedores_var <- proveedores[[var]]
skim(data.frame(proveedores_var))
})
# Nombramos los resúmenes por variable
names(resumen_no_numericas) <- non_numeric_vars
# Creamos un dataframe solo con las variables no numéricas
proveedores_non_numeric <- proveedores[ , non_numeric_vars, drop = FALSE]
# Obtenemos el resumen para estas variables
skim_non_numeric_summary <- skim(proveedores_non_numeric)
# Impresión de variables
skim_non_numeric_summary
```
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(proveedores)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(proveedores)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(proveedores)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
**TABLA 'categorias'**
Variables categóricas
```{r echo=FALSE}
skim_summary <- skim(categorias)
# Filtramos las variables no numéricas
non_numeric_vars <- skim_summary %>%
filter(skim_type != "numeric") %>%
pull(skim_variable)
# Creamos un resumen para cada variable no numérica
resumen_no_numericas <- lapply(non_numeric_vars, function(var) {
categorias_var <- categorias[[var]]
skim(data.frame(categorias_var))
})
# Nombramos los resúmenes por variable
names(resumen_no_numericas) <- non_numeric_vars
# Creamos un dataframe solo con las variables no numéricas
categorias_non_numeric <- categorias[ , non_numeric_vars, drop = FALSE]
# Obtenemos el resumen para estas variables
skim_non_numeric_summary <- skim(categorias_non_numeric)
# Impresión de variables
skim_non_numeric_summary
```
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(categorias)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(categorias)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(categorias)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
**TABLA 'productos'**
Variables categóricas
```{r echo=FALSE}
skim_summary <- skim(productos)
# Filtramos las variables no numéricas
non_numeric_vars <- skim_summary %>%
filter(skim_type != "numeric") %>%
pull(skim_variable)
# Creamos un resumen para cada variable no numérica
resumen_no_numericas <- lapply(non_numeric_vars, function(var) {
productos_var <- productos[[var]]
skim(data.frame(productos_var))
})
# Nombramos los resúmenes por variable
names(resumen_no_numericas) <- non_numeric_vars
# Creamos un dataframe solo con las variables no numéricas
productos_non_numeric <- productos[ , non_numeric_vars, drop = FALSE]
# Obtenemos el resumen para estas variables
skim_non_numeric_summary <- skim(productos_non_numeric)
# Impresión de variables
skim_non_numeric_summary
```
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(productos)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(productos)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(productos)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
**TABLA 'clientes'**
```{r echo=FALSE}
skim_summary <- skim(clientes)
# Filtramos las variables no numéricas
non_numeric_vars <- skim_summary %>%
filter(skim_type != "numeric") %>%
pull(skim_variable)
# Creamos un resumen para cada variable no numérica
resumen_no_numericas <- lapply(non_numeric_vars, function(var) {
clientes_var <- clientes[[var]]
skim(data.frame(clientes_var))
})
# Nombramos los resúmenes por variable
names(resumen_no_numericas) <- non_numeric_vars
# Creamos un dataframe solo con las variables no numéricas
clientes_non_numeric <- clientes[ , non_numeric_vars, drop = FALSE]
# Obtenemos el resumen para estas variables
skim_non_numeric_summary <- skim(clientes_non_numeric)
# Impresión de variables
skim_non_numeric_summary
```
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(clientes)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(clientes)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(clientes)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
**TABLA 'transportistas'**
```{r echo=FALSE}
skim_summary <- skim(transportistas)
# Filtramos las variables no numéricas
non_numeric_vars <- skim_summary %>%
filter(skim_type != "numeric") %>%
pull(skim_variable)
# Creamos un resumen para cada variable no numérica
resumen_no_numericas <- lapply(non_numeric_vars, function(var) {
transportistas_var <- transportistas[[var]]
skim(data.frame(transportistas_var))
})
# Nombramos los resúmenes por variable
names(resumen_no_numericas) <- non_numeric_vars
# Creamos un dataframe solo con las variables no numéricas
transportistas_non_numeric <- transportistas[ , non_numeric_vars, drop = FALSE]
# Obtenemos el resumen para estas variables
skim_non_numeric_summary <- skim(transportistas_non_numeric)
# Impresión de variables
skim_non_numeric_summary
```
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(transportistas)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(transportistas)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(transportistas)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
**TABLA 'pedidos'**
```{r echo=FALSE}
skim_summary <- skim(pedidos)
# Filtramos las variables no numéricas
non_numeric_vars <- skim_summary %>%
filter(skim_type != "numeric") %>%
pull(skim_variable)
# Creamos un resumen para cada variable no numérica
resumen_no_numericas <- lapply(non_numeric_vars, function(var) {
pedidos_var <- pedidos[[var]]
skim(data.frame(pedidos_var))
})
# Nombramos los resúmenes por variable
names(resumen_no_numericas) <- non_numeric_vars
# Creamos un dataframe solo con las variables no numéricas
pedidos_non_numeric <- pedidos[ , non_numeric_vars, drop = FALSE]
# Obtenemos el resumen para estas variables
skim_non_numeric_summary <- skim(pedidos_non_numeric)
# Impresión de variables
skim_non_numeric_summary
```
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(pedidos)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(pedidos)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(pedidos)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
**TABLA 'detalle_pdos'**
Variables categóricas, no hay
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(detalle_pdos)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(detalle_pdos)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(detalle_pdos)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
Una vez revisadas las variables de las tablas, se concluye que:
- con respecto a las variables categóricas **no se van a realizar ninguna labor de limpieza de datos.**
- con respecto a las variables numéricas, **se realizarán transformaciones para suavizar el efecto de los valores atípicos de las variables preciounitario de la tabla 'productos', flete de la tabla 'pedidos' y preciounitario y cantidad de la tabla 'detalle_pdos'**
Visualizamos cuales transformaciones son las más adecuadas para las variables númericas detalladas
```{r fig.height=6, fig.width=12}
productos %>%
plot_normality(preciounitario)
```
Realizamos las transformaciones
```{r}
sh_log_preciounit <- shapiro.test(log(productos$preciounitario))
sh_sqrt_preciounit <- shapiro.test(sqrt(productos$preciounitario))
```
Resultados
```{r}
resultados <- data.frame(
Transformación = c("Logarítmica", "Raíz cuadrada"),
Estadístico = c(sh_log_preciounit$statistic, sh_sqrt_preciounit$statistic),
`Valor p` = c(sh_log_preciounit$p.value, sh_sqrt_preciounit$p.value)
)
kable(resultados, digits = 4, caption = "Resultados de las Pruebas de Normalidad de Shapiro-Wilk")
```
Realizamos la misma operación para todas las variables que queremos transformar
```{r fig.height=6, fig.width=12, echo=FALSE}
pedidos %>%
plot_normality(flete)
```
```{r echo=FALSE}
sh_log_flete <- shapiro.test(log(pedidos$flete))
sh_sqrt_flete <- shapiro.test(sqrt(pedidos$flete))
```
```{r echo=FALSE}
resultados <- data.frame(
Transformación = c("Logarítmica", "Raíz cuadrada"),
Estadístico = c(sh_log_flete$statistic, sh_sqrt_flete$statistic),
`Valor p` = c(sh_log_flete$p.value, sh_sqrt_flete$p.value)
)
kable(resultados, digits = 4, caption = "Resultados de las Pruebas de Normalidad de Shapiro-Wilk")
```
```{r fig.height=6, fig.width=12, echo=FALSE}
detalle_pdos %>%
plot_normality(preciounitario)
```
```{r echo=FALSE}
sh_log_punit <- shapiro.test(log(detalle_pdos$preciounitario))
sh_sqrt_punit <- shapiro.test(sqrt(detalle_pdos$preciounitario))
```
```{r echo=FALSE}
resultados <- data.frame(
Transformación = c("Logarítmica", "Raíz cuadrada"),
Estadístico = c(sh_log_punit$statistic, sh_sqrt_punit$statistic),
`Valor p` = c(sh_log_punit$p.value, sh_sqrt_punit$p.value)
)
kable(resultados, digits = 4, caption = "Resultados de las Pruebas de Normalidad de Shapiro-Wilk")
```
```{r fig.height=6, fig.width=12, echo=FALSE}
detalle_pdos %>%
plot_normality(cantidad)
```
```{r echo=FALSE}
sh_log_cantidad <- shapiro.test(log(detalle_pdos$cantidad))
sh_sqrt_cantidad <- shapiro.test(sqrt(detalle_pdos$cantidad))
```
```{r echo=FALSE}
resultados <- data.frame(
Transformación = c("Logarítmica", "Raíz cuadrada"),
Estadístico = c(sh_log_cantidad$statistic, sh_sqrt_cantidad$statistic),
`Valor p` = c(sh_log_cantidad$p.value, sh_sqrt_cantidad$p.value)
)
kable(resultados, digits = 4, caption = "Resultados de las Pruebas de Normalidad de Shapiro-Wilk")
```
CONCLUSIONES PARA LAS TRANSFORMACIONES:
- De la tabla 'clientes'-\> variable preciounitario -\> **transformación logarítmica.**, la cual es la única de todas las transformaciones en la que existe normalidad.
- De la tabla 'pedidos'-\>variable flete -\> **transformación logarítmica**, al tener un valor estadístico más alto.
- De la tabla 'detalle_pdos'-\> la variable preciounitario -\> **transformación logarítmica**, al tener un valor estadístico más alto.
- De la tabla 'detalle_pdos'-\> la variable cantidad -\> **transformación de raíz cuadrada**, al tener un valor estadístico más alto.
## Creación de las tablas objeto de análisis (transformaciones)
### Tabla detallada 'detalle_pdos'
Para la creación de la tabla de 'detalle_pdos' tenemos que combinar varias tablas, además creamos un índice para evitar que se borren duplicados cara a futuros análisis con PowerBI y dos nuevas variables como son subtotal_pdo y total_pdo
```{sql, connection = con, output.var = "detalle_pdos"}
WITH tabla1 AS
(
SELECT ROW_NUMBER() OVER (ORDER BY T1.id_orden) AS indice,
T1.id_orden,
T4.id_empleado,
CONCAT (T4.nombre,' ', T4.apellido) AS nomb_empleado,
T1.id_producto,
T2.nombreproducto,
T5.id_categoria,
T5.nombrecategoria,
T5.descripcion AS descrip_categoria,
T3.id_cliente,
T7.nombrecliente,
T1.preciounitario AS pcu,
T2.preciounitario AS pvu,
T1.cantidad,
T1.descuento,
T2.preciounitario * T1.cantidad * (1 - T1.descuento) AS subtotal_pdo,
T6.nombreproveedor,
T6.ciudad AS ciudad_proveedor,
T6.pais AS pais_proveedor
FROM Ventas.DetalleOrden T1
LEFT JOIN Produccion.Productos T2
ON T1.id_producto = T2.id_producto
LEFT JOIN Ventas.Ordenes T3
ON T1.id_orden = T3.id_orden
LEFT JOIN RRHH.Empleados T4
ON T3.id_empleado = T4.id_empleado
LEFT JOIN Produccion.Categorias T5
ON T2.id_categoria = T5.id_categoria
LEFT JOIN Produccion.Proveedores T6
ON T2.id_proveedor = T6.id_proveedor
LEFT JOIN Ventas.Clientes T7
ON T3.id_cliente = T7.id_cliente
)
SELECT
*,
SUM (subtotal_pdo) OVER (PARTITION BY id_orden) AS total_pdo
FROM
tabla1
```
```{r echo=FALSE}
detalle_pdos$indice <- as.integer(detalle_pdos$indice)
datatable(head(detalle_pdos),
options = list(
pageLength = 6,
autoWidth = TRUE,
dom = 'Bfrtip',
buttons = I('colvis'),
stripe = TRUE,
hover = TRUE,
condensed = TRUE,
initComplete = JS(
"function(settings, json) {",
" $(this.api().table().header()).css({",
" 'background-color': 'grey',",
" 'color': 'white'",
" });",
" $(this.api().table().header()).find('th').css('font-weight', 'bold');",
"}"
)
)
)
```
### Tabla resumen 'pedidos'
Para la creación de la tabla de pedidos tenemos que combinar varias tablas
```{sql, connection = con, output.var = "pedidos"}
WITH tabla1 AS
(
SELECT T1.id_orden,
CONCAT (T4.nombre,' ', T4.apellido) AS nomb_empleado,
YEAR(T1.fecha_orden) AS año,
MONTH (T1.fecha_orden) AS mes,
T1.fecha_orden AS fecha_pedido,
T1.fecha_requerida AS fecha_entrega,
T1.flete,
T2.nombrecliente,
T2.ciudad AS ciudad_cliente,
T2.pais AS pais_cliente,
T3.compañia AS transportista
FROM ventas.Ordenes T1
LEFT JOIN ventas.Clientes T2
ON T1.id_cliente = T2.id_cliente
LEFT JOIN ventas.Transportistas T3
ON T1.id_transportista = T3.id_transportista
LEFT JOIN RRHH.Empleados T4
ON T1.id_empleado = T4.id_empleado
)
SELECT
*
FROM
tabla1
```
Mostramos las primeras filas del resultado
```{r echo=FALSE}
datatable(head(pedidos),
options = list(
pageLength = 6,
autoWidth = TRUE,
dom = 'Bfrtip',
buttons = I('colvis'),
stripe = TRUE,
hover = TRUE,
condensed = TRUE,
initComplete = JS(
"function(settings, json) {",
" $(this.api().table().header()).css({",
" 'background-color': 'grey',",
" 'color': 'white'",
" });",
" $(this.api().table().header()).find('th').css('font-weight', 'bold');",
"}"
)
)
)
```
## Manipulaciones finales para calidad de datos:
Resumen de datos de la tabla 'pedidos'
```{r echo=FALSE}
skim_summary <- skim(pedidos)
# Filtramos las variables no numéricas
non_numeric_vars <- skim_summary %>%
filter(skim_type != "numeric") %>%
pull(skim_variable)
# Creamos un resumen para cada variable no numérica
resumen_no_numericas <- lapply(non_numeric_vars, function(var) {
pedidos_var <- pedidos[[var]]
skim(data.frame(pedidos_var))
})
# Nombramos los resúmenes por variable
names(resumen_no_numericas) <- non_numeric_vars
# Creamos un dataframe solo con las variables no numéricas
pedidos_non_numeric <- pedidos[ , non_numeric_vars, drop = FALSE]
# Obtenemos el resumen para estas variables
skim_non_numeric_summary <- skim(pedidos_non_numeric)
# Impresión de variables
skim_non_numeric_summary
```
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(pedidos)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(pedidos)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(pedidos)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
Los rangos máximos de la variables 'flete', como se mencionó con anterioridad, son elevados y se revisarán por **posibles valores atípicos.**
Resumen de datos de la tabla 'detalle_pdos'
Variables categóricas, no hay
Variables numéricas
```{r echo=FALSE}
# Selección de variables con la librería DlookR
# Obtenemos el análisis numérico
diagnostico <- diagnose_numeric(detalle_pdos)
# Añadimos y renombramos columnas
diagnostico_ordenado <- diagnostico %>%
dplyr::select(variables, mean, min, Q1, median, Q3, max, zero, minus, outlier) %>%
mutate(
mediana_vs_media = abs(median - mean),
pct_dif = abs(median - mean) / median * 100,
media = mean,
mediana = median,
ceros = zero,
negativos = minus,
atipicos = outlier
)
# Selección de columnas
diagnostico_ordenado <- diagnostico_ordenado %>%
dplyr::select(variables, media, min, Q1, mediana, Q3, max, ceros, negativos, atipicos, mediana_vs_media, pct_dif)
# Obtenemos el análisis de valores atípicos
diagnostico_outliers <- diagnose_outlier(detalle_pdos)
# Renombramos las columnas
diagnostico_outliers <- diagnostico_outliers %>%
mutate(
num_atipicos = outliers_cnt,
ratio_atipicos = outliers_ratio,
media_con_atip = with_mean,
media_sin_atip = without_mean
)
# Seleccionamos columnas
diagnostico_outliers <- diagnostico_outliers %>%
dplyr::select(variables, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# Unimos ambas tablas basadas en la columna `variables`
tabla_num_dlookr <- left_join(diagnostico_ordenado, diagnostico_outliers, by = "variables")
###################################
# Selección de variables con la librería Skimr
# Obtenemos el resumen completo
resumen_completo <- skim(detalle_pdos)
# Filtramos para obtener solo las variables de tipo numerico
resumen_numeric <- resumen_completo %>%
filter(skim_type == "numeric")
# Selección de variables numericas y modificaciones
tabla_num_skim <- resumen_numeric %>%
dplyr::select(skim_variable, n_missing, numeric.hist) %>%
mutate(variables = skim_variable,
nulos = n_missing
)
# Selección final
tabla_num_skim <- tabla_num_skim %>%
dplyr::select(variables, nulos, numeric.hist)
# Union de tablas; de la libreria dlookr con la de la libreria skimr
tabla_final_num <- tabla_num_dlookr %>%
left_join(tabla_num_skim, by= "variables" )
# Reordenación de tabla final
tabla_final_num <- tabla_final_num %>%
dplyr::select(variables, numeric.hist, nulos, atipicos, ceros, negativos, media, min, Q1, mediana, Q3, max, mediana_vs_media, pct_dif, num_atipicos, ratio_atipicos, media_con_atip, media_sin_atip)
# VISUALIZACION FINAL VARIABLES NUMERICAS
# Ver en formato tabla
tabla_final_num %>% flextable()
```
Los rangos máximos de las variables 'pcu','pvu' y 'cantidad' , como se mencionó con anterioridad, son elevados y se revisarán por **posibles valores atípicos.**
### Revisión de la variable 'flete' de la tabla resumen 'pedidos'
```{r}
ggplot(pedidos) +
aes(x = "", y = flete) +
geom_boxplot(fill = "lightblue") +
coord_flip() +
theme_minimal()
```
A nivel general vemos muchos valores atípicos de la variable flete; a continuación vamos a segregar la variable por empleados para ver aún más detalle de los valores atípicos
```{r}
ggplot(pedidos) +
aes(x = "", y = flete, fill = nomb_empleado) +
geom_boxplot() +
scale_fill_hue(direction = 1) +
coord_flip() +
labs( title = "Flete facturado por Empleado") +
theme_minimal() +
theme(legend.position = "none", plot.title = element_text(hjust = 0.5)) +
facet_wrap(vars(nomb_empleado))
```
Ahora procedemos a analizar la media de flete facturado por cliente y lo comparamos con el flete facturado por orden; esa diferencia la contrastamos por empleado para ver como estos se desvian con respecto a la media
```{r}
rev_flete <- sqldf("
WITH inicial AS
(
SELECT
T1.nomb_empleado,
T1.nombrecliente,
T1.flete,
AVG (T1.flete) OVER() AS media_flete,
AVG (T1.flete) OVER (PARTITION BY T1.nombrecliente) AS media_flete_x_cliente
FROM pedidos T1
GROUP BY T1.nomb_empleado,
T1.nombrecliente
),
tabla1 AS
(
SELECT *,
flete - media_flete_x_cliente AS diferencia
FROM inicial
ORDER BY diferencia ASC
)
SELECT nomb_empleado,
media_flete,
SUM(diferencia) OVER (PARTITION BY nomb_empleado) dif_x_empleado
FROM tabla1
GROUP BY nomb_empleado,
media_flete
ORDER BY dif_x_empleado ASC
")
```
Resultado
```{r echo=FALSE}
datatable(rev_flete,
options = list(
pageLength = 10,
autoWidth = TRUE,
dom = 'Bfrtip',
buttons = I('colvis'),
stripe = TRUE,
hover = TRUE,
condensed = TRUE,
initComplete = JS(
"function(settings, json) {",
" $(this.api().table().header()).css({",
" 'background-color': 'grey',",
" 'color': 'white'",
" });",
" $(this.api().table().header()).find('th').css('font-weight', 'bold');",
"}"
)
)
)
```
Podemos concluir que los empleados concentran los fletes facturados en importes pequeños (según la mediana que se puede visualizar por cada empleado) y facturan algunos fletes elevados (atípicos); incluso así, podemos observar que el total de flete que factura cada empleado tiene un desvío negativo con respecto a la media de flete general.
Realizamos la transformacion de la variable flete detallada en el punto de *CONCLUSIONES PARA LAS TRANSFORMACIONES* y la añadimos al dataset
```{r}
pedidos$flete_log <- log(pedidos$flete)
skim(pedidos)
```
Comparamos la variable original con la variable transformada
```{r fig.height=6, fig.width=12, echo=FALSE}
pedidos %>%
plot_normality(flete)
pedidos %>%
plot_normality(flete_log)
```
Vemos una mejora de la normalidad en los datos de flete_log comparándola con su original, ya que se reduce el efecto de los valores atípicos.
### Revisión de la variable 'pcu' de la tabla detallada 'detalle_pdos'
```{r}
ggplot(detalle_pdos) +
aes(x = "", y = pcu, fill = nombreproveedor) +
geom_boxplot() +
scale_fill_hue(direction = 1) +
coord_flip() +
theme_minimal() +
theme(legend.position = "none", plot.title = element_text(hjust = 0.5)) +
facet_wrap(vars(nombreproveedor)) +
labs(title = "Precio unitario de producto por Proveedor")
```
**Existen algunos precios atipicos en algunos proveedores, el departamento de compras revisará en consecuencia.**
No obstante, realizamos la transformación de la variable pcu en el punto de *CONCLUSIONES PARA LAS TRANSFORMACIONES*; también realizamos la transformación de la variable pvu y ambas las añadimos al dataset
```{r}
detalle_pdos$pcu_log <- log(detalle_pdos$pcu)
detalle_pdos$pvu_log <- log(detalle_pdos$pvu)
skim(detalle_pdos)
```
Comparación de variables originales con variables transformadas
```{r, fig.height=6, fig.width=12, echo=FALSE}
detalle_pdos %>%
plot_normality(pcu)
detalle_pdos %>%
plot_normality(pcu_log)
detalle_pdos %>%
plot_normality(pvu)
detalle_pdos %>%
plot_normality(pvu_log)
```
Vemos una mejora de la normalidad en los datos tanto de pcu_log como de pvu_log comparando ambas variables con sus originales, ya que se reduce el efecto de los valores atípicos.
### Revisión de la variable 'cantidad' de la tabla detallada 'detalle_pdos'
```{r}
ggplot(detalle_pdos) +
aes(x = "", y = cantidad, fill = nomb_empleado) +
geom_boxplot() +
scale_fill_hue(direction = 1) +
labs(title = "Cantidades vendidas por empleado") +
coord_flip() +
theme_minimal() +
theme(legend.position = "none",
plot.title = element_text(hjust = 0.5)) +
facet_wrap(vars(nomb_empleado))
```
Dentro de la distribución normal de las cantidades vendidas, aparecen cantidades vendidas más elevadas que consideramos atipicas.
Realizamos la transformación de la variable cantidad en el punto de *CONCLUSIONES PARA LAS TRANSFORMACIONES* y la añadimos al dataset
```{r}
detalle_pdos$cantidad_sqrt <- sqrt(detalle_pdos$cantidad)
skim(detalle_pdos)
```
Comparación de variable original con la variable transformada
```{r, fig.height=6, fig.width=12, echo=FALSE}
detalle_pdos %>%
plot_normality(cantidad)
detalle_pdos %>%
plot_normality(cantidad_sqrt)
```
Vemos una mejora de la normalidad en la variable cantidad_sqrt, ya que se reduce el efecto de los valores atípicos.
## Creación de nuevas variables
Se crean nuevas variables que enriqueceran el análisis posterior.
Creamos nuevas variables en la tabla detallada 'detalle_pdos'
```{r}
new_var_detalle_pdos <- sqldf("
SELECT
*,
CASE WHEN descuento > 0 THEN 1 ELSE 0 END AS descuento_bin
FROM
detalle_pdos
")
```
```{r}
datatable(new_var_detalle_pdos,
options = list(
pageLength = 5,
autoWidth = TRUE,
dom = 'Bfrtip',
buttons = I('colvis'),
stripe = TRUE,
hover = TRUE,
condensed = TRUE,
initComplete = JS(
"function(settings, json) {",
" $(this.api().table().header()).css({",
" 'background-color': 'grey',",
" 'color': 'white'",
" });",
" $(this.api().table().header()).find('th').css('font-weight', 'bold');",
"}"
)
)
)
```
```{r}
totales_x_cliente <- sqldf("
SELECT
nombrecliente,
SUM (total_pdo) AS total_x_cliente
FROM
detalle_pdos
GROUP BY
nombrecliente
")
totales_x_cliente
```
Una vez tengamos todas las variables que queremos estudiar, las guardamos en formato .csv para poder trabajarlas dentro de un informe de PowerBi
```{r echo=FALSE}
## write.csv(pedidos, "C:/Users/doura/Desktop/script R/TRABAJOS/Quarto_document/pedidos.csv", row.names = FALSE)
## write.csv(new_var_pedidos, "C:/Users/doura/Desktop/script R/TRABAJOS/Quarto_document/new_var_pedidos.csv", row.names = FALSE)
## write.csv(detalle_pdos, "C:/Users/doura/Desktop/script R/TRABAJOS/Quarto_document/detalle_pdos.csv", row.names = FALSE)
## write.csv(new_var_detalle_pdos, "C:/Users/doura/Desktop/script R/TRABAJOS/Quarto_document/new_var_detalle_pdos.csv", row.names = FALSE)
```
## Análisis avanzado: insights relevantes con PowerBI
### Usando la matriz de correlación (tabla detalle_pdos)
Buscamos la fuerza de las correlaciones entre las variables numericas de la tabla 'detalle_pdos', para ello seleccionaremos las variables 'log_cantidad', 'beneficio' y 'aplica_descuento'; usamos una matriz de correlacion en PowerBI, la cual puede ser filtrada por empleados, clientes, clientes y además por el gráfico de clientes, obteniendo **valiosísimos insights de negocio:**
<iframe title="analisis_integral_BD_SQL_detalle_pdos" width="100%" height="373.5" src="https://app.powerbi.com/view?r=eyJrIjoiZDA2OTVlZDUtM2M3NC00Zjc2LWIxMjItOWM1MDhkNzg1NmQ3IiwidCI6ImRmODY3OWNkLWE4MGUtNDVkOC05OWFjLWM4M2VkN2ZmOTVhMCJ9" frameborder="0" allowFullScreen="true">
</iframe>
La matriz de correlación intenta explicar como de fuertes son las relaciones entre las variables; los resultados oscilan entre 1 (correlación positiva fuerte) y -1 (correlación negativa fuerte), siendo 0 cuando **NO** hay correlación.
A continuación, se muestra un análisis de ventas y fletes creados con PowerBI que ofrece información detallada aplicando técnicas de inteligencia de tiempo.
<iframe title="analisis_integral_BD_SQL_pedidos" width="100%" height="373.5" src="https://app.powerbi.com/view?r=eyJrIjoiYzk2NmE5MjktYjY5MS00ZTE1LWIyNTEtM2FhMjQzZWYyNzkwIiwidCI6ImRmODY3OWNkLWE4MGUtNDVkOC05OWFjLWM4M2VkN2ZmOTVhMCJ9" frameborder="0" allowFullScreen="true">
</iframe>
## Análisis avanzado: insights relevantes (segmentación de clientes K-means)
Para clusterizar a los clientes, primero debemos de hallar su frecuencia de compra
```{r}
frecuencia <- sqldf("
WITH tabla1 AS
(
SELECT
*,
COUNT(*) OVER (PARTITION BY nombrecliente) AS frec_compra
FROM
pedidos
)
SELECT
T1.nombrecliente,
T1.frec_compra,
T2.total_x_cliente
FROM
tabla1 T1
INNER JOIN totales_x_cliente T2
ON T1.nombrecliente = T2.nombrecliente
GROUP BY
T1.nombrecliente,
T1.frec_compra,
T2.total_x_cliente
")
head(frecuencia)
```
Realizamos las transformaciones oportunas para hallar el número óptimo de cluster para este estudio
```{r}
datos_frec_compra <- data.frame(frec_compra = frecuencia$frec_compra)
datos_frec_compra_scaled <- scale(datos_frec_compra)
k_values <- 1:10
wcss <- numeric(length(k_values))
for (k in k_values) {
kmeans_result <- kmeans(datos_frec_compra_scaled, centers = k, nstart = 25)
wcss[k] <- kmeans_result$tot.withinss
}
wcss_df <- data.frame(K = k_values, WCSS = wcss)
ggplot(wcss_df, aes(x = K, y = WCSS)) +
geom_line() +
geom_point() +
labs(title = "Prueba del Codo", x = "Número de Clusters (K)", y = "WCSS")
```
**RESULTADO:** número óptimo de cluster = 3
Ahora que ya sabemos los clusteres óptimos hallaremos el centroide de cada cluster y graficaremos todo para visualizar el resultado obtenido
```{r}
set.seed(123)
kmeans_result <- kmeans(frecuencia[, c("frec_compra", "total_x_cliente")], centers = 3)
frecuencia <- frecuencia %>%
mutate(cluster = as.factor(kmeans_result$cluster))
centroides <- frecuencia %>%
group_by(cluster) %>%
summarise(
frec_compra_centroide = mean(frec_compra),
total_centroide = mean(total_x_cliente)
)
ggplot(frecuencia) +
aes(x = frec_compra, y = total_x_cliente, color = as.factor(cluster)) +
geom_mark_hull(aes(fill = as.factor(cluster)), concavity = 5, expand = 0.03) +
geom_point(size = 1.5) +
geom_point(data = centroides, aes(x = frec_compra_centroide, y = total_centroide),
color = "blue", shape = 18, size = 4) +
theme_minimal() +
labs(color = "Cluster", fill = "Cluster")
```
En el gráfico podemos ver como se agrupa por medio de la clusterización el comportamiento de compra de cada cliente, según la frecuencia de compra con respecto al total de ventas de cada cliente.
# ANALISIS INFERENCIAL
Ahora vamos a realizar pruebas de hipótesis para ver la significancia de las variables
Añadimos una condición aplica_dcto usando la variable descuento
```{r}
descuento <- sqldf("
WITH tabla1 AS
(
SELECT
*,
CASE WHEN descuento_bin = 1 THEN 'si' ELSE 'no'END AS aplica_dcto
FROM
new_var_detalle_pdos
)
SELECT
aplica_dcto,
cantidad,
cantidad_sqrt,
subtotal_pdo
FROM
tabla1
")
head(descuento)
```
## Pruebas de hipótesis
### Conocer como afecta la relacion entre aplica_dcto con importes de ventas
Vamos a plantear una hipótesis sobre esta consulta en la que:
H0 (hipótesis nula) -\> Aplicar un descuento NO afecta significativamente el importe total de las ventas.
H1 (hipótesis alternativa)-\> Aplicar un descuento SI afecta significativamente el importe total de las ventas.
Para ello, primero filtramos la variable discreta en sus dos niveles (si o no)
```{r}
sin_dcto_s_vtas <- descuento %>% filter(aplica_dcto == "no") %>% pull (subtotal_pdo)
con_dcto_s_vtas <- descuento %>% filter(aplica_dcto == "si") %>% pull (subtotal_pdo)
```
Vemos si los datos siguen una distribución normal, para ello sabemos que tenemos muchas observaciones en nuestros datos, por lo que las valoramos
```{r}
observaciones <- length(descuento$aplica_dcto)
```
```{r observaciones, echo=FALSE, results='asis'}
cat("**Resultado observaciones:** ", observaciones, "\n")
```
Al tener \> 30 datos, tenemos una muestra lo suficientemente grande para poder asumir normalidad.
También hay que comprobar la homocedasticidad o igualdad de varianzas, para ello se realiza el test de Levene
```{r message=FALSE, warning=FALSE, echo=FALSE}
library(car)
levene_mediana <- leveneTest(subtotal_pdo~aplica_dcto, data = descuento, center = "median")
levene_media <- leveneTest(subtotal_pdo~aplica_dcto, data = descuento, center = "mean")
print(levene_mediana)
print(levene_media)
```
El resultado del test arroja un p-valor mayor a 0.05, tanto aplicando tanto la mediana como la media, por lo que podriamos usar el T-test ya que encontramos **homocedasticidad y asumimos normalidad.**
Ahora visualizamos los datos, tanto gráficamente como con un resumen
```{r}
ggplot(descuento, aes(x = aplica_dcto, y = subtotal_pdo, fill = aplica_dcto)) +
geom_boxplot() +
labs(title = "Distribución de Subtotal_pdo por Grupo de Descuento",
x = "Aplicación de Descuento",
y = "Subtotal_pdo") +
theme_minimal() +
coord_flip()
```
Debido a la presencia de atipicos vamos a normalizar los datos de la variable subtotal_pdo
```{r}
descuento$subtotal_pdo_log <- log(descuento$subtotal_pdo)
skim(descuento)
```
Comparación de la variable original con la variable transformada
```{r fig.height=6, fig.width=12, echo=FALSE}
descuento %>%
plot_normality(subtotal_pdo)
descuento %>%
plot_normality(subtotal_pdo_log)
```
Segregamos las estadísticas descriptivas de cada grupo aplica_dcto
```{r}
resumen_descuento_log <- descuento %>%
group_by(aplica_dcto) %>%
skim(subtotal_pdo_log)
resumen_descuento_log
```
Tanto la media como la mediana de los datos logarítmicos son muy parecidas entre los dos grupos de descuentos, pero esta diferencia es suficientemente significativa como para decir que son parecidas? para ello, aplicamos el t-test
Separamos las muestras
```{r}
sin_dcto_s_vtas_log <- descuento %>% filter(aplica_dcto == "no") %>% pull (subtotal_pdo_log)
con_dcto_s_vtas_log <- descuento %>% filter(aplica_dcto == "si") %>% pull (subtotal_pdo_log)
```
Realizamos el t-test comparando la superioridad de una muestra sobre la otra (análisis bilateral)
```{r, collapse=FALSE}
t.test(con_dcto_s_vtas_log, sin_dcto_s_vtas_log, alternative = "greater")
```
El resultado arroja un p-valor muy cercano a 0.05, por lo que, tras revisar los datos posteriormente, hay evidencias estadísticas suficientes para rechazar la hipótesis nula, es por lo que se concluye que **en promedio, los valores con descuento SI son mayores que los valores sin descuento**, lo podemos ver en el siguiente gráfico, en el cual transformamos la media de la variable logarítmica a una escala original para apreciar con más detalle las diferencias entre medias de los grupos
```{r fig.width=10, fig.height=8, message=FALSE, warning=FALSE}
medias <- descuento %>%
group_by(aplica_dcto) %>%
summarise(media_log = mean(subtotal_pdo_log),
media_original = exp(mean(subtotal_pdo_log)),
.groups = 'drop')
ggplot(descuento, aes(x = subtotal_pdo_log, fill = aplica_dcto)) +
geom_boxplot(aes(y = reorder(aplica_dcto, subtotal_pdo_log))) +
geom_density(aes(color = aplica_dcto), alpha = 0.3, size = 1) +
geom_vline(data = medias, aes(xintercept = media_log, color = aplica_dcto), linetype = "dashed", size = 1) +
geom_text(data = medias, aes(x = media_log, y = Inf,
label = sprintf("Media log_transformada = %.2f", media_original),
color = aplica_dcto),
vjust = 1.5, hjust = -0.1, size = 7) +
facet_wrap(~ aplica_dcto) +
scale_fill_hue(direction = 1) +
scale_color_hue(direction = 1) +
theme_minimal() +
theme(legend.position = "none",
plot.title = element_text(hjust = 0.5),
strip.text = element_text(size = 5)) +
labs(title = "Distribución de subtotal_pdo_log por aplica_dcto",
x = "subtotal_pdo (Log)",
y = "Densidad")
```
Media transformada con descuento: 346.94
Media transformada sin descuento: 319.01
Diferencia de medias: 27,93 (a favor de cantidades aplicando descuento)
**CONCLUSION FINAL -\> SI APLICAMOS DESCUENTOS VENDEMOS DE MEDIA 27,93 € MAS QUE SI NO APLICAMOS DESCUENTOS.**
### Conocer como afecta la relacion entre aplica_dcto con cantidades vendidas
Vamos a plantear una hipótesis sobre esta consulta en la que:
H0 -\> Aplicar un descuento NO afecta significativamente las cantidades vendidas.
H1 -\> Aplicar un descuento SI afecta significativamente las cantidades vendidas.
```{r echo=FALSE}
sin_dcto_cantidad_sqrt <- descuento %>% filter(aplica_dcto == "no") %>% pull (cantidad_sqrt)
con_dcto_cantidad_sqrt <- descuento %>% filter(aplica_dcto == "si") %>% pull (cantidad_sqrt)
```
Vemos si los datos siguen una distribución normal, para ello lo visualizamos gráficamente
```{r fig.width=10, fig.height=8, echo=FALSE}
media_por_grupo <- descuento %>%
group_by(aplica_dcto) %>%
summarize(media_cantidad_sqrt = mean(cantidad_sqrt), .groups = "drop")
ggplot(descuento, aes(aplica_dcto, cantidad_sqrt, fill = aplica_dcto, color= aplica_dcto)) +
stat_halfeye(alpha = 0.5, justification = -0.2, adjust = 0.3) +
geom_boxplot(width = 0.12, alpha = 0.3, outlier.color = "darkred", outlier.size = 2) +
geom_hline(data = media_por_grupo, aes(yintercept = media_cantidad_sqrt, color = aplica_dcto), linetype = "dashed", size = 0.8) +
coord_flip() +
theme_bw() +
theme(legend.position = "none")
```
Tenemos 2155 observaciones, por lo que asumimos normalidad en los datos
Vemos la homocedasticidad de los datos
```{r, collapse=FALSE, message=FALSE, warning=FALSE}
leveneTest(cantidad_sqrt~aplica_dcto, data = descuento, center = "mean")
```
El resultado arroja que los datos **presentan heterocedasticidad.**
Al tener normalidad pero no homocedasticidad, recurrimos al test de Welch
```{r collapse=FALSE}
t.test(cantidad_sqrt ~ aplica_dcto, data = descuento)
```
El resultado arroja un p-valor inferior a 0.05, por lo que se rechaza la hipótesis nula y se concluye que estadisticamente **aplicar un descuento SI afecta significativamente las cantidades vendidas**
Ahora veremos la significancia graficamente, pero calcularemos la media de la variable cantidad_sqrt debido a la alta presencia de atípicos en la variable original y luego haremos la transformación de vuelta a la escala original
```{r}
# Separamos los datos por grupo
sin_dcto <- descuento %>% filter(aplica_dcto == "no")
con_dcto <- descuento %>% filter(aplica_dcto == "si")
# Calculamos la media logarítmica para cada grupo
media_sqrt_sin_dcto <- mean(sin_dcto$cantidad_sqrt)
media_sqrt_con_dcto <- mean(con_dcto$cantidad_sqrt)
# Transformamos las medias logarítmicas a la escala original
media_sqrt_a_orig_sin_dcto <- exp(media_sqrt_sin_dcto)
media_sqrt_a_orig_con_dcto <- exp(media_sqrt_con_dcto)
```
```{r echo=FALSE, results='asis'}
cat("**Media sqrt sin descuento:**", media_sqrt_sin_dcto, "\n")
```
```{r echo=FALSE, results='asis'}
cat("**Media transformada sin descuento:**", media_sqrt_a_orig_sin_dcto, "\n")
```
```{r echo=FALSE, results='asis'}
cat("**Media sqrt con descuento:**", media_sqrt_con_dcto, "\n")
```
```{r echo=FALSE, results='asis'}
cat("**Media transformada con descuento:**", media_sqrt_a_orig_con_dcto, "\n")
```
Comparamos los resultados obtenidos con las medias originales y podemos ver como han variado
```{r echo=FALSE}
resumen_descuento_cant_original <- descuento %>%
group_by(aplica_dcto) %>%
skim(cantidad)
resumen_descuento_cant_original
```
CONCLUSIONES:
Debido a la presencia de valores atípicos, tomamos la media sqrt convirtiendola a la escala original como **valor correcto.**
Entonces podemos concluir que, sabiendo que estadisticamente **hay diferencias significativas** si aplicamos un descuento con respecto a las cantidades vendidas segun el t-test y valorando la media sqrt como se ha expuesto:
Media transformada con descuento: 128.0032
Media transformada sin descuento: 75.41746
Diferencia de medias: 52,59 (a favor de cantidades aplicando descuento)
**CONCLUSION FINAL -\> SI APLICAMOS DESCUENTOS VENDEMOS DE MEDIA 52,59 UNIDADES MAS QUE SI NO APLICAMOS DESCUENTOS.**
# ANALISIS PREDICTIVO
## Modelo de regresión lineal simple
Visualizamos las variables por si tenemos que realizar alguna transformación. Además vemos, si optaramos por ello, el resultado de la transformación
```{r fig.width=10, fig.height=8, warning=FALSE, message=FALSE}
frecuencia %>%
plot_normality()
```
Después de este análisis, optamos por añadir al dataset las 2 transformaciones de cada variable para ver su impacto entre las correlaciones y visualizamos el resultado obtenido tras la transformación de cada variable
```{r fig.width=10, fig.height=8, warning=FALSE, message=FALSE}
frecuencia$total_x_cliente_log <- log(frecuencia$total_x_cliente)
frecuencia$total_x_cliente_sqrt <- sqrt(frecuencia$total_x_cliente)
frecuencia$frec_compra_log <- log(frecuencia$frec_compra)
frecuencia$frec_compra_sqrt <- sqrt(frecuencia$frec_compra)
frecuencia %>%
plot_normality(total_x_cliente_log, total_x_cliente_sqrt, frec_compra_log, frec_compra_sqrt)
resultados_normalidad <- normality(frecuencia)
resultados_normalidad$p_value <- round(resultados_normalidad$p_value, 4)
resultados_normalidad %>% flextable()
```
La variables que presentan normalidad según el test de Shapiro-Wilk son las variables logaritmicas de total_x_cliente y frec_compra.
Graficamos la correlación entre todas las variables para visualizar los mejores resultados
```{r warning=FALSE, message=FALSE}
# Creamos la matriz de correlación
cor_matrix <- cor(frecuencia[, sapply(frecuencia, is.numeric)], use = "complete.obs")
# Graficamos la matriz de correlación
corrplot(cor_matrix,
method = "circle",
type = "upper",
addCoef.col = "white",
tl.col = "black",
tl.cex = 0.7,
number.cex = 1.5,
cl.lim = c(-1, 1))
```
Despúes del análisis visual de las correlaciones, se van a realizar varios modelos de regresión lineal para ver cual es el que ofrece **homocedasticidad,** siendo siempre la variable de respuesta el total de ventas. Para ello, se escogerán las variables independientes que tengan la correlación más alta con respecto a la variable dependiente.
MODELO 1
```{r collapse=FALSE}
# Modelo 1
rl_1 <- lm(sqrt(total_x_cliente) ~ frec_compra, data = frecuencia)
summary(rl_1)
bptest(rl_1)
```
MODELO 2
```{r collapse=FALSE}
# Modelo 2
rl_2 <- lm(log10(total_x_cliente) ~ log10(frec_compra), data = frecuencia)
summary(rl_2)
bptest(rl_2)
```
MODELO 3
```{r collapse=FALSE}
# Modelo 3
rl_3 <- lm(sqrt(total_x_cliente) ~ sqrt(frec_compra), data = frecuencia)
summary(rl_3)
bptest(rl_3)
```
MODELO 4
```{r collapse=FALSE}
# Modelo 4
rl_4 <- lm(total_x_cliente ~ frec_compra, data = frecuencia)
summary(rl_4)
coef_rl_4 <- coef(rl_4)
bptest(rl_4)
```
MODELO 5
```{r collapse=FALSE}
# Modelo 5
rl_5 <- lm(log10(total_x_cliente) ~ sqrt(frec_compra), data = frecuencia)
summary(rl_5)
bptest(rl_5)
```
MODELO 6
```{r collapse=FALSE}
# Modelo 6
rl_6 <- lm(log10(total_x_cliente) ~ frec_compra, data = frecuencia)
summary(rl_6)
bptest(rl_6)
```
El modelo 6 es el único modelo donde encontramos **homocedasticidad**; la normalidad de los datos se asume ya que tenemos >30 observaciones.
Graficamos el modelo 6
```{r}
# Coeficientes del modelo
coef_rl_6 <- coef(rl_6)
# Calculamos el valor de R^2
r_squared <- summary(rl_6)$r.squared
# Obtenemos los coeficientes del modelo (intercepto y pendiente)
intercept <- coef(rl_6)[1]
slope <- coef(rl_6)[2]
# Creamos la ecuación de la regresión en forma de texto
equation <- paste0("y = ", round(slope, 2), "x", " + ",round(intercept, 2))
r2_text <- paste0("R² = ", round(r_squared, 2))
ggplot(frecuencia) +
aes(x = frec_compra, y = log10(total_x_cliente)) +
geom_point(color = "lightblue") +
geom_abline(intercept = intercept, slope = slope, color = "darkblue") +
theme_minimal() +
annotate("text", x = min(log10(frecuencia$total_x_cliente)), y = max(log10(frecuencia$total_x_cliente)),
label = equation, color = "blue", hjust = 0, vjust = 1, size = 4) +
annotate("text", x = min(log10(frecuencia$total_x_cliente)), y = max(log10(frecuencia$total_x_cliente)) * 0.95,
label = r2_text, color = "blue", hjust = 0, vjust = 1, size = 4)
```
Vamos a pasar el eje y a escala original, para ello, tenemos que tomar la pendiente del modelo con las variables originales (rl_4) y el intercepto del modelo rl_6
```{r collapse=FALSE}
pendiente <- coef_rl_4[2]
pendiente
intercepto <- coef_rl_6[1]
intercepto
```
Creamos el modelo final de regresión lineal
```{r collapse=FALSE}
# Calculamos los valores ajustados
frecuencia$valores_ajustados <- intercepto + pendiente * frecuencia$frec_compra
# Ajustamos el modelo de regresión con los datos originales y valores ajustados
modelo_ajustado <- lm(total_x_cliente ~ valores_ajustados, data = frecuencia)
# Calculamos el valor de R² del modelo ajustado
r_squared_ajustado <- summary(modelo_ajustado)$r.squared
```
Por último, graficamos la regresión lineal
```{r}
# Creamos la ecuación de la regresión en forma de texto
equation <- paste0("y = ", round(pendiente, 2), "x", " + ",round(intercepto, 2))
r2_text <- paste0("R² = ", round(r_squared_ajustado, 2))
ggplot(frecuencia) +
aes(x = frec_compra, y = total_x_cliente) +
geom_point(color = "lightblue") +
geom_abline(intercept = intercepto, slope = pendiente, color = "darkblue") +
theme_minimal() +
annotate("text", x = min(frecuencia$frec_compra), y = max(frecuencia$total_x_cliente),
label = equation, color = "blue", hjust = 0, vjust = 1, size = 4) +
annotate("text", x = min(frecuencia$frec_compra), y = max(frecuencia$total_x_cliente) * 0.95,
label = r2_text, color = "blue", hjust = 0, vjust = 1, size = 4)
```
## Modelo de regresión logística
### Regresión logística (una variable independiente)
Para esta primera regresión logística usaremos como variable dependiente el total_x_cliente_log y como variable independiente la frec_compra_log
```{r}
# Calculamos la media de 'total_x_cliente_log'
media_total_x_cliente_log <- mean(frecuencia$total_x_cliente_log)
# Graficamos el resultado de la transformacion
ggplot(frecuencia, aes(x = total_x_cliente_log)) +
geom_boxplot(fill = "lightblue", color = "darkblue", outlier.color = "darkred", outlier.size = 2) +
geom_vline(xintercept = media_total_x_cliente_log, color = "red", linetype = "dashed", size = 1) +
labs(title = "Boxplot de Total por cliente (log)",
x = "Total por cliente (log)") +
theme_bw() +
theme(axis.title.y = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank())
```
```{r}
# Calculamos el umbral en la variable transformada
umbral_var_log <- media_total_x_cliente_log
# Aplicamos la transformación inversa para obtener el umbral en la escala original
# Transformación inversa de logarítmica es exp(x) - 1
umbral_var_original <- exp(umbral_var_log) - 1
```
```{r echo=FALSE, results='asis'}
cat("Umbral en la variable transformada:", umbral_var_log, "\n")
```
```{r echo=FALSE, results='asis'}
cat("Umbral en la variable original:", umbral_var_original, "\n")
```
Se establece las ventas de la siguiente forma; total_x_cliente > 21000 -> venta alta (el evento sucede-> 1, sino 0); la nueva variable la llamaremos vtas_bin y es la que usaremos finalmente como variable de respuesta en la regresión
```{r}
frecuencia <- sqldf("
SELECT
*,
CASE WHEN total_x_cliente > 21000 THEN 1 ELSE 0 END AS vtas_bin FROM
frecuencia
")
head(frecuencia)
```
RESUMEN
Variable independiente -> frec_compra_log
Variable dependiente -> vtas_bin
```{r}
# Ajustamos el modelo
mod_reg <- glm(formula = vtas_bin ~ frec_compra_log, family = binomial, data = frecuencia)
```
```{r collapse=FALSE}
# Medimos de la bondad de ajuste del modelo
PseudoR2(mod_reg, which = NULL)
```
El valor de ajuste del modelo de regresion logística es alto
```{r}
# Realizamos las predicciones
pred <- predict(mod_reg, type = "response")
# Para determinar el umbral de decisión, calculamos la curva ROC y el valor AUC
roc_curve <- roc(frecuencia$vtas_bin, pred)
plot(roc_curve)
```
```{r collapse=FALSE}
auc(roc_curve)
```
```{r}
# Clasificamos las predicciones
clas <- ifelse(pred > 0.5, "1", "0")
# Creamos la matriz de confusión
confusion_matrix <- table(pred = clas, actual = frecuencia$vtas_bin)
```
```{r collapse=FALSE}
confusion_matrix
```
```{r}
# Extraemos los valores de la matriz de confusión
TP <- confusion_matrix["1", "1"]
FP <- confusion_matrix["1", "0"]
TN <- confusion_matrix["0", "0"]
FN <- confusion_matrix["0", "1"]
# Calculamos la precisión del modelo a la hora de clasificar
precision <- TP / (TP + FP)
```
```{r collapse=FALSE}
print(paste("Precisión del modelo:", round(precision, 4)))
```
Ahora visualizamos, según el punto de corte indicado, a partir de cuando se clasifican las frecuencias de compra según sea una venta alta o no, pero antes pasamos a escala original la variable independiente
```{r}
frecuencia$frec_compra_original <- exp(frecuencia$frec_compra_log)
# Calculamos las predicciones del modelo
frecuencia$pred <- predict(mod_reg, type = "response")
# Clasificamos las predicciones en función del umbral que estimamos
frecuencia$clas <- ifelse(frecuencia$pred > 0.5, "1", "0")
```
```{r}
# Graficamos la clasificación
ggplot(frecuencia, aes(x = frec_compra_original, y = as.numeric(clas))) +
geom_point(aes(color = as.numeric(frec_compra_original)), alpha = 1) +
scale_color_gradient(low = "orange", high = "blue") +
stat_smooth(method = "glm", method.args = list(family = "binomial"), se = FALSE, color = "red") +
scale_y_continuous(limits = c(0, 1), breaks = c(0, 1)) +
labs(x = "frec_compra_original", y = "Det. tipo vta (alta > 21000)",
color = "frec_compra_original") +
theme_minimal()
```
La clasificación indica que, en el punto de corte o umbral de decisión de 0.5, el modelo estima que a partir de que el cliente compra 8 veces es el corte, es decir, que **a partir de que un cliente compre 8 veces o más, éstas compras tienen una probabilidad significativamente alta de ser clasificados como altas ventas**
Evolución de la frecuencia de compra, según las ventas predichas
```{r}
pred <- format(pred, scientific = FALSE)
pred <- as.numeric(pred)
ggplot(frecuencia, aes(x = frec_compra_original, y = as.numeric(pred))) +
geom_point(aes(color = as.numeric(frec_compra_original)), alpha = 1) +
scale_color_gradient(low = "orange", high = "blue") +
scale_y_continuous(limits = c(0, 1), breaks = c(0, 1)) +
labs(x = "frec_compra_original", y = "Probabilidad de ser ventas altas (pred)",
color = "frec_compra_original") +
theme_minimal()
```
**El modelo predice la probabilidad de que según sea la frecuencia de compra del cliente, estas sean catalogadas como alta venta o no; si el color es naranja la probabilidad es mucho más baja de que se catalogue tanto como 0 (baja venta) como 1 (alta venta)**
```{r}
frecuencia <- sqldf("
SELECT
*,
CASE WHEN vtas_bin = 1 THEN 'si' ELSE 'no' END AS es_venta_alta
FROM
frecuencia
")
head(frecuencia)
```
Visualizamos la frecuencia de compra original agrupada por si es considerada venta alta o no
```{r}
media_por_grupo <- frecuencia %>%
group_by(es_venta_alta) %>%
summarize(media_frec_compra = mean(frec_compra_original), .groups = "drop")
ggplot(frecuencia, aes(es_venta_alta, frec_compra_original, fill = es_venta_alta, color= es_venta_alta)) +
stat_halfeye(alpha = 0.5, justification = -0.2, adjust = 0.3) +
geom_boxplot(width = 0.12, alpha = 0.3, outlier.color = "darkred", outlier.size = 2) +
geom_hline(data = media_por_grupo, aes(yintercept = media_frec_compra, color = es_venta_alta), linetype = "dashed", size = 0.8) +
coord_flip() +
theme_bw() +
theme(legend.position = "none")
```
### Regresión logística (varias variables independientes)
```{r}
# Cargamos los datos, selección y nuevas variables
pedidos <- dbGetQuery(con, "SELECT * FROM Ventas.Ordenes")
detalle_pdos <- dbGetQuery(con, "SELECT * FROM Ventas.DetalleOrden")
productos <- dbGetQuery(con, "SELECT * FROM Produccion.Productos")
categorias <- dbGetQuery(con, "SELECT * FROM Produccion.Categorias")
reg_logis_dcto <- sqldf("
WITH tabla1 AS
(
SELECT
T1.id_orden,
T4.nombrecategoria,
T2.id_producto,
T2.preciounitario,
T2.cantidad,
T2.descuento,
CASE WHEN T2.descuento > 0 THEN 1 ELSE 0 END AS dcto_bin
FROM
pedidos T1
INNER JOIN detalle_pdos T2
ON T1.id_orden = T2.id_orden
INNER JOIN productos T3
ON T2.id_producto = T3.id_producto
INNER JOIN categorias T4
ON T3.id_categoria = T4.id_categoria
), tabla2 AS
(
SELECT
*,
preciounitario * cantidad * (1-descuento) AS total_con_dcto, -- PREDICTIVA
preciounitario * cantidad AS total_sin_dcto, -- PREDICTIVA,
preciounitario * cantidad - preciounitario * cantidad * (1-descuento) AS dcto_aplicado
FROM
tabla1
)
SELECT
dcto_bin,
preciounitario,
cantidad,
total_con_dcto,
total_sin_dcto,
dcto_aplicado,
CASE WHEN nombrecategoria = 'Bebidas' THEN 1 ELSE 0 END AS es_bebidas,
CASE WHEN nombrecategoria = 'Condimentos' THEN 1 ELSE 0 END AS es_Condimentos,
CASE WHEN nombrecategoria = 'Dulces' THEN 1 ELSE 0 END AS es_Dulces,
CASE WHEN nombrecategoria = 'clientes Lácteos' THEN 1 ELSE 0 END AS es_Lacteos,
CASE WHEN nombrecategoria = 'Cereales/Granos' THEN 1 ELSE 0 END AS es_Cereales_Granos,
CASE WHEN nombrecategoria = 'Carne/Aves' THEN 1 ELSE 0 END AS es_Carne_Aves,
CASE WHEN nombrecategoria = 'clientes Frescos' THEN 1 ELSE 0 END AS es_Frescos,
CASE WHEN nombrecategoria = 'Mariscos' THEN 1 ELSE 0 END AS es_Mariscos,
CASE WHEN dcto_bin = 0 THEN 'no' ELSE 'si' END AS hay_dcto
FROM
tabla2
")
head(reg_logis_dcto)
```
Graficamos la distribución de la variable cantidad agrupada por si hay o no descuento
```{r}
media_por_grupo <- reg_logis_dcto %>%
group_by(hay_dcto) %>%
summarize(media_cantidad = mean(cantidad), .groups = "drop")
ggplot(reg_logis_dcto, aes(hay_dcto, cantidad, fill = hay_dcto, color= hay_dcto)) +
stat_halfeye(alpha = 0.5, justification = -0.2, adjust = 0.3) +
geom_boxplot(width = 0.12, alpha = 0.3, outlier.color = "darkred", outlier.size = 2) +
geom_hline(data = media_por_grupo, aes(yintercept = media_cantidad, color = hay_dcto), linetype = "dashed", size = 0.8) +
coord_flip() +
theme_bw() +
theme(legend.position = "none")
```
También graficamos la distribución de la variable total_con_dcto
```{r}
media_total_con_dcto <- mean(reg_logis_dcto$total_con_dcto)
ggplot(reg_logis_dcto, aes(x = total_con_dcto)) +
geom_boxplot(fill = "lightblue", color = "darkblue", outlier.color = "darkred", outlier.size = 2) +
geom_vline(xintercept = media_total_con_dcto, color = "red", linetype = "dashed", size = 1) +
labs(title = "Boxplot de Total con Descuento",
x = "Total con Descuento") +
theme_bw() +
theme(axis.title.y = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank())
```
Se observan muchos outliers para establecer un umbral medio de esta variable dependiente, optamos por la transformación
```{r}
reg_logis_dcto$total_con_dcto_log <- log(reg_logis_dcto$total_con_dcto + 1)
reg_logis_dcto %>%
plot_normality(total_con_dcto_log)
```
```{r}
# Calculamos la media de 'total_con_dcto_log'
media_total_con_dcto_log <- mean(reg_logis_dcto$total_con_dcto_log)
# Creamos el boxplot horizontal
ggplot(reg_logis_dcto, aes(x = total_con_dcto_log)) +
geom_boxplot(fill = "lightblue", color = "darkblue", outlier.color = "darkred", outlier.size = 2) +
geom_vline(xintercept = media_total_con_dcto_log, color = "red", linetype = "dashed", size = 1) +
labs(title = "Boxplot de Total con Descuento_log",
x = "Total con Descuento_log") +
theme_bw() +
theme(axis.title.y = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank())
```
```{r}
# Calculamos el umbral en la variable transformada
umbral_var_log <- media_total_con_dcto_log
# Aplicamos la transformación inversa para obtener el umbral en la escala original
# Transformación inversa de logarítmica es exp(x) - 1
umbral_var_original <- exp(umbral_var_log) - 1
```
```{r echo=FALSE, results='asis'}
cat("**Umbral en la variable transformada:**", umbral_var_log, "\n")
```
```{r echo=FALSE, results='asis'}
cat("**Umbral en la variable original:**", umbral_var_original, "\n")
```
Se establece las ventas de la siguiente forma
total_con_dcto > 350 -> venta alta (el evento sucede-> 1, sino 0)
```{r}
reg_logis_dcto <- sqldf("
SELECT
*,
CASE WHEN total_con_dcto > 350 THEN 1 ELSE 0 END AS vtas_bin
FROM reg_logis_dcto
")
head(reg_logis_dcto)
```
```{r message=FALSE, warning=FALSE}
# Ajustamos un modelo completo con todas las variables
modelo_completo <- glm(vtas_bin ~ dcto_bin + preciounitario + cantidad + dcto_aplicado + es_bebidas + es_Condimentos + es_Dulces + es_Lacteos + es_Cereales_Granos + es_Carne_Aves + es_Frescos + es_Mariscos,
data = reg_logis_dcto, family = binomial)
# Aplicamos la selección stepwise
modelo_stepwise <- stepAIC(modelo_completo, direction = "both")
```
```{r collapse=FALSE, warning=FALSE}
# Vemos el resumen del modelo seleccionado
summary(modelo_stepwise)
```
```{r warning=FALSE}
# Ajustamos el modelo seleccionado por la validación stepwise
mod_reg_validado <- glm(formula = vtas_bin ~ dcto_bin + preciounitario + cantidad +
dcto_aplicado + es_bebidas + es_Condimentos + es_Cereales_Granos +
es_Mariscos, family = binomial, data = reg_logis_dcto)
```
```{r collapse=FALSE}
# Medimos la bondad de ajuste del modelo
PseudoR2(mod_reg_validado, which = NULL)
```
El valor de ajuste del modelo de regresion logística es alto
```{r}
# Realizamos las predicciones
pred <- predict(mod_reg_validado, type = "response")
# Determinamos el umbral de decisión para clasificar, para ello calculamos la curva ROC Y el AUC
roc_curve <- roc(reg_logis_dcto$vtas_bin, pred)
plot(roc_curve)
```
Tomamos como umbral el 0.7 para clasificar como 1
```{r collapse=FALSE}
auc(roc_curve)
```
```{r}
# Clasificación de las predicciones
clas <- ifelse(pred > 0.7, "1", "0")
# Matriz de confusión
confusion_matrix <- table(pred = clas, actual = reg_logis_dcto$vtas_bin)
```
```{r collapse=FALSE}
confusion_matrix
```
```{r}
# Extraemos los valores de la matriz de confusión
TP <- confusion_matrix["1", "1"]
FP <- confusion_matrix["1", "0"]
TN <- confusion_matrix["0", "0"]
FN <- confusion_matrix["0", "1"]
# Calculamos la precisión del modelo
precision <- TP / (TP + FP)
```
```{r collapse=FALSE}
print(paste("Precisión del modelo:", round(precision, 4)))
```
Ahora visualizamos, según el punto de corte indicado, a partir de cuando se clasifican las cantidades según sea una venta alta o no
```{r}
ggplot(mod_reg_validado, aes(x = cantidad, y = as.numeric(clas))) +
geom_point(aes(color = as.numeric(cantidad)), alpha = 1) +
scale_color_gradient(low = "orange", high = "blue") +
stat_smooth(method = "glm", method.args = list(family = "binomial"), se = FALSE, color = "red") +
scale_y_continuous(limits = c(0, 1), breaks = c(0, 1)) +
labs(x = "Cantidad", y = "Det. tipo vta (alta > 350)",
color = "Cantidad") +
theme_minimal()
```
La clasificación indica que, en el punto de corte o umbral de decisión de 0.7, el modelo estima que a partir de 32 unidades es el corte, es decir, que **pedidos a partir de 32 unidades tienen una probabilidad significativamente alta de ser clasificados como altas ventas**
Evolución del descuento aplicado, según la cantidad predicha
```{r}
# Convertimos las predicciones a formato numérico con 2 decimales
pred <- format(pred, scientific = FALSE)
pred <- as.numeric(pred)
# Creamos el gráfico con datos corregidos
ggplot(mod_reg_validado, aes(x = cantidad, y = as.numeric(pred))) +
geom_point(aes(color = as.numeric(cantidad)), alpha = 1) +
scale_color_gradient(low = "orange", high = "blue") +
scale_y_continuous(limits = c(0, 1), breaks = c(0, 1)) +
labs(x = "Cantidad", y = "Probabilidad de ser ventas altas (pred)",
color = "Cantidad") +
theme_minimal()
```
**El modelo predice la probabilidad de que diversas cantidades sean catalogadas como alta venta o no; si el color es naranja la probabilidad es mucho más baja de que se catalogue tanto como 0 (baja venta) como 1 (alta venta)**
