Base ficticia

Creación de la base de datos ficticia

set.seed(123)
N <- 55358

1. Variable independiente 1: Número de campañas de sensibilización # Distribución tipo Poisson con media baja, pero con cola

campanias <- rpois(N, lambda = 2)

2. Variable independiente 2: Nivel promedio de conocimiento de padres de familia # Aumenta con el número de campañas

conocimiento <- 40 + 
  5 * campanias +           
  rnorm(N, mean = 0, sd = 8)     

3. Probabilidad de la censura (escala latente) # Más campañas, más conocimiento = menor censura # Menos campañas, menos conocimiento = mayor censura #Modelo latente

z <- -0.8 * campanias - 0.05 * conocimiento + rnorm(N, 0, 1)

4. Convertimos la variable latente z en categorías ordinales # Los puntos de corte producen aprox. 40% bajo, 35% medio, 25% alto

censura <- cut(
  z,
  breaks = c(-Inf, -1, 0.5, Inf),
  labels = c("bajo", "medio", "alto"),
  ordered_result = TRUE
)

5. Data frame final

base_ficticia <- data.frame(
  colegio_id = 1:N,
  campanias = campanias,
  conocimiento = conocimiento,
  censura = censura
)

6. Vista rápida

head(base_ficticia)

##   colegio_id campanias conocimiento censura
## 1          1         1     43.34506    bajo
## 2          2         3     44.47825    bajo
## 3          3         2     55.75532    bajo
## 4          4         4     73.46844    bajo
## 5          5         4     64.84445    bajo
## 6          6         0     49.55040    bajo

summary(base_ficticia)

##    colegio_id      campanias      conocimiento      censura     
##  Min.   :    1   Min.   : 0.00   Min.   :  6.967   bajo :53561  
##  1st Qu.:13840   1st Qu.: 1.00   1st Qu.: 42.633   medio: 1702  
##  Median :27680   Median : 2.00   Median : 49.701   alto :   95  
##  Mean   :27680   Mean   : 1.99   Mean   : 50.018                
##  3rd Qu.:41519   3rd Qu.: 3.00   3rd Qu.: 57.042                
##  Max.   :55358   Max.   :11.00   Max.   :109.801

Correlación

Correlación de Spearman entre censura ordinal politómica y variables independientes numéricas

1. Campañas: Convertir censura de ordinal a numérica

censura_num <- as.numeric(base_ficticia$censura)

1.1. Spearman entre censura y campañas

cor_campanas <- cor.test(
  censura_num,
  base_ficticia$campanias,
  method = "spearman"
)

## Warning in cor.test.default(censura_num, base_ficticia$campanias, method =
## "spearman"): Cannot compute exact p-value with ties

cor_campanas

## 
##  Spearman's rank correlation rho
## 
## data:  censura_num and base_ficticia$campanias
## S = 3.5202e+13, p-value < 2.2e-16
## alternative hypothesis: true rho is not equal to 0
## sample estimates:
##        rho 
## -0.2450255

2. Spearman entre censura y conocimiento

cor_conocimiento <- cor.test(
  censura_num,
  base_ficticia$conocimiento,
  method = "spearman"
)

## Warning in cor.test.default(censura_num, base_ficticia$conocimiento, method =
## "spearman"): Cannot compute exact p-value with ties

cor_conocimiento

## 
##  Spearman's rank correlation rho
## 
## data:  censura_num and base_ficticia$conocimiento
## S = 3.4642e+13, p-value < 2.2e-16
## alternative hypothesis: true rho is not equal to 0
## sample estimates:
##        rho 
## -0.2252109

Regresión logística ordinal

modelo_ordinal <- MASS::polr(
  censura ~ campanias + conocimiento,
  data = base_ficticia,
  Hess = TRUE
)

summary(modelo_ordinal)

## Call:
## MASS::polr(formula = censura ~ campanias + conocimiento, data = base_ficticia, 
##     Hess = TRUE)
## 
## Coefficients:
##                 Value Std. Error t value
## campanias    -1.73453   0.050158  -34.58
## conocimiento -0.09947   0.003507  -28.36
## 
## Intercepts:
##            Value    Std. Error t value 
## bajo|medio  -2.2792   0.1311   -17.3891
## medio|alto   0.9054   0.1609     5.6280
## 
## Residual Deviance: 11210.84 
## AIC: 11218.84

Gráfico de la regresión logística ordinal

library(MASS)
library(ggplot2)
library(dplyr)

## 
## Adjuntando el paquete: 'dplyr'

## The following object is masked from 'package:MASS':
## 
##     select

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(tidyr)

nuevo <- data.frame(
  campanias = seq(min(base_ficticia$campanias),
                  max(base_ficticia$campanias),
                  length.out = 100),
  conocimiento = mean(base_ficticia$conocimiento)   # se mantiene constante
)

pred <- predict(modelo_ordinal, newdata = nuevo, type = "probs")

pred_df <- cbind(nuevo, pred) %>%
  pivot_longer(cols = c("bajo", "medio", "alto"),
               names_to = "categoria",
               values_to = "probabilidad")

ggplot(pred_df, aes(x = campanias, y = probabilidad, color = categoria)) +
  geom_line(size = 2) +  # líneas más gruesas
  scale_color_manual(
    values = c(
      "bajo" = "#1B9E77",   # verde elegante
      "medio" = "#D95F02",  # naranja profesional
      "alto" = "#7570B3"    # morado suave
    )
  ) +
  labs(
    title = "Probabilidades predichas del nivel de censura",
    subtitle = "Modelo de regresión logística ordinal (efecto del número de campañas)",
    x = "Número de campañas de sensibilización",
    y = "Probabilidad predicha",
    color = "Nivel de censura"
  ) +
  theme_minimal(base_size = 18) +
  theme(
    plot.title = element_text(face = "bold", size = 22),
    plot.subtitle = element_text(size = 16),
    legend.position = "top",
    legend.title = element_text(face = "bold"),
    panel.grid.minor = element_blank(),
    panel.grid.major.x = element_blank(),
    panel.grid.major.y = element_line(color = "grey85"),
    axis.title = element_text(face = "bold"),
    plot.margin = margin(15, 20, 15, 20)
  )

## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.