https://github.com/cran/fields
Raw File
Tip revision: 6769ffc81115fbf0bf7d9c566cf7ac81be0049dc authored by Doug Nychka on 25 July 2005, 00:00:00 UTC
version 3.04
Tip revision: 6769ffc
krig.image.r
"krig.image" <-
function (x, Y, cov.function, m = NULL, n = NULL, lambda = 0, 
    start = NULL, tol = 1e-05, kmax = 25, cov.obj = NULL, grid = NULL, 
    weights = rep(1, length(Y)), verbose = FALSE, conv.verbose = FALSE, 
    expand = 1, ...) 
{
    out <- list()
    out$call <- match.call()
    out$cov.function <- cov.function
    na.ind <- is.na(Y)
    out$na.ind <- na.ind
    out$xraw <- x[!na.ind, ]
    out$y <- Y[!na.ind]
    out$N <- length(out$y)
    out$weights <- weights[!na.ind]
    out$lambda <- lambda
    if (is.null(grid)) {
        if (is.null(cov.obj)) {
            x1r <- range(out$xraw[, 1])
            x2r <- range(out$xraw[, 2])
            if (verbose) {
                print(x1r)
                print(x2r)
            }
            out$grid <- list(x = seq(x1r[1], x1r[2], , m), y = seq(x2r[1], 
                x2r[2], , n))
        }
        else out$grid <- cov.obj$grid
    }
    else out$grid <- grid
    if (verbose) {
        print(out$grid)
    }
    if (is.null(cov.obj)) {
        cov.obj <- cov.function(grid = out$grid, setup = TRUE, ...)
    }
    out$cov.obj <- cov.obj
    out <- c(out, Krig.discretize(out$xraw, grid = out$grid, 
        expand = expand))
    if (verbose) {
        cat("row and columns of grid", fill = TRUE)
        print(c(out$m, out$n))
    }
    out <- c(out, list(x = cbind(out$grid$x[out$index[, 1]], 
        out$grid$y[out$index[, 2]])))
    if (verbose) {
        cat("results of finding indices X,y,weights, indices", 
            fill = TRUE)
        print(cbind(out$x, out$y, out$weights, out$index))
    }
    out <- c(out, Krig.replicates(out, verbose = verbose))
    out$indexM <- out$index[out$uniquerows, ]
    if (verbose) {
        cat("results of collapsing replicates", fill = TRUE)
        print(cbind(out$xM, out$yM, out$weightsM, out$indexM))
    }
    out$qr.T <- qr(cbind(rep(1, nrow(out$indexM)), out$xM))
    if (is.null(start)) {
        start <- rep(0, length(out$yM) - out$qr.T$rank)
    }
    out$multAx <- function(x, loc, cov.function, cov.obj, D, 
        qr.T) {
        temp <- qr.qy(qr.T, c(rep(0, qr.T$rank), x))
        qr.q2ty(qr.T, cov.function(loc, , temp, cov.obj = cov.obj) + 
            D * temp)
    }
    Q2TY <- qr.q2ty(out$qr.T, out$yM)
    cat(" iterative solution of linear system", fill = TRUE)
    out2 <- conjugate.gradient(b = Q2TY, out$multAx, start = start, 
        tol = tol, kmax = kmax, D = out$lambda * out$weightsM, 
        loc = out$indexM, cov.function = out$cov.function, cov.obj = out$cov.obj, 
        qr.T = out$qr.T, verbose = conv.verbose)
    if (verbose) {
        cat("convergence info from conjugate gradient", fill = TRUE)
        print(out2$conv)
    }
    out$omega2 <- out2$x
    out$converge <- out2$conv
    if (out$converge$niter >= kmax) {
        warning("Exceeded max number of\niterations for congate gradient.")
    }
    out <- c(out, krig.image.parameters(out))
    class(out) <- "krig.image"
    if (verbose) {
        cat("estimated parameters delta, then beta", fill = TRUE)
        print(out$delta)
        print(out$beta)
    }
    if (verbose) {
        cat("estimated parameters sigma2 and rho", fill = TRUE)
        print(out$sigma2)
        print(out$rho)
    }
    xg <- make.surface.grid(out$grid)
    ig <- make.surface.grid(list(1:out$m, 1:out$n))
    z1 <- out$cov.function(ig, out$indexM, Y = out$delta, cov.obj = out$cov.obj)
    z2 <- out$beta[1] + xg %*% out$beta[2:3]
    out$surface <- as.surface(xg, z1 + z2)
    if (verbose) {
        print(out$surface$x)
        print(out$surface$y)
    }
    if (verbose) 
        print(out$rep.info)
    out$fitted.values <- predict(out, out$xraw)
    out$residuals <- out$y - out$fitted.values
    out
}
back to top