#' @include internals.R
#' @include omit_action.R
#' @include procmod_frame.R
#' @include formula_procmod_frame.R
#' @include multivariate.R
#'
#'
NULL

#' Converts a R object to a matrix usable in a procrustean model.
#'
#' @param x the R object to be converted
#' @param ... supplementary parametters used by some version of that method.
#'
#' @return a numeric matrix
#'
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as_procmod_data_matrix <- function(x, ...) {
  UseMethod("as_procmod_data_matrix",x)
}

#' @examples
#'     l <- matrix(sample(c(FALSE,TRUE),
#'                        size = 12,
#'                        replace = TRUE),
#'                 nrow = 4)
#'
#'    as_procmod_data_matrix(l)
#'
#' @rdname as_procmod_data_matrix
#' @export
as_procmod_data_matrix.logical <- function(x, ...) {
  xd <- dim(x)
  nc <- colnames(x)
  nr <- rownames(x)

  x <- as.numeric(x)

  dim(x) <- xd
  colnames(x) <- nc
  rownames(x) <- nr

  x
}

#' @examples
#'     n <- matrix(rnorm(12),
#'                 nrow = 4)
#'
#'     d <-dist(n)
#'     as_procmod_data_matrix(d)
#'
#' @rdname as_procmod_data_matrix
#' @export
as_procmod_data_matrix.dist <- function(x, ...) {
  ortho(x)
}

#' @examples
#'     n <- matrix(rnorm(12),
#'                 nrow = 4)
#'
#'     as_procmod_data_matrix(n)
#'
#' @rdname as_procmod_data_matrix
#' @export
as_procmod_data_matrix.numeric <- function(x, ...) {
  x
}

#' @examples
#'     d <- as.data.frame(matrix(rnorm(12),
#'                        nrow = 4))
#'     d$f <- factor(sample(c("A","B","C"),
#'                          4,
#'                          replace=TRUE),
#'                   levels = c("A","B","C","D"))
#'     as_procmod_data_matrix(d)
#'
#' @rdname as_procmod_data_matrix
#' @export
as_procmod_data_matrix.data.frame <- function(x, contrasts = NULL, ...) {
  convert_column <- function(col,name) {
    if (is.character(col)) {
      col <- as.factor(col)
    }

    if (is.factor(col)) {
      a <- attributes(col)
      ctr <- if (is.null(a$contrasts)) contrasts
             else a$contrasts

      col <-  if (is.null(ctr)) {
                stats::contrasts(col)[col, ,drop = FALSE]
              } else if (is.character(ctr) || is.function(ctr)) {
                col <- match.fun(ctr, descend = FALSE)(levels(col))[col, ,drop = FALSE]
              } else if (is.matrix(ctr)) {
                ctr[col, ,drop = FALSE]
              } else stop("cannot convert a factor to a contrast matrix")

      n_col <- colnames(col)

      if (is.null(n_col)) n_col <- as.character(1:ncol(col))
      colnames(col) <- paste0(name,":",n_col)

    } else if (is.logical(col)) {
      col <- as.numeric(col)
    }

    if (!is.numeric(col)) stop('cannot convert a column to numeric type')

    col
  }

  mat <- do.call(cbind,
                 mapply(convert_column,x,colnames(x),
                        SIMPLIFY = FALSE))

  rownames(mat) <- rownames(x)

  mat
}

#' Computes interaction matrix.
#'
#' In the procrotean models \code{\link[ProcMod]{pm}}, interactions
#' between explicative matrix are treated as adding an interaction
#' matrix to the model. An interaction matrix is computed by first,
#' aligning the matrix with the smaller number of columns to the other
#' using procrustean rotation, then both matrices are multiplied using the
#' Hadamar product.
#'
#' @param data1 the first matrix involved in the interaction
#' @param data2 the second matrix involved into the interaction
#'
#' @return a numeric matrix corresponding to the interaction matrix
#'
#' @examples
#'
#'     d1 <- as.data.frame(matrix(rnorm(12),
#'                        nrow = 4))
#'     d1$f <- factor(sample(c("A","B","C"),
#'                          4,
#'                          replace=TRUE),
#'                   levels = c("A","B","C","D"))
#'
#'     n <- matrix(rnorm(12),
#'                 nrow = 4)
#'
#'     d2 <-dist(n)
#'
#'     procmod_interaction_matrix(d1,d2)
#'
#' @export
procmod_interaction_matrix <- function(data1,data2) {
  data1 <- ortho(as_procmod_data_matrix(data1))
  data2 <- ortho(as_procmod_data_matrix(data2))

  nc1 <- ncol(data1)
  nc2 <- ncol(data2)

  if (nc1 > nc2) {
    temp <- data1
    data1 <- data2
    data2 <- temp
  }

  data1 <- protate(data1,data2)

  data1 * data2
}

.MFclass <- function(x) {
    if (is.logical(x))
        return("logical")
    if (is.ordered(x))
        return("ordered")
    if (is.factor(x))
        return("factor")
    if (is.data.frame(x))
        return("data.frame")
    if (is.character(x))
        return("character")
    if (is.matrix(x) && is.numeric(x))
        return(paste0("nmatrix.", ncol(x)))
    if (inherits(x,"dist"))
      if (ProcMod::is_euclid(x, tol = 1e-7))
          return("dist.metric")
      else
          return("dist.dissimilarity")
    if (is.numeric(x))
        return("numeric")
    return("other")
}

.deparse2 <- function(x) {
  paste(deparse(x,
    width.cutoff = 500L,
    backtick = !is.symbol(x) && is.language(x)
  ),
  collapse = " "
  )
}

#' Extracting the ProcMod Frame from a Formula or Fit.
#'
#' \code{procmod_model}, if the equivalent of \code{\link[stats]{model.frame}}
#' for Procrustean models. It creates a design (or model)
#' \code{\link[ProcMod]{procmod_frame}}, with the variables needed to use
#' formula and any ... arguments.
#'
#' @param formula	a model \code{formula} or \code{terms} object or an R object.
#' @param ...	for \code{procmod_model} methods, a mix of further arguments such
#'   as data, na.action, subset to pass to the default method. Any additional
#'   arguments (such as offset and weights or other named arguments) which reach
#'   the default method are used to create further columns in the model frame,
#'   with parenthesised names such as "(offset)".
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
procmod_model <- function(formula,...) {
  UseMethod("procmod_model",formula)
}


#' @param formula
#'
#' @param data an optional procmod frame, list or environment (or object
#'   coercible by \code{\link[ProcMod]{as_procmod_frame}} to a procmod frame)
#'   containing the variables in the model. If not found in data, the variables
#'   are taken from environment(formula), typically the environment from which
#'   \code{pm} is called.
#'
#' @param subset subset	an optional vector specifying a subset of observations
#'   to be used in the fitting process.
#'
#' @param na_action a function which indicates what should happen when the data
#'   contain NAs. The default is set by the \code{na.action} setting of
#'   \code{\link[base]{options}}, and is \code{\link[stats]{na.fail}} if that is
#'   unset. The ‘factory-fresh’ default is \code{\link[stats]{na.omit}}. Another
#'   possible value is NULL, no action. Value \code{\link[stats]{na.exclude}} can
#'   be useful.
#'
#' @param drop.unused.levels should factors have unused levels dropped? Defaults
#'   to FALSE.
#' @param ...
#'
#' @rdname procmod_model
#' @export
procmod_model.terms <- function(formula,
                                data = NULL,
                                subset = NULL,
                                na_action = na.fail,
                                drop.unused.levels = FALSE,
                                ...) {

  possible_newdata <- !missing(data) &&
                      is_procmod_frame(data) &&
                      identical(
                        substitute(data),
                        quote(newdata)
                      ) &&
                      (nr <- nrow(data)) > 0


  #
  # na_action is first set to the na_action parameter if provided
  #           secondly set to the na_action of data if defined
  #           secondly to the global na.action option if defined
  #           lastly to the default na.fail
  #
  if (missing(na_action)) {
    if (!is.null(naa <- attr(data, "na_action")) &
        mode(naa) != "numeric") {
      na_action <- naa
    } else if (!is.null(naa <- getOption("na.action"))) {
      na_action <- naa
    }
  }

  env <- environment(formula)

  # Get the row names for the data
  rownames <- .siteNames(data[[1]])

  # Retreive a list of all used variables
  vars <- attr(formula, "variables")



  predvars <- attr(formula, "predvars")

  if (is.null(predvars)) {
    predvars <- vars
  }

  # Retreive the name of the variable
  varnames <- sapply(vars, .deparse2)[-1L]

  # retreive the list of the values corresponding to each variable
  variables <- eval(predvars, data, env)

  resp <- attr(formula, "response")

  if (is.null(rownames) && resp > 0L) {
    lhs <- variables[[resp]]
    rownames <- .siteNames(lhs)
  }

  # Print a warning message if the new values for
  # variables have not the good size

  if (possible_newdata &&
      length(variables)) {
    nr2 <- max(sapply(variables, NROW))
    if (nr2 != nr) {
      warning(sprintf(paste0(
        ngettext(nr, "'newdata' had %d row",
                 "'newdata' had %d rows"),
        " ",
        ngettext(
          nr2,
          "but variable found had %d row",
          "but variables found have %d rows"
        )
      ),
      nr, nr2),
      call. = FALSE,
      domain = NA)
    }
  }

  if (is.null(attr(formula, "predvars"))) {
    # We mainly deal with scaled predictor
    # For models with an explicit call to scale
    for (i in seq_along(varnames)) {
      predvars[[i + 1L]] <- makepredictcall(
        variables[[i]],
        vars[[i + 1L]]
      )
    }
    attr(formula, "predvars") <- predvars
  }

  extras <- substitute(list(...))

  extranames <- names(extras[-1L])
  extras <- eval(extras, data, env)

  # Evaluate the subset expression if needed
  subset <- eval(substitute(subset), data, env)

  nvars <- length(variables)

  nextras <- length(extras)
  nactualextras <- sum(!vapply(extras, is.null, TRUE))

  alldata <- vector(mode = "list", nvars + nactualextras)
  allnames <- character(nvars + nactualextras)

  alldata[1:nvars]  <- variables[1:nvars]
  allnames[1:nvars] <- varnames[1:nvars]

  j <- nvars + 1
  for (i in seq_len(nextras)) {
    if (!is.null(extras[[i]])) {
      if (nchar(extranames[i]) + 3 > 256) {
        stop(sprintf("overlong names in '%s'", extranames[i]))
      }
      buf <- paste("(", extranames[i], ")", sep = "")
      alldata[[j]] <- .procmod_coerce_value(extras[[i]])
      allnames[j] <- buf
      j <- j + 1
    }
  }

  names(alldata) <- allnames

  alldata$row_names <- rownames
  alldata <- do.call(procmod_frame,alldata)

  if (!is.null(subset)) {
    if (is.numeric(subset)) {
      subset <- which(seq_len(nrow(alldata)) %in% subset)
    }
    if (is.character(subset)) {
      subset <- which(rownames(alldata) %in% subset)
    }

    alldata <- subset(alldata, subset = subset)
  }

  if (!is.null(na_action)) {
    # some na_actions need this to distinguish responses from
    # explanatory variables

    attr(alldata, "terms") <- terms

    if (is.character(na_action) && length(na_action) > 0) {
      na_action <- match.fun(na_action[1])
    }

    ans <- na_action(alldata)

    if (!is_procmod_frame(ans) ||
      length(ans) != length(alldata)) {
      stop("invalid result from na_action")
    }
  }
  else {
    ans <- alldata
  }


######

  if (drop.unused.levels) {
    for (i in seq_along(ans)) {
      v = ans[[i]]
      if (is.data.frame(v) || is.factor(v)) {
        v <- droplevels(v)
        ans[[i]] <- v
      }
    }
  }



  attr(formula, "dataClasses") <- vapply(ans, .MFclass, "")
  attr(ans, "terms") <- formula
  ans

}

#' @rdname procmod_model
#' @export
procmod_model.formula <- function(formula,
                                  data = NULL,
                                  subset = NULL,
                                  na_action = na.fail,
                                  drop.unused.levels = FALSE,
                                  ...) {


  if (missing(data))         data <- environment(formula)
  if (!is.environment(data)) data <- as_procmod_frame(data)

  formula <- terms(formula, data = data)

  env <- environment(formula)
  if (is.null(env)) env <- parent.frame()

  if (is.environment(data)) {
    data <- as_procmod_frame(eval(attr(formula, "variables"),
                                  envir = env))
  }

  fcall <- match.call()
  fcall[[1]] <- quote(procmod_model)
  fcall$formula <- quote(formula)
  fcall$data <- quote(data)


  eval(fcall)
}

#' @rdname procmod_model
#' @export
procmod_model.pm <- function(formula,...) {
  if (nargs() == 1) {

    #
    # looks if provided formula contains
    # a model and returns it
    #
    if (!is.null(formula$model)) return(formula$model)

    #
    # looks if provided formula contains
    # a term and a call attributs
    #
    if (all(c("terms", "call") %in% names(formula))) {

      fcall <- formula$call

      m <- match(c("formula", "data",
                   "subset", "weights",
                   "na_action"),
                 names(fcall),
                 0)

      fcall <- fcall[c(1, m)]
      fcall[[1L]] <- quote(procmod_model)
      env <- environment(formula$terms)

      if (is.null(env)) {
        env <- parent.frame()
      }

      return(eval(fcall, env))

    }

  }

}

#' @rdname procmod_model
#' @export
procmod_model.default <- function(formula,
                                  data = NULL,
                                  subset = NULL,
                                  na_action = na.fail,
                                  drop.unused.levels = FALSE,
                                  ...) {

  warning("You are using the procmod_model.default function")

  possible_newdata <- !missing(data) &&
                      is_procmod_frame(data) &&
                      identical(
                        substitute(data),
                        quote(newdata)
                      ) &&
                      (nr <- nrow(data)) > 0



  if (missing(formula)) {

    if (!missing(data)
        && inherits(data, "procmod_frame")
        && length(attr(data, "terms"))) {
      return(data)
    }

    formula <- as.formula(data)
  }
  else if (missing(data)
           && inherits(formula, "procmod.frame")) {

    if (length(attr(formula, "terms"))) {
      return(formula)
    }

    data <- formula
    formula <- as.formula(data)
  }

  formula <- as.formula(formula)


  if (missing(na_action)) {
    if (!is.null(naa <- attr(data, "na_action")) &
      mode(naa) != "numeric") {
      na_action <- naa
    } else if (!is.null(naa <- getOption("na.action"))) {
      na_action <- naa
    }
  }

  if (missing(data)) {
    data <- environment(formula)
  } else if (!is_procmod_frame(data) &&
    !is.environment(data) &&
    !is.null(attr(data, "class"))) {
    data <- as_procmod_frame(data)
  } else if (is.array(data)) {
    data <- as_procmod_frame(data)
  }

}


#' Plays the role of model.matrix in classical lm
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
vars_procmod <- function(object,
                         data = environment(object),
                         ...) {
  t <- if (missing(data)) {
    terms(object)
  } else {
    terms(object, data = data)
  }


  if (is.null(attr(data, "terms"))) {
    data <- procmod_model.default(object, data)
  } else {
    reorder <- match(vapply(attr(t, "variables"),
                            .deparse2,"")[-1L],
                     names(data))
    if (anyNA(reorder)) {
      stop("model frame and formula mismatch in model.matrix()")
    }
    if (!identical(reorder, seq_len(ncol(data)))) {
      data <- data[, reorder, drop = FALSE]
    }
  }


  data <- as_procmod_frame(lapply(data, as_procmod_data_matrix))


  factors <- attr(t, "factors")
  response <- attr(t, "response")

  matrices <- vector(mode="list", ncol(factors))

  for (i in seq_len(ncol(factors))) {
    ms <- data[factors[, i] > 0, drop = FALSE]

    m  <- ms[[1]]
    nms <- length(ms)
    if (nms > 1)
      for (j in 2:nms)
        m <- procmod_interaction_matrix(m,ms[[j]])
    matrices[[i]] <- m
  }

  names(matrices) <- attr(t, "term.labels")
  matrices <- as_procmod_frame(matrices)

  attr(matrices, "response") <- attr(t, "response")

  matrices
}

model_matrix.pm <- function(object,
                            data = environment(object),
                            contrasts.arg = NULL,
                            ...) {

  t <- if (missing(data)) terms(object)
       else terms(object, data = data)

  if (is.null(attr(data, "terms"))) {
    data <- procmod_model.default(object, data, xlev = xlev)
  } else {
      reorder <- match(vapply(attr(t, "variables"),
                              .deparse2,
                              ""
                             )[-1L], names(data))
    if (anyNA(reorder)) {
      stop("model frame and formula mismatch in model.matrix()")
    }
    if (!identical(reorder, seq_len(ncol(data)))) {
      data <- data[, reorder, drop = FALSE]
    }
  }
  int <- attr(t, "response")

  if (length(data)) {
    contr.funs <- as.character(getOption("contrasts"))
    namD <- names(data)
    for (i in namD) {
      if (is.character(data[[i]])) {
        data[[i]] <- factor(data[[i]])
      }
    }
    isF <- vapply(
      data, function(x) is.factor(x) || is.logical(x),
      NA
    )
    isF[int] <- FALSE
    isOF <- vapply(data, is.ordered, NA)
    for (nn in namD[isF]) {
      if (is.null(attr(data[[nn]], "contrasts"))) {
        contrasts(data[[nn]]) <- contr.funs[1 + isOF[nn]]
      }
    }
    if (!is.null(contrasts.arg) && is.list(contrasts.arg)) {
      if (is.null(namC <- names(contrasts.arg))) {
        stop("invalid 'contrasts.arg' argument")
      }
      for (nn in namC) {
        if (is.na(ni <- match(nn, namD))) {
          warning(gettextf(
            "variable '%s' is absent, its contrast will be ignored",
            nn
          ), domain = NA)
        } else {
          ca <- contrasts.arg[[nn]]
          if (is.matrix(ca)) {
            contrasts(data[[ni]], ncol(ca)) <- ca
          } else {
            contrasts(data[[ni]]) <- contrasts.arg[[nn]]
          }
        }
      }
    }
  }
  else {
    isF <- FALSE
    data[["x"]] <- raw(nrow(data))
  }
  ans <- .External2(C_modelmatrix, t, data)
  cons <- if (any(isF)) {
    lapply(data[isF], attr, "contrasts")
  }
  attr(ans, "contrasts") <- cons
  ans
}
