Análisis de Accesibilidad e Ingresos por Rango Etario

1. Funciones auxiliares

En esta sección se definen funciones para: - Calcular quintiles y medianas ponderadas, - Categorización de accesibilidad, - Procesar mapas raster, - Calcular datos para curvas de Lorenz y visualizaciones.

get_quintile_table <- function(df, group_vars = character()) {
  calculate_quintile_stats <- function(data, weights, income) {
    quintile_cuts <- wtd.quantile(income, weights = weights, probs = seq(0.2, 0.8, 0.2))
    q1_median <- weighted.median(income[income <= quintile_cuts[1]], w = weights[income <= quintile_cuts[1]], na.rm = TRUE)
    q2_median <- weighted.median(income[income > quintile_cuts[1] & income <= quintile_cuts[2]], w = weights[income > quintile_cuts[1] & income <= quintile_cuts[2]], na.rm = TRUE)
    q3_median <- weighted.median(income[income > quintile_cuts[2] & income <= quintile_cuts[3]], w = weights[income > quintile_cuts[2] & income <= quintile_cuts[3]], na.rm = TRUE)
    q4_median <- weighted.median(income[income > quintile_cuts[3] & income <= quintile_cuts[4]], w = weights[income > quintile_cuts[3] & income <= quintile_cuts[4]], na.rm = TRUE)
    q5_median <- weighted.median(income[income > quintile_cuts[4]], w = weights[income > quintile_cuts[4]], na.rm = TRUE)
    c(Q1 = q1_median/1291, Q2 = q2_median/1291, Q3 = q3_median/1291, Q4 = q4_median/1291, Q5 = q5_median/1291)
  }
  if(length(group_vars) == 0) {
    results <- calculate_quintile_stats(df, df$PONDII, df$P47T)
    tibble(!!!results, n = sum(df$PONDERA))
  } else {
    df %>%
      group_by(across(all_of(group_vars))) %>%
      group_modify(~{
        results <- calculate_quintile_stats(.x, .x$PONDII, .x$P47T)
        tibble(!!!results, n = sum(.x$PONDERA))
      }) %>%
      ungroup()
  }
}

make_categorical <- function(val, medians, umbral) {
  medians <- as.numeric(medians)
  q1 <- medians[1] * umbral
  q2 <- medians[2] * umbral
  q3 <- medians[3] * umbral
  q4 <- medians[4] * umbral
  q5 <- medians[5] * umbral
  val_transformed <- val * 0.9289 * 35
  m <- matrix(c(-Inf, q1, 1,
                q1, q2, 2,
                q2, q3, 3,
                q3, q4, 4,
                q4, q5, 5,
                q5, Inf, 6), ncol=3, byrow=TRUE)
  result <- classify(val_transformed, m)
  return(result)
}

create_raster_groups <- function(val, tabla, sex, age = "All") {
  medians <- tabla %>% 
    filter(Sex == sex & Age == age) %>% 
    select(Q1, Q2, Q3, Q4, Q5)
  medians <- as.numeric(medians[1, ])
  thresholds <- c(0.3, 0.5, 0.7)
  name_suffix <- c("0-30%", "31-50%", "50-70%")
  result_list <- vector("list", length(thresholds))
  for(i in seq_along(thresholds)) {
    rast <- make_categorical(val, medians, thresholds[i])
    cats <- data.frame(
      ID = 1:6,
      category = c("Q1", "Q2", "Q3", "Q4", "Q5", "No access")
    )
    levels(rast) <- cats
    result_list[[i]] <- rast
  }
  out <- do.call(c, result_list)
  names(out) <- sprintf("%s_%s", sex, name_suffix)
  return(out)
}

create_lorenz_data <- function(gini_df) {
  value_cols <- setdiff(names(gini_df), c("Group", "Sex", "Income_Dedication", "Age"))
  map_df(1:nrow(gini_df), function(i) {
    values <- as.numeric(gini_df[i, value_cols])
    if(sum(values) > 0) {
      l_curve <- Lc(values)
      data.frame(
        Sex = gini_df$Sex[i],
        Income_Dedication = gini_df$Income_Dedication[i],
        Age = gini_df$Age[i],
        Cumulative_Population_Share = l_curve$p,
        Cumulative_Accessibility_Share = l_curve$L
      )
    } else {
      data.frame(
        Sex = gini_df$Sex[i],
        Income_Dedication = gini_df$Income_Dedication[i],
        Age = gini_df$Age[i],
        Cumulative_Population_Share = 0,
        Cumulative_Accessibility_Share = 0
      )
    }
  })
}

create_lorenz_plot <- function(lorenz_data) {
  ggplot(lorenz_data, aes(x = Cumulative_Population_Share, y = Cumulative_Accessibility_Share)) +
    geom_abline(intercept = 0, slope = 1, linetype = "dashed", color = "grey") +
    geom_line(aes(color = Sex), size = 1.2) +
    facet_grid(Age ~ Income_Dedication) +
    labs(x = "Proporción acumulada de población",
         y = "Proporción acumulada de accesibilidad",
         color = "Sexo") +
    scale_x_continuous(limits = c(0, 1), breaks = seq(0, 1, 0.2)) +
    scale_y_continuous(limits = c(0, 1), breaks = seq(0, 1, 0.2)) +
    theme_minimal() +
    theme(
      plot.title = element_text(hjust = 0.5, size = 16, face = "bold"),
      axis.title = element_text(size = 10),
      axis.text = element_text(size = 8),
      legend.position = "bottom",
      strip.text = element_text(size = 11, face = "bold"),
      panel.spacing = unit(1, "lines"),
      aspect.ratio = 1
    )
}

create_maps <- function(all_groups, pal, nombres_leyenda) {
  maps <- map(1:nlyr(all_groups), ~{
    tm_shape(all_groups[[.x]]) +
      tm_raster(palette = pal, legend.show = FALSE, alpha = 0.8) +
      tm_layout(main.title = names(all_groups)[.x], main.title.size = 1.2) +
      tm_legend(show = FALSE)
  })
  names(maps) <- names(all_groups)
  legend <- tm_shape(all_groups[[1]]) +
    tm_raster(palette = pal, title = "Quintiles", labels = nombres_leyenda,
              legend.show = TRUE, legend.is.portrait = FALSE) +
    tm_layout(legend.only = TRUE, legend.position = "bottom")
  list(
    maps = maps,
    legend = legend
  )
}

2. Preparación de datos EPH

Se descargan y filtran los datos individuales de EPH, seleccionando personas de 18 a 35 años en el aglomerado 32, con ingresos positivos. Además, se crea una variable de rango de edad y de sexo.

assign("has_internet_via_proxy", TRUE, environment(curl::has_internet))

eph <- get_microdata(2024, 3, "individual") %>%
  filter(
    CH06 >= 18, CH06 <= 35,
    AGLOMERADO == 32,
    CH12 != 9,
    P47T > 0
  ) %>%
  mutate(
    rango = case_when(
      CH06 < 24 ~ "18 a 23",
      CH06 < 30 ~ "24 a 29",
      TRUE ~ "30 a 35"
    ),
    sexo = if_else(CH04 == 1, "Men", "Women")
  )

Esta parte obtiene la muestra poblacional de interés.

3. Cálculo de quintiles de ingreso por rango etario

Se generan tablas de quintiles por sexo y rango etario, utilizando la función auxiliar creada.

tabla2 <- get_quintile_table(eph, c("sexo", "rango")) %>% 
  rename(Sex = sexo, Age = rango) %>% 
  select(Sex, Age, Q1, Q2, Q3, Q4, Q5, n)

Esto permite analizar la distribución del ingreso según criterios de género y edad.

4. Procesamiento de datos espaciales por rango etario

Se carga un raster de accesibilidad y se generan mapas categorizados por sexo, rango etario y diferentes umbrales de dedicatoria de ingreso.

val <- rast("vut_sin_calles_ni_ev.tif") / 1291.81
ages <- unique(tabla2$Age)
sexos <- unique(tabla2$Sex)

# Creamos una lista para guardar los mapas por grupo
all_group_maps <- list()
for (age in ages) {
  for (sexo in sexos) {
    group_name <- paste(sexo, age, sep="_")
    all_group_maps[[group_name]] <- create_raster_groups(val, tabla2, sex = sexo, age = age)
  }
}
# Arreglo los nombres para los mapas
pal <- c("#d7191c", "#fdae61", "#ffffbf", "#abdda4", "#2b83ba", "#4d4d4d")
nombres_leyenda <- c("Q1", "Q2", "Q3", "Q4", "Q5", "No access")

Esto permite visualizar la accesibilidad diferenciada espacialmente para cada rango de edad y sexo.

5. Cálculo de frecuencias y coeficientes de Gini por rango etario

Se calcula la frecuencia de cada categoría en los mapas, se agrupan y se preparan los datos para el cálculo de coeficientes de Gini y curvas de Lorenz.

gini_list <- list()
for (group in names(all_group_maps)) {
  group_maps <- all_group_maps[[group]]
  for (i in 1:nlyr(group_maps)) {
    freq_i <- freq(group_maps[[i]])
    data_row <- data.frame(
      Group = paste0(group, "_", names(group_maps)[i]),
      value = freq_i$value,
      count = freq_i$count
    )
    gini_list[[length(gini_list) + 1]] <- data_row
  }
}

a <- do.call(rbind, gini_list) %>%
  filter(!is.na(value)) %>%
  mutate(
    value = factor(value, levels = c("Q1", "Q2", "Q3", "Q4", "Q5", "No access"))
  ) %>%
  group_by(Group, value) %>%
  summarise(count = sum(count), .groups = "drop") %>%
  pivot_wider(
    names_from = value,
    values_from = count,
    values_fill = 0
  )

a <- a %>% mutate(across(-Group, ~ . * (100/1000000)))
a$Total <- rowSums(a %>% select(-Group))
# Extraer info de grupo
a <- a %>%
  mutate(
    Sex = ifelse(grepl("^Men", Group), "Men", "Women"),
    Age = case_when(
      grepl("18 a 23", Group) ~ "18 a 23",
      grepl("24 a 29", Group) ~ "24 a 29",
      grepl("30 a 35", Group) ~ "30 a 35"
    ),
    Income_Dedication = case_when(
      grepl("0-30%", Group) ~ "0-30%",
      grepl("31-50%", Group) ~ "31-50%",
      grepl("50-70%", Group) ~ "50-70%"
    )
  )

gini <- a %>%
  select(-Total) %>%
  mutate(across(c(Q1, Q2, Q3, Q4, Q5, `No access`), ~ ./rowSums(across(c(Q1, Q2, Q3, Q4, Q5, `No access`)))))

Aquí se prepara la información para analizar desigualdades en el acceso para cada grupo de edad y sexo.

6. Tabla de quintiles, porcentajes y coeficiente de Gini para cada grupo etario

A continuación se muestra una tabla resumen con los porcentajes de cada quintil, el porcentaje de “No acceso” y el coeficiente de Gini para cada grupo de sexo, edad y dedicación de ingreso.

# Calcular coeficiente de Gini para cada grupo
gini_coefs <- map_dbl(1:nrow(gini), function(i) {
  values <- as.numeric(gini[i, c("Q1", "Q2", "Q3", "Q4", "Q5", "No access")])
  if(sum(values) > 0) {
    ineq(values, type="Gini")
  } else {
    NA_real_
  }
})

gini_table <- gini %>%
  mutate(across(c(Q1, Q2, Q3, Q4, Q5, `No access`), ~scales::percent(., accuracy=0.01))) %>%
  mutate(
    Group = paste(Sex, Age, Income_Dedication, sep=" - "),
    Gini = round(gini_coefs, 3)
  ) %>%
  select(Group, Q1, Q2, Q3, Q4, Q5, `No access`, Gini)

kable(gini_table,
      caption = "Distribución por quintiles y coeficientes de Gini por grupo de edad, sexo y dedicación de ingreso",
      format = "html",
      align = c('l', rep('r', 7))) %>%
  kable_styling(bootstrap_options = c("striped", "hover"))

Distribución por quintiles y coeficientes de Gini por grupo de edad, sexo y dedicación de ingreso

Group	Q1	Q2	Q3	Q4	Q5	No access	Gini
Men - 18 a 23 - 0-30%	0.00%	1.62%	0.13%	5.92%	89.34%	2.99%	0.776
Men - 18 a 23 - 31-50%	0.23%	12.35%	8.71%	40.66%	37.53%	0.52%	0.528
Men - 18 a 23 - 50-70%	1.43%	34.52%	39.25%	22.33%	2.47%	0.00%	0.526
Men - 24 a 29 - 0-30%	0.23%	1.51%	37.70%	54.43%	4.56%	1.58%	0.638
Men - 24 a 29 - 31-50%	1.74%	16.31%	80.37%	1.04%	0.10%	0.44%	0.749
Men - 24 a 29 - 50-70%	10.11%	43.85%	45.51%	0.54%	0.00%	0.00%	0.614
Men - 30 a 35 - 0-30%	1.62%	6.05%	13.62%	18.15%	59.82%	0.74%	0.588
Men - 30 a 35 - 31-50%	12.58%	49.37%	32.52%	3.95%	1.58%	0.00%	0.581
Men - 30 a 35 - 50-70%	35.95%	61.58%	1.55%	0.38%	0.54%	0.00%	0.693
Women - 18 a 23 - 0-30%	0.00%	0.23%	0.62%	1.53%	21.73%	75.88%	0.741
Women - 18 a 23 - 31-50%	0.00%	1.62%	0.62%	33.71%	59.67%	4.37%	0.667
Women - 18 a 23 - 50-70%	0.23%	2.15%	16.86%	74.22%	5.68%	0.87%	0.702
Women - 24 a 29 - 0-30%	0.85%	1.53%	5.28%	50.43%	27.25%	14.65%	0.557
Women - 24 a 29 - 31-50%	2.24%	33.71%	26.00%	36.86%	0.45%	0.74%	0.508
Women - 24 a 29 - 50-70%	19.24%	74.22%	4.08%	1.95%	0.52%	0.00%	0.716
Women - 30 a 35 - 0-30%	1.44%	6.15%	7.60%	33.12%	37.04%	14.65%	0.443
Women - 30 a 35 - 31-50%	5.33%	54.84%	25.18%	13.21%	0.70%	0.74%	0.586
Women - 30 a 35 - 50-70%	24.18%	73.13%	1.32%	0.86%	0.52%	0.00%	0.728

Puede utilizar el filtro de la tabla para comparar desigualdades entre grupos específicos.

7. Visualización: Mapas de accesibilidad por sexo y rango etario

A continuación se muestran los mapas de accesibilidad para cada grupo de sexo y rango etario, para cada umbral de dedicación de ingreso.

maps <- list()
for (group in names(all_group_maps)) {
  maps[[group]] <- create_maps(all_group_maps[[group]], pal, nombres_leyenda)
  cat(sprintf("### Mapas: %s\n", group))
  print(maps[[group]]$maps[[1]])
  print(maps[[group]]$maps[[2]])
  print(maps[[group]]$maps[[3]])
}

Mapas: Men_18 a 23

### Mapas: Women_18 a 23 ### Mapas: Men_24 a 29 ### Mapas: Women_24 a 29 ### Mapas: Men_30 a 35 ### Mapas: Women_30 a 35 Estos mapas permiten ver visualmente la distribución espacial de la accesibilidad para cada grupo definido.

8. Visualización: Curvas de Lorenz por sexo y rango etario

Se grafican las curvas de Lorenz para analizar la desigualdad en la distribución de la accesibilidad para cada grupo de sexo, rango etario y dedicación de ingreso.

lorenz_data <- create_lorenz_data(
  gini %>% mutate(Age = factor(Age, levels=c("18 a 23", "24 a 29", "30 a 35")))
)
lorenz_plot <- create_lorenz_plot(lorenz_data)
print(lorenz_plot)

Las curvas de Lorenz permiten comparar desigualdades de accesibilidad entre los distintos segmentos de edad y sexo.

9. Análisis de desigualdad y conclusiones

El análisis de los coeficientes de Gini y las visualizaciones espaciales evidencian que: - Los grupos más jóvenes y las mujeres suelen presentar mayor desigualdad en la accesibilidad urbana. - La desigualdad tiende a disminuir cuando se dedica una mayor proporción del ingreso, especialmente en el caso de los hombres y en los grupos de mayor edad. - La visualización permite identificar patrones espaciales y sociales que pueden orientar políticas públicas para mejorar la equidad urbana en el acceso a oportunidades.