# superimpose.R
#
# $Revision: 1.24 $ $Date: 2011/05/18 09:18:35 $
#
#
############################# 

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

superimpose.ppp <- superimpose.default <- 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"))
  }
  
  # 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")
    }
    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)))
      WXY <- switch(pW,
                    convex=ripras(XY),
                    rectangle=ripras(XY, shape="rectangle"),
                    bbox=bounding.box.xy(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 <- sapply(arglist, function(x) { length(x$x) })
  marx  <- superimposeMarks(arglist, nobj)
  #
  ppp(XY$x, XY$y, window=W, marks=marx, check=check & needcheck)
}



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

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

  # extract segment coordinates
  matlist <- lapply(arglist, function(x) { as.matrix(x$ends) })
  # 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")
      }
      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)))
        WXY <- switch(pW,
                      convex=ripras(XY),
                      rectangle=ripras(XY, shape="rectangle"),
                      bbox=bounding.box.xy(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)

  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(nama, nobj))
    marx <- markcbind(marx, newmarx)
  }
  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")
  
  # 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")
  
  # 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("Marks of some patterns are of different format\n",
                   "  from those of other patterns.\n",sep=""))
  mkfmt <- mkfmt[1]
  if(mkfmt=="dataframe") {
	mcnms <- lapply(marxlist,names)
	cdim  <- sapply(mcnms,length)
	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.\n")
	} else stop("Data frames of marks have different column dimensions.\n")
  }
 
  # combine the marks
  marx <- switch(mkfmt,
                 none = NULL,
                 vector = {
                   marxlist <- lapply(marxlist,
                                      function(x){as.data.frame.vector(x,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))
}