#' Fit a flexible maximum-likelihood regression model
#'
#' @title Fit xreg2 Model
#' @description Fits a flexible maximum-likelihood regression model supporting
#'   censored, interval, and hybrid data. Accepts a list of
#'   \code{\link{xreg2_control}} objects and a matching named list of
#'   data frames.
#'
#' @param controlList An \code{xreg2ControlList} (produced by combining
#'   \code{xreg2_control} objects with \code{c()}), an \code{xreg2_obj} (for
#'   re-optimisation), or an \code{xreg2}/\code{xreg} fitted object (for
#'   re-fitting).
#' @param dataList Named list of data frames, one per component. Names must
#'   match those of \code{controlList}.
#' @param start_values Optional named numeric vector of starting values,
#'   overriding those in \code{controlList}.
#' @param fixed_values Named numeric vector of parameter values held fixed.
#' @param latent_classes Integer; number of latent classes. \code{0} disables.
#' @param latent_class_parameters Character vector of parameter names that
#'   vary by latent class.
#' @param latent_id_colname Character name of the grouping column for latent
#'   classes.
#' @param return_type Character; \code{"fit"} (default), \code{"control"},
#'   \code{"df"}, or \code{"predict"}.
#' @param print_sum Logical; print summary during optimisation. Default
#'   \code{FALSE}.
#' @param method Character; optimisation method. Default \code{"ucminf"}.
#' @param hessian Logical; compute Hessian for standard errors. Default
#'   \code{TRUE}.
#' @param run_from Internal; character string identifying the calling wrapper
#'   (e.g. \code{"hyreg"}). Used to suppress certain warnings when called
#'   from higher-level functions.
#' @param ... Additional arguments passed to the optimiser.
#'
#' @return An object of class \code{"xreg2"} with fitted coefficients,
#'   standard errors, log-likelihoods, and counts.
#'
#' @seealso \code{\link{xreg2_control}}, \code{\link{xreg2_optim}},
#'   \code{\link{predict.xreg2}}
#'
#' @examples
#' \donttest{
#' set.seed(1)
#' df   <- data.frame(y = rnorm(200, 2, 0.5), x = rnorm(200))
#' ctrl <- xreg2_control(
#'   formulas     = list(y ~ INTERCEPT + x * SLOPE),
#'   start_values = c(INTERCEPT = 0, SLOPE = 0),
#'   name         = "main"
#' )
#' fit  <- xreg2_fit(controlList = c(ctrl), dataList = list(main = df))
#' coef(fit)
#' }
#'
#' @export
xreg2_fit <- function(controlList,
                       dataList                = NULL,
                       start_values            = numeric(),
                       fixed_values            = numeric(),
                       latent_classes          = 0,
                       latent_class_parameters = character(),
                       latent_id_colname       = character(),
                       return_type             = "fit",
                       print_sum               = FALSE,
                       method                  = "ucminf",
                       hessian                 = TRUE,
                       run_from                = NULL,
                       ...) {
  xreg2_time <- Sys.time()

  if ("xreg2_obj" %in% class(controlList))
    return(xreg2_optim(xreg2obj = controlList, method = method,
                        hessian = hessian, fixed_values = fixed_values, ...))

  if (is.null(dataList)) stop('Argument "dataList" is missing, with no default.')

  dot_args <- list(...)
  dot_args[c("p_fun", "p_aggrgation_fun")] <- NULL

  if (latent_classes < 2) latent_class_parameters <- character()

  if (!is.character(latent_class_parameters)) {
    warning("Latent_class_parameters not character. Latent classes will be disregarded.")
    latent_class_parameters <- character()
    latent_classes          <- 0
    latent_id_colname       <- character()
  }
  if (!is.character(latent_id_colname)) {
    warning("latent_id_colname not character. Latent classes will be disregarded.")
    latent_class_parameters <- character()
    latent_classes          <- 0
    latent_id_colname       <- character()
  }
  if (length(latent_id_colname)) latent_id_colname <- latent_id_colname[1]

  startValues <- attr(controlList, "startValues")

  if (class(controlList)[1] %in% c("xreg", "xreg2")) {
    if (is.na(start_values[1])) start_values <- controlList$coef
    controlList <- controlList$controlList
  }

  formulas    <- controlList
  controlList <- do.call(xreg2_control,
                         match_formals(fun = xreg2_control, formulas = controlList))

  if ("xreg"    %in% class(start_values)) startValues <- start_values$coef
  if ("numeric" %in% class(start_values) && length(start_values) > 0)
    startValues <- start_values

  if ("data.frame" %in% class(dataList)) {
    dataList <- list(dataList)
    names(dataList)[1] <- names(controlList)[1]
    warning(paste0(
      "Dataframe provided where list expected in dataList argument. ",
      "The dataframe has been enclosed in a list, and named \"",
      names(controlList)[1], "\" to match the first xreg2Control-object."))
  }

  if (!all(names(dataList) %in% names(controlList)))
    stop(paste("No control list provided for ",
               paste(names(dataList)[!names(dataList) %in% names(controlList)],
                     collapse = ", ")))

  if (is.null(names(dataList))) {
    if (length(dataList) <= length(controlList)) {
      warning("Provided datalist was unnamed. Names coerced from controlList")
      names(dataList) <- names(controlList)[seq_len(length(dataList))]
    } else {
      stop("Provided datalist was unnamed, and longer than provided controllist. Exiting.")
    }
  }

  if (length(unique(names(startValues))) < length(startValues)) {
    warning(paste0(
      "More than one start value assigned for parameters (",
      paste(names(startValues)[-match(unique(names(startValues)), names(startValues))],
            collapse = ", "), "). First value used."))
    startValues <- startValues[unique(names(startValues))]
  }

  if (length(fixed_values)) {
    if (class(fixed_values)[1] %in% c("xreg", "xreg2")) {
      fixed_values <- fixed_values$coef
    }
    if ("data.frame" %in% class(fixed_values)) {
      fixed_df     <- fixed_values[, 1:2]
      fixed_values <- fixed_values[, 1]
      names(fixed_values) <- rownames(fixed_df)
    } else {
      fixed_df <- data.frame(Estimate    = fixed_values,
                             `Std. Error` = rep(NA, NROW(fixed_values)))
      colnames(fixed_df) <- c("Estimate", "Std. Error")
      rownames(fixed_df) <- names(fixed_values)
    }
  } else {
    fixed_df <- data.frame(a = numeric(), b = numeric())
  }
  colnames(fixed_df) <- c("Estimate", "Std. Error")
  fixedValues <- numeric()

  aggr            <- TRUE
  return_lik_df   <- (return_type == "df")
  return_first    <- (return_type == "first")
  if (return_type == "predict") {
    aggr          <- FALSE
    return_lik_df <- TRUE
    return_type   <- "first_df"
  }
  if (return_type == "first_df") {
    return_first    <- TRUE
    return_first_df <- TRUE
  } else {
    return_first_df <- FALSE
  }
  if (return_type == "precalc_df") {
    return_first    <- TRUE
    return_lik_df   <- FALSE
    return_first_df <- TRUE
  }

  prep_out        <- list()
  newDataList     <- list()
  all_defined_vars <- character()
  undefined_vars  <- character()
  valuevars       <- list()

  for (dataName in names(dataList)) {
    rel_col      <- vector()
    thisControl  <- controlList[[dataName]]
    data_df      <- dataList[[dataName]]
    orig_cols    <- colnames(data_df)
    valueVar     <- NA
    defined_vars <- colnames(data_df)
    local_vars   <- character()

    for (fnum in seq_along(thisControl$formulas)) {
      formula    <- thisControl$formulas[[fnum]]
      targetName <- as.character(formula[[2]])
      rel_col    <- c(rel_col, all.vars(formula)[!all.vars(formula) %in% rel_col])

      if (is.na(valueVar)) {
        if (targetName %in% colnames(data_df) ||
            length(grep(paste0(targetName, "\\."), colnames(data_df), value = TRUE)) == 2) {
          valuevars[[dataName]] <- targetName
          valueVar              <- targetName
        }
      }
      rhs_vars       <- all.vars(formula[[3]])
      undefined_vars <- c(undefined_vars, rhs_vars[!rhs_vars %in% defined_vars])
      all_defined_vars <- c(all_defined_vars,
                            undefined_vars[!undefined_vars %in% all_defined_vars])
      if (!targetName %in% c(colnames(data_df), valueVar))
        defined_vars <- c(defined_vars, targetName)
      local_vars <- c(local_vars, all.vars(formula), targetName)
    }

    local_vars <- local_vars[!local_vars %in% colnames(data_df)]
    controlList[[dataName]][["defined_vars"]] <- local_vars

    censor_bounds <- thisControl$censor_bounds
    grep_vals     <- grep(paste0(valueVar, "\\."), colnames(data_df), value = TRUE)

    if (length(grep_vals) > 2)
      stop("More than two columns matching target variable.")

    if (length(grep_vals) == 2) {
      if (all((data_df[, grep_vals[1]] - data_df[, grep_vals[2]]) >= 0)) {
        upper_bound_var <- grep_vals[1]
        lower_bound_var <- grep_vals[2]
      } else if (all((data_df[, grep_vals[1]] - data_df[, grep_vals[2]]) <= 0)) {
        upper_bound_var <- grep_vals[2]
        lower_bound_var <- grep_vals[1]
      } else {
        stop(paste0("Two columns matched the left-hand side: ",
                    grep_vals[1], " and ", grep_vals[2],
                    ". However, neither was always >= the other, so they cannot ",
                    "be used as upper/lower bounds. Quitting."))
      }
    } else {
      if (!valueVar %in% colnames(data_df)) {
        stop("No value columns specified.")
      } else {
        upper_bound_var <- lower_bound_var <- valueVar
      }
    }

    controlList[[dataName]]$upper_bound_var <- upper_bound_var
    controlList[[dataName]]$lower_bound_var <- lower_bound_var
    controlList[[dataName]]$valueVar        <- valueVar

    data_df[, c("internal_ub", "internal_lb")] <- data_df[, c(upper_bound_var, lower_bound_var)]
    formula[[2]] <- substitute(Xb)
    e_params     <- list(...)

    if (length(latent_id_colname)) {
      if (latent_id_colname %in% colnames(data_df))
        data_df$internal_classgroup <- data_df[, latent_id_colname]
    } else {
      data_df$internal_classgroup <- paste0(dataName, ".", seq_len(NROW(data_df)))
    }

    if ("id" %in% colnames(data_df)) data_df$internal_id <- as.integer(data_df$id)

    data_df <- within(data_df, {
      both_na    <- is.na(internal_ub) * is.na(internal_lb)
      internal_ub[internal_ub >= max(thisControl$censor_bounds)] <- Inf
      internal_lb[internal_lb <= min(thisControl$censor_bounds)] <- -Inf
      internal_lb[internal_lb >= max(thisControl$censor_bounds)] <- max(thisControl$censor_bounds)
      internal_ub[internal_ub <= min(thisControl$censor_bounds)] <- min(thisControl$censor_bounds)
      internal_ub[is.na(internal_ub)] <- Inf
      internal_lb[is.na(internal_lb)] <- -Inf
      internal_type              <- rep(3, NROW(internal_ub))
      internal_type[internal_ub == internal_lb]  <- 1
      internal_type[internal_ub == Inf]          <- 0
      internal_type[internal_lb == -Inf]         <- 2
      internal_count <- 1
    })

    if (sum(data_df$both_na)) {
      warning(paste0(sum(data_df$both_na), " rows in which ", valueVar,
                     " was NA were removed."))
      data_df <- data_df[!data_df$both_na, -(NCOL(data_df))]
    }

    if (!is.na((weights_var <- thisControl$weights_var)) &&
        weights_var %in% colnames(data_df))
      data_df$internal_count <- data_df[, weights_var]

    relevant_columns <- c(rel_col,
                          colnames(data_df)[grep("internal_", colnames(data_df))])

    if (aggr) {
      new_df             <- data_df[, colnames(data_df) %in% relevant_columns]
      new_df$internal_unique <- as.numeric(as.factor(
        apply(new_df, MARGIN = 1, FUN = "paste", collapse = "")))
      unique_df              <- unique(new_df)
      unique_df$internal_count <- aggregate(
        new_df$internal_count,
        by  = list(new_df$internal_unique),
        FUN = "sum")[unique_df$internal_unique, 2]
      newDataList[[dataName]] <- unique_df
    } else {
      newDataList[[dataName]] <- data_df
    }

    controlList[[dataName]]$orig_cols <- orig_cols
    startValues <- c(startValues,
                     thisControl$start_values[!names(thisControl$start_values) %in% names(startValues)])
    fixedValues <- c(fixedValues,
                     thisControl$fixed_values[!names(thisControl$fixed_values) %in% names(fixedValues)])
    all_defined_vars <- c(all_defined_vars,
                          defined_vars[!defined_vars %in% all_defined_vars])
    controlList[[dataName]]$obs_types <- c(
      Uncensored    = sum(data_df$internal_count * (data_df$internal_ub == data_df$internal_lb)),
      `Left censored`  = sum(data_df$internal_count * (data_df$internal_ub > data_df$internal_lb) *
                               (data_df$internal_ub < Inf) * (data_df$internal_lb == -Inf)),
      `Right censored` = sum(data_df$internal_count * (data_df$internal_ub > data_df$internal_lb) *
                               (data_df$internal_lb > -Inf) * (data_df$internal_ub == Inf)),
      Intervals     = sum(data_df$internal_count * (data_df$internal_ub > data_df$internal_lb) *
                            (data_df$internal_lb > -Inf) * (data_df$internal_ub < Inf)))
  }

  if (length(fixedValues)) {
    fixed_values[names(fixedValues)] <- fixedValues
    tmp <- rep(NA, NROW(fixed_values))
    names(tmp) <- names(fixed_values)
    tmp[rownames(fixed_df)] <- fixed_df[, 2]
    fixed_df <- data.frame(Estimate    = fixed_values,
                           `Std. Error` = tmp)
    colnames(fixed_df) <- c("Estimate", "Std. Error")
  }

  startValues[names(fixed_values)[names(fixed_values) %in% names(startValues)]] <-
    fixed_values[names(fixed_values) %in% names(startValues)]

  undefined_vars <- unique(undefined_vars[!undefined_vars %in%
                                            c(names(startValues), latent_class_parameters)])
  undefined_vars <- undefined_vars[!undefined_vars %in% c("Xb", names(fixedValues))]

  if (length(undefined_vars)) {
    tmp        <- paste(undefined_vars, collapse = ", ")
    used_from  <- if (!is.null(run_from)) run_from else "xreg2"
    if (!used_from == "hyreg")
      warning(paste0(
        "Used formulas contained variables not found in start_values or column names (",
        tmp, "). These will be initiated with a starting value of 0.1. ",
        "Defining start values either in xreg2_control or in the call to xreg2_fit ",
        "is highly recommended."))
    tmp <- rep(0.1, length(undefined_vars))
    names(tmp) <- undefined_vars
    startValues <- c(startValues, tmp)
  }

  if (latent_classes > 1) {
    for (lc in latent_class_parameters) {
      tmp <- 0.1
      names(tmp) <- lc
      if (lc %in% names(startValues)) {
        tmp         <- startValues[lc]
        startValues <- startValues[-which(names(startValues) == lc)]
        all_defined_vars <- all_defined_vars[-which(all_defined_vars == lc)]
      }
      for (i in seq_len(latent_classes)) {
        lci <- paste(lc, i, sep = ".")
        if (!lci %in% names(startValues)) {
          startValues <- c(startValues, tmp)
          names(startValues)[length(startValues)] <- lci
        }
        if (!lci %in% all_defined_vars) all_defined_vars <- c(all_defined_vars, lci)
      }
    }
  }

  if (length((tmp <- names(startValues[!names(startValues) %in% all_defined_vars])))) {
    startValues <- startValues[!names(startValues) %in% tmp]
    tmp <- paste(tmp, collapse = ", ")
    warning(paste0("Start values defined for variables (", tmp,
                   ") not found in column names or formulas. These have been removed."))
  }

  user_ctrl <- if ("optim_control" %in% names(e_params)) {
    dot_args["optim_control"] <- NULL
    e_params[["optim_control"]]
  } else list()

  default_ctrl <- switch(method,
    "L-BFGS-B"    = list(maxit = 10000, factr  = 1e-11,  lmm    = 10),
    "BFGS"         = list(maxit = 10000, reltol = 1e-11,  abstol = 1e-9),
    "CG"           = list(maxit = 10000, reltol = 1e-11),
    "Nelder-Mead"  = list(maxit = 10000, reltol = 1e-11),
    list()
  )
  ctrl <- modifyList(default_ctrl, user_ctrl)

  startValues[names(fixed_values)] <- fixed_values

  dtns <- names(newDataList)
  names(dtns) <- dtns

  greek <- c("ALPHA", "BETA", "GAMMA", "DELTA", "EPSILON", "ZETA", "ETA",
             "THETA", "IOTA", "KAPPA", "LAMBDA", "MU", "NU", "XI", "OMIKRON",
             "PI", "RHO", "SIGMA", "TAU", "UPSILON", "PHI", "CHI", "PSI", "OMEGA")

  xreg2lobj <- lapply(X = dtns, FUN = function(dtn) {
    thisfull <- newDataList[[dtn]]
    thisfull <- thisfull[, !colnames(thisfull) %in% "internal_classgroup"]
    tmpfull  <- thisfull[, !colnames(thisfull) %in% c("internal_id", "internal_count",
                                                        "internal_unique")]
    thisunique        <- unique(tmpfull)
    thisfull$umatch   <- multimatch(tmpfull, thisunique)

    sv <- startValues[!names(startValues) %in% names(fixed_values)]

    spvns <- unique(unlist(lapply(c(greek, "INTERCEPT", "SLOPE"),
                                  function(x) grep(x, names(sv), value = TRUE))))
    spvs  <- sv[spvns]
    sv    <- sv[!names(sv) %in% spvns]
    sv    <- c(sv, spvs)

    list(full          = thisfull,
         unique        = thisunique,
         coeff_names   = names(sv),
         formulas      = controlList[[dtn]]$formulas,
         lower         = controlList[[dtn]]$lower,
         upper         = controlList[[dtn]]$upper,
         random_formula= NULL,
         fixed         = fixed_values,
         ll_fun        = controlList[[dtn]]$p_fun,
         grad_fun      = controlList[[dtn]]$grad_fun,
         valuevar      = valuevars[[dtn]],
         startValues   = sv,
         ctrl          = ctrl)
  })
  class(xreg2lobj) <- c("xreg2_obj", "list")

  if (return_type == "control") {
    return(xreg2lobj)
  }

  oout <- do.call(xreg2_optim,
                  c(list(xreg2obj = xreg2lobj, method = method, hessian = hessian),
                    dot_args))
  oout$xreg2_time <- Sys.time() - xreg2_time
  return(oout)
}

# ---------------------------------------------------------------------------

#' Fit an xreg2 model from pre-structured data
#'
#' @title Fit xreg2 Model from Pre-Structured Data
#' @description Simplified version of \code{\link{xreg2_fit}} that accepts
#'   data already containing \code{ub} (upper bound) and \code{lb} (lower
#'   bound) columns instead of requiring data pre-processing.
#'
#' @inheritParams xreg2_fit
#'
#' @return An object of class \code{"xreg2"}.
#'
#' @seealso \code{\link{xreg2_fit}}, \code{\link{xreg2_control}}
#'
#' @examples
#' \donttest{
#' set.seed(1)
#' # xreg2_fit_s expects pre-structured data with lb and ub columns.
#' # Use lb == ub for exact (uncensored) observations.
#' y    <- rnorm(100, 2, 0.5)
#' df   <- data.frame(y = y, x = rnorm(100), lb = y, ub = y)
#' ctrl <- xreg2_control(
#'   formulas     = list(y ~ INTERCEPT + x * SLOPE),
#'   start_values = c(INTERCEPT = 0, SLOPE = 0, LN_SIGMA = 0),
#'   name         = "main"
#' )
#' fit  <- xreg2_fit_s(controlList = c(ctrl), dataList = list(main = df))
#' }
#'
#' @export
xreg2_fit_s <- function(controlList,
                          dataList                = NULL,
                          start_values            = numeric(),
                          fixed_values            = numeric(),
                          latent_classes          = 0,
                          latent_class_parameters = character(),
                          latent_id_colname       = character(),
                          return_type             = "fit",
                          print_sum               = FALSE,
                          method                  = "ucminf",
                          hessian                 = TRUE,
                          ...) {
  xreg2_time <- Sys.time()

  if ("xreg2_obj" %in% class(controlList))
    return(xreg2_optim(xreg2obj = controlList, method = method,
                        hessian = hessian, fixed_values = fixed_values, ...))

  ctrl <- switch(method,
    "BFGS"    = list(maxit = 10000, abstol = 1e-9,   reltol = 1e-11),
    "L-BFGS-B"= list(maxit = 10000, factr  = 1e-11,  lmm    = 10),
    NULL
  )

  dtns        <- names(dataList)
  names(dtns) <- dtns
  startValues <- start_values

  for (dtn in dtns) {
    startValues <- c(startValues,
                     controlList[[dtn]]$start_values[!names(controlList[[dtn]]$start_values) %in%
                                                       names(startValues)])
  }
  startValues[names(fixed_values)] <- fixed_values

  greek <- c("ALPHA", "BETA", "GAMMA", "DELTA", "EPSILON", "ZETA", "ETA",
             "THETA", "IOTA", "KAPPA", "LAMBDA", "MU", "NU", "XI", "OMIKRON",
             "PI", "RHO", "SIGMA", "TAU", "UPSILON", "PHI", "CHI", "PSI", "OMEGA")

  xreg2lobj <- lapply(X = dtns, FUN = function(dtn) {
    thisfull <- dataList[[dtn]]

    if ("id" %in% colnames(thisfull) && !"internal_id" %in% colnames(thisfull))
      thisfull$internal_id <- thisfull$id

    thisfull$internal_lb <- thisfull$lb
    thisfull$internal_ub <- thisfull$ub
    thisfull$internal_type                                    <- 3
    thisfull$internal_type[thisfull$internal_ub == thisfull$internal_lb] <- 1
    thisfull$internal_type[thisfull$internal_ub == Inf]       <- 0
    thisfull$internal_type[thisfull$internal_lb == -Inf]      <- 2
    thisfull$internal_count <- 1

    if (!is.null(controlList[[dtn]]$weights_var))
      if (!is.na(controlList[[dtn]]$weights_var))
        thisfull$internal_count <- thisfull[[controlList[[dtn]]$weights_var]]

    thisfull <- thisfull[, !colnames(thisfull) %in% "internal_classgroup"]
    tmpfull  <- thisfull[, !colnames(thisfull) %in% c("internal_count", "internal_unique")]
    thisunique        <- unique(tmpfull)
    thisfull$umatch   <- multimatch(tmpfull, thisunique)

    sv <- startValues[!names(startValues) %in% names(fixed_values)]

    spvns <- unique(unlist(lapply(c(greek, "INTERCEPT", "SLOPE"),
                                  function(x) grep(x, names(sv), value = TRUE))))
    spvs  <- sv[spvns]
    sv    <- sv[!names(sv) %in% spvns]
    sv    <- c(sv, spvs)

    fv <- if (!length(fixed_values)) NULL else fixed_values

    list(full          = thisfull,
         unique        = thisunique,
         coeff_names   = names(sv),
         formulas      = controlList[[dtn]]$formulas,
         lower         = controlList[[dtn]]$lower,
         upper         = controlList[[dtn]]$upper,
         random_formula= NULL,
         fixed         = fv,
         ll_fun        = controlList[[dtn]]$p_fun,
         grad_fun      = controlList[[dtn]]$grad_fun,
         valuevar      = NULL,
         startValues   = sv,
         ctrl          = ctrl)
  })
  class(xreg2lobj) <- c("xreg2_obj", "list")

  if (return_type == "control") {
    return(xreg2lobj)
  }

  oout <- xreg2_optim(xreg2lobj, method = method, hessian = hessian, ...)
  oout$xreg2_time <- Sys.time() - xreg2_time
  return(oout)
}

# ---------------------------------------------------------------------------

#' Optimise an xreg2 model object
#'
#' @title Optimise an xreg2 Model
#' @description Low-level optimisation routine called by \code{\link{xreg2_fit}}
#'   and \code{\link{xreg2_fit_s}}. Can also be called directly on an
#'   \code{xreg2_obj} to re-optimise with different settings.
#'
#'   Optimizer routing:
#'   \itemize{
#'     \item \code{"ucminf"} (default) — uses \pkg{ucminf} with central-difference
#'       gradients and high-precision tolerances.
#'     \item \code{"L-BFGS-B"}, \code{"BFGS"}, \code{"CG"}, \code{"Nelder-Mead"},
#'       \code{"SANN"}, \code{"Brent"} — uses \code{stats::optim()}.
#'       Box constraints (\code{lower}/\code{upper} set in
#'       \code{\link{xreg2_control}}) are enforced for \code{"L-BFGS-B"}.
#'     \item Any other method string — requires the \pkg{optimx} package (listed
#'       in \code{Suggests}) and dispatches via \code{optimx::optimr()}.
#'   }
#'
#'   Method-specific control defaults (high-precision) are set automatically and
#'   can be overridden by passing \code{optim_control = list(...)} to
#'   \code{\link{xreg2_fit}}.
#'
#' @param xreg2obj An \code{xreg2_obj} list produced by
#'   \code{\link{xreg2_fit}} with \code{return_type = "control"}.
#' @param method Character; optimisation method. \code{NULL} defaults to
#'   \code{"ucminf"}.
#' @param hessian Logical; compute Hessian. Default \code{TRUE}.
#' @param fixed_values Optional named numeric vector of additional fixed values.
#' @param optim_control Optional named list of control parameters that override
#'   the method-specific defaults set by \code{\link{xreg2_fit}}.  For example,
#'   \code{optim_control = list(maxit = 500)} tightens the iteration budget.
#'   Passed directly to \code{\link[ucminf]{ucminf}}, \code{\link[stats]{optim}},
#'   or \code{optimx::optimr} depending on \code{method}.
#' @param ... Additional arguments passed to the optimiser objective function.
#'
#' @return An object of class \code{"xreg2"}.
#'
#' @importFrom stats optim
#' @importFrom utils modifyList
#' @seealso \code{\link{xreg2_fit}}
#'
#' @examples
#' \donttest{
#' set.seed(1)
#' df   <- data.frame(y = rnorm(200, 2, 0.5), x = rnorm(200))
#' ctrl <- xreg2_control(
#'   formulas     = list(y ~ INTERCEPT + x * SLOPE),
#'   start_values = c(INTERCEPT = 0, SLOPE = 0),
#'   name         = "main"
#' )
#' obj          <- xreg2_fit(controlList = c(ctrl), dataList = list(main = df),
#'                           return_type = "control")
#' fit          <- xreg2_optim(obj, method = "ucminf")
#' fit_lbfgsb   <- xreg2_optim(obj, method = "L-BFGS-B")
#' }
#'
#' @export
xreg2_optim <- function(xreg2obj, method = NULL, hessian = TRUE,
                          fixed_values = NULL, optim_control = NULL, ...) {

  if (is.null(method)) method <- "ucminf"

  pars <- xreg2obj[[1]]$startValues

  if (!is.null(fixed_values)) {
    fixedvars <- xreg2obj[[1]]$fixed
    fixedvars[names(fixed_values)] <- fixed_values
    xreg2obj[[1]]$fixed      <- fixedvars
    pars <- pars[!names(pars) %in% names(fixedvars)]
    xreg2obj[[1]]$startValues <- pars
  }

  # Methods supported natively by stats::optim()
  OPTIM_METHODS <- c("nelder-mead", "bfgs", "cg", "l-bfgs-b", "sann", "brent")

  # Base control from xreg2_fit (method-specific defaults already merged with
  # any optim_control the user passed to xreg2_fit).  A further optim_control
  # passed directly to xreg2_optim() is applied on top.
  base_ctrl <- if (!is.null(xreg2obj[[1]]$ctrl)) xreg2obj[[1]]$ctrl else list()
  if (!is.null(optim_control))
    base_ctrl <- modifyList(base_ctrl, optim_control)

  optim_time_start <- Sys.time()

  if (length(pars)) {
    if (tolower(method) == "ucminf") {
      # ucminf-specific high-precision defaults; user ctrl overrides
      ucminf_defaults <- list(grad     = "central",
                              gradstep = c(1e-7, 1e-8),
                              maxeval  = 10000,
                              grtol    = 1e-8)
      ctrl <- modifyList(ucminf_defaults, base_ctrl)
      oout <- ucminf::ucminf(par = pars, fn = negll_list2, gr = gradll_list2,
                             dtalist = xreg2obj, hessian = hessian,
                             control = ctrl, ...)

    } else if (tolower(method) == "l-bfgs-b") {
      upper <- rep(Inf,  length(pars))
      lower <- rep(-Inf, length(pars))
      names(upper) <- names(lower) <- names(pars)

      uppers <- xreg2obj[[1]]$upper
      lowers <- xreg2obj[[1]]$lower
      uppers <- uppers[which(names(uppers) %in% names(pars))]
      lowers <- lowers[which(names(lowers) %in% names(pars))]
      upper[names(uppers)] <- uppers
      lower[names(lowers)] <- lowers

      oout <- stats::optim(par = pars, fn = negll_list2, gr = gradll_list2,
                           dtalist = xreg2obj,
                           method = "L-BFGS-B",
                           lower = lower, upper = upper,
                           control = base_ctrl, hessian = hessian, ...)

    } else if (tolower(method) %in% OPTIM_METHODS) {
      oout <- stats::optim(par = pars, fn = negll_list2, gr = gradll_list2,
                           dtalist = xreg2obj,
                           method = method,
                           control = base_ctrl, hessian = hessian, ...)

    } else {
      if (!requireNamespace("optimx", quietly = TRUE))
        stop(sprintf(
          paste0('Optimizer method "%s" is not supported by stats::optim().\n',
                 'Install the "optimx" package to enable additional methods:\n',
                 '  install.packages("optimx")'),
          method))
      oout <- optimx::optimr(par = pars, fn = negll_list2, gr = gradll_list2,
                             method = method, dtalist = xreg2obj,
                             hessian = hessian, control = base_ctrl, ...)
    }
    oout$fixed <- xreg2obj[[1]]$fixed
  } else {
    oout <- list(par   = c(pars, fixedvars),
                 fixed = fixedvars,
                 value = negll_list2(par = c(pars, fixedvars), dtalist = xreg2obj))
    hessian <- FALSE
  }

  oout$SE <- rep(NA, length(oout$par))
  names(oout$SE) <- names(oout$par) <- xreg2obj[[1]]$coeff_names

  if (hessian) {
    oout$vcov <- solve(oout$hessian)
    oout$SE[] <- sqrt(diag(oout$vcov))
  }

  oout$formulas <- lapply(xreg2obj, function(x) x$formulas)

  coef     <- oout$par
  oout$parf <- c(coef, oout$fixed)
  ncoef    <- length(coef)
  nfixed   <- length(oout$fixed)

  dtns        <- names(xreg2obj)
  names(dtns) <- dtns

  oout$minima <- sapply(dtns, function(dtn) negll_list2(oout$par, xreg2obj[dtn], ...))
  oout$minima <- c(oout$minima, total = sum(oout$minima))
  oout$counts <- sapply(xreg2obj, function(x) sum(x$full$internal_count))
  oout$counts <- c(oout$counts, total = sum(unlist(oout$counts)))
  oout$valuevars <- lapply(xreg2obj, function(x) x$valuevar)
  oout$coef   <- coef

  oout$coef_wfixed <- fullcoef <- data.frame(Estimate = c(coef, oout$fixed))

  if (NROW(fullcoef)) {
    fullcoef[, "Std. Error"] <- NA
    fullcoef$type <- rep(c("Fitted", "Fixed"), c(ncoef, nfixed))
    if (hessian) fullcoef[seq_len(ncoef), "Std. Error"] <- oout$SE
  }

  oout$full_coef  <- fullcoef
  oout$method     <- method
  oout$optim_time <- Sys.time() - optim_time_start
  class(oout)     <- "xreg2"
  oout
}
