1 Propósito

Este documento reproduce el análisis definitivo utilizado para construir los valores de referencia del CAPL-2 versión Colombia en la muestra multicéntrica de escolares de 8 a 12 años.

El flujo incluye:

  1. auditoría de la muestra analítica;
  2. ajuste de los diez modelos GAMLSS definitivos, separados por sexo;
  3. evaluación de GAIC, SBC y residuos cuantílicos normalizados;
  4. generación de percentiles P5 a P95;
  5. control de los límites teóricos de cada puntuación;
  6. correspondencia entre categorías oficiales del CAPL-2 y percentiles colombianos;
  7. percentiles empíricos de PACER, plancha, CAMSA y pasos promedio diarios.

Para Competencia física, Comportamiento diario, Motivación y confianza y el puntaje total, la localización se modeló mediante edad suavizada y región, mientras que la dispersión se modeló mediante edad suavizada. En Conocimiento y comprensión se utilizó una distribución beta inflada, con edad, región y grado en el parámetro de localización y los demás parámetros constantes.

2 1. Entorno reproducible

paquetes <- c(
  "readxl",
  "dplyr",
  "tidyr",
  "tibble",
  "purrr",
  "gamlss",
  "gamlss.dist",
  "capl",
  "knitr"
)

faltantes <- paquetes[
  !vapply(paquetes, requireNamespace, logical(1), quietly = TRUE)
]

if (length(faltantes) > 0) {
  stop(
    paste0(
      "Instale antes de continuar: ",
      paste(faltantes, collapse = ", ")
    )
  )
}

library(readxl)
library(dplyr)
library(tidyr)
library(tibble)
library(purrr)
library(gamlss)
library(gamlss.dist)
library(capl)
library(knitr)

set.seed(20260907)

3 2. Localización y lectura de la base definitiva

localizar_archivo <- function(nombre_archivo) {

  if (file.exists(nombre_archivo)) {
    return(normalizePath(nombre_archivo))
  }

  entrada <- tryCatch(
    knitr::current_input(dir = TRUE),
    error = function(e) ""
  )

  if (nzchar(entrada)) {

    candidato <- file.path(
      dirname(entrada),
      basename(nombre_archivo)
    )

    if (file.exists(candidato)) {
      return(normalizePath(candidato))
    }
  }

  archivos <- list.files(
    path = getwd(),
    recursive = TRUE,
    full.names = TRUE
  )

  coincidencias <- archivos[
    tolower(basename(archivos)) ==
      tolower(basename(nombre_archivo))
  ]

  if (length(coincidencias) >= 1) {
    return(normalizePath(coincidencias[1]))
  }

  stop(
    paste0(
      "No se encontró el archivo '",
      basename(nombre_archivo),
      "'. Guarde el Rmd y el Excel en la misma carpeta ",
      "o ajuste params$archivo_excel."
    )
  )
}

archivo <- localizar_archivo(
  params$archivo_excel
)

cat("Archivo localizado en:\n", archivo, "\n")
## Archivo localizado en:
##  C:\Users\Personal\Documents\análisis doctorado\Analisis\CAPL2_Colombia_BASE_FINAL_ANEXO_Y_AUDITORIA.xlsx
hojas <- readxl::excel_sheets(archivo)

if (!params$hoja_auditoria %in% hojas) {
  stop("No se encontró la hoja Base_auditoria.")
}

if (!params$hoja_anexo %in% hojas) {
  stop("No se encontró la hoja Base_anexo.")
}

base <- read_excel(
  archivo,
  sheet = params$hoja_auditoria
)

base_anexo <- read_excel(
  archivo,
  sheet = params$hoja_anexo
)

cat("Base_auditoria:", dim(base), "\n")
## Base_auditoria: 843 268
cat("Base_anexo:", dim(base_anexo), "\n")
## Base_anexo: 843 86

4 3. Preparación de la base de referencia

variables_necesarias <- c(
  "age",
  "gender",
  "region",
  "grade",
  "pc_score_final",
  "db_score_final",
  "mc_score_final",
  "ku_score_final",
  "capl_total_final"
)

faltan <- setdiff(
  variables_necesarias,
  names(base)
)

if (length(faltan) > 0) {
  stop(
    paste(
      "Faltan variables en Base_auditoria:",
      paste(faltan, collapse = ", ")
    )
  )
}

ref <- base %>%
  transmute(
    age = as.numeric(age),
    grade = as.numeric(grade),
    gender = tolower(as.character(gender)),
    region = as.character(region),
    pc_score_final = as.numeric(pc_score_final),
    db_score_final = as.numeric(db_score_final),
    mc_score_final = as.numeric(mc_score_final),
    ku_score_final = as.numeric(ku_score_final),
    capl_total_final = as.numeric(capl_total_final)
  ) %>%
  mutate(
    gender = factor(
      gender,
      levels = c("boy", "girl")
    ),
    region = factor(region)
  )

if (nrow(ref) != 843) {
  stop("La base de referencia no contiene los 843 escolares esperados.")
}

cat("Regiones:\n")
## Regiones:
print(levels(ref$region))
## [1] "Caribe"                 "Centro-Oriente"         "Centro sur-Amazonía"   
## [4] "Eje cafetero-Antioquia" "Llanos-Orinoquía"       "Pacífico"
cat("\nSexo:\n")
## 
## Sexo:
print(table(ref$gender, useNA = "ifany"))
## 
##  boy girl 
##  418  425
cat("\nEdad:\n")
## 
## Edad:
print(table(ref$age, useNA = "ifany"))
## 
##   8   9  10  11  12 
## 168 170 171 170 164

5 4. Casos analíticos definitivos

especificaciones <- tribble(
  ~variable,          ~sexo,  ~familia, ~usa_grado, ~n_esperado,
  "pc_score_final",   "boy",  "BCCG",  FALSE,      418,
  "pc_score_final",   "girl", "BCCG",  FALSE,      425,
  "db_score_final",   "boy",  "BCPE",  FALSE,      415,
  "db_score_final",   "girl", "NO",    FALSE,      425,
  "mc_score_final",   "boy",  "BCPE",  FALSE,      418,
  "mc_score_final",   "girl", "BCPE",  FALSE,      424,
  "ku_score_final",   "boy",  "BEINF", TRUE,       402,
  "ku_score_final",   "girl", "BEINF", TRUE,       413,
  "capl_total_final", "boy",  "BCCG",  FALSE,      414,
  "capl_total_final", "girl", "BCCG",  FALSE,      424
)

crear_datos_modelo <- function(
    variable_actual,
    sexo_actual,
    usa_grado
) {

  datos <- ref %>%
    mutate(
      score_aux = as.numeric(.data[[variable_actual]])
    )

  if (usa_grado) {

    datos %>%
      filter(
        gender == sexo_actual,
        !is.na(age),
        !is.na(region),
        !is.na(grade),
        !is.na(score_aux)
      ) %>%
      transmute(
        y = score_aux / 10,
        score_original = score_aux,
        age = as.numeric(age),
        region = factor(
          region,
          levels = levels(ref$region)
        ),
        grade = as.numeric(grade)
      )

  } else {

    datos %>%
      filter(
        gender == sexo_actual,
        !is.na(age),
        !is.na(region),
        !is.na(score_aux)
      ) %>%
      transmute(
        score = score_aux,
        age = as.numeric(age),
        region = factor(
          region,
          levels = levels(ref$region)
        )
      )
  }
}

tabla_casos <- purrr::pmap_dfr(
  especificaciones,
  function(variable, sexo, familia, usa_grado, n_esperado) {

    datos <- crear_datos_modelo(
      variable,
      sexo,
      usa_grado
    )

    tibble(
      variable = variable,
      sexo = sexo,
      familia = familia,
      n_esperado = n_esperado,
      n_observado = nrow(datos),
      coincide = nrow(datos) == n_esperado
    )
  }
)

knitr::kable(
  tabla_casos,
  caption = "Casos incluidos en los modelos definitivos"
)
Casos incluidos en los modelos definitivos
variable sexo familia n_esperado n_observado coincide
pc_score_final boy BCCG 418 418 TRUE
pc_score_final girl BCCG 425 425 TRUE
db_score_final boy BCPE 415 415 TRUE
db_score_final girl NO 425 425 TRUE
mc_score_final boy BCPE 418 418 TRUE
mc_score_final girl BCPE 424 424 TRUE
ku_score_final boy BEINF 402 402 TRUE
ku_score_final girl BEINF 413 413 TRUE
capl_total_final boy BCCG 414 414 TRUE
capl_total_final girl BCCG 424 424 TRUE 
if (!all(tabla_casos$coincide)) {
  stop(
    "Al menos uno de los tamaños analíticos no coincide con la versión definitiva."
  )
}

6 5. Ajuste de los modelos GAMLSS definitivos

Las familias retenidas fueron:

  • BCCG: Box-Cox Cole and Green.
  • BCPE: Box-Cox Power Exponential.
  • NO: distribución normal.
  • BEINF: distribución beta inflada.
obtener_familia <- function(nombre) {

  switch(
    nombre,
    "NO" = gamlss.dist::NO(),
    "BCCG" = gamlss.dist::BCCG(),
    "BCPE" = gamlss.dist::BCPE(),
    "BEINF" = gamlss.dist::BEINF(),
    stop("Familia no reconocida.")
  )
}

ajustar_modelo_final <- function(
    variable_actual,
    sexo_actual,
    familia_actual,
    usa_grado
) {

  datos <- crear_datos_modelo(
    variable_actual,
    sexo_actual,
    usa_grado
  )

  if (usa_grado) {

    modelo <- gamlss(
      y ~ pb(age) + region + grade,
      sigma.formula = ~ 1,
      nu.formula = ~ 1,
      tau.formula = ~ 1,
      family = BEINF(),
      data = datos,
      control = gamlss.control(
        n.cyc = 300,
        trace = FALSE
      )
    )

  } else {

    modelo <- gamlss(
      score ~ pb(age) + region,
      sigma.formula = ~ pb(age),
      family = obtener_familia(familia_actual),
      data = datos,
      control = gamlss.control(
        n.cyc = 300,
        trace = FALSE
      )
    )
  }

  list(
    modelo = modelo,
    datos = datos
  )
}
ajustes <- list()

for (i in seq_len(nrow(especificaciones))) {

  variable_actual <- especificaciones$variable[i]
  sexo_actual <- especificaciones$sexo[i]
  familia_actual <- especificaciones$familia[i]
  usa_grado <- especificaciones$usa_grado[i]

  clave <- paste(
    variable_actual,
    sexo_actual,
    sep = "__"
  )

  cat(
    "\nAjustando:",
    clave,
    "| familia:",
    familia_actual,
    "\n"
  )

  ajustes[[clave]] <- ajustar_modelo_final(
    variable_actual,
    sexo_actual,
    familia_actual,
    usa_grado
  )
}
## 
## Ajustando: pc_score_final__boy | familia: BCCG 
## 
## Ajustando: pc_score_final__girl | familia: BCCG 
## 
## Ajustando: db_score_final__boy | familia: BCPE 
## 
## Ajustando: db_score_final__girl | familia: NO 
## 
## Ajustando: mc_score_final__boy | familia: BCPE 
## 
## Ajustando: mc_score_final__girl | familia: BCPE 
## 
## Ajustando: ku_score_final__boy | familia: BEINF 
## 
## Ajustando: ku_score_final__girl | familia: BEINF 
## 
## Ajustando: capl_total_final__boy | familia: BCCG 
## 
## Ajustando: capl_total_final__girl | familia: BCCG

7 6. Criterios de información y diagnóstico residual

resumen_residuos <- function(modelo) {

  z <- as.numeric(
    residuals(
      modelo,
      what = "z-scores"
    )
  )

  z <- z[is.finite(z)]

  media <- mean(z)
  de <- sd(z)

  asimetria <- mean(
    ((z - media) / de)^3
  )

  curtosis <- mean(
    ((z - media) / de)^4
  ) - 3

  tibble(
    media_residuo = media,
    DE_residuo = de,
    asimetria = asimetria,
    curtosis = curtosis
  )
}

tabla_modelos <- purrr::pmap_dfr(
  especificaciones,
  function(variable, sexo, familia, usa_grado, n_esperado) {

    clave <- paste(variable, sexo, sep = "__")

    modelo <- ajustes[[clave]]$modelo
    datos <- ajustes[[clave]]$datos

    diag <- resumen_residuos(modelo)

    tibble(
      variable = variable,
      sexo = sexo,
      n = nrow(datos),
      familia = familia,
      convergio = isTRUE(modelo$converged),
      GAIC = as.numeric(
        GAIC(modelo, k = 2)
      ),
      SBC = as.numeric(
        GAIC(
          modelo,
          k = log(nrow(datos))
        )
      ),
      devianza_global = modelo$G.deviance,
      df = modelo$df.fit,
      media_residuo = diag$media_residuo,
      DE_residuo = diag$DE_residuo,
      asimetria = diag$asimetria,
      curtosis = diag$curtosis
    )
  }
)

knitr::kable(
  tabla_modelos,
  digits = 3,
  caption = "Ajuste y diagnóstico de los modelos GAMLSS definitivos"
)
Ajuste y diagnóstico de los modelos GAMLSS definitivos
variable sexo n familia convergio GAIC SBC devianza_global df media_residuo DE_residuo asimetria curtosis
pc_score_final boy 418 BCCG TRUE 2314.53 2354.887 2294.53 10.00 0.000 1.001 -0.010 -0.148
pc_score_final girl 425 BCCG TRUE 2307.19 2347.715 2287.19 10.00 -0.001 1.001 -0.035 -0.417
db_score_final boy 415 BCPE TRUE 2310.42 2354.733 2288.42 11.00 -0.013 1.000 0.015 -0.049
db_score_final girl 425 NO TRUE 2403.90 2446.545 2382.85 10.53 -0.001 1.001 0.079 -0.376
mc_score_final boy 418 BCPE TRUE 2207.76 2252.202 2185.74 11.01 -0.005 0.994 0.007 -0.048
mc_score_final girl 424 BCPE TRUE 2284.17 2328.716 2262.17 11.00 -0.023 1.000 0.028 -0.015
ku_score_final boy 402 BEINF TRUE -45.55 -1.594 -67.56 11.00 0.000 0.987 -0.117 0.001
ku_score_final girl 413 BEINF TRUE -86.70 -42.447 -108.70 11.00 -0.004 0.986 -0.026 -0.266
capl_total_final boy 414 BCCG TRUE 2936.36 2980.105 2914.62 10.87 0.001 1.001 -0.013 -0.071
capl_total_final girl 424 BCCG TRUE 2997.29 3039.550 2976.42 10.44 0.000 1.001 -0.004 -0.035

8 7. Worm plots globales

Los worm plots se utilizan como diagnóstico gráfico complementario de los residuos cuantílicos normalizados.

for (clave in names(ajustes)) {

  modelo <- ajustes[[clave]]$modelo

  # Extraer directamente los residuos cuantílicos normalizados.
  # Esto evita que wp() intente reconstruir la llamada original
  # del modelo y buscar el objeto local "datos", que ya no existe
  # fuera de la función de ajuste.
  z <- as.numeric(
    residuals(
      modelo,
      what = "z-scores"
    )
  )

  z <- z[is.finite(z)]

  wp(
    resid = z,
    main = clave,
    ylim.all = 2.5
  )
}

9 8. Generación de percentiles P5–P95

probabilidades <- seq(
  0.05,
  0.95,
  by = 0.05
)

nombres_percentiles <- paste0(
  "P",
  seq(5, 95, by = 5)
)

limites_teoricos <- tribble(
  ~variable,          ~minimo, ~maximo,
  "pc_score_final",        0,       30,
  "db_score_final",        0,       30,
  "mc_score_final",        0,       30,
  "ku_score_final",        0,       10,
  "capl_total_final",      0,      100
)

predecir_parametros <- function(
    modelo,
    datos_entrenamiento,
    datos_prediccion
) {

  p <- gamlss::predictAll(
    object = modelo,
    newdata = datos_prediccion,
    data = datos_entrenamiento,
    type = "response",
    output = "data.frame"
  )

  p <- as.data.frame(p)

  if (!"mu" %in% names(p)) {
    stop("predictAll no devolvió mu.")
  }

  if (!"sigma" %in% names(p)) {
    p$sigma <- NA_real_
  }

  if (!"nu" %in% names(p)) {
    p$nu <- NA_real_
  }

  if (!"tau" %in% names(p)) {
    p$tau <- NA_real_
  }

  p
}

cuantil_modelo <- function(
    familia,
    p,
    mu,
    sigma,
    nu,
    tau
) {

  if (familia == "NO") {

    return(
      gamlss.dist::qNO(
        p,
        mu = mu,
        sigma = sigma
      )
    )
  }

  if (familia == "BCCG") {

    return(
      gamlss.dist::qBCCG(
        p,
        mu = mu,
        sigma = sigma,
        nu = nu
      )
    )
  }

  if (familia == "BCPE") {

    return(
      gamlss.dist::qBCPE(
        p,
        mu = mu,
        sigma = sigma,
        nu = nu,
        tau = tau
      )
    )
  }

  if (familia == "BEINF") {

    return(
      10 *
        gamlss.dist::qBEINF(
          p,
          mu = mu,
          sigma = sigma,
          nu = nu,
          tau = tau
        )
    )
  }

  stop("Familia no reconocida.")
}
lista_percentiles_raw <- list()
lista_parametros <- list()

for (i in seq_len(nrow(especificaciones))) {

  variable_actual <- especificaciones$variable[i]
  sexo_actual <- especificaciones$sexo[i]
  familia_actual <- especificaciones$familia[i]
  usa_grado <- especificaciones$usa_grado[i]

  clave <- paste(
    variable_actual,
    sexo_actual,
    sep = "__"
  )

  modelo <- ajustes[[clave]]$modelo
  datos <- ajustes[[clave]]$datos

  if (usa_grado) {

    grid <- datos %>%
      count(
        age,
        region,
        grade,
        name = "n_perfil"
      ) %>%
      arrange(
        region,
        age,
        grade
      )

    nuevos <- grid %>%
      select(
        age,
        region,
        grade
      )

  } else {

    soporte <- datos %>%
      count(
        age,
        region,
        name = "n_perfil"
      )

    grid <- tidyr::expand_grid(
      age = 8:12,
      region = levels(ref$region)
    ) %>%
      mutate(
        age = as.numeric(age),
        region = factor(
          region,
          levels = levels(ref$region)
        )
      ) %>%
      left_join(
        soporte,
        by = c("age", "region")
      ) %>%
      mutate(
        n_perfil = tidyr::replace_na(
          n_perfil,
          0L
        ),
        grade = NA_real_
      )

    nuevos <- grid %>%
      select(
        age,
        region
      )
  }

  parametros <- predecir_parametros(
    modelo,
    datos,
    nuevos
  )

  tabla_actual <- grid %>%
    mutate(
      variable = variable_actual,
      sexo = sexo_actual,
      familia = familia_actual,
      mu = parametros$mu,
      sigma = parametros$sigma,
      nu = parametros$nu,
      tau = parametros$tau
    )

  for (j in seq_along(probabilidades)) {

    nombre_p <- nombres_percentiles[j]

    tabla_actual[[nombre_p]] <- cuantil_modelo(
      familia = familia_actual,
      p = probabilidades[j],
      mu = parametros$mu,
      sigma = parametros$sigma,
      nu = parametros$nu,
      tau = parametros$tau
    )
  }

  lista_percentiles_raw[[clave]] <- tabla_actual

  lista_parametros[[clave]] <- tabla_actual %>%
    select(
      variable,
      sexo,
      familia,
      age,
      region,
      grade,
      n_perfil,
      mu,
      sigma,
      nu,
      tau
    )
}

tabla_percentiles_raw <- bind_rows(
  lista_percentiles_raw
)

tabla_parametros <- bind_rows(
  lista_parametros
)

10 9. Auditoría de límites y tabla definitiva

tabla_percentiles_larga_raw <- tabla_percentiles_raw %>%
  pivot_longer(
    cols = all_of(nombres_percentiles),
    names_to = "percentil",
    values_to = "valor_raw"
  ) %>%
  left_join(
    limites_teoricos,
    by = "variable"
  ) %>%
  mutate(
    fuera_limite =
      valor_raw < minimo |
      valor_raw > maximo
  )

auditoria_limites <- tabla_percentiles_larga_raw %>%
  group_by(
    variable,
    sexo,
    familia
  ) %>%
  summarise(
    n_estimaciones = n(),
    n_fuera_limite = sum(
      fuera_limite,
      na.rm = TRUE
    ),
    minimo_estimado = min(
      valor_raw,
      na.rm = TRUE
    ),
    maximo_estimado = max(
      valor_raw,
      na.rm = TRUE
    ),
    .groups = "drop"
  )

knitr::kable(
  auditoria_limites,
  digits = 3,
  caption = "Auditoría de los límites teóricos antes de la restricción de presentación"
)
Auditoría de los límites teóricos antes de la restricción de presentación
variable sexo familia n_estimaciones n_fuera_limite minimo_estimado maximo_estimado
capl_total_final boy BCCG 570 0 44.806 85.959
capl_total_final girl BCCG 570 0 39.690 79.927
db_score_final boy BCPE 570 0 11.868 27.720
db_score_final girl NO 570 0 5.148 24.596
ku_score_final boy BEINF 1254 0 0.229 9.997
ku_score_final girl BEINF 1197 0 0.439 9.959
mc_score_final boy BCPE 570 0 13.346 29.955
mc_score_final girl BCPE 570 1 12.076 30.098
pc_score_final boy BCCG 570 0 6.867 26.329
pc_score_final girl BCCG 570 0 5.842 24.045 
tabla_percentiles <- tabla_percentiles_raw %>%
  left_join(
    limites_teoricos,
    by = "variable"
  ) %>%
  mutate(
    across(
      all_of(nombres_percentiles),
      ~ pmin(
        maximo,
        pmax(
          minimo,
          .x
        )
      )
    )
  ) %>%
  select(
    -minimo,
    -maximo
  )

tabla_principales <- tabla_percentiles %>%
  select(
    variable,
    sexo,
    familia,
    age,
    region,
    grade,
    n_perfil,
    P5,
    P25,
    P50,
    P75,
    P95
  )

knitr::kable(
  head(tabla_principales, 40),
  digits = 2,
  caption = "Ejemplo de los valores de referencia definitivos"
)
Ejemplo de los valores de referencia definitivos
variable sexo familia age region grade n_perfil P5 P25 P50 P75 P95
pc_score_final boy BCCG 8 Caribe NA 14 8.18 11.91 14.49 17.07 20.77
pc_score_final boy BCCG 8 Centro-Oriente NA 14 8.88 12.93 15.74 18.54 22.56
pc_score_final boy BCCG 8 Centro sur-Amazonía NA 14 7.06 10.28 12.51 14.73 17.92
pc_score_final boy BCCG 8 Eje cafetero-Antioquia NA 14 9.25 13.47 16.39 19.31 23.49
pc_score_final boy BCCG 8 Llanos-Orinoquía NA 14 10.15 14.79 18.00 21.20 25.80
pc_score_final boy BCCG 8 Pacífico NA 14 6.87 10.00 12.17 14.34 17.44
pc_score_final boy BCCG 9 Caribe NA 16 8.56 12.23 14.78 17.31 20.95
pc_score_final boy BCCG 9 Centro-Oriente NA 14 9.28 13.26 16.02 18.77 22.72
pc_score_final boy BCCG 9 Centro sur-Amazonía NA 14 7.41 10.59 12.79 14.99 18.14
pc_score_final boy BCCG 9 Eje cafetero-Antioquia NA 14 9.66 13.80 16.67 19.54 23.64
pc_score_final boy BCCG 9 Llanos-Orinoquía NA 14 10.59 15.13 18.28 21.42 25.93
pc_score_final boy BCCG 9 Pacífico NA 14 7.21 10.31 12.45 14.59 17.66
pc_score_final boy BCCG 10 Caribe NA 16 8.94 12.55 15.06 17.55 21.14
pc_score_final boy BCCG 10 Centro-Oriente NA 15 9.68 13.59 16.30 19.01 22.89
pc_score_final boy BCCG 10 Centro sur-Amazonía NA 14 7.76 10.90 13.07 15.24 18.35
pc_score_final boy BCCG 10 Eje cafetero-Antioquia NA 14 10.06 14.13 16.95 19.77 23.80
pc_score_final boy BCCG 10 Llanos-Orinoquía NA 14 11.02 15.48 18.56 21.64 26.06
pc_score_final boy BCCG 10 Pacífico NA 14 7.56 10.62 12.74 14.85 17.88
pc_score_final boy BCCG 11 Caribe NA 16 9.32 12.88 15.34 17.79 21.32
pc_score_final boy BCCG 11 Centro-Oriente NA 9 10.08 13.92 16.58 19.24 23.05
pc_score_final boy BCCG 11 Centro sur-Amazonía NA 16 8.11 11.21 13.35 15.49 18.56
pc_score_final boy BCCG 11 Eje cafetero-Antioquia NA 14 10.47 14.47 17.24 20.00 23.96
pc_score_final boy BCCG 11 Llanos-Orinoquía NA 14 11.45 15.82 18.85 21.86 26.19
pc_score_final boy BCCG 11 Pacífico NA 16 7.91 10.93 13.02 15.10 18.09
pc_score_final boy BCCG 12 Caribe NA 8 9.70 13.20 15.62 18.04 21.50
pc_score_final boy BCCG 12 Centro-Oriente NA 14 10.48 14.25 16.87 19.47 23.22
pc_score_final boy BCCG 12 Centro sur-Amazonía NA 14 8.47 11.52 13.63 15.74 18.77
pc_score_final boy BCCG 12 Eje cafetero-Antioquia NA 14 10.88 14.80 17.52 20.23 24.11
pc_score_final boy BCCG 12 Llanos-Orinoquía NA 14 11.88 16.16 19.13 22.08 26.33
pc_score_final boy BCCG 12 Pacífico NA 12 8.26 11.24 13.30 15.35 18.31
pc_score_final girl BCCG 8 Caribe NA 14 6.81 10.27 12.72 15.18 18.76
pc_score_final girl BCCG 8 Centro-Oriente NA 14 7.71 11.63 14.39 17.18 21.23
pc_score_final girl BCCG 8 Centro sur-Amazonía NA 14 6.07 9.16 11.34 13.54 16.73
pc_score_final girl BCCG 8 Eje cafetero-Antioquia NA 14 8.27 12.48 15.44 18.44 22.78
pc_score_final girl BCCG 8 Llanos-Orinoquía NA 14 8.32 12.55 15.53 18.54 22.92
pc_score_final girl BCCG 8 Pacífico NA 14 5.84 8.81 10.91 13.03 16.10
pc_score_final girl BCCG 9 Caribe NA 14 7.50 10.88 13.25 15.65 19.13
pc_score_final girl BCCG 9 Centro-Oriente NA 14 8.45 12.25 14.93 17.63 21.55
pc_score_final girl BCCG 9 Centro sur-Amazonía NA 14 6.72 9.75 11.88 14.03 17.15
pc_score_final girl BCCG 9 Eje cafetero-Antioquia NA 14 9.04 13.11 15.98 18.87 23.07 
write.csv(
  tabla_percentiles,
  "CAPL2_percentiles_GAMLSS_completos.csv",
  row.names = FALSE,
  fileEncoding = "UTF-8"
)

11 10. Correspondencia con las categorías oficiales del CAPL-2

Este análisis no modifica los puntos de corte oficiales. Únicamente determina la posición percentílica que ocupa cada transición oficial dentro de las distribuciones colombianas estimadas.

protocolos_capl <- tribble(
  ~variable,          ~protocolo, ~dominio,                       ~minimo, ~maximo,
  "pc_score_final",   "pc",       "Competencia física",                 0,  30,
  "db_score_final",   "db",       "Comportamiento diario",              0,  30,
  "mc_score_final",   "mc",       "Motivación y confianza",             0,  30,
  "ku_score_final",   "ku",       "Conocimiento y comprensión",         0,  10,
  "capl_total_final", "capl",     "CAPL-2 total",                       0, 100
)

niveles_categoria <- c(
  beginning = 1,
  progressing = 2,
  achieving = 3,
  excelling = 4
)

categorias_transicion <- tribble(
  ~categoria_oficial, ~nivel_objetivo,
  "Progressing", 2,
  "Achieving", 3,
  "Excelling", 4
)

buscar_transicion_capl <- function(
    edad,
    sexo,
    protocolo,
    nivel_objetivo,
    minimo,
    maximo,
    tolerancia = 1e-8
) {

  obtener_nivel <- function(puntaje) {

    interpretacion <- capl::get_capl_interpretation(
      age = edad,
      gender = sexo,
      score = puntaje,
      protocol = protocolo
    )

    if (
      length(interpretacion) == 0 ||
      is.na(interpretacion)
    ) {
      return(NA_real_)
    }

    as.numeric(
      niveles_categoria[
        as.character(interpretacion)
      ]
    )
  }

  inferior <- minimo
  superior <- maximo

  nivel_maximo <- obtener_nivel(superior)

  if (
    is.na(nivel_maximo) ||
    nivel_maximo < nivel_objetivo
  ) {
    return(NA_real_)
  }

  for (iteracion in seq_len(100)) {

    medio <- (
      inferior +
        superior
    ) / 2

    nivel_medio <- obtener_nivel(medio)

    if (is.na(nivel_medio)) {
      return(NA_real_)
    }

    if (nivel_medio >= nivel_objetivo) {
      superior <- medio
    } else {
      inferior <- medio
    }

    if (
      (superior - inferior) <
        tolerancia
    ) {
      break
    }
  }

  superior
}

cortes_oficiales <- tidyr::crossing(
  protocolos_capl,
  age = 8:12,
  sexo = c("boy", "girl"),
  categorias_transicion
) %>%
  rowwise() %>%
  mutate(
    punto_transicion_oficial =
      buscar_transicion_capl(
        edad = age,
        sexo = sexo,
        protocolo = protocolo,
        nivel_objetivo = nivel_objetivo,
        minimo = minimo,
        maximo = maximo
      )
  ) %>%
  ungroup()
calcular_percentil_colombiano <- function(
    familia,
    corte,
    mu,
    sigma,
    nu,
    tau
) {

  if (
    is.na(corte) ||
    is.na(mu) ||
    is.na(sigma)
  ) {
    return(NA_real_)
  }

  if (familia == "NO") {

    prob <- gamlss.dist::pNO(
      q = corte,
      mu = mu,
      sigma = sigma
    )

  } else if (familia == "BCCG") {

    prob <- gamlss.dist::pBCCG(
      q = corte,
      mu = mu,
      sigma = sigma,
      nu = nu
    )

  } else if (familia == "BCPE") {

    prob <- gamlss.dist::pBCPE(
      q = corte,
      mu = mu,
      sigma = sigma,
      nu = nu,
      tau = tau
    )

  } else if (familia == "BEINF") {

    prob <- gamlss.dist::pBEINF(
      q = corte / 10,
      mu = mu,
      sigma = sigma,
      nu = nu,
      tau = tau
    )

  } else {

    stop(
      paste(
        "Familia no reconocida:",
        familia
      )
    )
  }

  pmin(
    100,
    pmax(
      0,
      as.numeric(prob) * 100
    )
  )
}
tabla_correspondencia_detallada <- tabla_parametros %>%
  rename(
    age = age,
    sexo = sexo
  ) %>%
  inner_join(
    cortes_oficiales %>%
      select(
        variable,
        sexo,
        age,
        dominio,
        categoria_oficial,
        punto_transicion_oficial
      ),
    by = c(
      "variable",
      "sexo",
      "age"
    )
  ) %>%
  rowwise() %>%
  mutate(
    percentil_colombiano =
      calcular_percentil_colombiano(
        familia = familia,
        corte = punto_transicion_oficial,
        mu = mu,
        sigma = sigma,
        nu = nu,
        tau = tau
      )
  ) %>%
  ungroup()

tabla_correspondencia_resumen <- tabla_correspondencia_detallada %>%
  group_by(
    dominio,
    categoria_oficial,
    sexo
  ) %>%
  summarise(
    mediana = median(
      percentil_colombiano,
      na.rm = TRUE
    ),
    P25 = quantile(
      percentil_colombiano,
      0.25,
      na.rm = TRUE,
      names = FALSE
    ),
    P75 = quantile(
      percentil_colombiano,
      0.75,
      na.rm = TRUE,
      names = FALSE
    ),
    .groups = "drop"
  ) %>%
  arrange(
    dominio,
    categoria_oficial,
    sexo
  )

knitr::kable(
  tabla_correspondencia_resumen,
  digits = 1,
  caption = "Correspondencia entre puntos de entrada oficiales y percentiles colombianos"
)
Correspondencia entre puntos de entrada oficiales y percentiles colombianos
dominio categoria_oficial sexo mediana P25 P75
CAPL-2 total Achieving boy 75.2 61.0 83.9
CAPL-2 total Achieving girl 87.6 81.9 94.7
CAPL-2 total Excelling boy 95.3 88.1 97.8
CAPL-2 total Excelling girl 97.8 96.0 99.4
CAPL-2 total Progressing boy 6.2 3.2 8.2
CAPL-2 total Progressing girl 23.4 16.4 33.7
Competencia física Achieving boy 89.5 79.4 98.7
Competencia física Achieving girl 90.0 76.2 98.3
Competencia física Excelling boy 97.6 92.9 99.9
Competencia física Excelling girl 97.5 91.0 99.8
Competencia física Progressing boy 34.6 24.3 61.2
Competencia física Progressing girl 45.3 29.6 71.3
Comportamiento diario Achieving boy NA NA NA
Comportamiento diario Achieving girl NA NA NA
Comportamiento diario Excelling boy NA NA NA
Comportamiento diario Excelling girl NA NA NA
Comportamiento diario Progressing boy NA NA NA
Comportamiento diario Progressing girl NA NA NA
Conocimiento y comprensión Achieving boy 75.6 57.7 89.1
Conocimiento y comprensión Achieving girl 87.1 55.9 92.0
Conocimiento y comprensión Excelling boy 86.1 74.3 93.2
Conocimiento y comprensión Excelling girl 92.6 73.2 94.4
Conocimiento y comprensión Progressing boy 37.9 20.9 63.6
Conocimiento y comprensión Progressing girl 61.7 20.8 72.6
Motivación y confianza Achieving boy 41.0 38.0 43.6
Motivación y confianza Achieving girl 38.5 33.5 43.5
Motivación y confianza Excelling boy 63.0 59.1 65.7
Motivación y confianza Excelling girl 60.2 54.7 66.0
Motivación y confianza Progressing boy 2.8 2.4 3.2
Motivación y confianza Progressing girl 4.1 2.8 5.9 
write.csv(
  tabla_correspondencia_detallada,
  "CAPL2_correspondencia_categorias_percentiles.csv",
  row.names = FALSE,
  fileEncoding = "UTF-8"
)

12 11. Percentiles empíricos de componentes específicos

Los percentiles empíricos se estiman directamente de las distribuciones observadas, utilizando quantile(..., type = 7).

Para CAMSA se utiliza el menor tiempo registrado entre los dos ensayos disponibles.

variables_anexo <- c(
  "edad",
  "sexo",
  "pacer_vueltas_20m",
  "plancha_segundos",
  "camsa_tiempo_ensayo1",
  "camsa_tiempo_ensayo2",
  "promedio_pasos"
)

faltan_anexo <- setdiff(
  variables_anexo,
  names(base_anexo)
)

if (length(faltan_anexo) > 0) {
  stop(
    paste(
      "Faltan variables en Base_anexo:",
      paste(faltan_anexo, collapse = ", ")
    )
  )
}

componentes <- base_anexo %>%
  transmute(
    edad = as.numeric(edad),
    sexo = as.character(sexo),
    pacer = as.numeric(pacer_vueltas_20m),
    plancha = as.numeric(plancha_segundos),
    camsa_1 = as.numeric(camsa_tiempo_ensayo1),
    camsa_2 = as.numeric(camsa_tiempo_ensayo2),
    pasos = as.numeric(promedio_pasos)
  ) %>%
  mutate(
    camsa_mejor = case_when(
      is.na(camsa_1) &
        is.na(camsa_2) ~ NA_real_,
      is.na(camsa_1) ~ camsa_2,
      is.na(camsa_2) ~ camsa_1,
      TRUE ~ pmin(
        camsa_1,
        camsa_2
      )
    )
  )
componentes_largo <- componentes %>%
  select(
    edad,
    sexo,
    pacer,
    plancha,
    camsa_mejor,
    pasos
  ) %>%
  pivot_longer(
    cols = c(
      pacer,
      plancha,
      camsa_mejor,
      pasos
    ),
    names_to = "variable",
    values_to = "valor"
  ) %>%
  mutate(
    componente = case_when(
      variable == "pacer" ~ "PACER",
      variable == "plancha" ~ "Plancha",
      variable == "camsa_mejor" ~ "CAMSA",
      variable == "pasos" ~ "Pasos promedio diarios"
    ),
    unidad = case_when(
      variable == "pacer" ~ "Número de vueltas",
      variable == "plancha" ~ "Segundos",
      variable == "camsa_mejor" ~ "Segundos",
      variable == "pasos" ~ "Pasos/día"
    )
  )

tabla_componentes_empiricos <- componentes_largo %>%
  filter(
    edad %in% 8:12
  ) %>%
  group_by(
    componente,
    unidad,
    sexo,
    edad
  ) %>%
  summarise(
    n = sum(!is.na(valor)),
    P5 = quantile(
      valor,
      0.05,
      na.rm = TRUE,
      type = 7,
      names = FALSE
    ),
    P25 = quantile(
      valor,
      0.25,
      na.rm = TRUE,
      type = 7,
      names = FALSE
    ),
    P50 = quantile(
      valor,
      0.50,
      na.rm = TRUE,
      type = 7,
      names = FALSE
    ),
    P75 = quantile(
      valor,
      0.75,
      na.rm = TRUE,
      type = 7,
      names = FALSE
    ),
    P95 = quantile(
      valor,
      0.95,
      na.rm = TRUE,
      type = 7,
      names = FALSE
    ),
    .groups = "drop"
  ) %>%
  arrange(
    componente,
    sexo,
    edad
  )

knitr::kable(
  tabla_componentes_empiricos,
  digits = 2,
  caption = "Percentiles empíricos de componentes específicos del CAPL-2"
)
Percentiles empíricos de componentes específicos del CAPL-2
componente unidad sexo edad n P5 P25 P50 P75 P95
CAMSA Segundos Niña 8 84 18.38 21.57 23.44 26.12 29.64
CAMSA Segundos Niña 9 84 18.94 21.69 23.37 24.84 27.98
CAMSA Segundos Niña 10 84 18.16 20.84 22.94 26.22 28.97
CAMSA Segundos Niña 11 85 18.41 20.36 23.45 26.54 28.10
CAMSA Segundos Niña 12 88 18.17 20.91 22.75 24.63 28.84
CAMSA Segundos Niño 8 84 17.76 19.94 22.55 25.21 27.48
CAMSA Segundos Niño 9 86 16.82 20.17 22.43 24.85 27.27
CAMSA Segundos Niño 10 87 18.28 20.91 23.38 25.68 28.71
CAMSA Segundos Niño 11 85 18.30 20.67 22.81 25.92 28.18
CAMSA Segundos Niño 12 76 17.77 20.18 22.20 24.90 28.10
PACER Número de vueltas Niña 8 84 8.00 13.00 18.00 25.00 34.70
PACER Número de vueltas Niña 9 84 8.15 13.00 20.00 26.00 32.85
PACER Número de vueltas Niña 10 84 8.00 15.75 23.00 30.25 40.70
PACER Número de vueltas Niña 11 85 12.00 17.00 24.00 30.00 40.60
PACER Número de vueltas Niña 12 88 13.00 18.75 25.50 31.00 44.30
PACER Número de vueltas Niño 8 84 10.15 14.00 21.00 27.25 38.55
PACER Número de vueltas Niño 9 86 10.25 14.25 22.00 28.00 40.75
PACER Número de vueltas Niño 10 87 9.90 18.00 22.00 29.00 41.70
PACER Número de vueltas Niño 11 85 11.20 18.00 23.00 30.00 42.80
PACER Número de vueltas Niño 12 76 12.00 18.00 26.00 34.00 47.25
Pasos promedio diarios Pasos/día Niña 8 84 6401.05 8058.00 9460.50 10336.00 12804.70
Pasos promedio diarios Pasos/día Niña 9 84 6637.05 8221.75 9395.50 10869.50 12952.95
Pasos promedio diarios Pasos/día Niña 10 84 6766.75 8777.50 9801.50 11044.00 13495.15
Pasos promedio diarios Pasos/día Niña 11 85 6923.60 8639.00 10085.00 11282.00 13253.20
Pasos promedio diarios Pasos/día Niña 12 88 7506.80 8871.75 10364.00 11342.75 13173.20
Pasos promedio diarios Pasos/día Niño 8 83 8597.00 10141.50 11141.00 12841.50 14366.30
Pasos promedio diarios Pasos/día Niño 9 85 8335.00 10499.00 11759.00 13038.00 15482.00
Pasos promedio diarios Pasos/día Niño 10 87 8121.00 10587.50 11830.00 12844.50 14428.90
Pasos promedio diarios Pasos/día Niño 11 85 8869.60 10371.00 11692.00 13066.00 15124.80
Pasos promedio diarios Pasos/día Niño 12 75 8726.80 10368.00 11613.00 13112.00 14659.10
Plancha Segundos Niña 8 84 24.25 40.65 54.10 63.75 81.18
Plancha Segundos Niña 9 84 30.41 44.50 54.05 66.30 78.85
Plancha Segundos Niña 10 84 33.46 50.15 59.10 71.97 86.16
Plancha Segundos Niña 11 85 38.52 48.10 61.40 68.70 82.24
Plancha Segundos Niña 12 88 38.64 50.67 62.70 70.55 89.68
Plancha Segundos Niño 8 84 34.93 47.13 60.70 70.23 82.49
Plancha Segundos Niño 9 86 38.02 45.20 58.35 72.10 91.70
Plancha Segundos Niño 10 87 33.60 52.35 62.20 71.20 84.69
Plancha Segundos Niño 11 85 34.90 52.90 60.30 71.80 95.54
Plancha Segundos Niño 12 76 37.95 55.25 64.55 76.30 90.35 
write.csv(
  tabla_componentes_empiricos,
  "CAPL2_percentiles_empiricos_componentes.csv",
  row.names = FALSE,
  fileEncoding = "UTF-8"
)

13 12. Control final

control_final <- especificaciones %>%
  select(
    variable,
    sexo,
    familia,
    n_esperado
  ) %>%
  left_join(
    tabla_modelos %>%
      select(
        variable,
        sexo,
        n,
        familia_obtenida = familia,
        convergio
      ),
    by = c(
      "variable",
      "sexo"
    )
  ) %>%
  mutate(
    n_correcto =
      n == n_esperado,
    familia_correcta =
      familia ==
        familia_obtenida
  )

knitr::kable(
  control_final,
  caption = "Control de correspondencia de los modelos definitivos"
)
Control de correspondencia de los modelos definitivos
variable sexo familia n_esperado n familia_obtenida convergio n_correcto familia_correcta
pc_score_final boy BCCG 418 418 BCCG TRUE TRUE TRUE
pc_score_final girl BCCG 425 425 BCCG TRUE TRUE TRUE
db_score_final boy BCPE 415 415 BCPE TRUE TRUE TRUE
db_score_final girl NO 425 425 NO TRUE TRUE TRUE
mc_score_final boy BCPE 418 418 BCPE TRUE TRUE TRUE
mc_score_final girl BCPE 424 424 BCPE TRUE TRUE TRUE
ku_score_final boy BEINF 402 402 BEINF TRUE TRUE TRUE
ku_score_final girl BEINF 413 413 BEINF TRUE TRUE TRUE
capl_total_final boy BCCG 414 414 BCCG TRUE TRUE TRUE
capl_total_final girl BCCG 424 424 BCCG TRUE TRUE TRUE 
if (
  !all(control_final$n_correcto) ||
  !all(control_final$familia_correcta) ||
  !all(control_final$convergio)
) {
  warning(
    "Revise los modelos antes de publicar: existe alguna discrepancia en n, familia o convergencia."
  )
}

14 13. Información de sesión

sessionInfo()
## R version 4.5.1 (2025-06-13 ucrt)
## Platform: x86_64-w64-mingw32/x64
## Running under: Windows 11 x64 (build 26200)
## 
## Matrix products: default
##   LAPACK version 3.12.1
## 
## locale:
## [1] LC_COLLATE=Spanish_Colombia.utf8  LC_CTYPE=Spanish_Colombia.utf8   
## [3] LC_MONETARY=Spanish_Colombia.utf8 LC_NUMERIC=C                     
## [5] LC_TIME=Spanish_Colombia.utf8    
## 
## time zone: America/Bogota
## tzcode source: internal
## 
## attached base packages:
## [1] parallel  splines   stats     graphics  grDevices utils     datasets 
## [8] methods   base     
## 
## other attached packages:
##  [1] knitr_1.50        capl_1.42         gamlss_5.5-0      nlme_3.1-168     
##  [5] gamlss.dist_6.1-1 gamlss.data_6.0-7 purrr_1.1.0       tibble_3.3.0     
##  [9] tidyr_1.3.1       dplyr_1.2.0       readxl_1.4.5     
## 
## loaded via a namespace (and not attached):
##  [1] sass_0.4.10        generics_0.1.4     stringi_1.8.7      lattice_0.22-7    
##  [5] digest_0.6.37      magrittr_2.0.3     evaluate_1.0.4     grid_4.5.1        
##  [9] timechange_0.3.0   RColorBrewer_1.1-3 fastmap_1.2.0      cellranger_1.1.0  
## [13] jsonlite_2.0.0     Matrix_1.7-3       writexl_1.5.4      survival_3.8-3    
## [17] scales_1.4.0       jquerylib_0.1.4    cli_3.6.6          rlang_1.2.0       
## [21] withr_3.0.2        cachem_1.1.0       yaml_2.3.10        tools_4.5.1       
## [25] ggplot2_4.0.1      vctrs_0.7.1        R6_2.6.1           lifecycle_1.0.5   
## [29] lubridate_1.9.4    stringr_1.5.1      MASS_7.3-65        pkgconfig_2.0.3   
## [33] pillar_1.11.0      bslib_0.9.0        gtable_0.3.6       glue_1.8.0        
## [37] xfun_0.55          tidyselect_1.2.1   rstudioapi_0.17.1  farver_2.1.2      
## [41] htmltools_0.5.8.1  rmarkdown_2.29     compiler_4.5.1     S7_0.2.1