#' @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 length.out  an interger value specifying the number of row
#'                    of the returned matrix
#'
#' @return a new matrix with the same number of columns but with `length.out`
#'         rows.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#'

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

  if ((length.out%%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) < length.out)
    rep = rbind(rep,x)

  return(rep)
}

.procmod_coerce_value = function(x,nrows=0) {
  xi <- if (is.data.frame(x))
    as.matrix(x)
  else if (is.matrix(x))
    x
  else
    as.matrix(x)

  dxi = dim(xi)
  if (is.null(dxi))
    dxi=c(1,1)

  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, length.out = nrows)
  else stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
                             "replacement has %d rows, data has %d"),
                    N, nrows),
            domain = NA)

  return(xi)
}

#' Build a 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)
{
  has.row.names    = ! missing(row.names)

  varnames = dots.names(...)

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

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

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

  names(value)=varnames

  types <- character(n)

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

    if (reorder.rows &&
        ! is.null(row.names) &&
        ! is.null(rownames(xi)))
      xi=xi[row.names,]

    nrows[i] <- nrow(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 == rownames(value[[i]])))
          stop("Row names among matrices are not consistant")
      }
    else
      for (i in seq_len(n))
        rownames(value[[i]])=row.names
  }
  else
    for (i in seq_len(n))
      rownames(value[[i]])=NULL

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


#' Check if an object is a Matrix Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
is.procmod.frame = function(x) {
  inherits(x, "procmod.frame")
}

#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @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,...) {
  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]]

  do.call(procmod.frame,l,...)
}

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

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

  if (!is.null(value)) {
    value=.procmod_coerce_value(value,nrows)
    N <- nrow(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)

  }

  rownames(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) m[i,,drop=FALSE])
  }
  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)
}
