#
#	quadclass.S
#
#	Class 'quad' to define quadrature schemes
#	in (rectangular) windows in two dimensions.
#
#	$Revision: 4.17 $	$Date: 2011/05/24 07:30:48 $
#
# An object of class 'quad' contains the following entries:
#
#	$data:	an object of class 'ppp'
#		defining the OBSERVATION window, 
#		giving the locations (& marks) of the data points.
#
#	$dummy:	object of class 'ppp'
#		defining the QUADRATURE window, 
#		giving the locations (& marks) of the dummy points.
#	
#	$w: 	vector giving the nonnegative weights for the
#		data and dummy points (data first, followed by dummy)
#
#		w may also have an attribute attr(w, "zeroes")
#               equivalent to (w == 0). If this is absent
#               then all points are known to have positive weights.
#
#       $param:
#               parameters that were used to compute the weights
#               and possibly to create the dummy points (see below).
#              
#       The combined (data+dummy) vectors of x, y coordinates of the points, 
#       and their weights, are extracted using standard functions 
#       x.quad(), y.quad(), w.quad() etc.
#
# ----------------------------------------------------------------------
#  Note about parameters:
#
#       If the quadrature scheme was created by quadscheme(),
#       then $param contains
#
#           $param$weight
#                list containing the values of all parameters
#                actually used to compute the weights.
#
#           $param$dummy
#                list containing the values of all parameters
#                actually used to construct the dummy pattern
#                via default.dummy();
#                or NULL if the dummy pattern was provided externally
#
#   If you constructed the quadrature scheme manually, this
#   structure may not be present.
#
#-------------------------------------------------------------

quad <- function(data, dummy, w, param=NULL) {
  
  data <- as.ppp(data)
  dummy <- as.ppp(dummy)

  n <- data$n + dummy$n
	
  if(missing(w))
    w <- rep(1, n)
  else {
    w <- as.vector(w)
    if(length(w) != n)
      stop("length of weights vector w is not equal to total number of points")
  }

  if(is.null(attr(w, "zeroes")) && any( w == 0))
	attr(w, "zeroes") <- (w == 0)

  Q <- list(data=data, dummy=dummy, w=w, param=param)
  class(Q) <- "quad"

  invisible(Q)
}

# ------------------ extractor functions ----------------------

x.quad <- function(Q) {
  verifyclass(Q, "quad")
  c(Q$data$x, Q$dummy$x)
}

y.quad <- function(Q) {
  verifyclass(Q, "quad")
  c(Q$data$y, Q$dummy$y)
}

w.quad <- function(Q) {
  verifyclass(Q, "quad")
  Q$w
}

param.quad <- function(Q) {
  verifyclass(Q, "quad")
  Q$param
}
 
n.quad <- function(Q) {
  verifyclass(Q, "quad")
  Q$data$n + Q$dummy$n
}

marks.quad <- function(x, dfok=FALSE, ...) {
  verifyclass(x, "quad")
  dat <- x$data
  dum <- x$dummy
  if(dfok) warning("ignored dfok = TRUE; not implemented")
  mdat <- marks(dat, dfok=FALSE, ...)
  mdum <- marks(dum, dfok=FALSE, ...)
  if(is.null(mdat) && is.null(mdum))
    return(NULL)
  if(is.null(mdat))
    mdat <- rep(NA, dat$n)
  if(is.null(mdum))
    mdum <- rep(NA, dum$n)
  mall <- c(mdat, mdum)
  if(is.factor(mdat) && is.factor(mdum) && all(levels(mdat) == levels(mdum))) {
    mall <- factor(mall)
    levels(mall) <- levels(mdat)
  }
  return(mall)
}

is.marked.quad <- function(X, na.action="warn", ...) {
  marx <- marks(X, ...)
  if(is.null(marx))
    return(FALSE)
  if(any(is.na(marx)))
    switch(na.action,
           warn = {
             warning(paste("some mark values are NA in the point pattern",
                           deparse(substitute(X))))
           },
           fatal = {
             return(FALSE)
           },
           ignore = {}
           )
  return(TRUE)
}

is.multitype.quad <- function(X, na.action="warn", ...) {
  marx <- marks(X, ...)
  if(is.null(marx))
    return(FALSE)
  if(any(is.na(marx)))
    switch(na.action,
           warn = {
             warning(paste("some mark values are NA in the point pattern",
                           deparse(substitute(X))))
           },
           fatal = {
             return(FALSE)
           },
           ignore = {}
           )
  return(!is.data.frame(marx) && is.factor(marx))
}

is.data <- function(Q) {
  verifyclass(Q, "quad")
  return(c(rep(TRUE, Q$data$n),
	   rep(FALSE, Q$dummy$n)))
}

equals.quad <- function(Q) {
    # return matrix E such that E[i,j] = (X[i] == U[j])
    # where X = Q$data and U = union.quad(Q)
    n <- Q$data$n
    m <- Q$dummy$n
    E <- matrix(FALSE, nrow=n, ncol=n+m)
    diag(E) <- TRUE
    E
}

equalsfun.quad <- function(Q) {
  stopifnot(inherits(Q, "quad"))
  return(function(i,j) { i == j })
}

equalpairs.quad <- function(Q) {
  # return two-column matrix E such that
  #     X[E[i,1]] == U[E[i,2]] for all i
  # where X = Q$data and U = union.quad(Q)
  n <- Q$data$n
  return(matrix(rep(1:n,2), ncol=2))
}
      
union.quad <- function(Q) {
  verifyclass(Q, "quad")
  ppp(x= c(Q$data$x, Q$dummy$x),
      y= c(Q$data$y, Q$dummy$y),
      window=Q$dummy$window,
      marks=marks.quad(Q),
      check=FALSE)
}
	
#
#   Plot a quadrature scheme
#
#
plot.quad <- function(x, ..., main=deparse(substitute(x)), dum=list()) {
  verifyclass(x, "quad")
  data <- x$data
  dummy <- x$dummy
  dummyplot <- function(x, ..., pch=".", add=TRUE) {
    plot(x, pch=pch, add=add, ...)
  }
  if(!is.marked(data)) {
    plot(data, main=main, ...)
    do.call("dummyplot", append(list(
                                     dummy,
                                     main=paste(main, "\n dummy points")
                                     ),
                                dum))
  } else if(is.multitype(data)) {
    oldpar <- par(ask = interactive() &&
            (.Device %in% c("X11", "GTK", "windows", "Macintosh")))
    on.exit(par(oldpar))
    data.marks <- marks(data)
    dummy.marks <- marks(dummy)
    types <- levels(data.marks)
    for(k in types) {
      maink <- paste(main, "\n mark = ", k, sep="")
      plot(unmark(data[data.marks == k]), main=maink, ...)
      do.call("dummyplot", append(list(unmark(dummy[dummy.marks == k])), dum))
    }
  } else {
    plot(data, ..., main=main)
    addplot <- function(x, ..., add=TRUE, main=deparse(substitute(x))) {
      plot(x, ..., main=main, add=add)
    }
    do.call("addplot", append(list(dummy), dum))
  }
  invisible(NULL)
}

# subset operator

"[.quad" <- function(x, ...) {
  U <- union.quad(x)
  Z <- is.data(x)
  w <- w.quad(x)
  # determine serial numbers of points to be included
  V <- U %mark% seq_len(U$n)
  i <- marks(V[...])
  # extract corresponding subsets of vectors
  Z <- Z[i]
  w <- w[i]
  # take subset of points, using any type of subset index
  U <- U[...]
  # stick together
  quad(U[Z], U[!Z], w)
}


unitname.quad <- function(x) {
  return(unitname(x$data))
}

"unitname<-.quad" <- function(x, value) {
  unitname(x$data) <- value
  unitname(x$dummy) <- value
  return(x)
}