Descripción del caso

Let’s focus on families with multiple problems only, and let’s assume that individuals born in families with multiple problems are indeed trapped, but that they do not necessarily resort to crime. Model an aging chain of kids, youngsters, adults and retirees. Initially, there are 1 million kids, 1 million youngsters, 3 million adults, and 750000 retirees within these families with multiple problems. Suppose for the sake of simplicity that only retirees die, on average after an average time as retiree of 15 years, i.e. deaths equals retirees divided by average time as retiree. Similarly, adults flow after an average time as adult of 40 years from adults to retirees, youngsters after an average time as youngster of 12 years from youngsters to adults, and kids after an average time as kid of 12 years from kids to youngsters. Both adults and youngsters give birth: the birth inflow is thus the sum of the adults times the annual fertility rate of adults of 3 percent per adult per year and the youngsters times the annual fertility rate of youngsters of 0.3% per youngster per year.

Suppose 6 million crimes are committed annually by others, that is, by criminals that are not part of families with multiple problems. Apart from these crimes by others, crimes are committed by criminal kids at a rate of 2 criminal acts per criminal kid per year, by criminal youngsters at a rate of 4 criminal acts per criminal youngster per year, by criminal adults at a rate of 12 criminal acts per criminal adult per year, and by criminal retirees at a rate of 4 criminal acts per criminal retiree per year. Suppose that, in these families with multiple problems, the percentage of kids with criminal behavior amounts to 5%, the percentage of youngsters with criminal behavior amounts to 50%, the percentage of adults with criminal behavior amounts to 60%, and the percentage of retirees with criminal behavior amounts to 10%.

Make a SD simulation model of this description and verify it. Simulate a base run over a period of 50 years.

 

Diagrama causal del caso

El sistema representa la dinámica generacional de familias en situación vulnerable, estructurada como una cadena de envejecimiento con cuatro grupos: niños, jóvenes, adultos y ancianos. Las personas avanzan progresivamente de una etapa a otra después de permanecer un tiempo determinado en cada una. Solo los ancianos salen del sistema al fallecer, mientras que los adultos y jóvenes pueden tener hijos, lo que introduce nuevos individuos en la etapa de niños.

Paralelamente, existe un flujo de actividad delictiva asociado a cada grupo. No todos los miembros cometen crímenes, pero cada etapa tiene una proporción específica de individuos que sí lo hacen, con distintos niveles de frecuencia según su edad. Además, el sistema considera crímenes externos cometidos por personas ajenas a estas familias.

En esencia, el modelo muestra cómo las transiciones demográficas (nacimientos, envejecimiento y muertes) interactúan con los comportamientos delictivos, creando un ciclo que puede perpetuarse en el tiempo si no hay intervenciones que modifiquen las condiciones de vida de estas familias.

Diagrama de flujo del caso

Corrida del modelo a 50 años

library("deSolve")
library("ggplot2")

# Initial Conditions
InitialConditions <- c(
  kids = 1000000,
  youngsters = 1000000,
  adults = 3000000,
  retirees = 750000
)

# Parameters
parameters <- c(
  avg_kid_time = 12,          # años como niño
  avg_youngster_time = 12,    # años como joven
  avg_adult_time = 40,        # años como adulto
  avg_retirement_time = 15,   # años como jubilado (antes de morir)
  
  # Tasas de fertilidad
  adult_fertility_rate = 0.03,      # 3% por adulto por año
  youngster_fertility_rate = 0.003, # 0.3% por joven por año
  
  # Porcentajes criminales
  criminal_kids_rate = 0.05,       # 5% de niños
  criminal_youngsters_rate = 0.5,  # 50% de jóvenes
  criminal_adults_rate = 0.6,      # 60% de adultos
  criminal_retirees_rate = 0.1,    # 10% de jubilados
  
  # Tasa de crímenes por criminal
  crimes_per_kid = 2,
  crimes_per_youngster = 4,
  crimes_per_adult = 12,
  crimes_per_retiree = 4,
  
  # Crímenes externos
  crimes_by_others = 6000000 # 6 millones por año
)

# Corrected Model Function with proper retirees flow
family_model <- function(t, state, params) {
  with(as.list(c(state, params)), {
    # Muertes (solo retirees mueren)
    deaths <- retirees / avg_retirement_time  # retirees/15
    
    # Flujos entre grupos de edad
    adults_to_retirees <- adults / avg_adult_time  # adults/40
    youngsters_to_adults <- youngsters / avg_youngster_time  # youngsters/12
    kids_to_youngsters <- kids / avg_kid_time  # kids/12
    
    # Nacimientos
    births <- (adults * adult_fertility_rate) + (youngsters * youngster_fertility_rate)
    
    # Cálculo de crímenes
    crimes_kids <- kids * criminal_kids_rate * crimes_per_kid
    crimes_youngsters <- youngsters * criminal_youngsters_rate * crimes_per_youngster
    crimes_adults <- adults * criminal_adults_rate * crimes_per_adult
    crimes_retirees <- retirees * criminal_retirees_rate * crimes_per_retiree
    annual_crimes <- crimes_by_others + crimes_kids + crimes_youngsters + crimes_adults + crimes_retirees
    
    # Ecuaciones diferenciales 
    list(
      c(
        dkids = births - kids_to_youngsters,
        dyoungsters = kids_to_youngsters - youngsters_to_adults,
        dadults = youngsters_to_adults - adults_to_retirees,
        dretirees = adults_to_retirees - deaths  # Esto SI hace disminuir retirees
      ),
      # Variables reportadas
      annual_crimes = annual_crimes,
      crimes_kids = crimes_kids,
      crimes_youngsters = crimes_youngsters,
      crimes_adults = crimes_adults,
      crimes_retirees = crimes_retirees,
      external_crimes = crimes_by_others,
      deaths = deaths,  # Para verificar
      adults_to_retirees = adults_to_retirees  # Para verificar
    )
  })
}

# Run simulation
results <- as.data.frame(ode(
  y = InitialConditions,
  times = seq(0, 50, 1),
  func = family_model,
  parms = parameters
))

# Calculate total crimes after simulation
results$total_crimes <- cumsum(results$annual_crimes)

# 1. Population Dynamics Plot 
ggplot(results, aes(x = time)) +
  geom_line(aes(y = kids/1e6, color = "Kids"), linewidth = 1.2) +
  geom_line(aes(y = youngsters/1e6, color = "Youngsters"), linewidth = 1.2) +
  geom_line(aes(y = adults/1e6, color = "Adults"), linewidth = 1.2) +
  geom_line(aes(y = retirees/1e6, color = "Retirees"), linewidth = 1.2) +
  geom_line(aes(y = deaths/1e6, color = "Deaths"), linewidth = 1, linetype = "dashed") +
  labs(title = "Population Dynamics (Retirees Should Decrease)",
       subtitle = "Dashed line shows deaths (retirees/15)",
       x = "Years", 
       y = "Population (millions)") +
  scale_color_manual(name = "",
                     values = c("Kids" = "#1f77b4",
                               "Youngsters" = "#ff7f0e",
                               "Adults" = "#2ca02c",
                               "Retirees" = "#d62728",
                               "Deaths" = "black")) +
  theme_minimal() +
  theme(legend.position = "bottom")

Es interesante observar el gráfico de la dinámica poblacional ya que originalmente creí que “retirees” bajaría de forma más evidente, pero tras analizarlo con la metafora de la bañaera entendi que la población de jubilados actúa como el agua en una bañera: los adultos que se jubilan son el grifo (entrada) y las muertes el desagüe (salida). Al inicio, con 3 millones de adultos, entran 75,000 jubilados anuales (3M/40) mientras solo salen 50,000 (750k/15). Por eso el nivel sube al principio, el grifo aporta más agua de la que sale por el desagüe. Solo cuando disminuyan los adultos (se cierre el grifo) o aumenten las muertes (se ensanche el desagüe), la población jubilada comenzará a bajar.


# 2. Verificación de flujos
ggplot(results, aes(x = time)) +
  geom_line(aes(y = adults_to_retirees/1e3, color = "New Retirees (adults/40)"), linewidth = 1) +
  geom_line(aes(y = deaths/1e3, color = "Deaths (retirees/15)"), linewidth = 1) +
  labs(title = "Flow Verification: Retirees In vs Out",
       x = "Years", 
       y = "People per year (thousands)") +
  scale_color_manual(name = "",
                     values = c("New Retirees (adults/40)" = "#2ca02c",
                               "Deaths (retirees/15)" = "#d62728")) +
  theme_minimal() +
  theme(legend.position = "bottom")

Para confirmarlo hice una segunda grafica para confirmar la metáfora de la bañera: la línea verde (nuevos jubilados) vs la roja (muertes). Cuando la verde esté por debajo, la población de jubilados empezará a disminuir.

 

# 3. Annual Crime Composition
ggplot(results, aes(x = time)) +
  geom_line(aes(y = crimes_kids/1e6, color = "Kids (5%)"), linewidth = 1) +
  geom_line(aes(y = crimes_youngsters/1e6, color = "Youngsters (50%)"), linewidth = 1) +
  geom_line(aes(y = crimes_adults/1e6, color = "Adults (60%)"), linewidth = 1) +
  geom_line(aes(y = crimes_retirees/1e6, color = "Retirees (10%)"), linewidth = 1) +
  geom_line(aes(y = external_crimes/1e6, color = "External (6M/year)"), 
            linewidth = 1, linetype = "dashed") +
  labs(title = "Annual Crime Composition",
       x = "Years",
       y = "Crimes per year (millions)") +
  scale_color_manual(name = "",
                     values = c("Kids (5%)" = "#1f77b4",
                               "Youngsters (50%)" = "#ff7f0e",
                               "Adults (60%)" = "#2ca02c",
                               "Retirees (10%)" = "#d62728",
                               "External (6M/year)" = "#7f7f7f")) +
  theme_minimal() +
  theme(legend.position = "bottom")

En esta gráfica podemos ver que los adultos son los mayores responsables del crimen anual por lo que si quisieramos reducir delitos, deberíamos enfocarnos en controlar a adultos y jóvenes.


Para comprender el impacto acumulado de esta dinámica criminal a lo largo del tiempo, la siguiente tabla muestra cómo los delitos se acumulan década tras década:

results$total_crimes <- cumsum(results$annual_crimes)

# tabla 
crime_table <- results[seq(1, nrow(results), 10), c("time", "total_crimes")]
crime_table$total_crimes_millions <- crime_table$total_crimes / 1e6

#tabla formateada
knitr::kable(crime_table, 
             col.names = c("Año", "Crímenes totales acumulados", "Crímenes (millones)"),
             caption = "Incremento acumulado de crímenes cada 10 años",
             align = c("c", "c", "c"),
             digits = 2)
Incremento acumulado de crímenes cada 10 años
Año Crímenes totales acumulados Crímenes (millones)
1 0 30000000 30.00
11 10 333921924 333.92
21 20 645457972 645.46
31 30 965477014 965.48
41 40 1294667953 1294.67
51 50 1633526753 1633.53

Mientras la gráfica anterior nos indicaba dónde enfocar esfuerzos inmediatos (adultos y jóvenes), esta tabla evidencia la urgencia de intervenciones tempranas. Ya que un programa de rehabilitación lograría reducir la transición a la criminalidad y por ende los de delitos acumulados para el año 50 serían mucho más bajos. Finalmente para entender el comportamiento a través del tiempo en forma gráfica tenemos lo siguiente:

# 4. Gráfica de Crímenes Totales Acumulados)
ggplot(results, aes(x = time, y = total_crimes/1e6)) +
  geom_line(color = "#9467bd", linewidth = 1.5) +
  labs(
    title = "Total Accumulated Crimes Over Time",
    subtitle = "Sum of all crimes year by year",
    x = "Years", 
    y = "Total Crimes (millions)"
  ) +
  theme_minimal() +
  theme(plot.title = element_text(face = "bold"))

Aquí la línea morada muestra la suma acumulada de todos los crímenes anuales (familia + externos). Es positiva porque cada año se suman nuevos crímenes al total histórico, además nunca baja porque es un acumulado (no se restan crímenes).


Referencias:

Pruyt, E. (2013). Small system dynamics models for big issues: Triple jump towards real-world complexity (First ed., version 1.0). TU Delft Library.