#' @include mprocuste.R
#'
NULL

#' Compute the Akaike Information criterion (AIC) for a procruste model.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
AIC.pm <- function(object, ..., k = length(object$coefficients)) {
  RSS <- sum(object$residuals^2)
  RSS <- object$TSS * (1 - sum(object$varpart))
  n <- nrow(object$fitted.values)
  return(n * log(RSS / n) + 2 * k)
}


#' Extract AIC from a Procrustean Fitted Model.
#'
#' Computes the (generalized) Akaike An Information Criterion for a fitted parametric model.
#'
#' @details This is the \code{\link[ProcMod]{pm}} method for the
#'    \code{\link[stats]{extractAIC}} generic function.
#'
#' The criterion used is
#'      \deqn{AIC = - 2*log L + k * edf},
#' where L is the likelihood and edf the equivalent degrees of freedom
#' (i.e., the number of free parameters for usual parametric models) of fit.
#'
#' k = 2 corresponds to the traditional AIC, using k = log(n) provides the BIC
#' (Bayesian IC) instead.
#'
#' @param fit	fitted model, the result of \code{link[ProcMod]{pm}}.
#' @param scale	optional numeric specifying the scale parameter of the model,
#'              see scale in \code{\link[stats]{step}}. \code{scale} specifies
#'              the estimate of the error variance, and \code{scale} = 0 indicates
#'              that it is to be estimated by maximum likelihood.
#' @param k	numeric specifying the ‘weight’ of the equivalent degrees
#'        of freedom (=: edf) part in the AIC formula.
#' @param ... further arguments (currently unused in base R).
#'
#' @seealso \code{\link[stats]{extractAIC}}
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
extractAIC.pm <- function(fit, scale=0, k = 2, ...) {
  n <- nrow(fit$residuals)
  edf <- n - fit$df.residual
  RSS <- deviance.pm(fit)
  dev <- if (scale > 0) RSS / scale - n
         else n * log(RSS / n)

  c(edf, dev + k * edf)
}



#' Extract Model Residuals.
#'
#' @description residuals is a generic function which extracts model
#'              residuals from objects returned by modeling functions.
#'              The abbreviated form resid is an alias for residuals.
#'              It is intended to encourage users to access object
#'              components through an accessor function rather than by
#'              directly referencing an object slot.
#'
#' @param obj    R object of class `pm`
#' @param type	 the type of residuals which should be returned.
#'               Can be abbreviated.
#'
#' @return Numeric matrix of n rows, where n is the number
#'         of observations.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
residuals.pm <- function(object, type = c(
                           "working", "response", "deviance",
                           "pearson", "partial"
                         ), ...) {
  type <- match.arg(type)
  r <- object$residuals
  res <- switch(type, working = , response = r, deviance = ,
    pearson = if (is.null(object$weights)) {
      r
    } else {
      sweep(r,
        MARGIN = 1,
        STATS = sqrt(object$weights),
        FUN = "*"
      )
    },
    partial = r
  )
  res <- naresid(object$na_action, res)
  if (type == "partial") {
    stop("'partial' residuals not yet implemented for procrustean models ")
    res <- res + predict(object, type = "terms")
  }
  res
}




#' Model Deviance for the procruste model.
#'
#' @description Returns the deviance of a fitted model object.
#'
#' @return The value of the deviance extracted from the object object.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
deviance.pm <- function(object, ...) {
  sum(weighted.residuals(object)^2, na.rm = TRUE)
}


#' @export
pm_stepAIC <- function(model, start = c("empty","full"),
                       scale = 0, direction = c("both", "backward", "forward"),
                       trace = 1, keep = NULL, steps = 1000, k = 2,
                       tol = 1e-07) {

  cov_mat <- model$cov
  cor_mat <- cov2cor(cov_mat)

  TSS <- model$TSS
  vmax <- ncol(cov_mat)
  usable <- if (length(model$weights) > 0) sum(model$weights > 0)
            else nrow(model$fitted.values)

  response = 1

  next_models <- function(current) {
     all <- 2:vmax

     model <- list(`  current` = current)

     if ((direction == "both" || direction == "forward")
         && length(current) < (vmax - 1)) {
       to_add <- setdiff(all, current)
       newm <- lapply(to_add, function(x) c(current,x))
       names(newm) <- paste0("+ ",rownames(cor_mat)[to_add])
       model <- c(model, newm)
     }

     if ((direction == "both" || direction == "backward")
         && length(current) > 0) {
       newm <- lapply(-(1:length(current)),
                                function(x) current[x])
       names(newm) <- paste0("- ",rownames(cor_mat)[current])
       model <- c(model, newm)
     }

     model
  }

  model_string <- function(xs) {
    paste0(rownames(cor_mat)[response],
           " ~ ",
           paste(if (length(xs) > 0) rownames(cor_mat)[sort(xs)]
                 else "0",
                 collapse = " + "))
  }

  cat(sprintf("Direction : %s\n",direction))

  current <- if (start == "full" || direction == "backward") 2:vmax
             else if (start == "empty" || direction == "forward") integer(0)
             else stop("bad combination of start and direction parametters")

  step <- 1
  bm <- ""

  while (step <= steps && bm !="  current"){

    mods <- next_models(current)
    AICs <- numeric(length = length(mods))
    edf  <- numeric(length = length(mods))

    for (mod in seq_along(mods)) {
      RSS <- TSS

      if (length(mods[[mod]]) > 0) {
          a <- c(response,mods[[mod]])
          cors <- cor_mat[a,a]
          YX <- cors[-1,1]
          Xs <- cors[-1,-1]
          RSS <- (1 - sum(qr.coef(qr(Xs, tol = tol),YX) * YX)) * TSS
        }

      AICs[mod] <- usable * log(RSS / usable) +
                            k * (length(mods[[mod]]) + 1)
    }

    cat(sprintf("current model : %s (AIC = %.3f)\n",
                model_string(mods[[1]]),
                AICs[1]))

    names(AICs) <- names(mods)
    bests <- order(AICs)

    for (b in bests) {
      cat(sprintf("     %-20s : %.3f\n", names(mods)[b], AICs[b]))
    }

    current <- mods[[bests[1]]]
    bm <- names(mods)[bests[1]]


    cat(sprintf("selected model : %s (AIC = %.3f)\n\n",
                model_string(current),
                AICs[bests[1]]))
  }
  #n * log(RSS / n) + k * edf

}
