"Krig.engine.default" <- function(out, verbose=FALSE){ # # matrix decompositions for computing estimate # # Computational outline ( "." is used for subscript) # # The form of the estimate is # fhat(x) = sum phi.j(x) d.j + sum psi.k c.k # # the {phi.j} are the fixed part of the model usually low order polynomials # and is also referred to as spatial drift. # # the {psi.k} are the covariance function evaluated at the unique observation # locations. if xM.k is the kth unique location psi.k(x)= k(x, xM.k) # xM is also out$knots in the code below. # # the goal is find decompositions that facilitate rapid solution for # the vectors d and c. # # First outline calculations with equal weights # T the fixed effects regression matrix T.ij = phi.j(xM.i) # K the covariance matrix for the unique locations # From the spline literature the solution solves the well known system # of two eqautions: # -K( yM - Td - Kc) + lambda *Kc = 0 # -T^t ( yM-Td -Kc) =0 # Divide through by K and substitute, these are equivalent to # -1- -( yM- Td - Kc) + lambda c = 0 # -2- T^t c = 0 # # A QR decomposition is done for T= (Q.1,Q.2)R # by definition Q.2^T T =0 # equation -2- can be thought of as a constraint # with c= Q.2 beta2 # substitute in -1- and multiply through by Q.2^T # -Q.2^T yM + Q.2^T K Q.2 beta2 + lambda beta2 = 0 # # Solving # beta2 = {Q.2^T K Q.2 beta2 + lambda I )^ {-1} Q.2^T yM # # eigenvalues and eigenvectors found for M= Q.2^T K Q.2 # # # From -1- Td = yM - Kc - lambda c # (Q.1^T) Td = (Q.1^T) ( yM- Kc) # # ( lambda c is zero by constraint) # # so Rd = (Q.1^T) ( yM- Kc) # use qr functions to find d. # Tmatrix<- do.call(out$null.function.name, c(out$null.args, list(x=out$xM,Z=out$ZM)) ) if( verbose){ cat(" Model Matrix: spatial drift and Z", fill=TRUE) print( Tmatrix) } # Tmatrix premultiplied by sqrt of wieghts Tmatrix<- out$W2%d*%Tmatrix qr.T <- qr(Tmatrix ) # #verbose block if (verbose) { cat( "first 5 rows of qr.T$qr",fill=TRUE) print(qr.T$qr[1:5,]) } # # find Q_2 K Q_2^T where K is the covariance matrix at the knot points # tempM<- t( out$W2 %d*% do.call(out$cov.function.name, c(out$args, list(x1 = out$knots, x2 = out$knots))) ) tempM <- out$W2 %d*% tempM tempM <- qr.yq2(qr.T, tempM) tempM <- qr.q2ty(qr.T, tempM) np <- nrow(out$knots) nt <- (qr.T$rank) if (verbose) { cat("np, nt", np, nt, fill = TRUE)} # # Full set of decompositions for # estimator for nonzero lambda tempM <- eigen(tempM, symmetric=TRUE) D <- c(rep(0, nt), 1/tempM$values) # # verbose block if (verbose) { cat("eigen values:", fill = TRUE) print(D) } # # Form the matrix decompositions and transformed data vector used to # evaluate the solution, GCV, REML at different lambdas # G <- matrix(0, ncol = np, nrow = np) G[(nt + 1):np, (nt + 1):np] <- tempM$vectors G <- G * matrix(D, ncol = np, nrow = np, byrow = TRUE) u <- c( rep(0, nt), t(tempM$vectors) %*% qr.q2ty(qr.T, c(out$W2%d*%out$yM ) )) # # verbose block if (verbose){ print(u) print(out$pure.ss) } # return( list(u = u, D = D, G = G, qr.T = qr.T, decomp = "WBW", V = tempM$vectors, nt=nt, np=np)) }