Project: s41467-024-52548-3 | Function: fit_twinning.binary (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:** Fits binary logistic regression models for twinning probability with polynomial effects of age and parity, including maternal ID as random effect. Core statistical model implementation.

**KEY TERMS:** {
  "twin": "twinning status",
  "age": "maternal age",
  "parity": "birth order",
  "maternal_id": "maternal identifier"
}

**CONTEXT CODE:**   if (poly_order > 0 && any(is.na(birth_level_data$parity))) {
    birth_level_data <- birth_level_data[!is.na(birth_level_data$parity), ]
    warning("the data contains missing values for parity, so such rows have not been fitted")
  }
  
  if (poly_order == 0) {
    formula <- paste0("IBI ~ 1 + (1|maternal_id) ", extra_vars)
  } else {
    formula <- paste0("IBI ~ 1 + poly(cbind(age, parity), ", poly_order, ") + (1|maternal_id) ", extra_vars)
  }
  
  ## extract initial parameter values if simpler fit provided:
  inits <- NULL
  if (!is.null(.simpler_fit)) {
    inits <- spaMM::get_inits_from_fit(.simpler_fit)
  }
  
  ## prepare the model formula:
  if (twin_as.predictor) {
    formula <- sub(pattern = "1 + ", replacement = "1 + twin + ", x = formula, fixed = TRUE)
  }
  
  if (verbose) {
    if (poly_order > 1L) {
      print(paste0("Fitting model '", formula, "'... (be patient)"))
    } else {
      print(paste0("Fitting model '", formula, "'..."))
    }
  }
  
  ## We remove 6 months to the IBI in order to avoid numerical issues during bootstraps and simulation.
  ## The idea is that no interbirth interval should ever be predicted to be lower than 6 months and
  ## the model will actually predict the duration between those 6 months and the next birth.
  ## Importantly, this implies that 6 months should always be added to predictions from such models.
  ## Since as.integer() does floor when rounding and since a real double can be just its integer value,
  ## the correct way to remove 6 months is to actually remove a little less:
  birth_level_data$IBI <- as.integer(birth_level_data$IBI - 5.5)
  
  args <- list(formula = stats::as.formula(formula), data = birth_level_data, family = spaMM::negbin(link = "log"), method = "PQL/L", init = inits$init)
  
  ## fit the model:
  fit_model_safely(timeout = timeout, .args = args)
}


#' @describeIn fit_models fit the model predicting the probability of twinning for a given birth event
#' @export
#'
#' @describeIn fit_models fit the model predicting the probability of twinning for a given birth event
#' @export
fit_twinning.binary <- function(birth_level_data, poly_order = NA, maternal_ID_as.predictor = TRUE, max_order = 6L, timeout = Inf, verbose = TRUE, extra_vars = "", .simpler_fit = NULL) {
  stop("Function implementation has been masked")
}


#' @describeIn fit_models fit all three life history models according to the simulation scenario
#'
#' This function fits all three life history models according to the simulation scenario provided.
#' The polynomial orders are estimated, which is why each of the three models has to be fitted seven
#' times under its default settings (order 0->6). It also returns the total time elapsed by the
#' function.
#'
#' @export
#'
fit_life_histories <- function(scenario, birth_level_data, max_order = 6L, timeout = Inf, verbose = TRUE, extra_vars="") {
  
  ## expand the data:
  birth_level_data <- expand_data(birth_level_data)
  
  ## start stopwatch:
  time_begin <- Sys.time()
  
  ## fit parity progression with or without twin as predictor:
  fit_PP <- fit_PP(birth_level_data = birth_level_data, poly_order = NA, twin_as.predictor = grepl("P", scenario), max_order = max_order, timeout = timeout, verbose = verbose, extra_vars=extra_vars)
  
  ## fit IBI with or without twin as predictor:
  fit_IBI <- fit_IBI(birth_level_data = birth_level_data, poly_order = NA, twin_as.predictor = grepl("I", scenario), max_order = max_order, timeout = timeout, verbose = verbose, extra_vars=extra_vars)
  
  ## fit the probability of twinning for a given birth event with or without parity/age as fixed effects, and with and without maternal_id as random effect:
  fit_twinning.binary <- fit_twinning.binary(birth_level_data = birth_level_data,
                                             poly_order = ifelse(grepl("S", scenario), NA, 0L),
                                             maternal_ID_as.predictor = grepl("H", scenario),
                                             max_order = max_order,  timeout = timeout, verbose = verbose, extra_vars=extra_vars)
  
  ## stop stopwatch:
  time_end <- Sys.time()
  
  ## compute time elapsed:
  time_elapsed <- as.numeric(time_end - time_begin, units = "secs")
  
  ## return all 3 fits:
  list(fit_PP = fit_PP, fit_IBI = fit_IBI, fit_twinning.binary = fit_twinning.binary,
       time_elapsed = time_elapsed)
}




#' @describeIn fit_models compute the slope between the total number of births and the per-birth twinning probability from birth level data
#'
#' This function fits the model investigating the relationship between parity and twinning
#' probability using [`fit_twinning.binomial`] and retrieve the slope of interest. For this, it
#' aggregates the birth level data.
#'
#' @export
#'
compute_slope_from_birth.level.data = function(birth_level_data, timeout = Inf, verbose = TRUE, extra_vars="") {
  
  ## expand the data:
  birth_level_data <- expand_data(birth_level_data)
  
  ## aggregated the data:
  mother_level_data <- aggregate_data(birth_level_data)
  
  ## fit the model:
  fit_twinning.binomial <- fit_twinning.binomial(mother_level_data = mother_level_data, timeout = timeout, verbose = verbose, extra_vars=extra_vars)
  
  ## extract and return the slope:
  spaMM::fixef(fit_twinning.binomial)[["births_total"]]
}


#' @describeIn fit_models internal function calling the fitting function from spaMM
#'
#' This internal function allows for the handling of messages and timeout threshold.
#' It is called by all the other fitting functions.
#'
#' @export
#'
fit_model_safely <- function(timeout, .args) {
  ## setting timeout:
  setTimeLimit(elapsed = timeout, transient = TRUE)
  on.exit(setTimeLimit(cpu = Inf, elapsed = Inf, transient = FALSE))
  
  ## fit the model while capturing messages produced by spaMM to prevent various displays (e.g. about testing separation)
  ## and displaying a message in case of fit failing:
  
  fit <- NULL # initialize fit, in case not created due to abort
  
  tryCatch(
    sink_messages <- utils::capture.output(fit <- do.call(spaMM::fitme, args = .args), type = "message"),
    error = function(ex) {message("\n The fitting of model(s) has aborted. This is possibly because the fitting time has exceeded the threshold set with 'timeout'. It could also be because you are using the wrong data structure (missing predictor?). For debugging purposes, the argument of the call has been saved in a file called timeout_xxx.rda storing a hidden object .args.")
      save(.args, file = paste0("timeout_", round(as.numeric(Sys.time())), ".rda")) ## save call if problem (with IBI = IBI - 6)
      return(NULL)})
  
  fit
}





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