# Additonal file 3 - Santana et al. (Genetics Selection Evolution) # ======================================================================== # Additional validation using an independent beef cattle dataset # ======================================================================== # The agreement between complete and degraded indicators was evaluated using # a generic beef cattle dataset with up to 16 body weight records per animal. # Complete indicators were computed using all available records, whereas # degraded indicators were computed after retaining only three records per # animal, one within each growth phase. This comparison was used to assess # whether indicators derived from sparse three-point trajectories preserved # the information obtained from more complete longitudinal growth records. # ======================================================================== # Script for computing resilience–uniformity indicators: # "LNVAR", "LMS", "MAD", "AUC", "MDD", and "RSI" # # Step 1: Fit collective reference growth curves by contemporary group # separately by sex, using all available records after basic # data quality control. # # Step 2: Compute the indicators and restrict the dataset to animals with # six or more body weight records, using additional quality control # criteria appropriate for covariance component estimation. # # Step 3: Repeat Step 1 after degrading the dataset to retain at most # three body weight records per animal, one within each growth phase # whenever available. # # Step 4: Repeat Step 2 using only animals with three body weight records, # specifically one record within each growth phase. # # Step 5: Compute the statistics of interest comparing the indicators derived # from the complete dataset (dat12, obtained in Step 2) with those # derived from the degraded dataset (dat18, obtained in Step 4). # ======================================================================== # Statistics used to compare complete and degraded indicators # ======================================================================== # Spearman correlation: # Evaluates the rank agreement between the complete and degraded versions # of each indicator. This metric assesses whether animals classified as # more or less resilient/uniform using the complete data tend to retain similar # relative positions when indicators are computed from degraded data. # # Pearson correlation: # Evaluates the linear association between the complete and degraded # versions of each indicator. This metric assesses whether numerical # changes in the degraded indicator follow proportional changes in the # corresponding complete indicator. # # Linear regression: # For each indicator, the degraded value is regressed on the complete value: # degraded indicator = intercept + slope * complete indicator + error. # The intercept evaluates systematic displacement between the two versions, # whereas the slope evaluates scale preservation. A slope close to 1 and an # intercept close to 0 indicate stronger agreement between complete and # degraded indicators. The coefficient of determination (R2) quantifies the # proportion of variation in the degraded indicator explained by the complete # indicator. # ======================================================================== # ======================================================================== # Results: agreement between complete and degraded indicators # ======================================================================== # Indicator N animals Spearman P(Spearman) Pearson P(Pearson) Intercept P(Intercept) Slope P(Slope) R2 # LNVAR 8,996 0.67 <0.001 0.64 <0.001 -0.63 <0.001 1.06 <0.001 0.41 # LMS 8,996 0.83 <0.001 0.79 <0.001 -0.57 <0.001 1.03 <0.001 0.62 # MAD 8,996 0.84 <0.001 0.87 <0.001 1.35 <0.001 0.83 <0.001 0.75 # AUC 8,996 0.79 <0.001 0.82 <0.001 0.39 <0.001 0.76 <0.001 0.67 # MDD 8,996 0.58 <0.001 0.56 <0.001 0.06 <0.001 0.68 <0.001 0.32 # RSI 8,996 0.63 <0.001 0.63 <0.001 -0.10 <0.001 1.14 <0.001 0.39 # ======================================================================== library(tidyverse) library(lubridate) library(quantreg) library(e1071) library(corrr) library(purrr) library(broom) # Columns in data.txt: # id_produto = animal / gc_cresc = contemporary group (with sex) / gc_cresc = contemporary group (without sex) / # ida_pesagem = age at measurement (days) / peso_real = weight (kg) dat07 <- read_table(" --- PUT YOUR PATH HERE --- /data.txt", col_names = c("id_produto", "gc_cresc", "gc_cv","ida_pesagem", "peso_real")) # Step 1 # ======================================================================== # Iterative data quality control - gc_cresc # collective growth curve (reference) # ======================================================================== dat_atual <- dat07 n_old <- 0 iter_count <- 0 repeat { iter_count <- iter_count + 1 cat( "Iteração QC completo", iter_count, ": Número de observações no arquivo:", nrow(dat_atual), "\n" ) n_new <- nrow(dat_atual) if (n_new == n_old) { dat08 <- dat_atual rm(dat_atual) break } n_old <- n_new dat_atual <- dat_atual %>% #------------------------------------------------------------ # Labels the growth phases of interest #------------------------------------------------------------ mutate( fase_pesagem = case_when( !is.na(peso_real) & ida_pesagem <= 90 ~ "jovem", !is.na(peso_real) & ida_pesagem >= 115 & ida_pesagem <= 295 ~ "desmama", !is.na(peso_real) & ida_pesagem >= 364 & ida_pesagem <= 640 ~ "sobreano", TRUE ~ NA_character_ ) ) %>% #------------------------------------------------------------ # Step 1: Retains only contemporary groups with at least # three valid body weight records in each growth phase of interest. # Important: body weight records outside these windows are not removed. #------------------------------------------------------------ group_by(gc_cresc) %>% mutate( n_peso_90d = sum( !is.na(peso_real) & ida_pesagem <= 90, na.rm = TRUE ), n_peso_desmama = sum( !is.na(peso_real) & ida_pesagem >= 115 & ida_pesagem <= 295, na.rm = TRUE ), n_peso_sobreano = sum( !is.na(peso_real) & ida_pesagem >= 364 & ida_pesagem <= 640, na.rm = TRUE ), n_anim = n_distinct(id_produto) ) %>% ungroup() %>% filter( n_anim >= 5, n_peso_90d >= 3, n_peso_desmama >= 3, n_peso_sobreano >= 3 ) %>% select(-n_anim, -n_peso_90d, -n_peso_desmama, -n_peso_sobreano) %>% #------------------------------------------------------------ # Step 2: Removes observations above or below 4 SD from the # mean body weight within each contemporary group. # Because no phase-specific filtering is applied, this control uses # all remaining observations within each contemporary group. #------------------------------------------------------------ group_by(gc_cresc) %>% mutate( sup_peso_real = mean(peso_real, na.rm = TRUE) + 4 * sd(peso_real, na.rm = TRUE), inf_peso_real = mean(peso_real, na.rm = TRUE) - 4 * sd(peso_real, na.rm = TRUE) ) %>% ungroup() %>% filter( peso_real <= sup_peso_real, peso_real >= inf_peso_real ) %>% select(-sup_peso_real, -inf_peso_real) } # Quick check # Number of body weight records per animal qc_n_fenot <- dat08 %>% count(id_produto, name = "n_pesagens") %>% count(n_pesagens, name = "n_animais") # Age range by growth phase qc_idades <- dat08 %>% group_by(gc_cresc) %>% summarise( n = n(), idade_min = min(ida_pesagem, na.rm = TRUE), idade_media = mean(ida_pesagem, na.rm = TRUE), idade_max = max(ida_pesagem, na.rm = TRUE), .groups = "drop" ) # ======================================================================== # Quantile regression for fitting contemporary-group growth curves # ======================================================================== dat09 <- dat08 %>% group_by(gc_cresc) %>% group_modify(~ { dados <- .x tau <- 0.7 # Defining the quantile of interest # Fitting the quantile polynomial model mod <- tryCatch( rq(peso_real ~ ida_pesagem + I(ida_pesagem^2) + I(ida_pesagem^3), tau = tau, data = dados), error = function(e) return(NULL) ) # If the model fails, returns NA if (is.null(mod)) { return(dados %>% mutate( residQUAN = NA_real_, estQUAN = NA_real_, MAE_QUAN = NA_real_, pseudor2_QUAN = NA_real_, b0_QUAN = NA_real_, b1_QUAN = NA_real_, b2_QUAN = NA_real_, b3_QUAN = NA_real_ )) } # Prediction and residuals dados$residQUAN <- resid(mod) dados$estQUAN <- predict(mod) # MAE and Koenker and Machado's (1999) pseudo-R2 MAE <- median(abs(dados$residQUAN), na.rm = TRUE) peso_tau <- quantile(dados$peso_real, probs = tau, na.rm = TRUE) loss_res <- sum(dados$residQUAN * (tau - (dados$residQUAN < 0))) loss_tot <- sum((dados$peso_real - peso_tau) * (tau - (dados$peso_real < peso_tau))) pseudo_r2 <- 1 - (loss_res / loss_tot) # Regression coefficients coefs <- coef(mod) dados %>% mutate( MAE_QUAN = MAE, pseudor2_QUAN = pseudo_r2, b0_QUAN = coefs[1], b1_QUAN = coefs[2], b2_QUAN = coefs[3], b3_QUAN = coefs[4] ) }) %>% ungroup() #////////////////////////////////////////////////////////////////////////////// # Resilience-uniformity indicators #////////////////////////////////////////////////////////////////////////////// # ======================================================================== # Maximum Drawdown (MDD) relative # ======================================================================== calc_mdd <- function(res) { res <- res[!is.na(res)] if (length(res) < 2) { return(NA_real_) } peak_so_far <- cummax(res) drawdowns <- peak_so_far - res mdd_raw <- max(drawdowns, 0) denom <- max(abs(res)) + 1e-6 mdd_raw / denom } # ======================================================================== # Recovery Slope Index (RSI) # ======================================================================== calc_rsi <- function(idade, res) { dat <- tibble::tibble( idade = idade, res = res ) %>% dplyr::filter(!is.na(idade), !is.na(res)) %>% dplyr::arrange(idade) %>% dplyr::distinct(idade, .keep_all = TRUE) if (nrow(dat) < 2) { return(NA_real_) } slopes <- diff(dat$res) / diff(dat$idade) pos <- sum(pmax(slopes, 0), na.rm = TRUE) tot <- sum(abs(slopes), na.rm = TRUE) + 1e-6 pos / tot } # ======================================================================== # Absolute AUC using the trapezoidal rule # Sum of the absolute values of interval-specific trapezoidal areas # ======================================================================== calc_auc_abs <- function(t, y, scale = 1000) { dat <- tibble::tibble( t = t, y = y ) %>% dplyr::filter(!is.na(t), !is.na(y)) %>% dplyr::arrange(t) %>% dplyr::distinct(t, .keep_all = TRUE) if (nrow(dat) < 2) { return(NA_real_) } dx <- diff(dat$t) ym <- (head(dat$y, -1) + tail(dat$y, -1)) / 2 areas <- dx * ym sum(abs(areas), na.rm = TRUE) / scale } # Step 2 # ======================================================================== # Joint computation of indicators for animals with >= 3 weight records # ======================================================================== dat10 <- dat09 %>% arrange(id_produto, ida_pesagem) %>% group_by(id_produto) %>% filter( n() >= 3, sum(!is.na(residQUAN)) >= 3, sum(!is.na(ida_pesagem)) >= 3 ) %>% summarise( # ==================================================================== # Ln(Var) # ==================================================================== lnvar = log(var(residQUAN, na.rm = TRUE) + 1e-6), # ==================================================================== # LMS - logarithm of the mean of squares # ==================================================================== lms = log(mean(residQUAN^2, na.rm = TRUE) + 1e-6), # ==================================================================== # IDAN / MAD - mean absolute deviation # ==================================================================== idan = mean(abs(residQUAN), na.rm = TRUE), # ==================================================================== # AUC - area under the curve # ==================================================================== auc_abs = calc_auc_abs(ida_pesagem, residQUAN, scale = 1000), # ==================================================================== # Maximum Drawdown # ==================================================================== mdd = calc_mdd(residQUAN), # ==================================================================== # Recovery Slope Index # ==================================================================== rsi = calc_rsi(ida_pesagem, residQUAN), .groups = "drop" ) #////////////////////////////////////////////////////////////////////////////// # Merges indicators with the dataset dat11 <- dat08 %>% inner_join(dat10, by = "id_produto") # ======================================================================== # Iterative data quality control - CV - Complete*** # ======================================================================== dat_atual <- dat11 # arquivo de input n_old <- 0 iter_count <- 0 repeat { iter_count <- iter_count + 1 cat( "Iteração", iter_count, ": Número de observações no arquivo:", nrow(dat_atual), "\n") n_new <- nrow(dat_atual) # Counts the number of rows/observations in the file # Stops if the number of observations has not changed if (n_new == n_old) { dat12 <- dat_atual # File used to store the results rm(dat_atual) # Removes the temporary file at the end of the iterations break } n_old <- n_new dat_atual <- dat_atual %>% # Step 1: Retains only animals with at least # one body weight record in each growth phase group_by(id_produto) %>% mutate( n_peso_90d = sum( !is.na(peso_real) & ida_pesagem <= 90, na.rm = TRUE ), n_peso_desmama = sum( !is.na(peso_real) & ida_pesagem >= 115 & ida_pesagem <= 295, na.rm = TRUE ), n_peso_sobreano = sum( !is.na(peso_real) & ida_pesagem >= 364 & ida_pesagem <= 640, na.rm = TRUE ) ) %>% ungroup() %>% filter( n_peso_90d >= 1, n_peso_desmama >= 1, n_peso_sobreano >= 1 ) %>% select(-n_peso_90d, -n_peso_desmama, -n_peso_sobreano) %>% # Step 2: Removes contemporary groups with fewer than 5 animals group_by(gc_cv) %>% mutate( n_anim = n_distinct(id_produto) # Number of distinct animals per group ) %>% ungroup() %>% filter(n_anim >= 5) %>% # At least 5 animals must be present within each contemporary group select(-n_anim) %>% # Step 3: Removes animals with fewer than 6 body weight records group_by(id_produto) %>% mutate( n_fenot = n() # Number of phenotypic records per animal ) %>% ungroup() %>% filter(n_fenot >= 6) %>% # At least 6 phenotypic records must be available per animal select(-n_fenot) } # Quick check # Number of body weight records per animal qc_n_fenot <- dat12 %>% count(id_produto, name = "n_pesagens") %>% count(n_pesagens, name = "n_animais") # Age range by growth phase qc_idades <- dat12 %>% group_by(gc_cv) %>% summarise( n = n(), idade_min = min(ida_pesagem, na.rm = TRUE), idade_media = mean(ida_pesagem, na.rm = TRUE), idade_max = max(ida_pesagem, na.rm = TRUE), .groups = "drop" ) # Step 3 # ======================================================================== # Iterative data quality control - Growth Curve - Reduced # up to 3 body weight records per animal # ======================================================================== # ======================================================================== # Single sampling - up to 3 body weight records per animal # ======================================================================== set.seed(123) # Ensures sampling reproducibility # dat08 as input = creates a "degraded" version of the basic dataset # (1+ body weight records) dat14_0 <- dat08 %>% # Selects only body weight records within the growth phases filter(!is.na(fase_pesagem)) %>% arrange(id_produto, ida_pesagem) %>% group_by(id_produto, fase_pesagem) %>% group_modify(~ { if (.y$fase_pesagem == "jovem") { .x %>% filter(ida_pesagem == min(ida_pesagem, na.rm = TRUE)) %>% slice_sample(n = 1) } else { .x %>% slice_sample(n = 1) } }) %>% ungroup() %>% arrange(id_produto, ida_pesagem) dat_atual <- dat14_0 # Input file (previous complete gc_cresc) n_old <- 0 iter_count <- 0 repeat { iter_count <- iter_count + 1 cat( "Iteração", iter_count, ": Número de observações no arquivo:", nrow(dat_atual), "\n" ) n_new <- nrow(dat_atual) # Counts the number of rows/observations in the file # Stops if the number of observations has not changed if (n_new == n_old) { dat14_1 <- dat_atual # File used to store the results rm(dat_atual) # Removes the temporary file at the end of the iterations break } n_old <- n_new dat_atual <- dat_atual %>% #------------------------------------------------------------ # Removes contemporary groups with fewer than 5 animals and # fewer than 3 valid body weight records in each growth phase #------------------------------------------------------------ group_by(gc_cresc) %>% mutate( n_anim = n_distinct(id_produto), n_peso_jovem = sum(fase_pesagem == "jovem" & !is.na(peso_real), na.rm = TRUE), n_peso_desmama = sum(fase_pesagem == "desmama" & !is.na(peso_real), na.rm = TRUE), n_peso_sobreano = sum(fase_pesagem == "sobreano" & !is.na(peso_real), na.rm = TRUE) ) %>% ungroup() %>% filter( n_anim >= 5, n_peso_jovem >= 3, n_peso_desmama >= 3, n_peso_sobreano >= 3 ) %>% select(-n_anim, -n_peso_jovem, -n_peso_desmama, -n_peso_sobreano) } # Quick check # Number of body weight records per animal qc_n_fenot <- dat14_1 %>% count(id_produto, name = "n_pesagens") %>% count(n_pesagens, name = "n_animais") # Age range by growth phase qc_idades <- dat14_1 %>% group_by(gc_cresc) %>% summarise( n = n(), idade_min = min(ida_pesagem, na.rm = TRUE), idade_media = mean(ida_pesagem, na.rm = TRUE), idade_max = max(ida_pesagem, na.rm = TRUE), n_anim = n_distinct(id_produto), .groups = "drop" ) # ======================================================================== # Quantile regression for fitting contemporary-group growth curves - reduced/degraded # ======================================================================== dat15 <- dat14_1 %>% group_by(gc_cresc) %>% group_modify(~ { dados <- .x tau <- 0.7 # Defining the quantile of interest # Fitting the quantile polynomial model mod <- tryCatch( rq(peso_real ~ ida_pesagem + I(ida_pesagem^2) + I(ida_pesagem^3), tau = tau, data = dados), error = function(e) return(NULL) ) # If the model fails, returns NA if (is.null(mod)) { return(dados %>% mutate( residQUAN = NA_real_, estQUAN = NA_real_, MAE_QUAN = NA_real_, pseudor2_QUAN = NA_real_, b0_QUAN = NA_real_, b1_QUAN = NA_real_, b2_QUAN = NA_real_, b3_QUAN = NA_real_ )) } # Prediction and residuals dados$residQUAN <- resid(mod) dados$estQUAN <- predict(mod) # MAE and Koenker and Machado's (1999) pseudo-R2 MAE <- median(abs(dados$residQUAN), na.rm = TRUE) peso_tau <- quantile(dados$peso_real, probs = tau, na.rm = TRUE) loss_res <- sum(dados$residQUAN * (tau - (dados$residQUAN < 0))) loss_tot <- sum((dados$peso_real - peso_tau) * (tau - (dados$peso_real < peso_tau))) pseudo_r2 <- 1 - (loss_res / loss_tot) # Regression coefficients coefs <- coef(mod) dados %>% mutate( MAE_QUAN = MAE, pseudor2_QUAN = pseudo_r2, b0_QUAN = coefs[1], b1_QUAN = coefs[2], b2_QUAN = coefs[3], b3_QUAN = coefs[4] ) }) %>% ungroup() #////////////////////////////////////////////////////////////////////////////// # Step 4 # ======================================================================== # Joint computation of indicators for animals with >= 3 weight records # ======================================================================== dat16 <- dat15 %>% arrange(id_produto, ida_pesagem) %>% group_by(id_produto) %>% filter( n() >= 3, sum(!is.na(residQUAN)) >= 3, sum(!is.na(ida_pesagem)) >= 3 ) %>% summarise( # ==================================================================== # Ln(Var) # ==================================================================== lnvarr = log(var(residQUAN, na.rm = TRUE) + 1e-6), # ==================================================================== # LMS - logarithm of the mean of squares # ==================================================================== lmsr = log(mean(residQUAN^2, na.rm = TRUE) + 1e-6), # ==================================================================== # IDAN / MAD - mean absolute deviation of deviations # ==================================================================== idanr = mean(abs(residQUAN), na.rm = TRUE), # ==================================================================== # AUC - area under the curve # ==================================================================== auc_absr = calc_auc_abs(ida_pesagem, residQUAN, scale = 1000), # ==================================================================== # Maximum Drawdown # ==================================================================== mddr = calc_mdd(residQUAN), # ==================================================================== # Recovery Slope Index # ==================================================================== rsir = calc_rsi(ida_pesagem, residQUAN), .groups = "drop" ) #////////////////////////////////////////////////////////////////////////////// # Merges indicators with the dataset dat17 <- dat14_1 %>% inner_join(dat16) # ======================================================================== # Iterative data quality control - CV - Reduced/degraded*** 3 records/animal # ======================================================================== dat_atual <- dat17 # input n_old <- 0 iter_count <- 0 repeat { iter_count <- iter_count + 1 cat( "Iteração", iter_count, ": Número de observações no arquivo:", nrow(dat_atual), "\n" ) n_new <- nrow(dat_atual) # Stops if the number of observations has not changed if (n_new == n_old) { dat18 <- dat_atual rm(dat_atual) break } n_old <- n_new dat_atual <- dat_atual %>% #------------------------------------------------------------ # Step 1: Removes contemporary groups with fewer than 5 animals #------------------------------------------------------------ group_by(gc_cv) %>% mutate( n_anim = n_distinct(id_produto) ) %>% ungroup() %>% filter(n_anim >= 5) %>% select(-n_anim) %>% #------------------------------------------------------------ # Step 2: Retains only animals with exactly 3 weight records, # with 1 record in each growth phase: young, weaning, and yearling #------------------------------------------------------------ group_by(id_produto) %>% mutate( n_fenot = n(), n_fases = n_distinct(fase_pesagem), n_jovem = sum(fase_pesagem == "jovem" & !is.na(peso_real), na.rm = TRUE), n_desmama = sum(fase_pesagem == "desmama" & !is.na(peso_real), na.rm = TRUE), n_sobreano = sum(fase_pesagem == "sobreano" & !is.na(peso_real), na.rm = TRUE) ) %>% ungroup() %>% filter( n_fenot == 3, n_fases == 3, n_jovem == 1, n_desmama == 1, n_sobreano == 1 ) %>% select(-n_fenot, -n_fases, -n_jovem, -n_desmama, -n_sobreano) } # Quick check # Number of body weight records per animal qc_n_fenot <- dat18 %>% count(id_produto, name = "n_pesagens") %>% count(n_pesagens, name = "n_animais") # Age range by growth phase qc_idades <- dat18 %>% group_by(gc_cv) %>% summarise( n = n(), idade_min = min(ida_pesagem, na.rm = TRUE), idade_media = mean(ida_pesagem, na.rm = TRUE), idade_max = max(ida_pesagem, na.rm = TRUE), n_anim = n_distinct(id_produto), .groups = "drop" ) # Step 5 # Computation of statistics comparing complete vs. "degraded" indicators # ======================================================================== # Complete dataset (+6 weight records/animal for indicator construction) # ======================================================================== dat19 <- dat12 %>% select(id_produto, lnvar, lms, idan, auc_abs, mdd, rsi) %>% distinct(id_produto, .keep_all = TRUE) # ======================================================================== # Degraded dataset (3 weight records/animal for indicator construction) # ======================================================================== dat20 <- dat18 %>% select(id_produto, lnvarr, lmsr, idanr, auc_absr, mddr, rsir) %>% distinct(id_produto, .keep_all = TRUE) # ======================================================================== # Merging complete and degraded indicators # ======================================================================== dat21 <- dat19 %>% inner_join(dat20, by = "id_produto") # ======================================================================== # Spearman correlation among all indicators # ======================================================================== dat22 <- dat21 %>% select( lnvar, lms, idan, auc_abs, mdd, rsi, lnvarr, lmsr, idanr, auc_absr, mddr, rsir ) %>% correlate(method = "spearman") # ======================================================================== # Pearson correlation among all indicators # ======================================================================== dat23 <- dat21 %>% select( lnvar, lms, idan, auc_abs, mdd, rsi, lnvarr, lmsr, idanr, auc_absr, mddr, rsir ) %>% correlate(method = "pearson") # ======================================================================== # Complete vs. degraded indicator pairs # ======================================================================== dat24 <- tibble( indicador = c("LNVAR", "LMS", "IDAN", "AUC", "MDD", "RSI"), completo = c("lnvar", "lms", "idan", "auc_abs", "mdd", "rsi"), degradado = c("lnvarr", "lmsr", "idanr", "auc_absr", "mddr", "rsir") ) # ======================================================================== # Indicator-specific complete vs. degraded correlations + p-values # ======================================================================== dat25 <- dat24 %>% mutate( n = nrow(dat21), spearman = map2_dbl(completo, degradado, ~ unname(cor.test(dat21[[.x]], dat21[[.y]], method = "spearman", exact = FALSE)$estimate) ), p_spearman = map2_dbl(completo, degradado, ~ cor.test(dat21[[.x]], dat21[[.y]], method = "spearman", exact = FALSE)$p.value ), pearson = map2_dbl(completo, degradado, ~ unname(cor.test(dat21[[.x]], dat21[[.y]], method = "pearson")$estimate) ), p_pearson = map2_dbl(completo, degradado, ~ cor.test(dat21[[.x]], dat21[[.y]], method = "pearson")$p.value ) ) # ======================================================================== # Regressions: degraded indicator on complete indicator # ======================================================================== dat26 <- dat24 %>% mutate( modelo = map2(completo, degradado, ~ { form <- as.formula(paste(.y, "~", .x)) lm(form, data = dat21) }) ) # ======================================================================== # Regression coefficients: intercept and slope # ======================================================================== dat27 <- dat26 %>% mutate( coeficientes = map(modelo, tidy) ) %>% select(indicador, completo, degradado, coeficientes) %>% unnest(coeficientes) %>% mutate( parametro = case_when( term == "(Intercept)" ~ "intercept", TRUE ~ "slope" ) ) %>% select( indicador, completo, degradado, parametro, estimate, std.error, statistic, p.value ) # ======================================================================== # Regression goodness-of-fit statistics # ======================================================================== dat28 <- dat26 %>% mutate( ajuste = map(modelo, glance) ) %>% select(indicador, completo, degradado, ajuste) %>% unnest(ajuste) %>% select( indicador, completo, degradado, r.squared, sigma, statistic, p.value, df, df.residual, nobs ) %>% rename( p_model = p.value ) # ======================================================================== # Final summary table # ======================================================================== dat29 <- dat27 %>% select(indicador, parametro, estimate, p.value) %>% pivot_wider( names_from = parametro, values_from = c(estimate, p.value), names_glue = "{.value}_{parametro}" ) %>% rename( intercept = estimate_intercept, slope = estimate_slope, p_intercept = p.value_intercept, p_slope = p.value_slope ) %>% left_join( dat28 %>% select(indicador, r.squared, sigma, p_model, nobs), by = "indicador" ) %>% left_join( dat25 %>% select(indicador, n, spearman, p_spearman, pearson, p_pearson), by = "indicador" ) %>% select( indicador, n, spearman, p_spearman, pearson, p_pearson, intercept, p_intercept, slope, p_slope, r.squared, p_model ) dat29