[Robast-commits] r612 - in branches/robast-0.9/pkg: . ROptEst/R ROptEst/man RobAstRDA RobAstRDA/R RobAstRDA/man RobExtremes RobExtremes/R RobExtremes/inst/AddMaterial/interpolation RobExtremes/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Feb 16 23:26:48 CET 2013
Author: ruckdeschel
Date: 2013-02-16 23:26:47 +0100 (Sat, 16 Feb 2013)
New Revision: 612
Added:
branches/robast-0.9/pkg/ROptEst/R/interpolLM.R
branches/robast-0.9/pkg/ROptEst/R/recomputeInterpolators.R
branches/robast-0.9/pkg/ROptEst/man/internal-interpolate.Rd
branches/robast-0.9/pkg/RobAstRDA/
branches/robast-0.9/pkg/RobExtremes/R/getStartIC.R
branches/robast-0.9/pkg/RobExtremes/R/internal-getpsi.R
branches/robast-0.9/pkg/RobExtremes/man/getStartIC-methods.Rd
Removed:
branches/robast-0.9/pkg/ROptEst/R/internal-getpsi.R
branches/robast-0.9/pkg/ROptEst/man/internalInterpolate.Rd
branches/robast-0.9/pkg/RobExtremes/R/sysdata.rda
branches/robast-0.9/pkg/RobRDA/
Modified:
branches/robast-0.9/pkg/ROptEst/R/getStartIC.R
branches/robast-0.9/pkg/ROptEst/man/getStartIC-methods.Rd
branches/robast-0.9/pkg/RobAstRDA/DESCRIPTION
branches/robast-0.9/pkg/RobAstRDA/R/Comment.R
branches/robast-0.9/pkg/RobAstRDA/man/0RobRDA-package.Rd
branches/robast-0.9/pkg/RobExtremes/DESCRIPTION
branches/robast-0.9/pkg/RobExtremes/NAMESPACE
branches/robast-0.9/pkg/RobExtremes/R/SnQn.R
branches/robast-0.9/pkg/RobExtremes/R/interpolLM.R
branches/robast-0.9/pkg/RobExtremes/R/interpolSn.R
branches/robast-0.9/pkg/RobExtremes/R/recomputeInterpolators.R
branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R
branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R
branches/robast-0.9/pkg/RobExtremes/man/0RobExtremes-package.Rd
branches/robast-0.9/pkg/RobExtremes/man/internal-interpolate.Rd
Log:
+ moved interpolation grids to new package RobAStRDA (renamed from RobRDA)
+ explained purpose of package RobAStRDA in man/0RobRDA-package.Rd and in R/Comment.R
+ moved non-RobExtremes-specific interpolation infrastructure to package ROptEst,
* .mergeF
* .copyGrid
* .renameGridName
* .MakeGridList
* .saveInterpGrid (with new argument structure / new defaults)
* .recomputeInterpolators
* .getLMGrid
* .RMXE.th
* .MBRE.th
* .OMSE.th
they all get "imported" in RobExtremes by something like
.recomputeInterpolators <- ROptEst:::.recomputeInterpolators
+ .recomputeInterpolators, .saveInterpGrid gain argument sysdataWriteFile to be able to write to other
files (other than sysdata.rda) => no need anymore to write in separate folders when creating new
grids in parallel
+ getStartIC - method for interpolRisks (and hence internal-getpsi, too) moved from
ROptEst to RobExtremes
+ getStartIC-method for interpolRisks and Sn methods now load grids from RobAStRDA namespace
Modified: branches/robast-0.9/pkg/ROptEst/R/getStartIC.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/getStartIC.R 2013-02-16 16:04:40 UTC (rev 611)
+++ branches/robast-0.9/pkg/ROptEst/R/getStartIC.R 2013-02-16 22:26:47 UTC (rev 612)
@@ -79,34 +79,3 @@
})
-setMethod("getStartIC",signature(model = "L2ScaleShapeUnion", risk = "interpolRisk"),
- function(model, risk, ...){
-
- mc <- match.call(expand.dots=TRUE)
-
- gridn <- type(risk)
- nam <- name(model)
- xi <- main(param(model))["shape"] #[scaleshapename(model)["shape"]]
- beta <- main(param(model))["scale"] #[scaleshapename(model)["scale"]]
- nsng <- character(0)
- sng <- try(getFromNamespace(.versionSuff(gridn), ns = "RobExtremes"),
- silent=TRUE)
- if(!is(sng,"try-error")) nsng <- names(sng)
- if(length(nsng)){
- if(nam %in% nsng){
- interpolfct <- sng[[nam]]$fct
- .modifyIC <- function(L2Fam, IC){
- para <- param(L2Fam)
- xi0 <- main(para)["shape"]#[scaleshapename(L2Fam)["scale"]]
- beta0 <- main(para)["scale"]#[scaleshapename(L2Fam)["scale"]]
- .getPsi(xi0,beta0, interpolfct, L2Fam, type(risk))}
- IC0 <- .getPsi(xi, beta, interpolfct, model, type(risk))
- IC0 at modifyIC <- .modifyIC
- return(IC0)
- }
- }
- mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias()
- mc$neighbor <- ContNeighborhood(radius=0.5)
- return(do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2)))
- })
-
Deleted: branches/robast-0.9/pkg/ROptEst/R/internal-getpsi.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/internal-getpsi.R 2013-02-16 16:04:40 UTC (rev 611)
+++ branches/robast-0.9/pkg/ROptEst/R/internal-getpsi.R 2013-02-16 22:26:47 UTC (rev 612)
@@ -1,62 +0,0 @@
-.getPsi <- function(xi, beta, fct, L2Fam , type){
-
- L2deriv <- L2Fam at L2deriv
- .dbeta <- diag(c(beta,1))
- b <- fct[[1]](xi)
- a <- c(.dbeta%*%c(fct[[2]](xi),fct[[3]](xi)))
- aw <- c(.dbeta%*%c(fct[[4]](xi),fct[[5]](xi)))
- am <- mean(c(fct[[7]](xi),fct[[8]](xi)))
- A <- .dbeta%*%matrix(c(fct[[6]](xi),am,am,fct[[9]](xi)),2,2)%*%.dbeta
- am <- mean(c(fct[[11]](xi),fct[[12]](xi)))
- Aw <- .dbeta%*%matrix(c(fct[[10]](xi),am,am,fct[[13]](xi)),2,2)%*%.dbeta
-
-
-
- normt <- NormType()
- biast <- symmetricBias()
- nb <- ContNeighborhood(radius=0.5)
- ICT <- paste("optimally robust IC for", switch(type,
- ".OMSE"="maxMSE",".RMXE"="RMX", ".MBRE"="maxBias"))
- riskT <- if(type!=".MBRE") "asGRisk" else "asBias"
-
- w <- new("HampelWeight")
- stand(w) <- Aw
- cent(w) <- aw
- clip(w) <- b
-
- if(type!=".MBRE"){
- weight(w) <- getweight(w, neighbor = nb, biastype = biast,
- normW = normt)
- }else weight(w) <- minbiasweight(w, neighbor = nb, biastype = biast,
- normW = normt)
-
- res <- list(a = a, A = A, b = b, d = 0*a,
- normtype = normt, biastype = biast, w = w,
- info = c("optIC", ICT), risk = list(),
- modifyIC = NULL)
-
-
- IC <- generateIC(nb, L2Fam, res)
- return(IC)
-}
-
-if(FALSE){
- res <- list(a = a, A = A, b = b, d = 0*a, w = w)
-
- IC <- ContIC(name = "interpolated IC of contamination type",
- CallL2Fam = L2Fam at fam.call,
- Curve = generateIC.fct(nb, L2Fam, res),
- clip = b,
- cent = a,
- stand = A,
- lowerCase =0*a,
- w = w,
- neighborRadius = nb at radius,
- modifyIC = NULL,
- normtype = normt,
- biastype = biast,
- Risks = list(),
- Infos = matrix(c("optIC", ICT), ncol = 2,
- dimnames = list(character(0), c("method", "message"))
- ))
-}
\ No newline at end of file
Added: branches/robast-0.9/pkg/ROptEst/R/interpolLM.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/interpolLM.R (rev 0)
+++ branches/robast-0.9/pkg/ROptEst/R/interpolLM.R 2013-02-16 22:26:47 UTC (rev 612)
@@ -0,0 +1,199 @@
+.RMXE.th <- function(th, PFam, modifyfct){
+ PFam <- modifyfct(th,PFam)
+ IC <- radiusMinimaxIC(L2Fam=PFam, neighbor= ContNeighborhood(),
+ risk = asMSE(), verbose = FALSE)
+ return(c(b=clip(IC), a=cent(IC), a.w = cent(weight(IC)),
+ A=stand(IC), A.w = stand(weight(IC))))
+}
+
+.MBRE.th <- function(th, PFam, modifyfct){
+ PFam <- modifyfct(th,PFam)
+ RobM <- InfRobModel(center = PFam, neighbor = ContNeighborhood(radius = 15))
+ IC <- optIC(model = RobM, risk = asBias(), verbose = FALSE)
+ mA <- max(stand(IC))
+ mAw <- max(stand(weight(IC)))
+ return(c(b=clip(IC), a=cent(IC), aw=cent(weight(IC)),
+ A=stand(IC)/mA, Aw=stand(weight(IC))/mAw))
+}
+
+.OMSE.th <- function(th, PFam, modifyfct){
+ PFam <- modifyfct(th,PFam)
+ RobM <- InfRobModel(center = PFam, neighbor = ContNeighborhood(radius = .5))
+ IC <- optIC(model = RobM, risk = asMSE(), verbose = FALSE)
+ res=c(b=clip(IC), a=cent(IC), a.w = cent(weight(IC)),
+ A=stand(IC), A.w = stand(weight(IC)))
+ return(res)
+}
+
+.getLMGrid <- function(thGrid, PFam, optFct = .RMXE.th, modifyfct,
+ GridFileName="LMGrid.Rdata",
+ withSmooth = TRUE, withPrint = FALSE, withCall = FALSE){
+ print(match.call())
+ call <- match.call()
+ thGrid <- unique(sort(thGrid))
+ itLM <- 0
+ getLM <- function(th){
+ itLM <<- itLM + 1
+ if(withPrint) cat("Evaluation Nr.", itLM," at th = ",th,"\n")
+ a <- try(optFct(th=th,PFam=PFam,modifyfct=modifyfct), silent=TRUE)
+ if(is(a,"try-error")) a <- rep(NA,13)
+ return(a)
+ }
+
+ distroptions.old <- distroptions()
+ distrExOptions.old <- distrExOptions()
+ distroptions("withgaps"=FALSE)
+ distrExOptions( MCIterations=1e6,
+ GLIntegrateTruncQuantile=.Machine$double.eps,
+ GLIntegrateOrder=1000,
+ ElowerTruncQuantile=1e-7,
+ EupperTruncQuantile=1e-7,
+ ErelativeTolerance = .Machine$double.eps^0.4,
+ m1dfRelativeTolerance = .Machine$double.eps^0.4,
+ m2dfRelativeTolerance = .Machine$double.eps^0.4,
+ nDiscretize = 300, IQR.fac = 20)
+ on.exit({do.call(distrExOptions,args=distrExOptions.old)
+ do.call(distroptions,args=distroptions.old)
+ })
+ LMGrid <- sapply(thGrid,getLM)
+ if(GridFileName!="") save(LMGrid, file=GridFileName)
+ res <- .MakeGridList(thGrid, Y=t(LMGrid), withSmooth = withSmooth)
+ print(res)
+ rm(itLM,getLM)
+ if(withCall) rm(call)
+ return(list(grid = res$grid,
+ fct = res$fct, call = if(withCall) call else NULL))
+}
+
+.MakeGridList <- function(thGrid, Y, withSmooth = TRUE){
+ if(length(dim(Y))==3)
+ LMGrid <- Y[,1,,drop=TRUE]
+ else LMGrid <- Y[,drop=FALSE]
+
+ iNA <- apply(LMGrid,1, function(u) any(is.na(u)))
+ LMGrid <- LMGrid[!iNA,,drop=FALSE]
+ thGrid <- thGrid[!iNA]
+ oG <- order(thGrid)
+ thGrid <- thGrid[oG]
+ LMGrid <- LMGrid[oG,,drop=FALSE]
+ if(withSmooth)
+ LMGrid2 <- apply(LMGrid,2,function(u) smooth.spline(thGrid,u)$y)
+
+ fctL <- vector("list",ncol(LMGrid))
+ xm <- thGrid[1]
+ xM <- (rev(thGrid))[1]
+ for(i in 1:ncol(LMGrid)){
+ LMG <- LMGrid[,i]
+ fct <- splinefun(x=thGrid,y=LMG)
+ ym <- LMG[1]
+ dym <- (LMG[2]-LMG[1])/(thGrid[2]-thGrid[1])
+ yM <- (rev(LMG))[1]
+ dyM <- ((rev(LMG))[2]-(rev(LMG))[1])/((rev(thGrid))[2]-(rev(thGrid))[1])
+ fctX <- function(x){
+ y0 <- fct(x)
+ y1 <- y0
+ y1[x<xm] <- ym+dym*(x[x<xm]-xm)
+ y1[x>xM] <- yM+dyM*(x[x>xM]-xM)
+ if(any(is.na(y0)))
+ warning("There have been xi-values out of range of the interpolation grid.")
+ return(y1)
+ }
+ environment(fctX) <- nE <- new.env()
+ assign("fct",fct, envir=nE)
+ assign("yM",yM, envir=nE)
+ assign("ym",ym, envir=nE)
+ assign("dyM",dyM, envir=nE)
+ assign("dym",dym, envir=nE)
+ fctL[[i]] <- fctX
+ }
+ if(ncol(LMGrid)==1) fctL <- fctL[[1]]
+ rm(LMG,fct,fctX,iNA,ym,yM,dym,dyM)
+ return(list(grid = cbind(xi=thGrid,LM=LMGrid),
+ fct = fctL))
+}
+
+
+.saveInterpGrid <- function(thGrid, PFam, sysRdaFolder,
+ sysdataWriteFile = "sysdata.rda", getFun = .getLMGrid, ...,
+ modifyfct, nameInSysdata, GridFileName, withSmooth = TRUE,
+ withPrint = TRUE, withCall = FALSE, Y = NULL, elseFun = NULL){
+ if(missing(sysRdaFolder)) stop("You must specify argument 'sysRdaFolder'.")
+
+ if(missing(GridFileName))
+ GridFileName <- paste(sub("^\\.(.+)","\\1",nameInSysdata),".Rdata",sep="")
+ newEnv <- new.env()
+ sysdataFile <- file.path(sysRdaFolder, sysdataWriteFile)
+ cat("sysdataFile = ", sysdataFile, "\n")
+
+ if(file.exists(sysdataFile)){
+ load(file=sysdataFile,envir=newEnv)
+ whatIsThereAlready <- ls(envir=newEnv, all.names=TRUE)
+ }else whatIsThereAlready <- character(0)
+
+ cat("whatIsThereAlready = ", head(whatIsThereAlready), "\n")
+
+ if(exists(.versionSuff(nameInSysdata),envir=newEnv,inherits=FALSE)){
+ InterpGrids <- get(.versionSuff(nameInSysdata), envir=newEnv)
+ namesInterpGrids <- names(InterpGrids)
+ cat(gettext("Names of existing grids:\n"))
+ cat(paste(" ", namesInterpGrids , "\n"))
+
+ if(name(PFam)%in% namesInterpGrids){
+ cat(gettext("There already is a grid for family "), name(PFam),".\n",sep="")
+ if(!is.null(InterpGrids[[name(PFam)]]$call)){
+ cat(gettextf("It was generated by\n"),sep="")
+ print(InterpGrids[[name(PFam)]]$call)
+ }
+ cat("\n",
+ gettext("Do you really want to overwrite it (yes=1/no else)?"),"\n",
+ sep="")
+ ans <- try(scan(what=integer(1)), silent = TRUE)
+ if(is(ans,"try-error")) ans <- 0
+ if(ans==1){
+ if(is.null(Y)) {
+ InterpGrids[[name(PFam)]] <- getFun(thGrid = thGrid, PFam = PFam,
+ ..., modifyfct = modifyfct, withSmooth = withSmooth,
+ withPrint = withPrint, withCall = withCall,
+ GridFileName = GridFileName)
+ }else{ if(!is.null(elseFun)){
+ InterpGrids[[name(PFam)]] <- elseFun(thGrid, Y,
+ withSmooth = withSmooth)
+ }else return(NULL)
+ }
+
+ l.ng <- -1
+ cat(gettext("SnGrid successfully produced.\n"))
+ }else l.ng <- -2
+ }else l.ng <- length(InterpGrids)+1
+ }else{
+ l.ng <- 1
+ InterpGrids <- vector("list",1)
+ whatIsThereAlready <- c(whatIsThereAlready,.versionSuff(nameInSysdata))
+ }
+
+ if(l.ng>0){
+ if(is.null(Y)) {
+ InterpGrids[[l.ng]] <- getFun(thGrid = thGrid, PFam = PFam,
+ ..., modifyfct = modifyfct, withSmooth = withSmooth,
+ withPrint = withPrint, withCall = withCall,
+ GridFileName = GridFileName)
+ }else{ if(!is.null(elseFun)){
+ InterpGrids[[l.ng]] <- elseFun(thGrid, Y, withSmooth = withSmooth)
+ }else return(NULL)
+ }
+ cat(gettext("Grid successfully produced.\n"))
+ names(InterpGrids)[l.ng] <- name(PFam)
+ }
+
+ if(l.ng> -2){
+ assign(.versionSuff(nameInSysdata), InterpGrids, envir=newEnv)
+ save(list=whatIsThereAlready, file=sysdataFile, envir=newEnv)
+ tools::resaveRdaFiles(sysdataFile)
+ cat(gettextf("%s successfully written to sysdata.rda file.\n",
+ nameInSysdata))
+ }
+ rm(list=whatIsThereAlready,envir=newEnv)
+ gc()
+ return(invisible(NULL))
+}
+
Added: branches/robast-0.9/pkg/ROptEst/R/recomputeInterpolators.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/recomputeInterpolators.R (rev 0)
+++ branches/robast-0.9/pkg/ROptEst/R/recomputeInterpolators.R 2013-02-16 22:26:47 UTC (rev 612)
@@ -0,0 +1,228 @@
+.recomputeInterpolators <- function(sysdataFiles, sysRdaFolder = ".",
+ sysdataWriteFile = "sysdata.rda",
+ excludeGrids = NULL, excludeNams = NULL,
+ others = FALSE, onlyothers = FALSE,
+ translate = TRUE, overwrite = TRUE, integrateto = FALSE,
+ onlyCurrent = FALSE, withPrint =TRUE,
+ withSmooth = TRUE,
+ debug = FALSE){
+
+ wprint <- function(...){ if (withPrint) print(...)}
+
+ sam <- new.env()
+ for(File in sysdataFiles) .mergeF(File, envir = sam,
+ excludeGrids = excludeGrids , excludeNams = excludeNams)
+
+ keep <- if(getRversion()>="2.16") "N" else "O"
+ todo <- if(getRversion()>="2.16") "O" else "N"
+
+ whatIsThereAlready <- ls(all.names=TRUE, envir=sam)
+ whatIsThereAlready.N <- grep(paste("^\\..+\\.",keep,"$",sep=""),
+ whatIsThereAlready,value=T)
+
+ whatIsThereAlready.O <- grep(paste("^\\..+\\.",todo,"$",sep=""),
+ whatIsThereAlready,value=T)
+ whatIsThereAlready.E <- setdiff(setdiff(whatIsThereAlready,
+ whatIsThereAlready.N),whatIsThereAlready.O)
+
+ wprint(whatIsThereAlready.N)
+
+ only.grid <- new.env()
+
+ if(others){
+ wprint("recomputed anew from neither .O nor .N architecture")
+
+ for(what in whatIsThereAlready.E){
+ wprint(what)
+ what.to <- paste(what,".",keep,sep="")
+ vec <- get(what, envir=sam)
+ for(Fam in names(vec)){
+ wprint(Fam)
+ grid <- vec[[Fam]]$grid
+ wprint(head(grid))
+ a0 <- .MakeGridList(grid[,1], Y=grid[,-1,drop=FALSE],
+ withSmooth = withSmooth)
+ vec[[Fam]] <- a0
+ }
+ assign(what.to, vec, envir=only.grid)
+ }
+ lsA <- ls(all.names=T,envir=only.grid)
+ wprint(lsA)
+ }
+
+ if(!onlyothers){
+
+ wprint("copied/recomputed anew from from current architecture")
+
+ for(what in whatIsThereAlready.N){
+ wprint(what)
+ vec <- get(what, envir=sam)
+ if(overwrite){
+ for(Fam in names(vec)){
+ wprint(Fam)
+ grid <- vec[[Fam]]$grid
+ wprint(head(grid))
+ a0 <- .MakeGridList(grid[,1], Y=grid[,-1,drop=FALSE],
+ withSmooth = withSmooth)
+ vec[[Fam]] <- a0
+ }
+ }
+ if(integrateto){
+ vec.E <- get(what, envir = only.grid)
+ for(Fam in names(vec)){
+ wprint(Fam)
+ grid.E <- vec.E[[Fam]]$grid
+ grid <- vec[[Fam]]$grid
+ grid.0 <- rbind(grid.E, grid)
+ oI <- order(grid.0[,1])
+ wI <- !duplicated(grid.0[oI,1])
+ grid <- grid.0[wI,]
+ wprint(head(grid))
+ a0 <- .MakeGridList(grid[,1], Y=grid[,-1,drop=FALSE],
+ withSmooth = withSmooth)
+ vec[[Fam]] <- a0
+ }
+ }
+ assign(what, vec, envir=only.grid)
+ }
+ lsA <- ls(all.names=T,envir=only.grid)
+ wprint(lsA)
+
+ if(!onlyCurrent){
+ wprint("copy foreign architecture")
+ for(what in whatIsThereAlready.O){
+ wprint(what)
+ assign(what, get(what, envir=sam), envir=only.grid)
+ }
+ }
+ lsA <- ls(all.names=T,envir=only.grid)
+ wprint(lsA)
+
+ if(translate)
+ for(what in whatIsThereAlready.O){
+ wprint("translating foreign to current architecture")
+ what.N <- sub(paste("\\.", todo, "$", sep=""),
+ paste(".", keep, sep=""),what)
+ wprint(c(from=what, to=what.N))
+
+ wG <- get(what, envir=sam)
+ anyFam <- FALSE
+ vec <- NULL
+ if(onlyCurrent) if(what.N %in% whatIsThereAlready.N)
+ vec <- get(what.N,envir=sam)
+ for(Fam in names(wG)){
+ wprint(Fam)
+ if(! Fam %in% names(vec)){
+ anyFam <- TRUE
+ grid <- wG[[Fam]]$grid
+ wprint(head(grid))
+ a0 <- .MakeGridList(grid[,1], Y=grid[,-1,drop=FALSE],
+ withSmooth = withSmooth)
+ vec[[Fam]] <- a0
+ }
+ }
+ if(integrateto){
+ vec.E <- get(what, envir = only.grid)
+ anyFam <- TRUE
+ for(Fam in names(wG)){
+ wprint(Fam)
+ grid.E <- vec.E[[Fam]]$grid
+ grid <- wG[[Fam]]$grid
+ grid.0 <- rbind(grid.E, grid)
+ oI <- order(grid.0[,1])
+ wI <- !duplicated(grid.0[oI,1])
+ grid <- grid.0[wI,]
+ wprint(head(grid))
+ a0 <- .MakeGridList(grid[,1], Y=grid[,-1,drop=FALSE],
+ withSmooth = withSmooth)
+ vec[[Fam]] <- a0
+ }
+ }
+ if(anyFam) assign(what.N, vec, envir=only.grid)
+ }
+ lsA <- ls(all.names=T,envir=only.grid)
+ wprint(lsA)
+ }
+
+ sysFile <- file.path(sysRdaFolder, sysdataWriteFile)
+
+ if(!debug){
+ save(list=lsA, envir=only.grid, file=sysFile)
+ tools::resaveRdaFiles(sysFile)
+ }else{
+ print(paste("save(list=lsA, envir=only.grid, file=", sysFile,")", sep=""))
+ }
+}
+
+.renameGridName <- function(gridnam, namOld, namNew, rdafileOld, rdafileNew){
+ nE <- new.env()
+ load(rdafileOld,envir=nE)
+ what <- ls(all.names=TRUE,envir=nE)
+ a <- get(gridnam, envir=nE)
+ na <- names(a)
+ wi <- which(namOld==na)
+ na[wi] <- namNew
+ names(a) <- na
+ assign(gridnam,a,envir=nE)
+ save(list=what, file=rdafileNew, envir=nE)
+}
+
+.mergeF <- function(file,envir, excludeGrids = NULL, excludeNams = NULL){
+ envir2 <- new.env()
+ load(file,envir=envir2)
+ rm(list=excludeGrids, envir=envir2)
+ what1 <- ls(all.names=TRUE,envir=envir)
+ what2 <- ls(all.names=TRUE,envir=envir2)
+ for(w2 in what2){
+ wG2 <- get(w2, envir=envir2)
+ if(w2 %in% what1){
+ wG1 <- get(w2, envir=envir)
+ for(Fam1 in names(wG1)){
+ if( Fam1 %in% excludeNams) wG2[[Fam1]] <- NULL
+ if( ! Fam1 %in% names(wG2)) wG2[[Fam1]] <- wG1[[Fam1]]
+ }
+ }
+ assign(w2,wG2,envir=envir)
+ }
+ return(invisible(NULL))
+}
+if(FALSE){
+ a <- NULL; a[["TU"]] = 2
+ save(a,file="testA.Rdata")
+ a <- NULL; a[["HU"]] = 3
+ nE <- new.env(); assign("a",a,envir=nE)
+ .mergeF("testA.Rdata",nE)
+ get("a",envir=nE)
+}
+
+.copyGrid <- function(grid, gridnam, namOld, namNew, rdafileOld, rdafileNew){
+ nE <- new.env()
+ load(rdafileOld,envir=nE)
+ gr <- get(gridnam,envir=nE)
+ gr[[namNew]] <- gr[[namOld]]
+ gr[[namNew]]$grid <- grid
+ assign(gridnam,gr,envir=nE)
+ what <- ls(envir=nE, all.names = TRUE)
+ save(list=what, file= rdafileNew, envir=nE)
+}
+
+if(FALSE){
+ source("makegridlist.R")
+ .myFolder <- "C:/rtest/RobASt/branches/robast-0.9/pkg"
+ source(file.path(.myFolder,"RobExtremes/R","recomputeinterpolators.R"))
+ .myfiles1 <- file.path(.myFolder,
+ c("ROptEst/R", "RobExtremes/R", "RobExtremesBuffer"),
+ "sysdata.rda")
+
+ .myfiles <- file.path(.myFolder, "RobExtremes/R/sysdata.rda")
+
+ .recomputeInterpolators(file.path(.myFolder,"RobExtremes/R/sysdata.rda"),
+ sysRdaFolder = file.path(.myFolder,"RobExtremes/R"), debug = TRUE)
+
+ wha <- c(".OMSE",".RMXE",".MBRE",".SnGrids")
+ for(w in wha) assign(w,get(w, envir=asNamespace("RobExtremes")),envir=nE)
+ save(list=wha,envir=nE, file="sysdata-oold.rda")
+
+ .recomputeInterpolators(c("sysdata-ooold.rda","sysdata-0.rda"), others = TRUE, onlyothers = FALSE, sysRdaFolder = ".", integrateto = TRUE)
+
+}
\ No newline at end of file
Modified: branches/robast-0.9/pkg/ROptEst/man/getStartIC-methods.Rd
===================================================================
--- branches/robast-0.9/pkg/ROptEst/man/getStartIC-methods.Rd 2013-02-16 16:04:40 UTC (rev 611)
+++ branches/robast-0.9/pkg/ROptEst/man/getStartIC-methods.Rd 2013-02-16 22:26:47 UTC (rev 612)
@@ -3,12 +3,10 @@
\alias{getStartIC-methods}
\alias{getStartIC}
\alias{getStartIC,ANY,ANY-method}
-\alias{getStartIC,L2ParamFamily,asRisk-method}
\alias{getStartIC,L2ParamFamily,asGRisk-method}
\alias{getStartIC,L2ParamFamily,asBias-method}
\alias{getStartIC,L2ParamFamily,asCov-method}
\alias{getStartIC,L2ParamFamily,trAsCov-method}
-\alias{getStartIC,L2ScaleShapeUnion,interpolRisk-method}
\title{Methods for Function getStartIC in Package `ROptEst' }
@@ -16,7 +14,11 @@
argument \code{ICstart} in \code{kStepEstimator}.}
\usage{getStartIC(model, risk, ...)
-\S4method{getStartIC}{L2ParamFamily,asRisk}(model, risk, ..., ..debug=FALSE)
+\S4method{getStartIC}{ANY,ANY}(model, risk, ...)
+\S4method{getStartIC}{L2ParamFamily,asGRisk}(model, risk, ..., ..debug=FALSE)
+\S4method{getStartIC}{L2ParamFamily,asBias}(model, risk, ..., ..debug=FALSE)
+\S4method{getStartIC}{L2ParamFamily,asCov}(model, risk, ..., ..debug=FALSE)
+\S4method{getStartIC}{L2ParamFamily,trAsCov}(model, risk, ..., ..debug=FALSE)
}
\arguments{
@@ -28,14 +30,19 @@
\section{Methods}{\describe{
\item{getStartIC}{\code{signature(model = "ANY", risk = "ANY")}:
issue that this is not yet implemented. }
-\item{getStartIC}{\code{signature(model = "L2ParamFamily", risk = "asRisk")}:
+\item{getStartIC}{\code{signature(model = "L2ParamFamily", risk = "asGRisk")}:
depending on the values of argument \code{eps} (to be passed on through
the \code{\dots} argument) computes the optimally robust influence
function on the fly via calls to \code{optIC} or \code{radiusMinimaxIC}. }
-\item{getStartIC}{\code{signature(model = "L2ScaleShapeUnion", risk = "interpolRisk")}:
- computes the optimally robust influence function by interpolation
- on a grid (using helper function \code{.getPsi}).}
-
+\item{getStartIC}{\code{signature(model = "L2ParamFamily", risk = "asBias")}:
+ computes the most-bias-robust influence function on the fly via
+ calls to \code{optIC}. }
+\item{getStartIC}{\code{signature(model = "L2ParamFamily", risk = "asCov")}:
+ computes the classically optimal influence function on the fly via
+ calls to \code{optIC}. }
+\item{getStartIC}{\code{signature(model = "L2ParamFamily", risk = "trAsCov")}:
+ computes the classically optimal influence function on the fly via
+ calls to \code{optIC}. }
}}
\value{
An IC of type \code{HampIC}.
Added: branches/robast-0.9/pkg/ROptEst/man/internal-interpolate.Rd
===================================================================
--- branches/robast-0.9/pkg/ROptEst/man/internal-interpolate.Rd (rev 0)
+++ branches/robast-0.9/pkg/ROptEst/man/internal-interpolate.Rd 2013-02-16 22:26:47 UTC (rev 612)
@@ -0,0 +1,220 @@
+\name{internal_interpolate_helpers}
+\alias{internal_interpolate_helpers}
+\alias{internalInterpolate}
+\alias{.mergeF}
+\alias{.copyGrid}
+\alias{.renameGridName}
+\alias{.MakeGridList}
+\alias{.saveInterpGrid}
+\alias{.recomputeInterpolators}
+\alias{.versionSuff}
+\alias{.getLMGrid}
+\alias{.RMXE.th}
+\alias{.MBRE.th}
+\alias{.OMSE.th}
+
+\title{Internal helper functions for generating interpolation grids for
+ speed up in package RobExtremes}
+
+\description{
+These functions are used internally to generate interpolation grids,
+for Lagrange multipliers or LDEstimators in package \pkg{RobExtremes},
+to be stored in the
+respective \file{sysdata.rda} file. }
+
+\usage{
+.versionSuff(name)
+
+.RMXE.th(th, PFam, modifyfct)
+.MBRE.th(th, PFam, modifyfct)
+.OMSE.th(th, PFam, modifyfct)
+
+.getLMGrid(thGrid, PFam, optFct = .RMXE.th, modifyfct,
+ GridFileName="LMGrid.Rdata", withSmooth = TRUE,
+ withPrint = FALSE, withCall = FALSE)
+
+.MakeGridList(thGrid, Y, withSmooth = TRUE)
+
+.saveInterpGrid(thGrid, PFam, sysRdaFolder, sysdataWriteFile = "sysdata.rda",
+ getFun = .getLMGrid, ..., modifyfct, nameInSysdata, GridFileName,
+ withSmooth = TRUE, withPrint = TRUE, withCall = FALSE, Y = NULL,
+ elseFun = NULL)
+
+.recomputeInterpolators(sysdataFiles, sysRdaFolder = ".",
+ sysdataWriteFile = "sysdata.rda", excludeGrids = NULL,
+ excludeNams = NULL, others = FALSE,
+ onlyothers = FALSE, translate = TRUE, overwrite = TRUE,
+ integrateto = FALSE, onlyCurrent = FALSE, withPrint =TRUE,
+ withSmooth = TRUE, debug = FALSE)
+
+.renameGridName(gridnam, namOld, namNew, rdafileOld, rdafileNew)
+.copyGrid(grid, gridnam, namOld, namNew, rdafileOld, rdafileNew)
+.mergeF(file,envir, excludeGrids = NULL, excludeNams = NULL)
+}
+
+\arguments{
+ \item{name}{Grid name to append a suffix according to the R-version. }
+ \item{th}{numeric of length 1; the grid value at which to compute LMs. }
+ \item{PFam}{an object of class \code{"ParamFamily"}, the parametric family
+ at which to evaluate the Lagrange multipliers or LDEstimators;
+ in our use case, it is a shape-scale model, hence the respective
+ (main) parameter must contain \code{"scale"} and \code{"shape"}. }
+ \item{modifyfct}{function with arguments \code{th} and \code{PFam} to move
+ the parametric family to the point of the grid value; returns the
+ moved parametric family.}
+ \item{withSmooth}{logical of length 1: shall a smoothing spline be used?}
+ \item{withPrint}{logical of length 1: shall current grid value be printed out?}
+ \item{thGrid}{numeric; grid values. }
+ \item{Y}{in case \code{.MakeGridList}: array or matrix; in case
+ \code{.saveInterpGrid} array or \code{NULL}; if non-null,
+ contains precomputed y-values, so that call to \code{getFun}
+ resp. \code{optFct} can be omitted. }
+ \item{optFct}{function with arguments \code{theta}, \code{PFam},
+ and modifyfct; determines the Lagrange multipliers. }
+ \item{GridFileName}{character; if \code{GridFileName!=""}, the pure
+ y-grid values are saved under this filename. }
+ \item{withCall}{logical of length 1: shall the call be saved, too?}
+ \item{thGrid}{numeric; grid values. }
+ \item{sysRdaFolder}{the folder where \pkg{RobExtremes}
+ (or the respective package) is being developed; must not be missing. }
+ \item{getFun}{function with first argument \code{th}, second argument
+ \code{PFam} and last arguments \code{GridFileName},
+ \code{withSmooth}, \code{withPrint}, and \code{withCall};
+ produces the y-values for the interpolation grid. }
+ \item{\dots}{further arguments to be passed on to \code{getFun}. }
+ \item{nameInSysdata, nam}{name under which the list of interpolated grids is stored
+ in file \file{sysdata.rda}. }
+ \item{elseFun}{function or \code{NULL}; if \code{Y} is non-null, contains
+ function to transform \code{Y} to desired return value. }
+
+ \item{sysdataFiles}{character; filenames of \file{sysdata.rda} files from
+ where to extract the interpolation grids. }
+ \item{sysdataWriteFile}{filename for the \file{sysdata.rda} on which to write
+ the results.}
+ \item{excludeGrids}{character (or \code{NULL}); grids to be excluded
+ from recomputation}
+ \item{excludeNams}{character (or \code{NULL}); families to be excluded
+ from recomputation}
+ \item{overwrite}{logical; if \code{TRUE} foreign grids are translated
+ to current R version. }
+ \item{overwrite}{logical; if \code{TRUE} existing interpolation functions
+ for the current R version get recomputed.}
+ \item{others}{logical; if \code{TRUE} and in the \file{sysdata.rda} files
+ to be modified, there are grids not ending to \code{.N} (for R>2.16)
+ or \code{.O} (for R<2.16), we also recompute the interpolation
+ functions for these grids. }
+ \item{onlyothers}{logical; if \code{TRUE}, only the interpolation functions
+ for \code{others}-grids (see argument \code{others}) are recomupted. }
+ \item{onlyCurrent}{logical; if \code{TRUE} existing interpolation functions
+ for the foreign R version are not included in the new \file{sysdata.rda}
+ file.}
+ \item{integrateto}{logical; if \code{TRUE} and there are grids with
+ ending \code{.N}, \code{.O} and ``others'', these are merged. }
+ \item{debug}{logical; if \code{TRUE} the \file{sysdata.rda} file is not
+ created/overwritten in the end. }
+ \item{gridnam}{character; name of the grid to be renamed. }
+ \item{namOld}{character; name of the parametric family to be renamed (from). }
+ \item{namNew}{character; name of the parametric family to be renamed (to). }
+ \item{grid}{matrix or array; grid to be inserted. }
+ \item{rdafileOld}{character; filename of the \file{sysdata.rda}-type file
+ to be read out.}
+ \item{rdafileNew}{character; filename of the \file{sysdata.rda}-type file
+ to be written on.}
+ \item{file}{character; the name of a file to be read out}
+ \item{envir}{an environment}
+ \item{name}{character; name of the symbol in the \file{sysdata.rda}
+ interpolation object without suffix}
+ \item{xi}{numeric; shape parameter}
+ \item{beta}{numeric; scale parameter}
+ \item{fct}{a list of functions}
+ \item{L2Fam}{ object of class \code{L2ParamFamily} }
+ \item{type}{type of the IC; one of the values \code{".OMSE"},
+ \code{".RMXE"}, \code{".MBRE"}.}
+}
+\details{
+ \code{.versionSuff}, according to the current R-version, appends a suffix
+ ".O" for R<2.16 and ".N" otherwise to argument \code{name}. Needed as
+ the return values of \code{splinefun} are incompatible in these two
+ situations: i.e., a function with body of type
+ \code{.C("R_splinefun", as.double(x),....}) respectively
+ a function with body of type \code{.splinefun(....))});
+ a similar case happens with \code{approxfun}.
+
+ \code{.MBRE.th} computes the Lagrange multipliers for the MBRE estimator,
+ \code{.OMSE.th} for the OMSE estimator at radius \code{r=0.5},
+ and \code{.RMXE.th} the RMXE estimator.
+
+ \code{.MakeGridList} transforms the return values of the preceding functions
+ gathered in matrices in respective grids and can also be used for
+ Lagrange multiplier matrices already computed otherwise.
+
+ \code{.saveInterpGrid} is the utility to do the actual computation.
+ More specifically, the code first loads the contents of file
+ \file{sysdata.rda} into an environment which is particularly created
+ for this purpose (if this file exists). It then looks up whether a
+ respective entry for family \code{PFam} already exists in
+ \file{sysdata.rda}-object \code{nameInSysdata}.
+ If this is the case the developer is asked whether he wants to overwrite
+ the respective entry, and if so he does so with the results of a respective
+ call to \code{getFun}.
+
+ In case there has not been an \file{sysdata.rda}-object \code{nameInSysdata}
+ so far, the code creates one and writes the results of a respective
+ call to \code{getFun} to it.
+
+ \code{.recomputeInterpolators} recomputes the interpolating functions from
+ grids in existing \file{sysdata.rda} files -- either to translate them
+ to another R version, or to shrink the respective file.
+
+ \code{.renameGridName} is a utility to rename items from a grid. It takes
+ grid \code{gridnam} from file \code{rdafileOld} and takes
+ the name \code{namOld} of a respective item (i.e., a parametric family),
+ renames it to \code{namNew} and writes the result back
+ to file \code{rdafileNew}.
+
+ \code{.copyGrid} takes out a respective item \code{namOld} (i.e., a parametric
+ family) of grid \code{gridnam} from file \code{rdafileOld}
+ copies it to a new grid object onto item \code{namNew}, replaces
+ the respective grid-entry by \code{grid}, and saves the result to
+ to file \code{rdafileNew}.
+
+ \code{.mergeF} merges the contents of file \code{file} into environment
+ \code{envir} in the sense, that if both \code{file} and \code{envir}
+ contain a list object \code{a} also the items of \code{a} are merged,
+ where---as for objects themselves--- contents of \code{file} overwrite
+ contents of \code{envir}.
+}
+\note{These functions are only meant for the developers of package
+ \pkg{ROptEst} (or respective packages).
+ They can be used to speed up things by interpolation.
+ Our use case is a speed up for further scale-shape families (or enhance
+ existing speed-ups) such that the respective grids are stored in
+ a \file{sysdata.rda} file of an external package \pkg{RobAStRda}
+ ---see mail exchange P.Ruckdeschel - U.Ligges on R-devel---
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 612
More information about the Robast-commits
mailing list