[Robast-commits] r561 - in branches/robast-0.9/pkg/RobExtremes: R inst/AddMaterial/interpolation
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jan 25 14:56:29 CET 2013
Author: ruckdeschel
Date: 2013-01-25 14:56:29 +0100 (Fri, 25 Jan 2013)
New Revision: 561
Added:
branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R
branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/plotInterpol.R
Modified:
branches/robast-0.9/pkg/RobExtremes/R/sysdata.rda
branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R
branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationsmanipulations.R
Log:
RobExtremes: added some more grids and
some diagnostic tools for interpolation grids (accessible through R-code)
Rdir <- system.file("AddMaterial/interpolation", package= "RobExtremes")
dir(Rdir)
file.show(file.path(Rdir,"plotInterpol.R"))
Modified: branches/robast-0.9/pkg/RobExtremes/R/sysdata.rda
===================================================================
(Binary files differ)
Added: branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R (rev 0)
+++ branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/getLMInterpol.R 2013-01-25 13:56:29 UTC (rev 561)
@@ -0,0 +1,43 @@
+getLMs <- function(Gridnam,Famnam,xi=0.7, baseDir="C:/rtest/robast"){
+ ## Gridnam in (Sn,OMSE,RMXE,MBRE)
+ ## Famnam in "Generalized Pareto Family",
+ ## "Generalized Extreme Value Family with positive shape parameter: Frechet Family",
+ ## "Gamma family",
+ ## "Weibull Family"
+ ## xi Scaleparameter (can be vector)
+ ## basedir: Oberverzeichnis des r-forge svn checkouts
+ file <- file.path(baseDir, "branches/robast-0.9/pkg/RobExtremes/R/sysdata.rda")
+ if(!file.exists(file)) stop("Fehler mit Checkout")
+ nE <- new.env()
+ load(file, envir=nE)
+ Gnams <- c("Sn","OMSE","RMXE","MBRE")
+ Fnams <- c("Generalized Pareto Family",
+ "Generalized Extreme Value Family with positive shape parameter: Frechet Family",
+ "Gamma family",
+ "Weibull Family")
+ if(! Gridnam %in% Gnams) stop("Falscher Gittername")
+ if(! Famnam %in% Fnams) stop("Falscher Familienname")
+ isSn <- (Gridnam == "Sn")
+ GN0 <- Gridnam; if(isSn) GN0 <- "SnGrids"
+ GN <- paste(".",GN0,".",if(getRversion()<"2.16") "O" else "N", sep="")
+ fct <- get(GN,envir=nE)[[Famnam]]$fct
+
+ if(!isSn)){
+ ## für Gridnam != Sn ist LM für jeden xi Wert ein Vektor der Länge 13, genauer
+ # in 1:13 (clip=b, cent.a=a1.a,a2.a, cent.i=a1.i,a2.i,
+ ## stand.a=A.a=matrix(c(A11.a,(A12.a+A21.a)/2,
+ # (A12.a+A21.a)/2,A.22.a), 2, 2),
+ ## stand.i=A.i=matrix(c(A11.i,(A12.i+A21.i)/2,
+ # (A12.i+A21.i)/2,A.22.i), 2, 2),
+ ## und optIC = Y.a min(1,b/norm(Y.i)), Y.* = A.* Lambda - a.*
+ len <- length(fct)
+ LM <- sapply(1:len, function(i) fct[[i]](xi))
+ if(length(xi)==1) LM <- matrix(LM,ncol=len)
+ colnames(LM) <- c("b","a1.a", "a2.a", "a1.i", "a2.i", "A11.a",
+ "A12.a", "A21.a", "A22.a", "A11.i", "A12.i", "A21.i", "A22.i")
+ return(cbind(xi,LM))
+ }else{
+ Sn <- fct(xi)
+ return(cbind(xi,Sn))
+ }
+}
Modified: branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R 2013-01-25 06:15:34 UTC (rev 560)
+++ branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationscripts.R 2013-01-25 13:56:29 UTC (rev 561)
@@ -66,7 +66,7 @@
sapply(c(.myFolder1,.myFolder2,.myFolder3), chkExist)
PF <- GEVFamily()
.saveInterpGrid(getShapeGrid(gridsize=500, cutoff.at.0=0.005),
- sysRdaFolder = .myFolder, accuracy = 5000,upp=10,
+ sysRdaFolder = .myFolder2, accuracy = 5000,upp=10,
PFam = PF)
## to make this parallel, we write the results to different folders:
.svInt(.OMSE.xi, ".OMSE", PFam = PF, sysRdafolder = .myFolder1)
Modified: branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationsmanipulations.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationsmanipulations.R 2013-01-25 06:15:34 UTC (rev 560)
+++ branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/interpolationsmanipulations.R 2013-01-25 13:56:29 UTC (rev 561)
@@ -74,20 +74,26 @@
ls(envir=nE); f(); ls(envir=nE)
-
+require(RobExtremes)
+.basepath <- "C:/rtest/RobASt/branches/robast-0.9/pkg"
+.myFolder <- file.path(.basepath,"RobExtremesBuffer")
.myFolderA <- file.path(.basepath,"RobExtremesBuffer/all2")
-.myFolderW <- file.path(.basepath,"RobExtremesBuffer/WTS")
+.myFolderW <- file.path(.basepath,"RobExtremesBuffer/WTS2")
+fn2 <- file.path(.myFolder,"tmp2/sysdata.rda")
fn00=file.path(.myFolderW,"tmp0/sysdata.rda")
fn01=file.path(.myFolderW,"tmp1/sysdata.rda")
fn02=file.path(.myFolderW,"tmp2/sysdata.rda")
-fn1=file.path(.myFoldera,"sysdata.rda")
+fn03=file.path(.myFolderW,"tmp3/sysdata.rda")
fnA <- file.path(.myFolderA,"sysdata.rda")
#fn2=file.path(.myFoldera,"sysdata-1.rda")
-RobExtremes:::.recomputeInterpolators(c(fn00, fn01,fn02, fn1), sysRdaFolder = .myFolderA, overwrite=TRUE, translate=FALSE)
+#RobExtremes:::.recomputeInterpolators(c(fn01,fn02, fn1), sysRdaFolder = .myFolderA, overwrite=TRUE, translate=FALSE)
+file.copy(fnA,fn1, overwrite=T)
+RobExtremes:::.recomputeInterpolators(c(fn02, fn01, fn1), sysRdaFolder = .myFolderA, overwrite=TRUE, translate=FALSE)
nE= new.env()
load(fnA,envir=nE)
w = ls(all=T,envir=nE)
lapply(w, function(x) {u=get(x,envir=nE); print(x);print(names(u))})
+lapply(grep("\\.N$",w,val=T), function(x) {u=get(x,envir=nE); for(i in 1:length(u)){if(length(u)<4){ print(u[[i]]$fct[[1]](0.3)); print(u[[i]]$fct[[2]](0.3))}else{print(u[[i]]$fct(0.3))}}})
.basepath <- "C:/rtest/RobASt/branches/robast-0.9/pkg"
.myFolderA <- file.path(.basepath,"RobExtremesBuffer/all2")
@@ -100,3 +106,30 @@
load(fnA,envir=nE)
w = ls(all=T,envir=nE)
lapply(w, function(x) {u=get(x,envir=nE); print(x);print(names(u))})
+lapply(grep("\\.O$",w,val=T), function(x) {u=get(x,envir=nE); for(i in 1:length(u)){if(length(u)<4){ print(u[[i]]$fct[[1]](0.3)); print(u[[i]]$fct[[2]](0.3))}else{print(u[[i]]$fct(0.3))}}})
+
+fu <- function(xi){
+ ext <- if(getRversion<"2.16") "\\.O$" else "\\.N$"
+ lapply(grep(ext,w,val=T), function(x) {
+ print(x)
+ u <- get(x,envir=nE);
+ for(i in 1:length(u)){
+ ni <- names(u)[i]
+ print(ni)
+ print(!grepl("Sn",x))
+ if(!grepl("Sn",x)){
+ len <- length(u[[i]]$fct)
+ yi <- sapply(1:len, function(j) u[[i]]$fct[[j]](xi))
+ if(length(xi)==1) yi <- matrix(yi,ncol=len)
+ colnames(yi) <- c("b","a1.a", "a2.a", "a1.i", "a2.i", "A11.a",
+ "A12.a", "A21.a", "A22.a", "A11.i", "A12.i", "A21.i", "A22.i")
+ print(cbind(xi,yi))
+ }else{
+ Sn <- u[[i]]$fct(xi)
+ print(cbind(xi,Sn))
+ }
+ }
+ return(invisible(NULL))
+ })
+ return(invisible(NULL))
+}
Added: branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/plotInterpol.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/plotInterpol.R (rev 0)
+++ branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/plotInterpol.R 2013-01-25 13:56:29 UTC (rev 561)
@@ -0,0 +1,35 @@
+plotLM <- function(Gridnam,Famnam,whichLM, baseDir="C:/rtest/robast"){
+ ## Gridnam in (Sn,OMSE,RMXE,MBRE)
+ ## Famnam in "Generalized Pareto Family",
+ ## "Generalized Extreme Value Family with positive shape parameter: Frechet Family",
+ ## "Gamma family",
+ ## "Weibull Family"
+ ## whichLM ignoriert für Gridnam == Sn
+ # in 1:13 (clip=b, cent.a=a1.a,a2.a, cent.i=a1.i,a2.i,
+ ## stand.a=A.a=matrix(c(A11.a,(A12.a+A21.a)/2,
+ # (A12.a+A21.a)/2,A.22.a), 2, 2),
+ ## stand.i=A.i=matrix(c(A11.i,(A12.i+A21.i)/2,
+ # (A12.i+A21.i)/2,A.22.i), 2, 2),
+ ## und optIC = Y.a min(1,b/norm(Y.i)), Y.* = A.* Lambda - a.*
+ ## basedir: Oberverzeichnis des r-forge svn checkouts
+ file <- file.path(baseDir, "branches/robast-0.9/pkg/RobExtremes/R/sysdata.rda")
+ if(!file.exists(file)) stop("Fehler mit Checkout")
+ nE <- new.env()
+ load(file, envir=nE)
+ Gnams <- c("Sn","OMSE","RMXE","MBRE")
+ Fnams <- c("Generalized Pareto Family",
+ "Generalized Extreme Value Family with positive shape parameter: Frechet Family",
+ "Gamma family",
+ "Weibull Family")
+ if(! Gridnam %in% Gnams) stop("Falscher Gittername")
+ if(! Famnam %in% Fnams) stop("Falscher Familienname")
+ isSn <- (Gridnam == "Sn")
+ GN0 <- Gridnam; if(isSn) GN0 <- "SnGrids"
+ GN <- paste(".",GN0,".",if(getRversion()<"2.16") "O" else "N", sep="")
+ gr <- get(GN,envir=nE)[[Famnam]]$grid
+
+ if(!isSn) if(whichLM<1 | whichLM>13) stop("Falsche Koordinate")
+ if(isSn) whichLM <- 1
+ wM <- whichLM + 1
+ plot(gr[,1], gr[,wm])
+}
More information about the Robast-commits
mailing list