# superimpose.R
#
# $Revision: 1.36 $ $Date: 2016/10/17 06:48:25 $
#
#
############################# 

superimpose <- function(...) {
  # remove any NULL arguments
  arglist <- list(...)
  if(any(isnull <- sapply(arglist, is.null)))
    return(do.call(superimpose, arglist[!isnull]))
  UseMethod("superimpose")
}

superimpose.default <- function(...) {
  argh <- list(...)
  #' First expand any arguments which are lists of objects
  argh <- expandSpecialLists(argh, "solist")
  #' Now dispatch
  if(any(sapply(argh, is.lpp)) || any(sapply(argh, inherits, what="linnet")))
    return(do.call(superimpose.lpp, argh))
  if(any(sapply(argh, is.psp)))
    return(do.call(superimpose.psp, argh))
  #' default
  return(do.call(superimpose.ppp, argh))
}

superimpose.ppp <- function(..., W=NULL, check=TRUE) {
  arglist <- list(...)
  # Check that all "..." arguments have x, y coordinates
  hasxy <- unlist(lapply(arglist, checkfields, L=c("x", "y")))
  if(!all(hasxy)) {
    nbad <- sum(bad <- !hasxy)
    stop(paste(ngettext(nbad, "Argument", "Arguments"),
               commasep(which(bad)),
               ngettext(nbad, "does not", "do not"),
               "have components x and y"),
         call.=FALSE)
  }
  
  # concatenate lists of (x,y) coordinates
  XY <- do.call(concatxy, arglist)
  needcheck <- TRUE

  # determine whether there is any window information
  if(!is.owin(W)) {
    # we have to compute the final window
    WXY <- NULL
    Wppp <- NULL
    if(any(isppp <- unlist(lapply(arglist, is.ppp)))) {
      # extract windows from ppp objects
      wins <- unname(lapply(arglist[isppp], as.owin))
      # take union
      Wppp <- if(length(wins) == 1) wins[[1]] else do.call(union.owin, wins)
    } 
    if(is.function(W)) {
      # W is a function like bounding.box.xy or ripras
      # Apply function to the x,y coordinates; it should return an owin
      WXY <- W(XY)
      if(!is.owin(WXY))
        stop("Function W did not return an owin object", call.=FALSE)
    }
    if(is.character(W)) {
      # character string identifies a function
      pW <- pmatch(W, c("convex", "rectangle", "bbox", "none"))
      if(is.na(pW))
        stop(paste("Unrecognised option W=", sQuote(W)), call.=FALSE)
      WXY <- switch(pW,
                    convex=ripras(XY),
                    rectangle=ripras(XY, shape="rectangle"),
                    bbox=boundingbox(XY),
                    none=NULL)
      # in these cases we don't need to verify that the points are inside.
      needcheck <- !is.null(WXY)
    }
    if(is.null(WXY) && is.null(Wppp)) {
      # no window information
      return(XY)
    }
    W <- union.owin(WXY, Wppp)
  }
  # extract the marks if any
  nobj <- lengths(lapply(arglist, getElement, name="x"))
  marx  <- superimposeMarks(arglist, nobj)
  #
  ppp(XY$x, XY$y, window=W, marks=marx, check=check & needcheck)
}

superimpose.splitppp <- superimpose.ppplist <-
  function(..., W=NULL, check=TRUE) {
    arglist <- list(...)
    while(any(h <- sapply(arglist, inherits, what=c("splitppp", "ppplist")))) {
      i <- min(which(h))
      arglist <- insertinlist(arglist, i, arglist[[i]])
    }
    do.call(superimpose, append(arglist, list(W=W, check=check)))
  }

superimpose.psp <- function(..., W=NULL, check=TRUE) {
  # superimpose any number of line segment patterns
  arglist <- list(...)
  misscheck <- missing(check)

  if(!all(sapply(arglist, is.psp)))
    stop("Patterns to be superimposed must all be psp objects", call.=FALSE)

  # extract segment coordinates
  matlist <- lapply(lapply(arglist, getElement, name="ends"),
                    asNumericMatrix)
  
  # tack them together
  mat <- do.call(rbind, matlist)

  # determine whether there is any window information
  needcheck <- FALSE
  if(!is.owin(W)) {
    # we have to compute the final window
    WXY <- NULL
#    Wpsp <- NULL
    if(any(ispsp <- unlist(lapply(arglist, is.psp)))) {
      # extract windows from psp objects
      wins <- unname(lapply(arglist[ispsp], as.owin))
      # take union
      Wppp <- if(length(wins) == 1) wins[[1]] else do.call(union.owin, wins)
    }
    if(is.function(W) || is.character(W)) {
      # guess window from x, y coordinates
      XY <- list(x=cbind(mat[,1], mat[,3]),
                 y=cbind(mat[,2], mat[,4]))
      if(is.function(W)) {
        # W is a function like bounding.box.xy or ripras
        # Apply function to the x,y coordinates; it should return an owin
        WXY <- W(XY)
        if(!is.owin(WXY))
          stop("Function W did not return an owin object", call.=FALSE)
      }
      if(is.character(W)) {
        # character string identifies a function
        pW <- pmatch(W, c("convex", "rectangle", "bbox", "none"))
        if(is.na(pW))
          stop(paste("Unrecognised option W=", sQuote(W)), call.=FALSE)
        WXY <- switch(pW,
                      convex=ripras(XY),
                      rectangle=ripras(XY, shape="rectangle"),
                      bbox=boundingbox(XY),
                      none=NULL)
      # in these cases we don't need to verify that the points are inside.
        needcheck <- !is.null(WXY)
      }
    }
    W <- union.owin(WXY, Wppp)
  }
  
  # extract marks, if any
  nobj <- sapply(arglist, nsegments)
  marx <- superimposeMarks(arglist, nobj)

  if(misscheck && !needcheck) check <- FALSE
  return(as.psp(mat, window=W, marks=marx, check=check))
}

superimposeMarks <- function(arglist, nobj) {
  # combine marks from the objects in the argument list
  marxlist <- lapply(arglist, marks)
  marx <- do.call(markappend, unname(marxlist))
  nama <- names(arglist)
  if(length(nama) == length(arglist) && all(nzchar(nama))) {
    # arguments are named: use names as (extra) marks
    newmarx <- factor(rep.int(nama, nobj), levels=nama)
    marx <- markcbind(marx, newmarx)
    if(ncol(marx) == 2) {
      ## component marks were not named: call them 'origMarks'
      colnames(marx) <- c("origMarks", "pattern")
    } else colnames(marx)[ncol(marx)] <- "pattern"
  }
  return(marx)
}

#==+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===

  # This function is now deprecated.
superimposePSP <-
  function(..., W=NULL, check=TRUE)
{
  .Deprecated("superimpose","spatstat")
  
  # superimpose any number of line segment patterns
  arglist <- list(...)

  nargue <- length(arglist)
  if(nargue == 0)
    stop("No line segment patterns given", call.=FALSE)
  
  # catch possible abuses
  if(is.null(W) && any(suspicious <- (names(arglist) == "window"))) {
    id <- min(which(suspicious))
    Win <- arglist[[id]]
    if(is.owin(Win) || is.null(Win)) {
      W <- Win
      arglist <- arglist[-id]
      nargue <- length(arglist)
    }
  }

  # unpack a list
  if(nargue == 1) {
    X <- arglist[[1]]
    if(!inherits(X, "psp") && inherits(X, "list"))
      arglist <- X
  }

  isnull <- unlist(lapply(arglist, is.null))
  arglist <- arglist[!isnull]
  
  if(!all(unlist(lapply(arglist, is.psp))))
    stop("Some of the arguments are not psp objects", call.=FALSE)
  
  # extract segment coordinates
  matlist <- lapply(arglist, function(x) { as.matrix(x$ends) })
  # tack them together
  mat <- do.call(rbind, matlist)

  # extract marks if any
  marxlist <- lapply(arglist, marks)

  # check on compatibility of marks
  mkfmt <- sapply(marxlist,markformat)
  if(length(unique(mkfmt))>1)
	stop(paste("The marks of the point patterns have different formats:",
                   commasep(sQuote(mkfmt))),
             call.=FALSE)
  mkfmt <- mkfmt[1]
  if(mkfmt=="dataframe") {
	mcnms <- lapply(marxlist,names)
	cdim  <- lengths(mcnms)
	OK    <- length(unique(cdim)) == 1
	if(OK) {
		allInOne <- sapply(mcnms,paste,collapse="")
		OK <- length(unique(allInOne)) == 1
		if(!OK)
                  stop("Data frames of marks have different names", call.=FALSE)
	} else stop("Data frames of marks have different column dimensions",
                    call.=FALSE)
  }
 
  # combine the marks
  marx <- switch(mkfmt,
                 none = NULL,
                 vector = {
                   marxlist <- lapply(marxlist,
                                      as.data.frame.vector,
                                      nm="v1")
                   do.call(rbind, marxlist)[,1]
                 },
                 dataframe = do.call(rbind, marxlist))

  # determine window
  if(!is.null(W))
    W <- as.owin(W)
  else {
    # extract windows from psp objects
    Wlist <- lapply(arglist, as.owin)
    # take the union of all the windows
    W <- NULL
    for(i in seq_along(Wlist))
      W <- union.owin(W, Wlist[[i]])
  }

  return(as.psp(mat, window=W, marks=marx, check=check))
}