Nothing
##' Kriging quantile
##'
##' Evaluation of a kriging quantile a a new point. To be used in an
##' optimization loop.
##'
##'
##' @param x the input vector at which one wants to evaluate the criterion
##' @param model a Kriging model of "km" class
##' @param beta Quantile level (default value is 0.1)
##' @param type Kriging type: "SK" or "UK"
##' @param envir an optional environment specifying where to assign
##' intermediate values for future gradient calculations. Default is NULL.
##' @return Kriging quantile
##' @author Victor Picheny
##'
##' David Ginsbourger
##' @examples
##'
##'
##' ##########################################################################
##' ### KRIGING QUANTILE SURFACE ####
##' ### OF THE BRANIN FUNCTION KNOWN AT A 12-POINT LATIN HYPERCUBE DESIGN ####
##' ##########################################################################
##'
##' set.seed(421)
##'
##' # Set test problem parameters
##' doe.size <- 12
##' dim <- 2
##' test.function <- get("branin2")
##' lower <- rep(0,1,dim)
##' upper <- rep(1,1,dim)
##' noise.var <- 0.2
##'
##' # Generate DOE and response
##' doe <- as.data.frame(matrix(runif(doe.size*dim),doe.size))
##' y.tilde <- rep(0, 1, doe.size)
##' for (i in 1:doe.size) {
##' y.tilde[i] <- test.function(doe[i,]) + sqrt(noise.var)*rnorm(n=1)
##' }
##' y.tilde <- as.numeric(y.tilde)
##'
##' # Create kriging model
##' model <- km(y~1, design=doe, response=data.frame(y=y.tilde),
##' covtype="gauss", noise.var=rep(noise.var,1,doe.size),
##' lower=rep(.1,dim), upper=rep(1,dim), control=list(trace=FALSE))
##'
##' # Compute actual function and criterion on a grid
##' n.grid <- 12 # Change to 21 for a nicer picture
##' x.grid <- y.grid <- seq(0,1,length=n.grid)
##' design.grid <- expand.grid(x.grid, y.grid)
##' nt <- nrow(design.grid)
##'
##' crit.grid <- apply(design.grid, 1, kriging.quantile, model=model, beta=.1)
##' func.grid <- apply(design.grid, 1, test.function)
##'
##' # Compute kriging mean and variance on a grid
##' names(design.grid) <- c("V1","V2")
##' pred <- predict(model, newdata=design.grid, type="UK", checkNames = FALSE)
##' mk.grid <- pred$m
##' sk.grid <- pred$sd
##'
##' # Plot actual function
##' z.grid <- matrix(func.grid, n.grid, n.grid)
##' filled.contour(x.grid,y.grid, z.grid, nlevels=50, color = rainbow,
##' plot.axes = {title("Actual function");
##' points(model@@X[,1],model@@X[,2],pch=17,col="blue");
##' axis(1); axis(2)})
##'
##' # Plot Kriging mean
##' z.grid <- matrix(mk.grid, n.grid, n.grid)
##' filled.contour(x.grid,y.grid, z.grid, nlevels=50, color = rainbow,
##' plot.axes = {title("Kriging mean");
##' points(model@@X[,1],model@@X[,2],pch=17,col="blue");
##' axis(1); axis(2)})
##'
##' # Plot Kriging variance
##' z.grid <- matrix(sk.grid^2, n.grid, n.grid)
##' filled.contour(x.grid,y.grid, z.grid, nlevels=50, color = rainbow,
##' plot.axes = {title("Kriging variance");
##' points(model@@X[,1],model@@X[,2],pch=17,col="blue");
##' axis(1); axis(2)})
##'
##' # Plot kriging.quantile criterion
##' z.grid <- matrix(crit.grid, n.grid, n.grid)
##' filled.contour(x.grid,y.grid, z.grid, nlevels=50, color = rainbow,
##' plot.axes = {title("kriging.quantile");
##' points(model@@X[,1],model@@X[,2],pch=17,col="blue");
##' axis(1); axis(2)})
##'
##' @export
kriging.quantile <- function(x, model, beta=0.1, type = "UK", envir=NULL)
{
########## Convert x in proper format(s) ###
d <- length(x)
if (d != model@d){ stop("x does not have the right size") }
newdata.num <- as.numeric(x)
newdata <- data.frame(t(newdata.num))
colnames(newdata) = colnames(model@X)
# Prediction en newdata en partant de X
predx <- predict(model, newdata=newdata, type=type, checkNames = FALSE)
mk <- predx$mean
sk <- predx$sd
qk <- mk + qnorm(beta)*sk
if (!is.null(envir)) {
assign("mk", mk, envir=envir)
assign("sk", sk, envir=envir)
assign("c", predx$c, envir=envir)
assign("Tinv.c", predx$Tinv.c, envir=envir)
}
return(res <- qk)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.