#' @include internals.R
#' @include omit.action.R
#' @include procmod.frame.R
#' @include formula.procmod.frame.R
#'
NULL

.modelprocmodframe=function(term, row.names,
                            variables,varnames,
                            dots,dotnames,
                            subset, na.action) {

  stopifnot(is.list(variables))
  stopifnot(is.character(varnames))


  nvars = length(variables)

  stopifnot(nvars == length(varnames))

  stopifnot(is.list(dots))
  ndots = length(dots)
  stopifnot(ndots==length(dotnames))

  nactualdots = 0;

  for (i in seq_len(ndots))
    if (! is.null(dots[[i]])) nactualdots=nactualdots+1

  data = vector(mode="list", nvars + nactualdots)
  names= character(nvars + nactualdots)

  for (i in seq_len(nvars)) {
    data[[i]]=variables[[i]]
    names[i]=varnames[i]
  }

  j=1
  for (i in seq_len(ndots)) {
    if (! is.null(dots[[i]])) {
      if (nchar(dotnames[i]) + 3 > 256)
        stop(sprintf("overlong names in '%s'",dotnames[i]))
      buf=paste('(',dotnames[i],')',sep="")
      data[nvars + j]=dots[i]
      names[nvars + j]=buf
      j=j+1
    }
  }

  names(data)=names

  data$row.names=row.names
  data = do.call(ProcMod::procmod.frame,data)


  if (! is.null(subset) ) {
    if (is.numeric(subset))
      subset = which(seq_len(nrow(data)) %in% subset)
    if (is.character(subset))
      subset = which(rownames(data) %in% subset)

    data = subset(data,subset=subset)
  }

  if ( ! is.null(na.action)) {
    # some na.actions need this to distinguish responses from
    # explanatory variables

    attr(data,"terms",terms)

    if ( is.character(na.action) && length(na.action) > 0)
      na.action = match.fun(na.action[1]);

    ans = do.call(na.action,list(data))

    if ( !is.procmod.frame(ans) ||
         length(ans) != length(data))
      stop("invalid result from na.action")

  }
  else
    ans = data;

  return(ans)

}


#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
model.procmod.default = function (formula,
                                  data = NULL,
                                  subset = NULL,
                                  na.action = na.fail,
                                  drop.unused.levels = FALSE,
                                  xlev = NULL,
                                  ...)
{

  possible_newdata = !missing(data) &&
    is.procmod.frame(data) &&
    identical(substitute(data),
              quote(newdata)) &&
    (nr = nrow(data)) > 0


  if (!missing(formula) &&
      nargs() == 1 &&
      is.list(formula) &&
      !is.null(m <- formula$model))
    return(m)


  if (!missing(formula)
      && nargs() == 1 &&
      is.list(formula) &&
      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.procmod.default)
    env <- environment(formula$terms)
    if (is.null(env))
      env <- parent.frame()
    return(eval(fcall, env))
  }


  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)

  if (!inherits(formula, "terms"))
    formula <- terms(formula, data = data)


  env <- environment(formula)

  rownames <- .row_names_info(data, 0L)

  vars <- attr(formula, "variables")
  predvars <- attr(formula, "predvars")
  if (is.null(predvars))
    predvars <- vars

  varnames <- sapply(vars, function(x) paste(deparse(x, width.cutoff = 500),
                                             collapse = " "))[-1L]

  variables <- eval(predvars, data, env)
  resp <- attr(formula, "response")
  if (is.null(rownames) && resp > 0L) {
    lhs <- variables[[resp]]
    rownames <- rownames(lhs)
  }

  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"))) {
    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)

  subset <- eval(substitute(subset), data, env)

  data = .modelprocmodframe(formula, rownames,
                            variables,varnames,
                            extras, extranames,
                            subset, na.action)


  # if (length(xlev)) {
  #   for (nm in names(xlev)) if (!is.null(xl <- xlev[[nm]])) {
  #     xi <- data[[nm]]
  #     if (is.character(xi))
  #       xi <- as.factor(xi)
  #     if (!is.factor(xi) || is.null(nxl <- levels(xi)))
  #       warning(gettextf("variable '%s' is not a factor",
  #                        nm), domain = NA)
  #     else {
  #       ctr <- attr(xi, "contrasts")
  #       xi <- xi[, drop = TRUE]
  #       nxl <- levels(xi)
  #       if (any(m <- is.na(match(nxl, xl))))
  #         stop(sprintf(ngettext(length(m), "factor %s has new level %s",
  #                               "factor %s has new levels %s"), nm, paste(nxl[m],
  #                                                                         collapse = ", ")), domain = NA)
  #       data[[nm]] <- factor(xi, levels = xl, exclude = NULL)
  #       if (!identical(attr(data[[nm]], "contrasts"),
  #                      ctr))
  #         warning(gettext(sprintf("contrasts dropped from factor %s",
  #                                 nm), domain = NA), call. = FALSE)
  #     }
  #   }
  # }
  # else if (drop.unused.levels) {
  #   for (nm in names(data)) {
  #     x <- data[[nm]]
  #     if (is.factor(x) && length(unique(x[!is.na(x)])) <
  #         length(levels(x))) {
  #       ctr <- attr(x, "contrasts")
  #       data[[nm]] <- x[, drop = TRUE]
  #       if (!identical(attr(data[[nm]], "contrasts"),
  #                      ctr))
  #         warning(gettext(sprintf("contrasts dropped from factor %s due to missing levels",
  #                                 nm), domain = NA), call. = FALSE)
  #     }
  #   }
  # }

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

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
vars.procmod = function(object, data = environment(object),
                          xlev = NULL, ...) {
  t <- if (missing(data))
    terms(object)
  else terms(object, data = data)

  if (is.null(attr(data, "terms")))
    data <- model.procmod.default(object, data, xlev = xlev)
  else {
    deparse2 <- function(x) paste(deparse(x, width.cutoff = 500L),
                                  collapse = " ")
    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]
  }

  attr(data,"response")=attr(t, "response")

  return(data)
}

