Project: s41467-024-53548-z | Function: getPartialR2 (r)

system: You are an expert R programmer implementing algorithms from scientific papers.
Complete the masked function based on the algorithm description.
Follow R best practices and maintain consistent code style.
Return **only** the complete R function code.

user: Complete this R function:

**DESCRIPTION:** Calculates partial R-squared for polygenic risk scores in brain trajectory models. Quantifies proportion of variance explained by genetic factors with confidence intervals.

**KEY TERMS:** {
  "model_drop": "reduced model without PRS",
  "partialR": "partial R-squared value",
  "PGSS_AD": "polygenic score for Alzheimer's disease"
}

**CONTEXT CODE:**     if (agecut2 == 55) { jjj=6 }
    if (agecut2 == 60) { jjj=7 }
    if (agecut2 == 65) { jjj=8 }
    if (agecut2 == 70) { jjj=9 }
    
    AGERELSLOPE[[jjj]]=list()
    AGERELSLOPENOAPOE[[jjj]]=list()
    ABSCHANGESLOPE[[jjj]]=list()
    ABSCHANGESLOPENOAPOE[[jjj]]=list()
    
    
    #--- raise lower age ---
    PGSS = PGSSFULL %>% filter(meanAge >= agecut2)
    #--- raise lower age ---

        
    runLM <- function(PGSS, Yvar, Xvar) {
      stop("Function implementation has been masked")
      covariates = c(
        "scale(meanAge)" ,
        "subject_sex" ,
        "mri_info_site_name",
        "GAF_PC1",
        "GAF_PC2",
        "GAF_PC3",
        "GAF_PC4",
        "GAF_PC5",
        "GAF_PC6",
        "GAF_PC7",
        "GAF_PC8",
        "GAF_PC9",
        "GAF_PC10" ,
        "nTimepoints",
        "intervalFirstlast"
      )
      lm_formula <- as.formula(paste(Yvar, "~", Xvar, "+", paste(covariates, collapse = " + ")))
      
      model <- lm(lm_formula, data = PGSS)
      modelsum = summary(model)
      
      return(
        list(
          model = model,
          summary = modelsum
          )
      )
      
    }
    
    #calc partial R sq
    getPartialR2 <- function(model, score, apoe = 1) {
      stop("Function implementation has been masked")
      # Calculate partial R^2 for the predictor matching 'score' in an lm 'model'
      # Returns a list where [[1]] is a one-row data.frame suitable for use inside mutate(...)
      if (!inherits(model, "lm")) {
        stop("model must be an object of class 'lm'")
      }

      # Extract term labels from the model (these match how terms appear in the formula)
      term_labels <- attr(terms(model), "term.labels")
      if (length(term_labels) == 0) {
        # no predictors
        out_df <- data.frame(partialR2 = NA_real_,
                             partialR2_p = NA_real_,
                             score = as.character(score),
                             apoe = as.integer(apoe),
                             stringsAsFactors = FALSE)
        return(list(out_df, NULL))
      }

      # Try to find the predictor term to evaluate based on 'score' or presence of 'PGSS'
      match_idx <- grep(score, term_labels, ignore.case = TRUE)
      if (length(match_idx) == 0) {
        match_idx <- grep("PGSS", term_labels, ignore.case = TRUE)
      }
      if (length(match_idx) == 0) {
        # fallback: try any term containing the score string partially
        match_idx <- which(sapply(term_labels, function(x) grepl(score, x, ignore.case = TRUE)))
      }
      if (length(match_idx) == 0) {
        # could not identify a term; return NAs
        out_df <- data.frame(partialR2 = NA_real_,
                             partialR2_p = NA_real_,
                             score = as.character(score),
                             apoe = as.integer(apoe),
                             stringsAsFactors = FALSE)
        return(list(out_df, NULL))
      }

      # Use the first matched term
      term_to_remove <- term_labels[match_idx[1]]

      # Compute full model R^2
      s_full <- summary(model)
      R2_full <- unname(s_full$r.squared)

      # Fit reduced model removing the identified term
      # Use update() so it keeps the same data/environment as original model
      # Build formula expression ". ~ . - term"
      # Wrap in tryCatch to handle potential errors
      reduced_model <- tryCatch(
        update(model, as.formula(paste(". ~ . -", term_to_remove))),
        error = function(e) NULL
      )

      if (is.null(reduced_model)) {
        # if update failed, return NA
        out_df <- data.frame(partialR2 = NA_real_,
                             partialR2_p = NA_real_,
                             score = as.character(score),
                             apoe = as.integer(apoe),
                             stringsAsFactors = FALSE)
        return(list(out_df, NULL))
      }

      R2_reduced <- tryCatch(summary(reduced_model)$r.squared, error = function(e) NA_real_)

      # Compute partial R^2 using (R2_full - R2_reduced) / (1 - R2_reduced)
      if (is.na(R2_full) || is.na(R2_reduced) || (1 - R2_reduced) == 0) {
        partialR2 <- NA_real_
      } else {
        partialR2 <- (R2_full - R2_reduced) / (1 - R2_reduced)
        # numeric safety: clip into [0,1]
        if (!is.finite(partialR2)) partialR2 <- NA_real_
        if (!is.na(partialR2)) {
          partialR2 <- max(0, min(1, partialR2))
        }
      }

      # Extract p-value for the term from the full model's coefficients if possible
      coefmat <- tryCatch(coef(summary(model)), error = function(e) NULL)
      pval <- NA_real_
      if (!is.null(coefmat)) {
        # Row names in coefmat should match term labels; try direct match, then grep
        rn <- rownames(coefmat)
        if (term_to_remove %in% rn) {
          pval <- as.numeric(coefmat[term_to_remove, "Pr(>|t|)"])
        } else {
          gidx <- grep(term_to_remove, rn, fixed = TRUE)
          if (length(gidx) == 0) {
            # try using score string
            gidx <- grep(score, rn, ignore.case = TRUE)
          }
          if (length(gidx) >= 1) {
            # take first match
            pval <- as.numeric(coefmat[gidx[1], "Pr(>|t|)"])
          }
        }
      }



Complete the function implementation replacing "stop("Not implemented")".