#
#  update.ppm.R
#
#
#  $Revision: 1.29 $    $Date: 2010/01/25 19:37:34 $
#
#
#

update.ppm <- function(object, ..., fixdummy=TRUE, use.internal=NULL,
                                    envir=parent.frame()) {
  verifyclass(object, "ppm")

  newformula <- function(old, change, eold=object$callframe, enew=envir) {
    old <- if(is.null(old)) ~1 else eval(old, eold)
    change <- if(is.null(change)) ~1 else eval(change, enew)
    old <- as.formula(old, env=eold)
    change <- as.formula(change, env=enew)
    update.formula(old, change)
  }
  
  # inspect model
  antique <- summary(object, quick="no prediction")$antiquated
  if(antique)
    stop("Model was fitted by a very old version of spatstat; cannot be updated")
  call <- object$call
  if(!is.call(call))
    stop(paste("Internal error - object$call is not of class",
               sQuote("call")))

  undecided <- is.null(use.internal) || !is.logical(use.internal)
  force.int   <- !undecided && use.internal
  force.ext   <- !undecided && !use.internal
  if(!force.int) {
    # check for validity of format
    badformat <- damaged.ppm(object)
  }
  if(undecided) {
    use.internal <- badformat
    if(badformat)
      message("object format corrupted; repairing it")
  } else if(force.ext && badformat)
    warning("object format corrupted; try update(object, use.internal=TRUE)")
  
  if(use.internal) {
    # reset the main arguments in the call using the internal data
    call$Q <- data.ppm(object)
    namobj <- names(call)
    if("trend" %in% namobj) call$trend <- newformula(call$trend, object$trend)
    if("interaction" %in% namobj) call$interaction <- object$interaction
    if("covariates" %in% namobj) call$covariates <- object$covariates
  }
  
  # handle arguments
  aargh <- list(...)

  if(length(aargh) == 0) 
    return(eval(call, as.list(envir), enclos=object$callframe))

  Q.is.new <- FALSE
  
  # split named and unnamed arguments
  nama <- names(aargh)
  named <- if(is.null(nama)) rep(FALSE, length(aargh)) else (nama != "")
  namedargs <- aargh[named]
  unnamedargs <- aargh[!named]
  nama <- names(namedargs)
  
  if(any(named)) {
    # any named arguments that were also present in the original call
    # override their original values
    existing <- !is.na(match(nama, names(call)))
    for (a in nama[existing]) call[[a]] <- aargh[[a]]

    # add any named arguments not present in the original call
    if (any(!existing)) {
      call <- c(as.list(call), namedargs[!existing])
      call <- as.call(call)
    }
    # is the point pattern or quadscheme new ?
    if("Q" %in% nama)
      Q.is.new <- TRUE
  }
  if(any(!named)) {
    # some objects identified by their class
    if(n <- sp.foundclasses(c("ppp", "quad"), unnamedargs, "Q", nama)) {
      call$Q <- unnamedargs[[n]]
      Q.is.new <- TRUE
    }
    if(n<- sp.foundclass("interact", unnamedargs, "interaction", nama))
      call$interaction <- unnamedargs[[n]]
    if(n<- sp.foundclasses(c("data.frame", "im"), unnamedargs, "covariates", nama))
      call$covariates <- unnamedargs[[n]]
    if(n<- sp.foundclass("formula", unnamedargs, "trend", nama))
      call$trend <- newformula(call$trend, unnamedargs[[n]])
    else if(n <- sp.foundclass("character", unnamedargs, "trend", nama)) {
      # string that might be interpreted as a formula
      strg <- unnamedargs[[n]]
      if(!is.na(charmatch("~", strg))) {
        fo <- as.formula(strg)
        call$trend <- newformula(call$trend, fo)
      } 
    }
  }
  
  # *************************************************************
  # ****** Special action when Q is a point pattern *************
  # *************************************************************
  if(Q.is.new && fixdummy && inherits((X <- eval(call$Q)), "ppp")) {
    # Instead of allowing default.dummy(X) to occur,
    # explicitly create a quadrature scheme from X,
    # using the same dummy points and weight parameters
    # as were used in the fitted model 
    Qold <- quad.ppm(object)
    if(is.marked(Qold)) {
      dpar <- Qold$param$dummy
      wpar <- Qold$param$weight
      Qnew <- do.call("quadscheme", append(list(X), append(dpar, wpar)))
    } else {
      Dum <- Qold$dummy
      wpar <- Qold$param$weight
      Qnew <- do.call("quadscheme", append(list(X, Dum), wpar))
    }
    # replace X by new Q
    call$Q <- Qnew
  }

  # finally call ppm
  return(eval(call, as.list(envir), enclos=object$callframe))
}

sp.foundclass <- function(cname, inlist, formalname, argsgiven) {
  ok <- unlist(lapply(inlist, inherits, what=cname))
  nok <- sum(ok)
  if(nok > 1)
    stop(paste("I am confused: there are two unnamed arguments",
               "of class", sQuote(cname)))
  if(nok == 0) return(0)
  absent <- !(formalname %in% argsgiven)
  if(!absent)
    stop(paste("I am confused: there is an unnamed argument",
               "of class", sQuote(cname), "which conflicts with the",
               "named argument", sQuote(formalname)))
  theposition <- seq(ok)[ok]
  return(theposition)
}

sp.foundclasses <- function(cnames, inlist, formalname, argsgiven) {
  pozzie <- logical(length(cnames))
  for(i in seq(cnames))
    pozzie[i] <- sp.foundclass(cnames[i],  inlist, formalname, argsgiven)
  found <- (pozzie > 0)
  nfound <- sum(found)
  if(nfound == 0)
    return(0)
  else if(nfound == 1)
    return(pozzie[found])
  else
    stop(paste("I am confused: there are", nfound,
               "unnamed arguments of different classes (",
               paste(sQuote(cnames(pozzie[found])), collapse=", "),
               ") which could be interpreted as",
               sQuote(formalname)))
}
    

damaged.ppm <- function(object) {
  # guess whether the object format has been damaged
  # e.g. by dump/restore
  gf <- getglmfit(object)
  badfit <- !is.null(gf) && !inherits(gf$terms, "terms")
  if(badfit)
    return(TRUE)
  # escape clause for fake models
  if(identical(object$fake, TRUE))
    return(FALSE)
  # otherwise it was made by ppm
  Qcall <- object$call$Q
  cf <- object$callframe
  if(is.null(cf)) {
    # Old format of ppm objects
    if(is.name(Qcall) && !exists(paste(Qcall)))
      return(TRUE)
    Q <- eval(Qcall)
  } else {
    # New format of ppm objects
    if(is.name(Qcall) && !exists(paste(Qcall), cf))
      return(TRUE)
    Q <- eval(Qcall, cf)
  }
  badQ <- is.null(Q) || !(inherits(Q, "ppp") || inherits(Q,"quad"))
  return(badQ)
}