#' @include internals.R
NULL

#' Internal function repeating a matrix.
#'
#' @description repeats several times the rows of a matrix
#'              to create a new matrix with more rows. The
#'              final row count must be a multiple of the
#'              initial row count
#'
#' @param x  The matrix to replicate
#' @param nrow  an interger value specifying the number of row
#'                    of the returned matrix
#'
#' @return a new matrix with the same number of columns but with `nrow`
#'         rows.
#'
#' @author Eric Coissac <eric.coissac@metabarcoding.org>
#' @author Christelle Gonindard-Melodelima <christelle.gonindard@metabarcoding.org>
#' @rdname internal.rep_matrix
#'

.rep_matrix = function(x,nrow) {
  N = nrow(x)

  if ((nrow %% N != 0L))
    stop(sprintf("The size of the longest object (%d) is not a multiple of the size of the shortest (%d)",
                 nrows,N),
         domain = NA)

  rep=x
  while (nrow(rep) < nrow)
    rep = rbind(rep,x)

  return(rep)
}

#' Internal function coercing the data to a matrix.
#'
#' @description Transforme the \code{x} value into a \code{numeric matrix} of
#'              the correct size or into a \code{dist} object.
#'
#' @param x  The data to coerce
#' @param nrows  an interger value specifying the number of row
#'               of the returned matrix
#'
#' @return a new numeric matrix with correct size.
#'
#' @author Eric Coissac <eric.coissac@metabarcoding.org>
#' @author Christelle Gonindard-Melodelima <christelle.gonindard@metabarcoding.org>
#' @rdname internal.procmod_coerce_value
#'
.procmod_coerce_value = function(x,nrows=0,contrasts=NULL) {
  xi <- if (is.data.frame(x))
            as.matrix(x)
        else if (is.matrix(x) || inherits(x,'dist'))
            x
        else if (is.factor(x)) {
            if (is.null(contrasts))
              contrasts(x)[x,]
            else if (is.character(contrasts) || is.function(contrasts))
              match.fun(contrasts,descend=FALSE)(x)[x,]
            else
              contrasts[x,]
        }
        else
            as.matrix(x)

  if (! (is.matrix(xi) || inherits(x,'dist')))
    stop('Value cannot be coerced to a Matrix')

  if (is.matrix(xi)) {
    dxi=dim(xi)
    rownamesi = rownames(xi)
    colnamesi = colnames(xi)

    xi  = as.numeric(xi)

    dim(xi)=dxi
    rownames(xi) = rownamesi
    colnames(xi) = colnamesi

    N = nrow(xi)

    if (nrows > 0L && N < nrows) {
      if (N > 0L && (nrows %% N == 0L))
        xi <- .rep_matrix(xi, nrow = nrows)
      else stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
                                 "replacement has %d rows, data has %d"),
                        N, nrows),
                domain = NA)
    }
  }
  else {
    N = attr(xi,"Size")
    if (nrows > 0L && N != nrows) {
      stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
                            "replacement has %d rows, data has %d"),
                   N, nrows),
           domain = NA)
    }
  }

  return(xi)
}

.siteNames = function(x) {
  if (inherits(x,'dist'))
    attr(x,'Labels')
  else
    rownames(x)
}

`.siteNames<-` = function(x,value) {
  if (inherits(x,'dist')) {
    stopifnot(is.null(value) || length(value)==attr(x,'Size'))
    attr(x,'Labels')=value
  }
  else
    rownames(x)=value

  x
}


.siteCount = function(x) {
  if (inherits(x,'dist'))
    attr(x,'Size')
  else
    nrow(x)
}


.siteSelect = function(x,select) {
  if (inherits(x,'dist'))
    as.dist(as.matrix(x)[select,select,drop=FALSE])
  else
    x[select,,drop=FALSE]

}


#' The procmod.frame data structure.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
procmod.frame = function(...,
                         row.names = NULL,
                         check.rows = FALSE,
                         check.names = TRUE,
                         reorder.rows = FALSE,
                         contrasts.arg = NULL)
{
  has.row.names    = ! missing(row.names)

  varnames = dots.names(...)

  x <- list(...)
  n <- length(x)

#  message(x)
#  message(n)
#  message(row.names)

  if ((! has.row.names || is.null(row.names)) && n >= 1)
    row.names = .siteNames(x[[1]])

  nrows <- integer(n)
  value <- vector(mode = "list", length = n)

  names(value)=varnames

  types <- character(n)

  for (i in seq_len(n)) {
    contrasts = contrasts.arg[varnames[i]]
    if (i==1)
      xi <- .procmod_coerce_value(x[[i]],
                                  contrasts=contrasts)
    else
      xi <- .procmod_coerce_value(x[[i]],
                                  nrows = nrows[1],
                                  contrasts=contrasts)

    if (reorder.rows &&
        ! is.null(row.names) &&
        ! is.null(.siteNames(xi)))
      xi=.siteSelect(xi,row.names)

    nrows[i] <- .siteCount(xi)
    value[[i]]=xi
  }

  stopifnot(all(nrows[i]==nrows))
  # message(row.names," : ",length(row.names),",",nrows[i])
  if (length(row.names)==nrows[i]) {
    attr(value,"row.names")=row.names
    if (check.rows)
      for (i in seq_len(n)) {
        if (! all(row.names == .siteNames(value[[i]])))
          stop("Row names among matrices are not consistant")
      }
    else
      for (i in seq_len(n))
        .siteNames(value[[i]])=row.names
  }
  else
    for (i in seq_len(n))
      .siteNames(value[[i]])=NULL

  return(make_subS3Class(value, "procmod.frame"))
}

#'
#' Check if an object is a ProcMod Frame.
#'
#' @rdname procmod.frame
#' @export
is.procmod.frame = function(x) {
  inherits(x, "procmod.frame")
}

#'
#' Coerce to a ProcMod Frame.
#'
#' @rdname procmod.frame
#' @export
as.procmod.frame = function(data,...) {
  UseMethod("as.procmod.frame",data)
}

#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.list = function(data,...) {
  data=c(data,list(...))
  do.call(procmod.frame,data)
}

#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.procmod.frame = function(data,...) {
  data
}

#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.array = function(data,...) {
  di = dim(data)
  stopifnot(length(di)==3)

  l = lapply(seq_len(di[3]),
             function(i) data[,,i])

  if (length(attr(data,"dimnames"))==3)
    names(l)=attr(data,"dimnames")[[3]]

  data=c(l,list(...))

  do.call(procmod.frame,l)
}

#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.pm = function(data,...) {
  vars.procmod(terms(data),data$model)
}

#' Dimensions of a Matrix Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
dim.procmod.frame = function(x)
  return(c(.siteCount(x[[1]]),length(x)))

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`[[<-.procmod.frame` = function (x, i, value)
{
  cl = class(x)
  nrows=.siteCount(x)
  class(x)="list"

  if (!is.null(value)) {
    value=.procmod_coerce_value(value,nrows)
    N <- .siteCount(value)

    if (N > nrows)
      stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
                            "replacement has %d rows, data has %d"),
                   N, nrows),
           domain = NA)

    if (N < nrows)
      stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
                            "replacement has %d rows, data has %d"),
                   N, nrows),
           domain = NA)

  }

  .siteNames(value)=attr(x,"row.names")

  x[[i]] <- value
  class(x)=cl

  return(x)
}

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`$<-.procmod.frame` = function (x, name, value) {
  x[[name]] <- value
  return(x)
}

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`[.procmod.frame` = function (x, i, j,
                              drop = TRUE)
{
  has.j    = !missing(j)
  has.i    = !missing(i)
  has.drop = !missing(drop)
  Narg = nargs() - 2 + (has.i | has.j | has.drop) - has.drop

  # message("Nargs = ",Narg," i:",has.i," j:",has.j," drop:",has.drop)

  if (!all(names(sys.call()) %in% c("", "drop")))
    warning("named arguments other than 'drop' are discouraged")


  if (! has.i && ! has.j)
      # Case 1 : X[]
      return(x)
  else if (! has.i && has.j) {
    # Case 2 : X[,j] ou x[i]
    # message('Case 2 : X[,j]')
      y <- as.list(x)[j]
  }
  else if ( has.i && Narg==1) {
    # Case 3 : X[,j] ou x[i]
    # message('Case 3 : X[i]')
    y <- as.list(x)[i]
  }
  else if ( has.i && !has.j && Narg>1) {
    # Case 4 : X[i,]
    # message('Case 4 : X[i,]')
    y = lapply(x, function(m) .siteSelect(m,i))
  }
  else if ( has.i && has.j ) {
    # message('Case 5 : X[i,j]')
    y = x[j,drop=FALSE]
    y = y[i,,drop=FALSE]
  }

  if (drop && length(y)==1L)
    y = y[[1]]
  else {
    y = make_subS3Class(y, "procmod.frame")
    attr(y,"row.names")=rownames(y[[1]])
  }

  return(y)
}

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
subset.procmod.frame = function (x, subset, select, drop = FALSE, ...)
{
  r <- if (missing(subset))
    rep_len(TRUE, nrow(x))
  else {
    e <- substitute(subset)
    r <- eval(e, x, parent.frame())
    if (!is.logical(r))
      stop("'subset' must be logical")
    r & !is.na(r)
  }
  vars <- if (missing(select))
    TRUE
  else {
    nl <- as.list(seq_along(x))
    names(nl) <- names(x)
    eval(substitute(select), nl, parent.frame())
  }
  x[r, vars, drop = drop]
}

#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.list.procmod.frame = function(x, ...) {
  class(x)='list'
  return(x)
}
