#' Create an xreg2 control object
#'
#' @title Create xreg2 Control Object
#' @description Creates a control object specifying the model formula(s),
#'   likelihood function, gradient function, and starting values for one
#'   component of a joint \code{xreg2} model.
#'
#' @param formulas A formula or list of formulas. The left-hand side names the
#'   dependent (or intermediate) variable; the right-hand side is evaluated in
#'   the context of parameter values and data columns.
#' @param start_values Named numeric vector of starting values. An existing
#'   \code{xreg2} fitted object may be supplied; coefficients are extracted.
#' @param fixed_values Named numeric vector of parameter values held fixed
#'   during optimisation.
#' @param p_fun Log-likelihood function. Default \code{xreg2_cont_normal}.
#'   Must accept \code{(par, dtalist, ...)} and return a scalar.
#' @param grad_fun Gradient function. Default uses \code{numDeriv::grad} with
#'   method \code{"simple"}.
#' @param p_aggregation_fun Aggregation function applied to the likelihood
#'   data-frame. Rarely changed by users.
#' @param weights_var Character name of a column in the data used as
#'   observation weights. \code{NA} for unweighted.
#' @param name Optional character label for this component.
#' @param censor_bounds Numeric vector of length 2 giving lower and upper
#'   censoring bounds. Default \code{c(-Inf, Inf)} (no censoring).
#' @param lower Named numeric vector of lower parameter bounds (for
#'   bounded optimisers).
#' @param upper Named numeric vector of upper parameter bounds.
#'
#' @return An object of class \code{c("xreg2Control", "list")}.
#'
#' @seealso \code{\link{xreg2_fit}}, \code{\link{c.xreg2Control}}
#'
#' @examples
#' ctrl <- xreg2_control(
#'   formulas     = list(y ~ INTERCEPT + x * SLOPE),
#'   start_values = c(INTERCEPT = 0, SLOPE = 0),
#'   p_fun        = xreg2_cont_normal,
#'   name         = "continuous"
#' )
#'
#' @export
xreg2_control <- function(formulas,
                           start_values        = numeric(),
                           fixed_values        = numeric(),
                           p_fun               = xreg2_cont_normal,
                           grad_fun            = function(par, ...) numDeriv::grad(func = p_fun, x = par, method = "simple", ...),
                           p_aggregation_fun   = function(d_df) return(-d_df$p * d_df$internal_count),
                           weights_var         = NA,
                           name                = NA,
                           censor_bounds       = c(-Inf, Inf),
                           lower               = NA,
                           upper               = NA) {

  if (class(start_values)[1] %in% c("xreg", "xreg2")) start_values <- start_values$coef
  if (class(formulas)[1] %in% c("xreg2Control", "xreg2ControlList"))
    return(c(formulas))
  if (class(formulas)[1] == "formula")
    formulas <- list(formulas)

  required <- attr(x = p_fun, which = "required")

  defined_vars <- character()
  for (formula in formulas) {
    targetName   <- as.character(formula[[2]])
    defined_vars <- c(defined_vars, targetName)
  }

  if (length(required)) {
    req <- as.list(rep(0, length(required)))
    names(req) <- names(required)
    for (i in seq_along(required)) {
      if (!names(req)[i] %in% defined_vars) {
        defined_vars <- c(defined_vars, names(req)[i])
        req_return   <- required[[i]]
        formulas     <- c(formulas, list(req_return$formula))
        if (exists("start_values", req_return))
          start_values <- c(start_values,
                            req_return$start_values[!req_return$start_values %in% start_values])
        if (exists("fixed_values", req_return))
          fixed_values <- c(fixed_values,
                            req_return$fixed_values[!req_return$fixed_values %in% fixed_values])
      }
    }
  }

  start_values <- start_values[unique(names(start_values))]
  retObj <- mget(c(names(formals()), "defined_vars"))
  retObj$columnNames <- character()
  for (formula in formulas) {
    retObj$columnNames <- c(retObj$columnNames,
                            all.vars(formula)[!all.vars(formula) %in% retObj$columnNames])
  }
  retObj$columnNames <- retObj$columnNames[!retObj$columnNames %in% names(start_values)]
  class(retObj) <- c("xreg2Control", "list")
  return(retObj)
}

#' Combine xreg2Control objects into a list
#'
#' @title Combine xreg2 Control Objects
#' @description Combines one or more \code{xreg2Control} objects into an
#'   \code{xreg2ControlList} suitable for passing to \code{\link{xreg2_fit}}.
#'
#' @param ... One or more \code{xreg2Control} objects. Named arguments are
#'   used as component names; unnamed arguments use the object's \code{name}
#'   field or a sequential integer.
#'
#' @return An object of class \code{c("xreg2ControlList", "list")}.
#'
#' @seealso \code{\link{xreg2_control}}, \code{\link{xreg2_fit}}
#'
#' @examples
#' ctrl1 <- xreg2_control(formulas = list(y ~ INTERCEPT + x * SLOPE),
#'                         name = "component1")
#' cl    <- c(ctrl1)
#'
#' @export
c.xreg2Control <- function(...) {
  args <- list(...)

  if (is.null(names(args))) names(args) <- rep(NA_character_, length(args))
  for (i in seq_along(args)) {
    if (is.na(names(args)[i])) {
      if (is.na(args[[i]]$name)) {
        names(args)[i] <- as.character(i)
      } else {
        names(args)[i] <- args[[i]]$name
      }
    }
    if (!"xreg2Control" %in% class(args[[i]]))
      stop("At least one non-xreg2Control object among arguments.")
  }
  class(args) <- c("xreg2ControlList", "list")

  columnNames <- character()
  startValues <- numeric()
  fixedValues <- numeric()
  lower       <- numeric()
  upper       <- numeric()

  for (xreg2Control in args) {
    columnNames <- c(columnNames,
                     xreg2Control$columnNames[!xreg2Control$columnNames %in% columnNames])
    startValues <- c(startValues,
                     xreg2Control$start_values[!names(xreg2Control$start_values) %in% names(startValues)])
    fixedValues <- c(fixedValues,
                     xreg2Control$fixed_values[!names(xreg2Control$fixed_values) %in% names(fixedValues)])
    lower <- c(lower, xreg2Control$lower[!xreg2Control$lower %in% lower])
    upper <- c(upper, xreg2Control$upper[!xreg2Control$upper %in% upper])
  }

  attr(args, which = "columnNames") <- columnNames
  attr(args, which = "startValues") <- startValues
  attr(args, which = "fixedValues") <- fixedValues
  attr(args, which = "lower")       <- lower
  attr(args, which = "upper")       <- upper

  return(args)
}

#' @rdname c.xreg2Control
#' @export
c.xreg2ControlList <- function(...) {
  args <- list(...)
  for (narg in seq_along(args)) {
    class(args[[narg]]) <- "list"
  }
  return(do.call(c.xreg2Control, do.call(c, args)))
}
