Introducción

El presente documento presenta la resolución del caso 6.7 propuesto por Pruyt (2013) sobre la dinámica de un sistema criminal.

Caso

Se presenta la traducción de caso dejando en inglés el nombre de las variables necesarias a considerar para modelarlo.

Centrémonos únicamente en las familias con múltiples problemas y asumamos que los individuos nacidos en estas familias están efectivamente atrapados, pero que no necesariamente recurren al crimen. Modelemos una cadena de envejecimiento compuesta por kids, youngsters, adults and retirees. Inicialmente, hay 1 millón de kids, 1 millón de youngsters, 3 millones de adults y 750,000 retirees dentro de estas familias con múltiples problemas.

Supongamos, por simplicidad, que solo los retirees mueren, en promedio después de un average time as retiree de 15 años, es decir, el número de muertes es igual al número de retirees dividido por average time as retiree. De manera similar, los adults pasan a ser retirees después de un average time as adult de 40 años, los youngsters pasan a ser adults después de un average time as youngster de 12 años, y los kids pasan a ser youngsters después de un average time as kid de 12 años from kids to youngsters.

Tanto los adults como los youngsters tienen hijos: el birth inflow es, por lo tanto, es la suma de los adults multiplicados por la annual fertility rate of adults de 3% por adult por año y los youngsters multiplicados por la annual fertility rate of youngsters de 0.3% por youngster por año.

Supongamos que se cometen 6 millones de crimes anualmente por otros, es decir, por criminales que no forman parte de familias con múltiples problemas. Supón que 6 millones de crimenes son cometidos por otros, es decir, por criminales que no son parte de una familia problemática. Además de estos crimes by others, los crímenes son cometidos por criminal kids a una rate de 2 criminal acts per criminal kid per year, por criminal youngsters a una rate de 4 criminal acts per criminal youngster per year, por criminal adults a una rate de 12 criminal acts per criminal adult per year y por criminal retirees a una rate de 4 criminal acts per criminal retiree per year.

Supongamos que, dentro de estas familias con múltiples problemas, el percentage of kids with criminal behavior asciende al 5%, el percentage of youngsters with criminal behavior asciende al 50%, el percentage of adults with criminal behavior asciende al 60% y el percentage of retirees with criminal behavior asciende al 10%.

En las siguientes secciones se presenta el diagrama causal (CLD) y el diagrama de flujo (SFD) del caso.

Diagrama Causal (CLD) del Caso

En este diagrama es posible apreciar dos dinámicas: La dinámica de crecimiento poblacional presentada por la parte superior del modelo y la dinámica de crecimiento del crimen marcada en la parte inferior del modelo.

Respecto al primero, notamos que la tasa de natalidad es afectada por la población de adultos, la población de jóvenes y la tasa de fertilidad de ambos grupos. De igual manera, notamos como cada grupo poblacional pasa al siguiente tan pronto se acaba la edad promedio para serlo (Ejemplo: Los niños pasan a adolescentes una vez pasa su tiempo promedio para serlo). Finalmente, vemos como el grupo poblacional de retirados afecta positivamente y es afectado negativamente por la variable de muertes.

En cuanto al segundo, vemos que los crimenes en el sistema son causados por dos tipos de crimenes: Crimenes cometidos por otros, y crimenes cometidos por cada grupo poblacional en el sistema, los cuales provienen de familias disfuncionales. Los crimenes cometidos por cada grupo poblacional son afectados por dos variables: El número de cada población que es criminal, y la tasa de criminalidad de cada grupo poblacional.

En conjutno, este sistema nos brinda las dos dinámicas descritas anteriormente. En la próxima sección se muestra el SFD del sistema.

Diagrama de Flujo (SFD) del Caso

Este SFD muestra el comportamiento descrito anteriormente mostrando que cada grupo poblacional es una variable de estado, que es afectada por la variable de flujo del tiempo en el que se pertenece a ese grupo lo cual lo lleva al siguiente, o a la muerte en el caso de los retirados.

Notamos que Crimen es una variable endógena que es afectada por otras dentro del sistema, como la tasa de criminalidad por grupo poblacional y el número de personas criminales en cada grupo, pero no es de estado, pues los crimenes no se acumulan en el tiempo.

A continuación, se presenta el código y resultado de la simulación.

Código y Resultados

library("deSolve")
## Warning: package 'deSolve' was built under R version 4.4.3
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
)

# Model Function
family_model <- function(t, state, params) {
  with(as.list(c(state, params)), {
    
    # Muertes (solo retirees mueren)
    deaths <- retirees / avg_retirement_time  
    
    # Transiciones entre grupos de edad
    adults_to_retirees <- adults / avg_adult_time  
    youngsters_to_adults <- youngsters / avg_youngster_time  
    kids_to_youngsters <- kids / avg_kid_time  
    
    # Nacimientos
    births <- (adults * adult_fertility_rate) + (youngsters * youngster_fertility_rate)
    
    # Crímenes por grupo de edad
    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
    
    # Total de crímenes anuales
    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
      ),
      # Variables adicionales para monitoreo
      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,
      adults_to_retirees = adults_to_retirees
    )
  })
}

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

# Cálculo de crímenes acumulados
results$total_crimes <- cumsum(results$annual_crimes)

# Gráfico de Dinámica Poblacional
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)") +
  theme_minimal() +
  theme(legend.position = "bottom")

Es posible notar como el comportamiento de los retirados no disminuye con el tiempo, esto debido a que nacen más personas de las que mueren, lo cual hace que en ultima instancia, no disminuzca el número de jubilados.

En cuanto a los resultados de los crimenes notamos lo siguiente:

# Mejorar el gráfico de crímenes anuales con plot()
plot(results$time, results$annual_crimes, 
     type = "l", col = "red", lwd = 2, 
     xlab = "Tiempo (años)", 
     ylab = "Crímenes anuales", 
     main = "Evolución de Crímenes Anuales",
     ylim = c(min(results$annual_crimes), max(results$annual_crimes)))

# Agregar puntos en cada año
points(results$time, results$annual_crimes, col = "red", pch = 16)


# Agregar una leyenda
legend("topright", legend = c("Crímenes anuales"), 
       col = c("red"), lwd = 2, lty = c(1, 2), pch = c(16, NA))

Notamos que los crimenes crecen a lo largo de estos 50 años. Visualizado en una tabla queda de la siguiente manera:

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

Este gráfico y tabla nos muestran que, sin controles de planeación familiar, la tasade crimenes sube. Observemos que pasa al bajar la tasa de nacimientos:

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.001,      # 0.1% por adulto por año (Control natal aplicado)
  youngster_fertility_rate = 0.00001, # 0.001% por joven por año (Control natal aplicado)
  
  # 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
)

# Model Function
family_model <- function(t, state, params) {
  with(as.list(c(state, params)), {
    
    # Muertes (solo retirees mueren)
    deaths <- retirees / avg_retirement_time  
    
    # Transiciones entre grupos de edad
    adults_to_retirees <- adults / avg_adult_time  
    youngsters_to_adults <- youngsters / avg_youngster_time  
    kids_to_youngsters <- kids / avg_kid_time  
    
    # Nacimientos
    births <- (adults * adult_fertility_rate) + (youngsters * youngster_fertility_rate)
    
    # Crímenes por grupo de edad
    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
    
    # Total de crímenes anuales
    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
      ),
      # Variables adicionales para monitoreo
      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,
      adults_to_retirees = adults_to_retirees
    )
  })
}

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

# Cálculo de crímenes acumulados
results$total_crimes <- cumsum(results$annual_crimes)

# Gráfico de Dinámica Poblacional
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)") +
  theme_minimal() +
  theme(legend.position = "bottom")

Es posible notar como el comportamiento de los retirados no disminuye con el tiempo, esto debido a que nacen más personas de las que mueren, lo cual hace que en ultima instancia, no disminuzca el número de jubilados.

En cuanto a los resultados de los crimenes notamos lo siguiente:

# Mejorar el gráfico de crímenes anuales con plot()
plot(results$time, results$annual_crimes, 
     type = "l", col = "red", lwd = 2, 
     xlab = "Tiempo (años)", 
     ylab = "Crímenes anuales", 
     main = "Evolución de Crímenes Anuales",
     ylim = c(min(results$annual_crimes), max(results$annual_crimes)))

# Agregar puntos en cada año
points(results$time, results$annual_crimes, col = "red", pch = 16)


# Agregar una leyenda
legend("topright", legend = c("Crímenes anuales"), 
       col = c("red"), lwd = 2, lty = c(1, 2), pch = c(16, NA))

Notamos que los crimenes disminuyen con el control natal a lo largo de estos 50 años. Visualizado en una tabla queda de la siguiente manera:

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 330072886 330.07
21 20 618147293 618.15
31 30 881711787 881.71
41 40 1115718060 1115.72
51 50 1320347235 1320.35

Lo anterior nos permite entender que existe algo de verdad en el postulado de Freakonomics que establece esta relación.

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.