#
assign("est.variogram",
function(point.obj,pair.obj,a1,a2) {

#  est.variogram takes a "point" object, point.obj, and a "pair" object, pair.obj,
#  calculates empirical variogram estimates.


#  The result is an object of type "variogram" with 4 components: $lags, 
#  $classic, $robust, and $n.
#
#  $lags - lag category
#  $bins - distance bins for plotting
#  $classic - the classic variogram estimator
#  $robust - the robust variogram estimator
#  $med - the median estimator
#  $n - the number of pairs in the lag

  if (!inherits(point.obj,"point")) stop('Point.obj must be of class, "point".\n')

  if (!inherits(pair.obj,"pair")) stop('Pair.obj must be of class, "pair".\n')

  if(missing(a1)) stop('Must enter at least one attribute.\n')
  if(missing(a2)) a2 <- a1

  a1 <- point.obj[[match(a1,names(point.obj))]]
  a2 <- point.obj[[match(a2,names(point.obj))]]

# Allocate some space...
  lags    <- sort(unique(pair.obj$lags))
  classic <- rep(0,length(lags))
  robust  <- rep(0,length(lags))
  med     <- rep(0,length(lags))
  n       <- rep(0,length(lags))

  diff <- a1[pair.obj$from]-a2[pair.obj$to]
  bo   <- split(diff,pair.obj$lags)

# this fails sometimes:
#  tmp<-unique(pair.obj$lags[-which.na(pair.obj$lags)])
# so do this:
  if (any(is.na(pair.obj$lags))) 
     tmp <- unique(pair.obj$lags[-which.na(pair.obj$lags)])
  else 
     tmp <- unique(pair.obj$lags)

  for (i in c(1:length(tmp))) {
#  for (i in unique(pair.obj$lags)) {
    n[i] _ length(bo[[i]][!is.na(bo[[i]])])

#   classic, see Matheron
    classic[i] <- sum((bo[[i]])^2,na.rm=T) / n[i]

#   robust & med, see Cressie, 1990
    robust[i] <- (sum(abs(bo[[i]])^.5,na.rm=T) / n[i] )^4 / (0.457 + (0.494/n[i]))
    med[i] <- (median(abs(bo[[i]])^.5,na.rm=T))^4 / (0.457 + (0.494/n[i]))
#    med[i] <- median(abs(bo[[i]]),na.rm=T)
  }    
  o.variogram <- data.frame(lags,bins=c(pair.obj$bins,recursive=T),classic,
                      robust,med,n=n)
  class(o.variogram) <- c("variogram","data.frame")
  return(o.variogram)

})

provide(sgeostat)
assign("export.point",
function(point.obj, filename) {

  if (!inherits(point.obj,"point")) stop('point.obj must be of class, "point".\n')

  cat(paste(paste(names(point.obj),collapse=","),'\n',collapse=""), file=filename)

  line <- NULL
  for (i in 1:(length(point.obj$x))) {
    for (j in 1:length(names(point.obj))) {
      line <- paste(line,(round(point.obj[[j]],digits=7))[i], collapse=",",sep=",")
    }
    cat(paste(line,'\n',collapse="",sep=""),file=filename,append=T)
  }

})
assign("fit.exponential",
function(v.object,c0=NULL,ce=NULL,ae=NULL,type='c',iterations=10,
         tolerance=.000001,echo=F,plot.it=F,weighted=T){
  # This program fits a univariate exponential model to an empirical variogram
  # estimate.  The SEMI variogram model is the model fit...

  if (!inherits(v.object,"variogram")) stop('v.object must be of class, "variogram".\n')

  if (is.null(c0) & is.null(ce) & is.null(ae)) estimate.initial <- T
  else estimate.initial <- F

  if ( !estimate.initial & (is.null(c0) | is.null(ce) | is.null(ae)))
    stop('c0, ce, and ae must all be entered.\n')

# Interpret the "type" argument...
  if (type == 'c') empgamma <- v.object$classic /2
  else if (type == 'r') empgamma <- v.object$robust /2
  else if (type == 'm') empgamma <- v.object$med /2
  else stop("type must be 'c', 'r', or 'm'.\n")

# Set up the first derivative functions for each of the parameters...
# dc0 = 1
  dce <- function(h,ae) { return(1-exp(-h/ae)) }
  dae <- function(h,ce,ae) { return(-ce*h/(ae^2)*
                              exp(-h/ae))}

# Set up the variogram function...
  exponential.v <- function(h,parameters)
                   ifelse(h==0,0,
                   parameters[1] + parameters[2]*(1-exp(-h/parameters[3])))

# Get the number of observations and the bins (h's)...
  numobs <- v.object$n
  h      <- v.object$bins

# If any numobs is 0, get rid of that lag...
  empgamma <- empgamma[numobs>0]
  h <- h[numobs>0]
  numobs <- numobs[numobs>0]

# Start the sums of squares at 0...
  rse <- 0

# Begin iterations...
  parameters <- c(c0,ce,ae)
  cat('Initial parameter estimates: ',parameters,'\n')
  loop <- T
  converge <- F
  i <- 1

# Plot it before we start if requested...
  if (plot.it) {
    v.m.object <- list(parameters=parameters,
                       model= exponential.v
                      )
    attr(v.m.object,'class') <- 'variogram.model'
    attr(v.m.object,'type') <- 'exponential'

    plot(v.object,v.m.object,type=type)
  }

  while (loop) {
    cat('Iteration:',i,'\n')
# establish the Y vector...
    y <- (empgamma - exponential.v(h,parameters))

# establish the x matrix...
    xmat <- cbind(rep(1,length(h)),
                  dce(h,parameters[3]), 
                  dae(h,parameters[2],parameters[3]))

# establish the weights (Cressie, p. 99)...
    if(weighted) {
      w <- numobs/(exponential.v(h,parameters))^2
      }
    else {
#      w <- (1:length(numobs))
      w <- rep(1,length(numobs))
      }
   
    if(echo) cat('  X matrix:\n')
    if(echo) print(cbind(y,xmat,w))
    if(echo) cat('\n\n')    

    fit <- lsfit(xmat,y,wt=w,intercept=F)

# calculate the new parameter estimates...
    parameters.old <- parameters
    parameters <- fit$coef + parameters
    parameters <- ifelse(parameters>0,parameters,.000001)
    cat('Gradient vector: ',fit$coef,'\n')
    cat('New parameter estimates: ',parameters,'\n\n')

# Check for convergence, see if the sum of squares has converged
    rse.old <- rse
    rse <- sum(fit$residuals^2)
    rse.dif <- rse-rse.old

# Check for convergence of parmeters...
    parm.dist <- sqrt(sum((parameters-parameters.old)^2))

    cat('rse.dif = ',rse.dif,'(rse =',rse,')  ;  parm.dist = ',parm.dist,'\n\n')
#    cat('rse.dif = ',rse.dif,'(rse =',rse,')\n\n')
#    if(rse.dif < tolerance & parm.dist < tolerance) {
    if(abs(rse.dif) < tolerance) {
      loop <- F
      converge <- T
      cat('Convergence achieved by sums of squares.\n')
    }

    i <- i+1
    if (i>iterations) {
      loop <- F
    }
    v.m.object <- list(parameters=parameters,
                       model= exponential.v
                      )
    attr(v.m.object,'class') <- 'variogram.model'
    attr(v.m.object,'type') <- 'exponential'
    if (plot.it)
      plot(v.object,v.m.object,type=type)
  }
  if (converge) 
    cat('Final parameter estimates: ',parameters,'\n\n')
  else
    cat('Convergence not achieved!\n')
  

  v.m.object <- list(parameters=parameters,
                     model= exponential.v
                    )
  attr(v.m.object,'class') <- 'variogram.model'
  attr(v.m.object,'type') <- 'exponential'

  return(v.m.object)
  
})
assign("fit.gaussian",
function(v.object,c0=NULL,cg=NULL,ag=NULL,type='c',iterations=10,
         tolerance=.000001,echo=F,plot.it=F,weighted=T){
  # This program fits a univariate gaussian model to an empirical variogram
  # estimate.  The SEMI variogram model is the model fit...

  if (!inherits(v.object,"variogram")) stop('v.object must be of class, "variogram".\n')

  if (is.null(c0) & is.null(cg) & is.null(ag)) estimate.initial <- T
  else estimate.initial <- F

  if ( !estimate.initial & (is.null(c0) | is.null(cg) | is.null(ag)))
    stop('c0, cg, and ag must all be entered.\n')

# Interpret the "type" argument...
  if (type == 'c') empgamma <- v.object$classic /2
  else if (type == 'r') empgamma <- v.object$robust /2
  else if (type == 'm') empgamma <- v.object$med /2
  else stop("type must be 'c', 'r', or 'm'.\n")

# Set up the first derivative functions for each of the parameters...
# dc0 = 1
  dcg <- function(h,ag) { return(1-exp(-h^2/ag^2)) }
  dag <- function(h,cg,ag) { return(-2*cg*h^2/(ag^3)*
                              exp(-h^2/ag^2))}

# Set up the variogram function...
  gaussian.v <- function(h,parameters)
                   ifelse(h==0,0,
                   parameters[1] + parameters[2]*(1-exp(-h^2/parameters[3]^2)))

# Get the number of observations and the bins (h's)...
  numobs <- v.object$n
  h      <- v.object$bins

# If any numobs is 0, get rid of that lag...
  empgamma <- empgamma[numobs>0]
  h <- h[numobs>0]
  numobs <- numobs[numobs>0]

# Start the sums of squares at 0...
  rse <- 0

# Begin iterations...
  parameters <- c(c0,cg,ag)
  cat('Initial parameter estimates: ',parameters,'\n')
  loop <- T
  converge <- F
  i <- 1

# Plot it before we start if requested...
  if (plot.it) {
    v.m.object <- list(parameters=parameters,
                       model= gaussian.v
                      )
    attr(v.m.object,'class') <- 'variogram.model'
    attr(v.m.object,'type') <- 'gaussian'

    plot(v.object,v.m.object,type=type)
  }

  while (loop) {
    cat('Iteration:',i,'\n')
# establish the Y vector...
    y <- (empgamma - gaussian.v(h,parameters))

# establish the x matrix...
    xmat <- cbind(rep(1,length(h)),
                  dcg(h,parameters[3]), 
                  dag(h,parameters[2],parameters[3]))

# establish the weights (Cressie, p. 99)...
    if(weighted) {
      w <- numobs/(gaussian.v(h,parameters))^2
      }
    else {
#      w <- (1:length(numobs))
      w <- rep(1,length(numobs))
      }
   
    if(echo) cat('  X matrix:\n')
    if(echo) print(cbind(y,xmat,w))
    if(echo) cat('\n\n')    

    fit <- lsfit(xmat,y,wt=w,intercept=F)

# calculate the new parameter estimates...
    parameters.old <- parameters
    parameters <- fit$coef + parameters
    parameters <- ifelse(parameters>0,parameters,.000001)
    cat('Gradient vector: ',fit$coef,'\n')
    cat('New parameter estimates: ',parameters,'\n\n')

# Check for convergence, see if the sum of squares has converged
    rse.old <- rse
    rse <- sum(fit$residuals^2)
    rse.dif <- rse-rse.old

# Check for convergence of parmeters...
    parm.dist <- sqrt(sum((parameters-parameters.old)^2))

    cat('rse.dif = ',rse.dif,'(rse =',rse,')  ;  parm.dist = ',parm.dist,'\n\n')
#    cat('rse.dif = ',rse.dif,'(rse =',rse,')\n\n')
#    if(rse.dif < tolerance & parm.dist < tolerance) {
    if(abs(rse.dif) < tolerance) {
      loop <- F
      converge <- T
      cat('Convergence achieved by sums of squares.\n')
    }

    i <- i+1
    if (i>iterations) {
      loop <- F
    }
    v.m.object <- list(parameters=parameters,
                       model= gaussian.v
                      )
    attr(v.m.object,'class') <- 'variogram.model'
    attr(v.m.object,'type') <- 'gaussian'
    if (plot.it)
      plot(v.object,v.m.object,type=type)
  }
  if (converge) 
    cat('Final parameter estimates: ',parameters,'\n\n')
  else
    cat('Convergence not achieved!\n')
  

  v.m.object <- list(parameters=parameters,
                     model= gaussian.v
                    )
  attr(v.m.object,'class') <- 'variogram.model'
  attr(v.m.object,'type') <- 'gaussian'

  return(v.m.object)
  
})
assign("fit.linear",
function(v.object,type='c',plot.it=F){
  # This program fits a univariate linear model to an empirical variogram
  # estimate.  The SEMI variogram model is the model fit...

  if (!inherits(v.object,"variogram")) stop('v.object must be of class, "variogram".\n')

# Interpret the "type" argument...
  if (type == 'c') empgamma <- v.object$classic /2
  else if (type == 'r') empgamma <- v.object$robust /2
  else if (type == 'm') empgamma <- v.object$med /2
  else stop("type must be 'classic', 'robust', or 'median'.\n")

# Set up the variogram function...
  linear.v <- function(h,parameters)
                   ifelse(h==0,0,
                   parameters[1] + parameters[2]*h)

# Get the number of observations and the bins (h's)...
  numobs <- v.object$n
  h      <- v.object$bins

# If any numobs is 0, get rid of that lag...
  empgamma <- empgamma[numobs>0]
  h <- h[numobs>0]
  numobs <- numobs[numobs>0]


  fit <- lsfit(h,empgamma)
  parameters <- fit$coef
  v.m.object <- list(parameters=parameters,
                     model= linear.v
                    )
  attr(v.m.object,'class') <- 'variogram.model'
  attr(v.m.object,'type') <- 'linear'
  if (plot.it)
    plot(v.object,v.m.object)

  return(v.m.object)
  
})
"fit.spherical" <-
function (v.object, c0 = NULL, cs = NULL, as = NULL, type = "c", 
        iterations = 10, tolerance = 1e-06, echo = F, plot.it = F, 
        weighted = T, delta = 0.1) 
{
        # This program fits a univariate spherical model to an empirical variogram
        # estimate.  The SEMI variogram model is the model fit...
        if (!inherits(v.object, "variogram")) 
                stop("v.object must be of class, \"variogram\".\n")
        if (is.null(c0) & is.null(cs) & is.null(as)) 
                estimate.initial <- T
        else estimate.initial <- F
        # Interpret the "type" argument...
        if (!estimate.initial & (is.null(c0) | is.null(cs) | 
                is.null(as))) 
                stop("c0, cs, and as must all be entered.\n")
        if (type == "c") 
                empgamma <- v.object$classic/2
        else if (type == "r") 
                empgamma <- v.object$robust/2
        else if (type == "m") 
                empgamma <- v.object$med/2
        else stop("type must be \'c\', \'r\', or \'m\'.\n")
        # Set up the variogram function...
        spherical.v <- function(h, parameters) ifelse(h == 0, 
                0, ifelse(h <= parameters[3], parameters[1] + 
                        parameters[2] * (3/2 * h/parameters[3] - 
                                1/2 * (h/parameters[3])^3), parameters[1] + 
                        parameters[2]))
        # Set up the first derivative functions for each of the parameters...
        # dc0 = 1
        # differences, not derivatives
        dcs <- function(h, p, p1) {
                return((spherical.v(h, p) - spherical.v(h, c(p[1], 
                        p1[2], p[3])))/(p[2] - p1[2]))
        }
        das <- function(h, p, p1) {
                return((spherical.v(h, p) - spherical.v(h, c(p[1], 
                        p[2], p1[3])))/(p[3] - p1[3]))
        }
        # Get the number of observations and the bins (h's)...
        numobs <- v.object$n
        h <- v.object$bins
        # If any numobs is 0, get rid of that lag...
        empgamma <- empgamma[numobs > 0]
        h <- h[numobs > 0]
        numobs <- numobs[numobs > 0]
        # Start the sums of squares at 0...
        rse <- 0
        # Begin iterations...
	# initial estimates:
        parameters <- c(c0, cs, as)
        # need two initial parameter estimates to calculate differences
	# second = first + first * delta %)
        parameters1 <- c(c0, cs, as) * (1 + delta/100)
        cat("Initial parameter estimates: \n first:", parameters, "\n second:", 
                parameters1,"\n")
        loop <- T
        converge <- F
        i <- 1
        # Plot it before we start if requested...
        if (plot.it) {
                v.m.object <- list(parameters = parameters, model = spherical.v)
                attr(v.m.object, "class") <- "variogram.model"
                attr(v.m.object, "type") <- "spherical"
                plot(v.object, v.m.object, type = type)
        }
        while (loop) {
                cat("Iteration:", i, "\n")
                # establish the Y vector...
                y <- (empgamma - spherical.v(h, parameters))
                # establish the x matrix...
                xmat <- cbind(rep(1, length(h)), dcs(h, parameters, 
                        parameters1), das(h, parameters, parameters1))
                # establish the weights (Cressie, p. 99)...
                if (weighted) {
                        w <- numobs/(spherical.v(h, parameters))^2
                }
                else {
                #        w <- (1:length(numobs))
                  w <- rep(1,length(numobs))
                }
                if (echo) 
                        cat("  X matrix:\n")
                if (echo) 
                        print(cbind(y, xmat, w))
                if (echo) 
                        cat("\n\n")
                fit <- lsfit(xmat, y, wt = w, intercept = F)
                # calculate the new parameter estimates...
                parameters.old <- parameters
                parameters <- fit$coef + parameters
                parameters <- ifelse(parameters > 0, parameters, 
                        1e-06)
                cat("Gradient vector: ", fit$coef, "\n")
                cat("New parameter estimates: ", parameters, 
                        "\n\n")
                # Check for convergence, see if the sum of squares has converged
                rse.old <- rse
                rse <- sum(fit$residuals^2)
                rse.dif <- rse - rse.old
                # Check for convergence of parmeters...
                parm.dist <- sqrt(sum((parameters - parameters.old)^2))
                cat("rse.dif = ", rse.dif, "(rse =", rse, ")  ;  parm.dist = ", 
                        parm.dist, "\n\n")
                #    cat('rse.dif = ',rse.dif,'(rse =',rse,')\n\n')
                #    if(rse.dif < tolerance & parm.dist < tolerance) {
                if (abs(rse.dif) < tolerance) {
                        loop <- F
                        converge <- T
                        cat("Convergence achieved by sums of squares.\n")
                }
                i <- i + 1
                if (i > iterations) {
                        loop <- F
                }
                v.m.object <- list(parameters = parameters, model = spherical.v)
                attr(v.m.object, "class") <- "variogram.model"
                attr(v.m.object, "type") <- "spherical"
                if (plot.it) 
                        plot(v.object, v.m.object, type = type)
                parameters1 <- parameters
                parameters <- parameters.old
        }
        if (converge) 
                cat("Final parameter estimates: ", parameters1, 
                        "\n\n")
        else cat("Convergence not achieved!\n")
        v.m.object <- list(parameters = parameters1, model = spherical.v)
        attr(v.m.object, "class") <- "variogram.model"
        attr(v.m.object, "type") <- "spherical"
        return(v.m.object)
}

assign("fit.trend",
function (point.obj,at,np=2,plot.it=T) {
  if (!inherits(point.obj,"point")) stop('Point.Obj must be of class, "point".\n')

  if(missing(at)) stop('Must enter at least one attribute.\n')

  z <- point.obj[[match(at,names(point.obj))]]

  X <- point.obj$x
  Y <- point.obj$y
  P <- ((np + 1) * (np + 2))/2
  mat <- matrix(1, length(X), P)
  dimnames(mat) <- list(NULL, c("const", rep("", P - 1)))
  ip <- 0
  if(np > 0)
    for(i in (0:np)) {
      for(j in (0:(np - i))) {
        ip <- ip + 1
        mat[, ip] <- X^j * Y^i
        dimnames(mat)[[2]][ip] <- paste("x^", j, " y^", 
        i, sep = "")
      }
    }
  if(length(z) != length(X))
    stop("lengths of x and z must match")
  z.qr <- qr(mat)
  R <- qr.R(z.qr)
  beta <- qr.coef(z.qr, z)
  W <- qr.resid(z.qr, z)
  ts <- structure(list(beta = beta, R = R,  np = np,
    x = X, y = Y, z = z, residuals = W), class = "trend.surface")

  if(plot.it) {
    n <- 25 # a density of 25x25
    tr.mat<-trend.matrix(ts,min(X),max(X),min(Y),max(Y),30)
#    points(perspp(X,Y,z,
#      persp(trend.matrix(ts,min(X),max(X),min(Y),max(Y),30))))
    contour(tr.mat$x,tr.mat$y,tr.mat$z)
    points(X,Y)
  }
    
  return(ts)
})

assign("trend.matrix",
function (ts.obj,xl,xu,yl,yu,n) {

# Adapted from Ripley's Trmat function...
  if(!inherits(ts.obj, "trend.surface"))
    stop("object not a fitted trend surface")
  dx <- (xu - xl)/n
  dy <- (yu - yl)/n
  x <- seq(xl, xu, dx)
  y <- seq(yl, yu, dx)
  z <- matrix(nrow = length(x), ncol = length(y))
  for(i in 1:length(y))
    z[, i] <- trend.value(ts.obj, x, rep(y[i], length(x)))
  invisible(list(x = x, y = y, z = z))
})

assign("trend.value",
function (ts.obj,x,y) {

# Adapted from Ripley's Trval function...
  if(length(x) != length(y))
    stop("lengths of x and y must match")
  degree <- ts.obj$np
  P <- ((degree + 1) * (degree + 2))/2
  mat <- matrix(1, length(x), P)
  ip <- 0
  if(degree > 0)
    for(i in (0:degree)) {
      for(j in (0:(degree - i))) {
        ip <- ip + 1
        mat[, ip] <- x^j * y^i
      }
    }
  as.vector(mat %*% ts.obj$beta)

})
# Versuch ...
"prediction.matrix"<-function (point.obj, v1, var.mod.object,
			       xl,xu,yl,yu,n,maxdist=NULL){
  if(!inherits(point.obj, "point"))
    stop("object not a point object")
  if(!inherits(var.mod.object, "variogram.model"))
    stop("object not a variogram.model object")
  dx <- (xu - xl)/n
  dy <- (yu - yl)/n
  x <- seq(xl, xu, dx)
  y <- seq(yl, yu, dx)
  z <- matrix(nrow = length(x), ncol = length(y))
  
  for(i in 1:length(y)){
    for(j in 1:length(x)){
      predpnt<-point(data.frame(x=x[j],y=y[i]))
      predpnt<- krige(predpnt,point.obj,v1,var.mod.object,maxdist)
      z[j, i]<-predpnt$zhat
    }
    invisible(list(x = x, y = y, z = z))
  }
}
fit.variogram<-function(model="exponential", ...){
        switch(model,
               exponential = fit.exponential(...),
               gaussian = fit.gaussian(...),
               wave = fit.wave(...),
               linear = fit.linear(...),
               spherical = fit.spherical(...)
		)
}
assign("fit.wave",
function(v.object,c0=NULL,cw=NULL,aw=NULL,type='c',iterations=10,
         tolerance=.00001,echo=F,plot.it=F,weighted=T){
  # This program fits a univariate periodical model to an empirical variogram
  # estimate.  The SEMI variogram model is the model fit...

  if (!inherits(v.object,"variogram")) stop('v.object must be of class, "variogram".\n')

  if (is.null(c0) & is.null(cw) & is.null(aw)) estimate.initial <- T
  else estimate.initial <- F

  if ( !estimate.initial & (is.null(c0) | is.null(cw) | is.null(aw)))
    stop('c0, cw, and aw must all be entered.\n')

# Interpret the "type" argument...
  if (type == 'c') empgamma <- v.object$classic /2
  else if (type == 'r') empgamma <- v.object$robust /2
  else if (type == 'm') empgamma <- v.object$medain /2
  else stop("type must be 'c', 'r', or 'm'.\n")

# Set up the first derivative functions for each of the parameters...
# dc0 = 1
  dcw <- function(h,aw) { return(1-(aw*sin(h/aw)/h)) }

  daw <- function(h,cw,aw) { return((cw/h)*(sin(h/aw) - (h/aw * cos(h/aw))))}

# Set up the variogram function...
  wave.v <- function(h,parameters)
                   ifelse(h==0,0,
                   parameters[1] + parameters[2]*(1-(parameters[3]*sin(h/parameters[3])/h)))

# Get the number of observations and the bins (h's)...
  numobs <- v.object$n
  h      <- v.object$bins

# If any numobs is 0, get rid of that lag...
  empgamma <- empgamma[numobs>0]
  h <- h[numobs>0]
  numobs <- numobs[numobs>0]

# Start the sums of squares at 0...
  rse <- 0

# Begin iterations...
  parameters <- c(c0,cw,aw)
  cat('Initial parameter estimates: ',parameters,'\n')
  loop <- T
  i <- 1
  while (loop) {
    cat('Iteration:',i,'\n')
# establish the Y vector...
    y <- (empgamma - wave.v(h,parameters))

# establish the x matrix...
    xmat <- cbind(rep(1,length(h)),
                  dcw(h,parameters[3]), 
                  daw(h,parameters[2],parameters[3]))

# establish the weights (Cressie, p. 99)...
    if(weighted) {
      w <- numobs/(wave.v(h,parameters))^2
      }
    else {
#      w <- (1:length(numobs))
      w <- rep(1,length(numobs))
      }
#    w <- numobs
   
    if(echo) cat('  X matrix:\n')
    if(echo) print(cbind(y,xmat,w))
    if(echo) cat('\n\n')    

    fit <- lsfit(xmat,y,wt=w,intercept=F)

# calculate the new parameter estimates...
    parameters.old <- parameters
    parameters <- fit$coef + parameters
    parameters <- ifelse(parameters>0,parameters,.000001)
    cat('Gradient vector: ',fit$coef,'\n')
    cat('New parameter estimates: ',parameters,'\n\n')

# Check for convergence, see if the sum of squares has converged
    rse.old <- rse
    rse <- sum(fit$residuals^2)
    rse.dif <- rse-rse.old

# Check for convergence of parmeters...
    parm.dist <- sqrt(sum((parameters-parameters.old)^2))

    cat('rse.dif = ',rse.dif,'(rse =',rse,')  ;  parm.dist = ',parm.dist,'\n\n')
#    cat('rse.dif = ',rse.dif,'(rse =',rse,')\n\n')
#    if(rse.dif < tolerance & parm.dist < tolerance) {
    if(abs(rse.dif) < tolerance) {
      loop <- F
      converge <- T
      cat('Convergence achieved by sums of squares.\n')
    }

    i <- i+1
    if (i>iterations) {
      loop <- F
      converge <- F
    }
    v.m.object <- list(parameters=parameters,
                       model= wave.v
                      )
    attr(v.m.object,'class') <- 'variogram.model'
    attr(v.m.object,'type') <- 'wave'
    if (plot.it)
      plot(v.object,v.m.object,type=type)
  }
  if (converge) 
    cat('Final parameter estimates: ',parameters,'\n\n')
  else
    cat('Convergence not achieved!\n')
  

  v.m.object <- list(parameters=parameters,
                     model= wave.v
                    )
  attr(v.m.object,'class') <- 'variogram.model'
  attr(v.m.object,'type') <- 'wave'

  return(v.m.object)
  
})
# A function to "identify" points in a "point" object...
# This function allows the user to identify points graphically.
assign("identify.point",
function(point.obj,a="",...) {

  a <- point.obj[[match(a,names(point.obj))]]
  if(!is.null(a))
    identify(point.obj$x,point.obj$y,a,...)
  else
    identify(point.obj$x,point.obj$y,...)

})
"krige" <-
function (s, point.obj, at, var.mod.obj, maxdist = NULL, extrap = F) 
{
	    if (!inherits(point.obj, "point")) 
	    	    stop("point.obj must be of class, \"point\".\n")
	    # perform kriging on all given points:
	    if (!inherits(var.mod.obj, "variogram.model")) 
	    	    stop("var.mod.obj must be of class, \"variogram.model\".\n")
	    s$do <- c(rep(T, length(s$x)))
	    # do nothing outside the convex hull?
	    # pull out the attribute vector...
	    if (!extrap) {
	    	    s$do <- in.convex.hull(tri.mesh(point.obj$x, point.obj$y, 
	    	    	    duplicate = "remove"), s$x, s$y)
	    }
	    at <- point.obj[[match(at, names(point.obj))]]
	    # if a maxdist hasn't been entered, then use all of the points...
	    if (is.null(maxdist)) 
	    	    krige.all(s, point.obj, at, var.mod.obj)
	    else krige.maxdist(s, point.obj, at, var.mod.obj, maxdist)
}
"krige.all" <-
function (s, point.obj, at, var.mod.obj) 
{
	    # Make a little distance function...
	    distance <- function(x1, y1, x2, y2) ((x1 - x2)^2 + (y1 - 
	    	    y2)^2)^0.5
	    # Now construct the Big Gamma oh matrix...
	    cat("\nUsing all points.\n  Preparing the kriging system matrix...")
	    distvect <- dist(cbind(point.obj$x, point.obj$y))
	    # Distances come out as a vector, convert to full matrix...
	    n <- attr(distvect, "Size")
	    distmtrx <- matrix(0, n, n)
	    distmtrx[lower.tri(distmtrx)] <- distvect
	    distmtrx <- distmtrx + t(distmtrx)
	    GMatrix <- var.mod.obj$model(distmtrx, var.mod.obj$parameters)
	    #browser()
	    GMatrix <- cbind(GMatrix, rep(1, length = nrow(GMatrix)))
	    GMatrix <- rbind(GMatrix, c(rep(1, length = nrow(GMatrix)), 
	    	    0))
	    cat("\n  Inverting the matrix")
	    if (nrow(GMatrix) > 100) 
	    	    cat(" (and it's a big one)")
	    cat("...")
	    GMatrix.inv <- solve(qr(GMatrix))
	    cat("\n")
	    zhat <- NULL
	    sigma2hat <- NULL
	    cat("  Predicting")
	    for (looper in 1:(length(s$x))) {
	    	    cat(".")
	    	    x <- s$x[looper]
	    	    y <- s$y[looper]
	    	    if (!s$do[looper]) {
	    	    	    zhat <- c(zhat, NA)
	    	    	    sigma2hat <- c(sigma2hat, NA)
	    	    }
	    	    else {
	    	    	    #   calculate the distance between the prediction point and all points...
	    	    	    dst <- distance(point.obj$x, point.obj$y, x, y)
	    	    	    xvect <- point.obj$x
	    	    	    yvect <- point.obj$y
	    	    	    #   Construct the little gamma oh vector...
	    	    	    gvector <- c(var.mod.obj$model(dst, var.mod.obj$parameters), 
	    	    	    	    1)
	    	    	    #   Solve the equations...
	    	    	    lambda.hat <- GMatrix.inv %*% gvector
	    	    	    #   Predict!
	    	    	    zhat <- c(zhat, sum(lambda.hat[1:(length(lambda.hat) - 
	    	    	    	    1)] * at))
	    	    	    sigma2hat <- c(sigma2hat, sum(lambda.hat * gvector))
	    	    }
	    }
	    cat("\n")
	    #  return(point(s$x,s$y,list(zhat=zhat,sigma2hat=sigma2hat)))
	    s.o <- point(s)
	    s.o$zhat <- zhat
	    s.o$sigma2hat <- sigma2hat
	    return(s.o)
}
"krige.maxdist" <-
function (s, point.obj, at, var.mod.obj, maxdist) 
{
	    # Make a little distance function...
	    distance <- function(x1, y1, x2, y2) ((x1 - x2)^2 + (y1 - 
	    	    y2)^2)^0.5
	    if (!inherits(s, "point")) 
	    	    stop("prediction point s must be of class, \"point\".\n")
	    cat(paste("\nUsing points within", maxdist, "units of prediction points.\n", 
	    	    collapse = " "))
	    zhat <- NULL
	    sigma2hat <- NULL
	    cat("  Predicting")
	    for (looper in 1:(length(s$x))) {
	    	    cat(".")
	    	    x <- s$x[looper]
	    	    y <- s$y[looper]
	    	    #   calculate the distance between the prediction point and all points...
	    	    dst <- distance(point.obj$x, point.obj$y, x, y)
	    	    xvect <- point.obj$x[dst <= maxdist]
	    	    yvect <- point.obj$y[dst <= maxdist]
	    	    at2 <- at[dst <= maxdist]
	    	    dst <- dst[dst <= maxdist]
	    	    #    cat('length(xvect) = ',length(xvect),'\n')
	    	    if (length(xvect) == 0 | (!s$do[looper])) {
	    	    	    zhat <- c(zhat, NA)
	    	    	    sigma2hat <- c(sigma2hat, NA)
	    	    }
	    	    else {
	    	    	    #     Now construct the Big Gamma oh matrix...
	    	    	    distvect <- dist(cbind(xvect, yvect))
	    	    	    #     Distances come out as a vector, convert to full matrix...
	    	    	    n <- attr(distvect, "Size")
	    	    	    distmtrx <- matrix(0, n, n)
	    	    	    distmtrx[lower.tri(distmtrx)] <- distvect
	    	    	    distmtrx <- distmtrx + t(distmtrx)
	    	    	    GMatrix <- var.mod.obj$model(distmtrx, var.mod.obj$parameters)
	    	    	    nr <- if (is.null(nrow(GMatrix))) 
	    	    	    	    0
	    	    	    else nrow(GMatrix)
	    	    	    GMatrix <- cbind(GMatrix, rep(1, length = nr))
	    	    	    GMatrix <- rbind(GMatrix, c(rep(1, length = nr), 
	    	    	    	    0))
	    	    	    matrix.size <- length(xvect) + 1
	    	    	    #     Construct the little gamma oh vector...
	    	    	    gvector <- c(var.mod.obj$model(dst, var.mod.obj$parameters), 
	    	    	    	    1)
	    	    	    #     Solve the equations...
	    	    	    #      lambda.hat <- solve(qr(GMatrix),gvector)
	    	    	    #     Predict!
	    	    	    #      zhat <- c(zhat,sum(lambda.hat[1:(length(lambda.hat)-1)] * at2))
	    	    	    #      sigma2hat <- c(sigma2hat,sum(lambda.hat * gvector))
	    	    	    #
	    	    	    #     ... the above prediction mechanism would stop with an error
	    	    	    #         message, if the krige matrix is singular on some prediction 
	    	    	    #         point. The prediction on the next lines would not stop at all,
	    	    	    #         it only assigns NAs to such prediction points: 
	    	    	    #
	    	    	    Gqr <- qr(GMatrix)
	    	    	    if (Gqr$rank != 0) {
	    	    	    	    lambda.hat <- qr.coef(Gqr, gvector)
	    	    	    	    #     Predict!
	    	    	    	    zhat <- c(zhat, sum(lambda.hat[1:(length(lambda.hat) - 
	    	    	    	     1)] * at2))
	    	    	    	    sigma2hat <- c(sigma2hat, sum(lambda.hat * 
	    	    	    	     gvector))
	    	    	    }
	    	    	    else {
	    	    	    	    zhat <- c(zhat, NA)
	    	    	    	    sigma2hat <- c(sigma2hat, NA)
	    	    	    }
	    	    }
	    }
	    cat("\n")
	    #  return(point(s$x,s$y,list(zhat=zhat,sigma2hat=sigma2hat)))
	    s.o <- point(s)
	    s.o$zhat <- zhat
	    s.o$sigma2hat <- sigma2hat
	    return(s.o)
}
# lagplot.s creates a lagplot for an object of type "point"
assign("lagplot",
function(point.obj,pair.obj,a1,a2,lag=1,std=F,query.a=NULL,xlim=NULL,ylim=NULL) {

  if (!inherits(point.obj,"point")) stop('Point.obj must be of class, "point".\n')

  if (!inherits(pair.obj,"pair")) stop('Pair.obj must be of class, "pair".\n')

  if(missing(a1)) stop('Must enter at least one attribute.\n')
  if(missing(a2)) a2 <- a1

  att1 <- point.obj[[match(a1,names(point.obj))]]

  att2 <- point.obj[[match(a2,names(point.obj))]]

  if(std) {
    att1 <- (att1 - mean(att1,na.rm=T))/var(att1[!is.na(att1)])
    att2 <- (att2 - mean(att2,na.rm=T))/var(att2[!is.na(att2)])
  }

  plot((att1[pair.obj$from])[pair.obj$lags==lag],
       (att2[pair.obj$to])[pair.obj$lags==lag],
#       xlim=c(-2.5,2.5),ylim=c(-2.5,2.5),
       xlab=paste(a1,'(s)',sep=''),
#       ylab=paste(a2,'(s+h)',sep=''),fty='s')
       ylab=paste(a2,'(s+h)',sep=''))
  title(paste(deparse(substitute(point.obj)),": lag " ,lag,sep=''))
  abline(0,1)

  if(!is.null(query.a)) {
    i <- (1:length(names(point.obj)))[names(point.obj) == query.a]
    query.att <- point.obj[[i]]
    cat('Identify "from" points...')
    identify((att1[pair.obj$from])[pair.obj$lags==lag],
             (att2[pair.obj$to])[pair.obj$lags==lag],
             (query.att[pair.obj$from])[pair.obj$lags==lag],col=2)
    cat('\nIdentify "to" points...')
    identify((att1[pair.obj$from])[pair.obj$lags==lag],
             (att2[pair.obj$to])[pair.obj$lags==lag],
             (query.att[pair.obj$to])[pair.obj$lags==lag],col=3)

  }
       
})
#

assign("pair",
function (point.obj,num.lags=10,type='isotropic',theta=0,dtheta=5,maxdist) {
  if (!inherits(point.obj,"point")) stop('Point.Obj must be of class, "point".\n')

  if (length(type) != 1) stop('Length of "type" must be 1.\n')
  if ((type != "isotropic") & (type != 'anisotropic'))
    stop('Type must be "isotropic" or "anisotropic".\n')

  if (missing(maxdist)) maxdist <- -1
  if (type[1] == 'isotropic') o.pair <- pair.iso(point.obj,num.lags,maxdist)
  else o.pair <- pair.aniso(point.obj,num.lags,theta,dtheta,maxdist)

  cat("\n")  
  class(o.pair) <- "pair"
  return(o.pair)
})


#************ pair.iso *******************
# creates pointers for the n choose 2 possible pairs of points...
#******************************************

assign("pair.iso",
function(point.obj,num.lags,maxdist) {
# we only need some of the pairs...
  max.entered <- T
  if (maxdist < 0) {
    max.entered <- F
    maxdist <- ((max(point.obj$x)-min(point.obj$x))^2 + (max(point.obj$y)-min(point.obj$y))^2)^0.5
  }

  from <- numeric(0)
  to <- numeric(0)
  n <- length(point.obj$x)
  if (n > 1000) cat('Creating from, to vectors')
  for (i in 1:(n-1)) {
    cat ('.')
     
    candidates <- (i+1):n
    candidates <- candidates[(point.obj$x[candidates] > point.obj$x[i]-maxdist) &
                            (point.obj$x[candidates] < point.obj$x[i]+maxdist) &
                            (point.obj$y[candidates] > point.obj$y[i]-maxdist) &
                            (point.obj$y[candidates] < point.obj$y[i]+maxdist)]

    from <- c(from,rep(i,length(candidates)))
    to <- c(to,candidates)
  }
  if (n > 1000) cat('\n')

# calculate the distance between all possible pairs...
  if (n > 1000) cat('Calculating distances...')
  dist <- sqrt( (point.obj$x[from]-point.obj$x[to])^2 + 
                (point.obj$y[from]-point.obj$y[to])^2 )
  if (n > 1000) cat('\n')

# apply the maximum distance cutoff, if specified...
  if (maxdist < 0) maxdist <- max(dist,na.rm=T)
  if (max.entered) {
    if (n > 1000) cat('Applying maxdist criterion...')
    from <- from[dist<=maxdist]
    to   <- to[dist<=maxdist]
    dist <- dist[dist<=maxdist]
    if (n > 1000) cat('\n')
  }
  else maxdist <- max(dist)

# create the vector to use to "cut" the bins...
  bins.cut <- seq(0,maxdist,maxdist/num.lags)

# create the vector of bins center points (for plotting)...
#  bins.cent <- list()
# revision 11/4/99 rsb
  bins.cent <- numeric(length(bins.cut)-1)
  for (i in 1:(length(bins.cut)-1))
    bins.cent[i] <- bins.cut[i]+(bins.cut[i+1]-bins.cut[i])/2

# cut the data into lag bins...
  if (n > 1000) cat('Cutting distances into bins...')
#  lags <- cut(dist,bins.cut)
  lags <- cut(dist,bins.cut,labels=c(1:num.lags))
  if (n > 1000) cat('\n')

# Journel says that you should have at least 30 pairs of points
# give a warning if not
  for(i in 1:num.lags) {
    if (length(lags[lags==1]) < 30) 
      cat(paste('NOTE: Number of pairs in lag ',i,': ',length(lags[lags==i]),'\n',collapse=""))
  }

  pair <- list(from=from,to=to,lags=lags,dist=dist,bins=bins.cent)
  attr(pair,"type") <- 'isotropic'
  attr(pair,"theta") <- NULL
  attr(pair,"dtheta") <- NULL

  return(pair)
})

#
#************ pair.aniso *******************
# Creates pairs that fall within a given direction and angle
#********************************************
assign("pair.aniso",
function(point.obj,num.lags,theta,dtheta,maxdist) {

# we only need some of the pairs...
  from <- NULL
  to <- NULL
  n <- length(point.obj$x)
  if (n > 1000) cat('Creating from, to vectors')
  for (i in 1:(n-1)) {
    if (i%%5==0) cat ('.')
     
    candidates <- (i+1):n
    candidates <- candidates[point.obj$x[candidates] > point.obj$x[i]-maxdist &
                            point.obj$x[candidates] < point.obj$x[i]+maxdist &
                            point.obj$y[candidates] > point.obj$y[i]-maxdist &
                            point.obj$y[candidates] < point.obj$y[i]+maxdist]

    from <- c(from,rep(i,length(candidates)))
    to <- c(to,candidates)
  }
  cat('\n')
  if (n > 1000) cat('\n')
  
# look both ways...
  xx <- from
  from <- c(from,to)
  to   <- c(to,xx)

# Calculate the distance...
  dist <- sqrt( (point.obj$x[from]-point.obj$x[to])^2 + 
                (point.obj$y[from]-point.obj$y[to])^2 )

# Apply the maximum distance criteria, if entered...
  if (maxdist < 0) maxdist <- max(dist,na.rm=T)
  from <- from[dist<=maxdist]
  to   <- to[dist<=maxdist]
  dist <- dist[dist<=maxdist]

# calc the angle between pairs
  angle <- calcangle(point.obj$x[from],point.obj$y[from],
                 point.obj$x[to],point.obj$y[to])

# if two points have the same location, they will be NA's
  to    <- to[!is.na(angle)]
  from  <- from[!is.na(angle)]
  dist  <- dist[!is.na(angle)]
  angle <- angle[!is.na(angle)]

# convert theta and dtheta to radians...
  theta.rad <- 2*pi*theta/360
  dtheta.rad <- 2*pi*dtheta/360

# Get the angle to look for data...
# need to be careful around angle 0...
  startangle <- theta.rad-dtheta.rad
  endangle <- theta.rad+dtheta.rad
  if(startangle<0) startangle <- 2*pi+startangle
  else if (endangle>2*pi) endangle <- endangle-2*pi

# Apply the angle criteria...
  if (startangle>endangle) {
    from <- from[angle>startangle | angle<endangle]
    to <- to[angle>startangle | angle<endangle]
    dist <- dist[angle>startangle | angle<endangle]
    angle <- angle[angle>startangle | angle<endangle]
  }
  else {
    from <- from[angle>startangle & angle<endangle]
    to <- to[angle>startangle & angle<endangle]
    dist <- dist[angle>startangle & angle<endangle]
    angle <- angle[angle>startangle & angle<endangle]
  }

# create the vector to use to "cut" the bins...
  bins.cut <- seq(0,max(dist,na.rm=T),max(dist,na.rm=T)/num.lags)

# create the vector of bin center points (for plotting)...
  bins.cent <- NULL
  for (i in 1:(length(bins.cut)-1))
    bins.cent[i] <- bins.cut[i]+(bins.cut[i+1]-bins.cut[i])/2

# cut the pairs into lags...
  lags <- cut(dist,bins.cut,labels=c(1:num.lags))

# ?? says that there should be at least 30 pairs in each bin.
# Give a warning otherwise...
  for(i in 1:num.lags) {
    if (length(lags[lags==i]) < 30) 
      cat(paste('NOTE: Number of pairs in lag ',i,': ',length(lags[lags==i]),'\n',collapse=""))
  }

  pair <- list(from=from,to=to,lags=lags,dist=dist,bins=bins.cent)
  attr(pair,"type") <- 'anisotropic'
  attr(pair,"theta") <- format(theta)
  attr(pair,"dtheta") <- format(dtheta)

  return(pair)
})


#**************
assign("calcangle",
function(x1,y1,x2,y2) {

  xdoty <- x2-x1
  lenvect <- sqrt( (x2-x1)^2 + (y2-y1)^2 )
  angle <- acos( xdoty / lenvect )

  angle <- ifelse( y2 < y1, (2*pi)-angle, angle)

  return(angle)
})

#
#
#************ pair.newangle *******************
# Takes an anisotopic pair object and makes a
# isotropic version.  Don't have to search the thing.
#********************************************
assign("pair.newangle",
function(point.obj, pair.obj,num.lags=10,theta=0,dtheta=5,maxdist) {

  if (!inherits(point.obj,"point")) stop('Point.obj must be of class, "point".\n')
  if (!inherits(pair.obj,"pair")) stop('Pair.obj must be of class, "pair".\n')
  if (attr(pair.obj,"type") != 'isotropic') stop('Pair.obj must be isotropic.\n')

  from <- pair.obj$from
  to   <- pair.obj$to

# look both ways...
  xx <- from
  from <- c(from,to)
  to   <- c(to,xx)

# Calculate the distance...
  dist <- sqrt( (point.obj$x[from]-point.obj$x[to])^2 + 
                (point.obj$y[from]-point.obj$y[to])^2 )

# Apply the maximum distance criteria, if entered...
  if (maxdist < 0) maxdist <- max(dist,na.rm=T)
  from <- from[dist<=maxdist]
  to   <- to[dist<=maxdist]
  dist <- dist[dist<=maxdist]

# calc the angle between pairs
  angle <- calcangle(point.obj$x[from],point.obj$y[from],
                 point.obj$x[to],point.obj$y[to])

# if two points have the same location, they will be NA's
  to    <- to[!is.na(angle)]
  from  <- from[!is.na(angle)]
  dist  <- dist[!is.na(angle)]
  angle <- angle[!is.na(angle)]

# convert theta and dtheta to radians...
  theta.rad <- 2*pi*theta/360
  dtheta.rad <- 2*pi*dtheta/360

# Get the angle to look for data...
# need to be careful around angle 0...
  startangle <- theta.rad-dtheta.rad
  endangle <- theta.rad+dtheta.rad
  if(startangle<0) startangle <- 2*pi+startangle
  else if (endangle>2*pi) endangle <- endangle-2*pi

# Apply the angle criteria...
  if (startangle>endangle) {
    from <- from[angle>startangle | angle<endangle]
    to <- to[angle>startangle | angle<endangle]
    dist <- dist[angle>startangle | angle<endangle]
    angle <- angle[angle>startangle | angle<endangle]
  }
  else {
    from <- from[angle>startangle & angle<endangle]
    to <- to[angle>startangle & angle<endangle]
    dist <- dist[angle>startangle & angle<endangle]
    angle <- angle[angle>startangle & angle<endangle]
  }

# create the vector to use to "cut" the bins...
  bins.cut <- seq(0,max(dist,na.rm=T),max(dist,na.rm=T)/num.lags)

# create the vector of bin center points (for plotting)...
  bins.cent <- NULL
  for (i in 1:(length(bins.cut)-1))
    bins.cent[i] <- bins.cut[i]+(bins.cut[i+1]-bins.cut[i])/2

# cut the pairs into lags...
  lags <- cut(dist,bins.cut)

# ?? says that there should be at least 30 pairs in each bin.
# Give a warning otherwise...
  for(i in 1:num.lags) {
    if (length(lags[lags==i]) < 30) 
      cat(paste('NOTE: Number of pairs in lag ',i,': ',length(lags[lags==i]),'\n',collapse=""))
  }

  pair <- list(from=from,to=to,lags=lags,dist=dist,bins=bins.cent)
  attr(pair,"type") <- 'anisotropic'
  attr(pair,"theta") <- format(theta)
  attr(pair,"dtheta") <- format(dtheta)

  attr(pair,"class") <- "pair"
  return(pair)

})
# A plot function for the "point" class of objects
assign("plot.point",
function (point.obj,a,axes=F,xlab='',ylab='',legend.pos=0,...) {
# Be careful to plot in a square region.  We can't distort the earth!
# I can't seem to force Splus to use the same scaling on both axes!
# But we must find a way!
  old.par <- par(pty='s')
  xdiff _ max(point.obj$x) - min(point.obj$x)
  ydiff _ max(point.obj$y) - min(point.obj$y)
  if (xdiff < ydiff) {
#   Set up our limits so that there are ydiff units on x and y...
    ylimits _ c(min(point.obj$y),max(point.obj$y))
    xlimits _ c((min(point.obj$x) + xdiff/2) - ydiff/2,
                (min(point.obj$x) + xdiff/2) + ydiff/2)
  }
  else {
    xlimits _ c(min(point.obj$x),max(point.obj$x))
    ylimits _ c((min(point.obj$y) + ydiff/2) - xdiff/2,
                (min(point.obj$y) + ydiff/2) + xdiff/2)
  }
  if (!missing(a)) {
    a.name<-a
    a <- point.obj[[match(a,names(point.obj))]]
#    colors <- cut(a,c(min(a)-1,quantile(a,c(.25,.5,.75,1))))
    a.q<-quantile(a,c(.25,.5,.75,1))	
    qcol<-c(3,7,2,6) # green, yellow, red, cyan
    colors <- cut(a,c(min(a)-1,a.q),labels=c(1:4))
    plot(point.obj$x,point.obj$y, axes=axes,xlab=xlab,ylab=ylab,type='n',
         xlim=xlimits,ylim=ylimits)
    for (i in as.numeric(unique(colors))){
      points(point.obj$x[colors==i],point.obj$y[colors==i],col=qcol[i],...)
}
    if (legend.pos!=0){
      l.x<-switch(legend.pos,
		  xlimits[1],xlimits[2],
		  xlimits[2],xlimits[1])
      l.xj<-switch(legend.pos,0,1,1,0)
      l.y<-switch(legend.pos,
		  ylimits[1],ylimits[1],
		  ylimits[2],ylimits[2])
      l.yj<-switch(legend.pos,0,0,1,1)
      legend(l.x,
	     l.y,
	     c(paste("[",min(a),",",a.q[1],"]"),
	       paste("(",a.q[1],",",a.q[2],"]"),
	       paste("(",a.q[2],",",a.q[3],"]"),
	       paste("(",a.q[3],",",max(a),"]")),
	     qcol,
	     xjust=l.xj,yjust=l.yj)
    }
    title(deparse(substitute(point.obj)))
    
  }
  else {
    plot(point.obj$x,point.obj$y, axes=axes,xlab=xlab,ylab=ylab,
         xlim=xlimits,ylim=ylimits)
    title(deparse(substitute(point.obj)))
  }
  invisible(par(old.par))
})
################
#  Create a plotting routine for variograms...
assign("plot.variogram",	
function(variogram.obj,var.mod.obj=NULL,title.str=NULL,ylim=NULL,type='c',N=F) {

#  oldpar <- par()
#  par(mfrow=c(2,1),lab=c(12,5,7), #lab=c(length(variogram.obj$lag),5,7),
#      mar=c(4,12,4,12)+.1)

if (!inherits(variogram.obj,'variogram')) stop('variogram.obj must be of class "variogram"')
if (!missing(var.mod.obj))
  if (!inherits(var.mod.obj,'variogram.model')) stop('variogram.obj must be of class "variogram.model"')

if(type!='c'&type!='r'&type!='m') stop('type must be "c", "r", or "m".\n')

  if(type=='c'){
    ylabel _ 'Classical semi-variogram estimator'
    y _ variogram.obj$classic
  }
  if(type=='r'){
    ylabel _ 'Robust semi-variogram estimator'
    y _ variogram.obj$robust
  }
  if(type=='m'){
    ylabel _ 'Median semi-varigram estimator'
    y _ variogram.obj$med
  }
  y _ y/2


  if(is.null(ylim)) ylim <- c(0,max(variogram.obj$classic/2,variogram.obj$robust/2,na.rm=T))
  plot(variogram.obj$bins,y,
       ylim=ylim,
       xlim=c(0,max(variogram.obj$bins)),
       xlab="Lag",ylab=ylabel,
       type="p")

  if(N)
    text(variogram.obj$bins,y,variogram.obj$n)

  if(is.null(title.str))
    title(paste("Variogram estimator:",deparse(substitute(variogram.obj))))
  else
    title(title.str)
				    
# See if we need to plot a fitted variogram...
  if(!is.null(var.mod.obj)) {
    if (is.null(attr(var.mod.obj,"class"))) stop('var.mod.obj must be of class, "variogram.model".\n')
    else if (attr(var.mod.obj,"class") != 'variogram.model') stop('var.mod.obj must be of class, "variogram.model".\n')
    h <- seq(from=0.0001,to=max(variogram.obj$bins),length=50)
    lines(h,var.mod.obj$model(h,var.mod.obj$parameters))
  }

#  plot(variogram.obj$lag,variogram.obj$med,
#       ylim=c(0,max(variogram.obj$classic,variogram.obj$robust,variogram.obj$med,na.rm=T)),
#       xlab="Lag",ylab="Median estimator",
#       type="h")

#  plot(variogram.obj$bins,variogram.obj$robust,
#       ylim=c(0,max(variogram.obj$classic,variogram.obj$robust,variogram.obj$med,na.rm=T)),
#       xlim=c(0,max(variogram.obj$bins)),
#       xlab="Lag",ylab="Robust estimator",
#       type="p")


#  par(mfrow=c(1,1))
#  invisible(par(oldpar))
})
assign("point",
function (dframe,x='x',y='y') {

  if (!is.data.frame(dframe))
    stop("dframe must be a data frame.")

  if (is.na(match(x,names(dframe))))
    stop ("Could not find the X column.")

  if (is.na(match(y,names(dframe))))
    stop ("Could not find the Y column.")

  names(dframe)[match(x,names(dframe))] <- 'x'
  names(dframe)[match(y,names(dframe))] <- 'y'

  o.point <- data.frame(dframe)

  class(o.point) <- c("point","data.frame")
  return(o.point)
})
# print.pair prints out INFORMATION ABOUT an object of class "pair"
assign("print.pair",
function(pair.obj) {

  cat(paste('\nPair object:',deparse(substitute(pair.obj)),'\n'))

  if (!is.null(attributes(pair.obj)$type))
    cat('\n      Type:            ',attributes(pair.obj)$type)
  if (!is.null(attributes(pair.obj)$theta))
    cat('\n      Theta:           ',attributes(pair.obj)$theta)
  if (!is.null(attributes(pair.obj)$dtheta))
    cat('\n      Dtheta:          ',attributes(pair.obj)$dtheta)
  cat('\n      Number of pairs: ',length(pair.obj$from))
  cat('\n      Number of lags:  ',length(unique(pair.obj$lags)))
  cat('\n      Max h:           ',max(pair.obj$dist))
  cat('\n\n')


})
# print.point prints out INFORMATION ABOUT an object of class "point"
assign("print.point",
function(point.obj) {

  cat(paste('\nPoint object:',deparse(substitute(point.obj)),'\n'))

  cat(paste('\n   Locations: ',length(point.obj$x),sep=''))
  cat(paste('\n\n   Attributes:\n      ',paste(names(point.obj),
                    collapse='\n      '),sep=''))
  cat('\n\n')


})
# spacebox.s creates a box plot of squared or square root difference plots...
assign("spacebox",
function(point.obj,pair.obj,a1,a2,type='r',...) {

  if (!inherits(point.obj,"point")) stop('Point.obj must be of class, "point".\n')

  if (!inherits(pair.obj,"pair")) stop('Pair.obj must be of class, "pair".\n')

  if(missing(a1)) stop('Must enter at least one attribute.\n')
  if(missing(a2)) a2 <- a1

  a1 <- point.obj[[match(a1,names(point.obj))]]

  a2 <- point.obj[[match(a2,names(point.obj))]]

  if (type=='r') {  # square root difference cloud
    diff <- (abs(a1[pair.obj$from]-a2[pair.obj$to]))^0.5
    ylab <- 'square root differnece'
  }
  else {
    diff <- (a1[pair.obj$from]-a2[pair.obj$to])^2
    ylab <- 'squared differnece'
  }
  names_sort(unique(pair.obj$lags))
  attr(names,'levels') <- NULL
  names <- format(names)
  boxplot(split(diff,pair.obj$lags),
# revision 11/4-99 rsb
#	  names=names,
	  names.x=names,
	  varwidth=T)
  title(xlab='lag',
	ylab=ylab)

  return(invisible(NULL))
})
#
# spacecloud.s creates a box plot of squared or square root difference plots...
assign("spacecloud",
function(point.obj,pair.obj,a1,a2,type='r',query.a=NULL,...) {

  if (!inherits(point.obj,"point")) stop('Point.obj must be of class, "point".\n')

  if (!inherits(pair.obj,"pair")) stop('Pair.obj must be of class, "pair".\n')

  if(missing(a1)) stop('Must enter at least one attribute.\n')
  if(missing(a2)) a2 <- a1

  a1 <- point.obj[[match(a1,names(point.obj))]]

  a2 <- point.obj[[match(a2,names(point.obj))]]

  if (type=='r') {  # square root difference cloud
    diff <- (abs(a1[pair.obj$from]-a2[pair.obj$to]))^0.5
    ylab <- 'square root differnece'
  }
  else {
    diff <- (a1[pair.obj$from]-a2[pair.obj$to])^2
    ylab <- 'squared differnece'
  }

  plot(pair.obj$dist,diff,
          xlab='lag',ylab=ylab,...)
  title(deparse(substitute(point.obj)))
  if(!is.null(query.a)) {
    query.att <- point.obj[[match(query.a,names(point.obj))]]
    cat('Identify "from" points...')
    identify(pair.obj$dist,diff,
             query.att[pair.obj$from])#,col=2)
    cat('\nIdentify "to" points...')
    identify(pair.obj$dist,diff,
             query.att[pair.obj$to])#,col=3)

    cat('\n')
  }

  return(invisible(NULL))
})
which.na<-function(data)
{
seq(along=data)[is.na(data)]
}

require(mva)
require(tripack)
