From noreply at r-forge.r-project.org Fri May 3 11:02:03 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 3 May 2013 11:02:03 +0200 (CEST) Subject: [Robast-commits] r658 - branches/robast-0.9/pkg/RobExtremesBuffer Message-ID: <20130503090203.41803183CE8@r-forge.r-project.org> Author: pupashenko Date: 2013-05-03 11:02:02 +0200 (Fri, 03 May 2013) New Revision: 658 Added: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBR_MISHA.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-MBRE_MISHA.pdf branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R Log: Tickets #139 und #140 sind fertig von meine seite Added: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBR_MISHA.pdf =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBR_MISHA.pdf ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-MBRE_MISHA.pdf =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-MBRE_MISHA.pdf ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R (rev 0) +++ branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R 2013-05-03 09:02:02 UTC (rev 658) @@ -0,0 +1,228 @@ +### preparations: +# (0) R-forge checkout von distr und robast machen; Pakete installieren +###### +# Reihenfolge +#### *: von r-forge, **: von CRAN, ***: von BioConductor +# vorab: +# CRAN: ** sfsmisc, setRNG, fBasics, fGarch, mvtnorm, lattice, RColorBrewer +# BioConductor: *** Biobase, affy, beadarray +# source("http://bioconductor.org/biocLite.R") +# biocLite() +# biocLite(c("affy", "beadarray")) +# +# * RobAStRDA +# * startupmsg +# * SweaveListingUtils +# * distr +# * distrEx +# * distrTeach +# * distrRmetrics +# * distrSim +# * distrEllipse +# * distrTEst +# * RandVar +# * distrMod +# * distrDoc +# * RobAStBase +# * ROptEst +# * RobExtremes +# * RobLox +# * RobLoxBioC +# * ROptEstOld +# * ROptRegTS +# * RobRex +# +## evtl naechste Zeile modifizieren +baseDir0 <- "D:/SVN repositories/robast" +interpolDir <- "branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation" +interpolFile <- "plotInterpol.R" +## +# (1) Paket laden +# sourceDir <- function(path, trace = TRUE, ...) { +# for (nm in list.files(path, pattern = "[.][RrSsQq]$")) { +# if(trace) cat(nm,":") +# try(source(file.path(path, nm), ...)) +# if(trace) cat("\n") +# } +# } +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RandVar/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobAStBase/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobAStRDA/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobExtremes/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobExtremesBuffer/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobLox/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobLoxBioC/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobRex/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/ROptEst/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/ROptEstOld/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/ROptReg/R/" +# setwd(path) +# sourceDir(path) +# +# path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/ROptRegTS/R/" +# setwd(path) +# sourceDir(path) + + +require(RobExtremes) +## +## in \branches\robast-0.9\pkg\RobExtremes\inst\AddMaterial\interpolation +## file plotInterpol.R einsourcen +source(file.path(baseDir0,interpolDir, interpolFile)) + +### .saveGridToRDA und .computeInterpolators aus Namespace holen: +.saveGridToRda <- RobAStRDA:::.saveGridToRda +.computeInterpolators <- RobAStRDA:::.computeInterpolators + +## Risiken auf P+M+B+G+MP+D (jeder 22) +#P OMSE.GEV, OMSE.Gamma +#MP MBRE.GEV, MBRE.Gamma, +#M RMXE.GEV, RMXE.Gamma +#G OMSE.GPD, OMSE.Weibull +#D MBRE.GPD MBRE.Weibull +#B RMXE.GPD RMXE.Weibull + +## in den Plots: schwarz: ungegl?ttet; +## rot: bereits im Gitter vorhandene Gl?ttung; +## gr?n: aktuelle TestGl?ttung + +## Definition von Shortcuts +## Peter: / bei Euch entsprechend erste beide Argumente von myplot2, myplot3, zu ersetzen +myplot2 <- function(whichLM, plotGridRestriction = NULL, + df = NULL, gridRestrForSmooth = NULL, withSmooth=TRUE, ...) + plotLM("MBRE",Famnam="GEV",whichLM=whichLM, baseDir=baseDir0, withSmooth=withSmooth, + plotGridRestriction=plotGridRestriction, + smoothtry = TRUE, df = df, + gridRestrForSmooth = gridRestrForSmooth, ...) +myplot3 <- function(whichLM, plotGridRestriction = NULL, + df = NULL, gridRestrForSmooth = NULL, withSmooth=TRUE, ...) + plotLM("MBRE",Famnam="Gam",whichLM=whichLM, baseDir=baseDir0, withSmooth=withSmooth, + plotGridRestriction=plotGridRestriction, + smoothtry = TRUE, df = df, + gridRestrForSmooth = gridRestrForSmooth, ...) + +### folder setzen +oldwd <- getwd() +.basepath <- file.path(baseDir0, "branches/robast-0.9/pkg") +.myFolderFrom <- file.path(.basepath,"RobExtremesBuffer") +### Zwischenspeichern des rda-files +myRDA1 <- file.path(.basepath,"RobExtremesBuffer/sysdata.rda") +### Endort des rda-files +myRDA <- file.path(.basepath,"RobAStRDA/R/sysdata.rda") +CSVFiles <- grep("\\.csv$", dir(.myFolderFrom), value=TRUE) +CSVFiles <- paste(.myFolderFrom, CSVFiles, sep="/") +CSVFiles2 <- file.path(.myFolderFrom,"interpolMBREGEVFamily.csv") +CSVFiles3 <- file.path(.myFolderFrom,"interpolMBREGammafamily.csv") +file.copy(from=myRDA,to=myRDA1) + +### 1. Runde +### "MBRE"-"GEV" +## df und gridR Werte durch Ausprobieren gewonnen +myplot2(1, df = 10, gridR = -(1:270)) +myplot2(2, df = 12, gridR = -(1:270)) +myplot2(3, df = 10, gridR = -(1:270)) +myplot2(4, df = 10, gridR = -(1:270)) +myplot2(5, df = 10, gridR = -(1:270)) +myplot2(6, df = 20, gridR = -(1:270)) +myplot2(7, df = 20, gridR = -(1:270)) +myplot2(8, df = 20, gridR = -(1:270)) +myplot2(9, df = 20, gridR = -(1:270)) +myplot2(10, df = 20, gridR = -(1:270)) +myplot2(11, df = 20, gridR = -(1:270)) +myplot2(12, df = 20, gridR = -(1:270)) +myplot2(13, df = 20, gridR = -(1:270)) + +### sammeln der gridR und df Werte (ggf in listen) +gridR2 <- -(1:275) +dfR2 <- 20 + +### alle Plotten zur Kontrolle +myplot2("all", df=20, gridR=gridR2, withSmooth=FALSE, pre=windows()) + +### schreiben der gegl?tteten Gitter ins rda-file, +## aber zun?chst noch woanders (myRDA1) gespeichert: +.saveGridToRda(CSVFiles2, toFileRDA = myRDA1, withMerge = TRUE, + withPrint = TRUE, withSmooth = TRUE, df = dfR2, + gridRestrForSmooth=gridR2) + +### 1. Runde +### "MBRE"-"Gamma" +## df und gridR Werte durch Ausprobieren gewonnen +myplot3(1, df = 4, gridR = -(1:260), plotG=-(1:20)) +myplot3(2, df = 4, gridR = -(1:260), plotG=-(1:10)) +myplot3(3, df = 4, gridR = -(1:260), plotG=-(1:20)) +myplot3(4, df = 4, gridR = -(1:260)) +myplot3(5, df = 4, gridR = -(1:260), plotG=-(1:20)) +myplot3(6, df = 5, gridR = -(1:150), plotG=-(1:20), withSmooth=FALSE) +myplot3(7, df = 2, gridR = -(1:260)) +myplot3(8, df = 2, gridR = -(1:260), plotG=-(1:20)) +myplot3(9, df = 5, gridR = -(1:260), plotG=-(1:10)) +myplot3(10, df = 5, gridR = -(1:150), plotG=-(1:20), withSmooth=FALSE) +myplot3(11, df = 2, gridR = -(1:260), plotG=-(1:10)) +myplot3(12, df = 2, gridR = -(1:260), plotG=-(1:20)) +myplot3(13, df = 4, gridR = -(1:260), plotG=-(1:10)) + +### sammeln der gridR, plotR und df Werte (ggf in listen) +plotR3 <- list(-(1:20),-(1:20),-(1:10),NULL,-(1:20), + -(1:20), NULL, -(1:20), -(1:10),-(1:20), + -(1:10),-(1:20),-(1:20)) +gridR3 <- list(-(1:260),-(1:260),-(1:260),-(1:260),-(1:260),-(1:150), + -(1:260),-(1:260),-(1:260),-(1:150),-(1:260),-(1:260),-(1:260)) +dfR3 <- c(4,4,4,4,4,5,2,2,5,5,2,2,4) +### alle Plotten zur Kontrolle +myplot3("all", df=dfR3, gridR=gridR3, plotG=plotR3, withSmooth=FALSE, pre=windows()) +### schreiben der gegl?tteten Gitter ins rda-file, +## aber zun?chst noch woanders (myRDA1) gespeichert: +.saveGridToRda(CSVFiles3, toFileRDA = myRDA1, withMerge = TRUE, + withPrint = TRUE, withSmooth = TRUE, df = dfR3, + gridRestrForSmooth=gridR3) + +if(getRversion()>"2.16"){ +### generierung der Interpolatoren (in R>3.0) +.computeInterpolators(myRDA1, myRDA,withSmoothFct = TRUE) +} +######################################---bis hierher mit R-3.0.0 laufen lassen ## + +######################################---ab hier mit R-2.15.2 laufen lassen ## +if(getRversion()<"2.16"){ +### generierung der Interpolatoren (in R<=2.15) +## folgenden Code einsourcen: +### change adequately: +.baseDir.loc <- "C:/rtest/RobASt" +.basepath <- file.path(.baseDir.loc,"branches/robast-0.9/pkg") +myRDA <- file.path(.basepath,"RobAStRDA/R/sysdata.rda") +require(RobAStRDA) +RobAStRDA:::.computeInterpolators(myRDA, myRDA,withSmoothFct = TRUE) +} + From noreply at r-forge.r-project.org Mon May 6 11:04:10 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 May 2013 11:04:10 +0200 (CEST) Subject: [Robast-commits] r659 - branches/robast-0.9/pkg/RobExtremesBuffer Message-ID: <20130506090410.5F156184DD4@r-forge.r-project.org> Author: pupashenko Date: 2013-05-06 11:04:09 +0200 (Mon, 06 May 2013) New Revision: 659 Added: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBRE_MISHA.pdf Removed: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBR_MISHA.pdf Modified: branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R Log: Noch ein bisschen st?\195?\164rker GEV-MBRE gegl?\195?\164ttet. Copied: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBRE_MISHA.pdf (from rev 658, branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBR_MISHA.pdf) =================================================================== (Binary files differ) Deleted: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBR_MISHA.pdf =================================================================== (Binary files differ) Modified: branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R 2013-05-03 09:02:02 UTC (rev 658) +++ branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R 2013-05-06 09:04:09 UTC (rev 659) @@ -149,27 +149,32 @@ ### 1. Runde ### "MBRE"-"GEV" ## df und gridR Werte durch Ausprobieren gewonnen -myplot2(1, df = 10, gridR = -(1:270)) -myplot2(2, df = 12, gridR = -(1:270)) -myplot2(3, df = 10, gridR = -(1:270)) -myplot2(4, df = 10, gridR = -(1:270)) -myplot2(5, df = 10, gridR = -(1:270)) -myplot2(6, df = 20, gridR = -(1:270)) -myplot2(7, df = 20, gridR = -(1:270)) -myplot2(8, df = 20, gridR = -(1:270)) -myplot2(9, df = 20, gridR = -(1:270)) -myplot2(10, df = 20, gridR = -(1:270)) -myplot2(11, df = 20, gridR = -(1:270)) -myplot2(12, df = 20, gridR = -(1:270)) -myplot2(13, df = 20, gridR = -(1:270)) +myplot2(1, df = 3, gridR = -(1:390)) +myplot2(2, df = 5, gridR = -(1:210)) +myplot2(3, df = 3, gridR = -(1:190)) +myplot2(4, df = 6, gridR = -(1:220)) +myplot2(5, df = 8, gridR = -(1:230)) +myplot2(6, df = 15, gridR = -(1:70)) +myplot2(7, df = 20, gridR = -(1:130)) +myplot2(8, df = 15, gridR = -(1:140)) +myplot2(9, df = 6, gridR = -(1:500)) +myplot2(10, df = 15, gridR = -(1:140)) +myplot2(11, df = 20, gridR = -(1:130)) +myplot2(12, df = 17, gridR = -(1:130)) +myplot2(13, df = 6, gridR = -(1:500)) + ### sammeln der gridR und df Werte (ggf in listen) -gridR2 <- -(1:275) -dfR2 <- 20 - +plotR2 <- list(-(1:20),-(1:20),-(1:20),-(1:20),-(1:20), + -(1:20), -(1:20), -(1:20), -(1:20),-(1:20), + -(1:20),-(1:20),-(1:20)) +gridR2 <- list(-(1:390),-(1:210),-(1:190),-(1:220),-(1:230),-(1:70), + -(1:130),-(1:140),-(1:500),-(1:140),-(1:130),-(1:130), -(1:500)) +dfR2 <- c(3,5,3,6,8,15,20,15,6,15,20,17,6) ### alle Plotten zur Kontrolle -myplot2("all", df=20, gridR=gridR2, withSmooth=FALSE, pre=windows()) +myplot2("all", df=dfR2, gridR=gridR2, plotG=plotR2, withSmooth=FALSE, pre=windows()) + ### schreiben der gegl?tteten Gitter ins rda-file, ## aber zun?chst noch woanders (myRDA1) gespeichert: .saveGridToRda(CSVFiles2, toFileRDA = myRDA1, withMerge = TRUE, From noreply at r-forge.r-project.org Mon May 13 14:13:10 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 13 May 2013 14:13:10 +0200 (CEST) Subject: [Robast-commits] r660 - branches/robast-0.9/pkg/RobExtremes/R Message-ID: <20130513121310.916D218495A@r-forge.r-project.org> Author: ruckdeschel Date: 2013-05-13 14:13:10 +0200 (Mon, 13 May 2013) New Revision: 660 Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R Log: RobExtremes: fixed bug in btq, bDq, btes, bDes, btel, bDel in GEVFamily.R found by Gerald (had to replace 1-p0 by p0) Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-05-06 09:04:09 UTC (rev 659) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-05-13 12:13:10 UTC (rev 660) @@ -161,19 +161,19 @@ btq <- bDq <- btes <- bDes <- btel <- bDel <- NULL if(!is.null(p)){ - btq <- substitute({ q <- loc0 + theta[1]*((-log(1-p0))^(-theta[2])-1)/theta[2] + btq <- substitute({ q <- loc0 + theta[1]*((-log(p0))^(-theta[2])-1)/theta[2] names(q) <- "quantile" }, list(loc0 = loc, p0 = p)) bDq <- substitute({ scale <- theta[1]; shape <- theta[2] - D1 <- ((-log(1-p0))^(-shape)-1)/shape - D2 <- -scale/shape*(D1 + log(-log(1-p0))*(-log(1-p0))^(-shape)) + D1 <- ((-log(p0))^(-shape)-1)/shape + D2 <- -scale/shape*(D1 + log(-log(p0))*(-log(p0))^(-shape)) D <- t(c(D1, D2)) rownames(D) <- "quantile"; colnames(D) <- NULL D }, list(p0 = p)) btes <- substitute({ if(theta[2]>=1L) es <- NA else { pg <- pgamma(-log(p0),1-theta[2], lower.tail = TRUE) - es <- theta[1] * (gamma(1-theta[2]) * pg/ (1-p0) - 1 )/ + es <- theta[1] * (gamma(1-theta[2]) * pg/ p0 - 1 )/ theta[2] + loc0 } names(es) <- "expected shortfall" es }, list(loc0 = loc, p0 = p)) @@ -182,9 +182,9 @@ pg <- pgamma(-log(p0), 1-theta[2], lower.tail = TRUE) dd <- ddigamma(-log(p0),1-theta[2]) g0 <- gamma(1-theta[2]) - D1 <- (g0*pg/(1-p0)-1)/theta[2] + D1 <- (g0*pg/p0-1)/theta[2] D21 <- theta[1]*D1/theta[2] - D22 <- theta[1]*dd/(1-p0)/theta[2] + D22 <- theta[1]*dd/p0/theta[2] D2 <- -D21+D22} D <- t(c(D1, D2)) rownames(D) <- "expected shortfall" From noreply at r-forge.r-project.org Tue May 14 14:15:08 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 14 May 2013 14:15:08 +0200 (CEST) Subject: [Robast-commits] r661 - branches/robast-0.9/pkg/RobExtremesBuffer Message-ID: <20130514121508.C30E41851D8@r-forge.r-project.org> Author: dashunka Date: 2013-05-14 14:15:08 +0200 (Tue, 14 May 2013) New Revision: 661 Added: branches/robast-0.9/pkg/RobExtremesBuffer/DashaLMScripts.R branches/robast-0.9/pkg/RobExtremesBuffer/GPD-MBRE_DASHA.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-MBRE_DASHA.pdf Log: Plots zum Ticket #139 Added: branches/robast-0.9/pkg/RobExtremesBuffer/DashaLMScripts.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/DashaLMScripts.R (rev 0) +++ branches/robast-0.9/pkg/RobExtremesBuffer/DashaLMScripts.R 2013-05-14 12:15:08 UTC (rev 661) @@ -0,0 +1,175 @@ +### preparations: +# (0) R-forge checkout von distr und robast machen; Pakete installieren +###### +# Reihenfolge +#### *: von r-forge, **: von CRAN, ***: von BioConductor +# vorab: +# CRAN: ** sfsmisc, setRNG, fBasics, fGarch, mvtnorm, lattice, RColorBrewer +# BioConductor: *** Biobase, affy, beadarray +# source("http://bioconductor.org/biocLite.R") +# biocLite() +# biocLite(c("affy", "beadarray")) +# +# * RobAStRDA +# * startupmsg +# * SweaveListingUtils +# * distr +# * distrEx +# * distrTeach +# * distrRmetrics +# * distrSim +# * distrEllipse +# * distrTEst +# * RandVar +# * distrMod +# * distrDoc +# * RobAStBase +# * ROptEst +# * RobExtremes +# * RobLox +# * RobLoxBioC +# * ROptEstOld +# * ROptRegTS +# * RobRex +# +## evtl naechste Zeile modifizieren +baseDir0 <- "D:/Mathematics/KL-PhD/robast" +interpolDir <- "branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation" +interpolFile <- "plotInterpol.R" +## +# (1) Paket laden +require(RobExtremes) +## +## in \branches\robast-0.9\pkg\RobExtremes\inst\AddMaterial\interpolation +## file plotInterpol.R einsourcen +source(file.path(baseDir0,interpolDir, interpolFile)) + +### .saveGridToRDA und .computeInterpolators aus Namespace holen: +.saveGridToRda <- RobAStRDA:::.saveGridToRda +.computeInterpolators <- RobAStRDA:::.computeInterpolators + +## Risiken auf P+M+B+G+MP+D (jeder 22) +#P OMSE.GEV, OMSE.Gamma +#MP MBRE.GEV, MBRE.Gamma, +#M RMXE.GEV, RMXE.Gamma +#G OMSE.GPD, OMSE.Weibull +#D MBRE.GPD MBRE.Weibull +#B RMXE.GPD RMXE.Weibull + +## in den Plots: schwarz: ungegl?ttet; +## rot: bereits im Gitter vorhandene Gl?ttung; +## gr?n: aktuelle TestGl?ttung + +## Definition von Shortcuts +## Peter: / bei Euch entsprechend erste beide Argumente von myplot2, myplot3, zu ersetzen +myplot2 <- function(whichLM, plotGridRestriction = NULL, + df = NULL, gridRestrForSmooth = NULL, withSmooth=TRUE, ...) + plotLM("MBRE",Famnam="Generalized",whichLM=whichLM, baseDir=baseDir0, withSmooth=withSmooth, + plotGridRestriction=plotGridRestriction, + smoothtry = TRUE, df = df, + gridRestrForSmooth = gridRestrForSmooth, ...) +myplot3 <- function(whichLM, plotGridRestriction = NULL, + df = NULL, gridRestrForSmooth = NULL, withSmooth=TRUE, ...) + plotLM("MBRE",Famnam="Weibull",whichLM=whichLM, baseDir=baseDir0, withSmooth=withSmooth, + plotGridRestriction=plotGridRestriction, + smoothtry = TRUE, df = df, + gridRestrForSmooth = gridRestrForSmooth, ...) + +### folder setzen +oldwd <- getwd() +.basepath <- file.path(baseDir0, "branches/robast-0.9/pkg") +.myFolderFrom <- file.path(.basepath,"RobExtremesBuffer") +### Zwischenspeichern des rda-files +myRDA1 <- file.path(.basepath,"RobExtremesBuffer/sysdata.rda") +### Endort des rda-files +myRDA <- file.path(.basepath,"RobAStRDA/R/sysdata.rda") +CSVFiles <- grep("\\.csv$", dir(.myFolderFrom), value=TRUE) +CSVFiles <- paste(.myFolderFrom, CSVFiles, sep="/") +CSVFiles2 <- file.path(.myFolderFrom,"interpolMBREGEVFamily.csv") +CSVFiles3 <- file.path(.myFolderFrom,"interpolMBREGammafamily.csv") +file.copy(from=myRDA,to=myRDA1) + +### 1. Runde +### "MBRE"-"GPD" +## df und gridR Werte durch Ausprobieren gewonnen +myplot2(1, df = 5, gridR = -(1:120)) +myplot2(2, df = 9, gridR = -(1:110)) +myplot2(3, df = 10, gridR = -(1:130)) +myplot2(4, df = 9, gridR = -(1:100)) +myplot2(5, df = 15, gridR = -(1:120)) +myplot2(6, df = 15, gridR = -(1:70)) +myplot2(7, df = 15, gridR = -(1:130)) +myplot2(8, df = 10, gridR = -(1:120)) +myplot2(9, df = 4, gridR = -(1:695)) +myplot2(10, df = 20, gridR = -(1:110)) +myplot2(11, df = 20, gridR = -(1:110)) +myplot2(12, df = 20, gridR = -(1:110)) +myplot2(13, df = 4, gridR = -(1:695)) + + +### sammeln der gridR und df Werte (ggf in listen) +plotR2 <- list(-(1:20),-(1:20),-(1:20),-(1:20),-(1:20), + -(1:20), -(1:20), -(1:20), -(1:20),-(1:20), + -(1:20),-(1:20),-(1:20)) +gridR2 <- list(-(1:120),-(1:110),-(1:130),-(1:100),-(1:120),-(1:70), + -(1:130),-(1:120),-(1:695),-(1:110),-(1:110),-(1:110), -(1:695)) +dfR2 <- c(5,9,10,9,15,15,15,10,4,20,20,20,4) +### alle Plotten zur Kontrolle +myplot2("all", df=dfR2, gridR=gridR2, plotG=plotR2, withSmooth=FALSE, pre=windows()) + + +### schreiben der gegl?tteten Gitter ins rda-file, +## aber zun?chst noch woanders (myRDA1) gespeichert: +.saveGridToRda(CSVFiles2, toFileRDA = myRDA1, withMerge = TRUE, + withPrint = TRUE, withSmooth = TRUE, df = dfR2, + gridRestrForSmooth=gridR2) + +### 1. Runde +### "MBRE"-"Weibull" +## df und gridR Werte durch Ausprobieren gewonnen +myplot3(1, df = 4, gridR = -(1:260), plotG=-(1:20)) +myplot3(2, df = 4, gridR = -(1:260), plotG=-(1:10)) +myplot3(3, df = 4, gridR = -(1:460), plotG=-(1:20)) +myplot3(4, df = 6, gridR = -(1:310)) +myplot3(5, df = 4, gridR = -(1:460), plotG=-(1:20)) +myplot3(6, df = 5, gridR = -(1:250), plotG=-(1:20), withSmooth=FALSE) +myplot3(7, df = 2, gridR = -(1:460)) +myplot3(8, df = 2, gridR = -(1:360), plotG=-(1:20)) +myplot3(9, df = 5, gridR = -(1:260), plotG=-(1:10)) +myplot3(10, df = 5, gridR = -(1:250), plotG=-(1:20), withSmooth=FALSE) +myplot3(11, df = 2, gridR = -(1:460), plotG=-(1:10)) +myplot3(12, df = 2, gridR = -(1:360), plotG=-(1:20)) +myplot3(13, df = 4, gridR = -(1:260), plotG=-(1:10)) + +### sammeln der gridR, plotR und df Werte (ggf in listen) +plotR3 <- list(-(1:20),-(1:20),-(1:10),NULL,-(1:20), + -(1:20), NULL, -(1:20), -(1:10),-(1:20), + -(1:10),-(1:20),-(1:20)) +gridR3 <- list(-(1:260),-(1:260),-(1:460),-(1:310),-(1:460),-(1:250), + -(1:460),-(1:360),-(1:260),-(1:250),-(1:460),-(1:360),-(1:260)) +dfR3 <- c(4,4,4,6,4,5,2,2,5,5,2,2,4) +### alle Plotten zur Kontrolle +myplot3("all", df=dfR3, gridR=gridR3, plotG=plotR3, withSmooth=FALSE, pre=windows()) +### schreiben der gegl?tteten Gitter ins rda-file, +## aber zun?chst noch woanders (myRDA1) gespeichert: +.saveGridToRda(CSVFiles3, toFileRDA = myRDA1, withMerge = TRUE, + withPrint = TRUE, withSmooth = TRUE, df = dfR3, + gridRestrForSmooth=gridR3) + +if(getRversion()>"2.16"){ + ### generierung der Interpolatoren (in R>3.0) + .computeInterpolators(myRDA1, myRDA,withSmoothFct = TRUE) +} +######################################---bis hierher mit R-3.0.0 laufen lassen ## + +######################################---ab hier mit R-2.15.2 laufen lassen ## +if(getRversion()<"2.16"){ + ### generierung der Interpolatoren (in R<=2.15) + ## folgenden Code einsourcen: + ### change adequately: + .baseDir.loc <- "C:/rtest/RobASt" + .basepath <- file.path(.baseDir.loc,"branches/robast-0.9/pkg") + myRDA <- file.path(.basepath,"RobAStRDA/R/sysdata.rda") + require(RobAStRDA) + RobAStRDA:::.computeInterpolators(myRDA, myRDA,withSmoothFct = TRUE) +} \ No newline at end of file Added: branches/robast-0.9/pkg/RobExtremesBuffer/GPD-MBRE_DASHA.pdf =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/RobExtremesBuffer/GPD-MBRE_DASHA.pdf ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-MBRE_DASHA.pdf =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-MBRE_DASHA.pdf ___________________________________________________________________ Added: svn:mime-type + application/octet-stream From noreply at r-forge.r-project.org Fri May 24 17:48:39 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 24 May 2013 17:48:39 +0200 (CEST) Subject: [Robast-commits] r662 - in branches/robast-0.9/pkg: RobAStRDA/R RobExtremesBuffer Message-ID: <20130524154839.8AE0E1813B9@r-forge.r-project.org> Author: ruckdeschel Date: 2013-05-24 17:48:39 +0200 (Fri, 24 May 2013) New Revision: 662 Modified: branches/robast-0.9/pkg/RobAStRDA/R/sysdata.rda branches/robast-0.9/pkg/RobExtremesBuffer/DashaLMScripts.R branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R Log: inserted Dasha's and Misha's smoothers into RobAStRDA and slightly modified the respective scripts Modified: branches/robast-0.9/pkg/RobAStRDA/R/sysdata.rda =================================================================== (Binary files differ) Modified: branches/robast-0.9/pkg/RobExtremesBuffer/DashaLMScripts.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/DashaLMScripts.R 2013-05-14 12:15:08 UTC (rev 661) +++ branches/robast-0.9/pkg/RobExtremesBuffer/DashaLMScripts.R 2013-05-24 15:48:39 UTC (rev 662) @@ -33,7 +33,46 @@ # * RobRex # ## evtl naechste Zeile modifizieren +### preparations: +# (0) R-forge checkout von distr und robast machen; Pakete installieren +###### +# Reihenfolge +#### *: von r-forge, **: von CRAN, ***: von BioConductor +# vorab: +# CRAN: ** sfsmisc, setRNG, fBasics, fGarch, mvtnorm, lattice, RColorBrewer +# BioConductor: *** Biobase, affy, beadarray +# source("http://bioconductor.org/biocLite.R") +# biocLite() +# biocLite(c("affy", "beadarray")) +# +# * RobAStRDA +# * startupmsg +# * SweaveListingUtils +# * distr +# * distrEx +# * distrTeach +# * distrRmetrics +# * distrSim +# * distrEllipse +# * distrTEst +# * RandVar +# * distrMod +# * distrDoc +# * RobAStBase +# * ROptEst +# * RobExtremes +# * RobLox +# * RobLoxBioC +# * ROptEstOld +# * ROptRegTS +# * RobRex +# +## evtl naechste Zeile modifizieren +#Peter +baseDir0 <- "C:/rtest/RobASt" +#Dasha baseDir0 <- "D:/Mathematics/KL-PhD/robast" + interpolDir <- "branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation" interpolFile <- "plotInterpol.R" ## @@ -85,8 +124,8 @@ myRDA <- file.path(.basepath,"RobAStRDA/R/sysdata.rda") CSVFiles <- grep("\\.csv$", dir(.myFolderFrom), value=TRUE) CSVFiles <- paste(.myFolderFrom, CSVFiles, sep="/") -CSVFiles2 <- file.path(.myFolderFrom,"interpolMBREGEVFamily.csv") -CSVFiles3 <- file.path(.myFolderFrom,"interpolMBREGammafamily.csv") +CSVFiles2 <- file.path(.myFolderFrom,"interpolMBREGeneralizedParetoFamily.csv") +CSVFiles3 <- file.path(.myFolderFrom,"interpolMBREWeibullfamily.csv") file.copy(from=myRDA,to=myRDA1) ### 1. Runde @@ -172,4 +211,4 @@ myRDA <- file.path(.basepath,"RobAStRDA/R/sysdata.rda") require(RobAStRDA) RobAStRDA:::.computeInterpolators(myRDA, myRDA,withSmoothFct = TRUE) -} \ No newline at end of file +} Modified: branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R 2013-05-14 12:15:08 UTC (rev 661) +++ branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R 2013-05-24 15:48:39 UTC (rev 662) @@ -33,6 +33,44 @@ # * RobRex # ## evtl naechste Zeile modifizieren +### preparations: +# (0) R-forge checkout von distr und robast machen; Pakete installieren +###### +# Reihenfolge +#### *: von r-forge, **: von CRAN, ***: von BioConductor +# vorab: +# CRAN: ** sfsmisc, setRNG, fBasics, fGarch, mvtnorm, lattice, RColorBrewer +# BioConductor: *** Biobase, affy, beadarray +# source("http://bioconductor.org/biocLite.R") +# biocLite() +# biocLite(c("affy", "beadarray")) +# +# * RobAStRDA +# * startupmsg +# * SweaveListingUtils +# * distr +# * distrEx +# * distrTeach +# * distrRmetrics +# * distrSim +# * distrEllipse +# * distrTEst +# * RandVar +# * distrMod +# * distrDoc +# * RobAStBase +# * ROptEst +# * RobExtremes +# * RobLox +# * RobLoxBioC +# * ROptEstOld +# * ROptRegTS +# * RobRex +# +## evtl naechste Zeile modifizieren +#Peter +baseDir0 <- "C:/rtest/RobASt" +#Misha baseDir0 <- "D:/SVN repositories/robast" interpolDir <- "branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation" interpolFile <- "plotInterpol.R" @@ -45,51 +83,51 @@ # if(trace) cat("\n") # } # } -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RandVar/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobAStBase/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobAStRDA/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobExtremes/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobExtremesBuffer/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobLox/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobLoxBioC/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/RobRex/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/ROptEst/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/ROptEstOld/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/ROptReg/R/" # setwd(path) # sourceDir(path) -# +# # path = "D:/SVN repositories/robast/branches/robast-0.9/pkg/ROptRegTS/R/" # setwd(path) # sourceDir(path) From noreply at r-forge.r-project.org Fri May 24 18:27:02 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 24 May 2013 18:27:02 +0200 (CEST) Subject: [Robast-commits] r663 - branches/robast-0.9/pkg/RobExtremes/R Message-ID: <20130524162702.6FA5418517F@r-forge.r-project.org> Author: ruckdeschel Date: 2013-05-24 18:27:02 +0200 (Fri, 24 May 2013) New Revision: 663 Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R Log: fixed error in ES in GEVFamily.R discovered by Gerald and found yet other faults in EL Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-05-24 15:48:39 UTC (rev 662) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-05-24 16:27:02 UTC (rev 663) @@ -173,7 +173,7 @@ D }, list(p0 = p)) btes <- substitute({ if(theta[2]>=1L) es <- NA else { pg <- pgamma(-log(p0),1-theta[2], lower.tail = TRUE) - es <- theta[1] * (gamma(1-theta[2]) * pg/ p0 - 1 )/ + es <- theta[1] * (gamma(1-theta[2]) * pg/ (1-p0) - 1 )/ theta[2] + loc0 } names(es) <- "expected shortfall" es }, list(loc0 = loc, p0 = p)) @@ -182,9 +182,9 @@ pg <- pgamma(-log(p0), 1-theta[2], lower.tail = TRUE) dd <- ddigamma(-log(p0),1-theta[2]) g0 <- gamma(1-theta[2]) - D1 <- (g0*pg/p0-1)/theta[2] + D1 <- (g0*pg/(1-p0)-1)/theta[2] D21 <- theta[1]*D1/theta[2] - D22 <- theta[1]*dd/p0/theta[2] + D22 <- theta[1]*dd/(1-p0)/theta[2] D2 <- -D21+D22} D <- t(c(D1, D2)) rownames(D) <- "expected shortfall" @@ -193,14 +193,14 @@ } if(!is.null(N)){ btel <- substitute({ if(theta[2]>=1L) el <- NA else{ - el <- N0*(loc0+theta[1]*gamma(1-theta[2])/theta[2])} + el <- N0*(loc0+theta[1]*(gamma(1-theta[2])-1)/theta[2])} names(el) <- "expected loss" el }, list(loc0 = loc,N0 = N)) bDel <- substitute({ if(theta[2]>=1L){ D1 <- D2 <- NA}else{ scale <- theta[1]; shape <- theta[2] - D1 <- N0*gamma(1-shape)/shape + D1 <- N0*(gamma(1-shape)-1)/shape D2 <- -N0*theta[1]*digamma(1-theta[2])/theta[2]- - D1*scale/(1-shape)} + D1*scale/shape} D <- t(c(D1, D2)) rownames(D) <- "expected loss" colnames(D) <- NULL From noreply at r-forge.r-project.org Fri May 24 19:16:02 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 24 May 2013 19:16:02 +0200 (CEST) Subject: [Robast-commits] r664 - branches/robast-0.9/pkg/RobExtremesBuffer Message-ID: <20130524171602.E09FC1851DA@r-forge.r-project.org> Author: ruckdeschel Date: 2013-05-24 19:16:02 +0200 (Fri, 24 May 2013) New Revision: 664 Modified: branches/robast-0.9/pkg/RobExtremesBuffer/interpolRisk-Test.R Log: RobExtremesBuffer: enhanced interpolRisk-Test.R by an additional argument samples (sample size) Modified: branches/robast-0.9/pkg/RobExtremesBuffer/interpolRisk-Test.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/interpolRisk-Test.R 2013-05-24 16:27:02 UTC (rev 663) +++ branches/robast-0.9/pkg/RobExtremesBuffer/interpolRisk-Test.R 2013-05-24 17:16:02 UTC (rev 664) @@ -2,7 +2,7 @@ ### Tests fuer InterpolRisiken #################################################### PFam <- NULL -mytest <- function(PF = GParetoFamily, xi = 0.5, seed=130313, beta=1){ +mytest <- function(PF = GParetoFamily, xi = 0.5, seed=130313, beta=1, samples=100){ ### arguments ## PF: generating function of the family ## xi: shape parameter @@ -12,7 +12,7 @@ cat(" ", name(PFam)," ") cat("\n---------------------------------\n") set.seed(seed) - dat0 <- r(PFam)(100) + dat0 <- r(PFam)(samples) cat("\n\n\n---------------------------------\n") cat("RMXE") cat("\n---------------------------------\n") From noreply at r-forge.r-project.org Mon May 27 15:04:23 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 27 May 2013 15:04:23 +0200 (CEST) Subject: [Robast-commits] r665 - branches/robast-0.9/pkg/RobExtremes/R Message-ID: <20130527130424.00FAF18560D@r-forge.r-project.org> Author: ruckdeschel Date: 2013-05-27 15:04:23 +0200 (Mon, 27 May 2013) New Revision: 665 Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R Log: and yet another bug in bDel / GEV Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-05-24 17:16:02 UTC (rev 664) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-05-27 13:04:23 UTC (rev 665) @@ -198,8 +198,9 @@ el }, list(loc0 = loc,N0 = N)) bDel <- substitute({ if(theta[2]>=1L){ D1 <- D2 <- NA}else{ scale <- theta[1]; shape <- theta[2] - D1 <- N0*(gamma(1-shape)-1)/shape - D2 <- -N0*theta[1]*digamma(1-theta[2])/theta[2]- + ga <- gamma(1-shape) + D1 <- N0*(ga-1)/shape + D2 <- -N0*scale*ga*digamma(1-shape)/shape- D1*scale/shape} D <- t(c(D1, D2)) rownames(D) <- "expected loss" From noreply at r-forge.r-project.org Mon May 27 22:27:32 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 27 May 2013 22:27:32 +0200 (CEST) Subject: [Robast-commits] r666 - in branches/robast-0.9/pkg: RobExtremes/R RobExtremes/man RobExtremesBuffer Message-ID: <20130527202732.F268518444C@r-forge.r-project.org> Author: ruckdeschel Date: 2013-05-27 22:27:32 +0200 (Mon, 27 May 2013) New Revision: 666 Added: branches/robast-0.9/pkg/RobExtremesBuffer/checkOfInterest.R Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R branches/robast-0.9/pkg/RobExtremes/R/GParetoFamily.R branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R branches/robast-0.9/pkg/RobExtremes/man/GEVFamily.Rd branches/robast-0.9/pkg/RobExtremes/man/GParetoFamily.Rd branches/robast-0.9/pkg/RobExtremes/man/WeibullFamily.Rd branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R Log: RobExtremes: fixed some bugs in of.interest RobExtremesBuffer: submitted some checks in checkOfInterest.R Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-05-27 13:04:23 UTC (rev 665) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-05-27 20:27:32 UTC (rev 666) @@ -145,7 +145,8 @@ p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, withCentL2 = FALSE, - withL2derivDistr = FALSE){ + withL2derivDistr = FALSE, + ..ignoreTrafo = FALSE){ theta <- c(loc, scale, shape) .warningGEVShapeLarge(shape) @@ -163,6 +164,7 @@ if(!is.null(p)){ btq <- substitute({ q <- loc0 + theta[1]*((-log(p0))^(-theta[2])-1)/theta[2] names(q) <- "quantile" + q }, list(loc0 = loc, p0 = p)) bDq <- substitute({ scale <- theta[1]; shape <- theta[2] @@ -208,10 +210,11 @@ D }, list(loc0 = loc, N0 = N)) } - if(is.null(trafo)) + fromOfInt <- FALSE + if(is.null(trafo)||..ignoreTrafo){fromOfInt <- TRUE trafo <- .define.tau.Dtau(of.interest, btq, bDq, btes, bDes, btel, bDel, p, N) - else if(is.matrix(trafo) & nrow(trafo) > 2) + }else if(is.matrix(trafo) & nrow(trafo) > 2) stop("number of rows of 'trafo' > 2") #### param <- ParamFamParameter(name = "theta", main = c(theta[2],theta[3]), @@ -229,8 +232,9 @@ ## Pickand estimator if(is.null(start0Est)){ #source("kMedMad_Qn_Estimators.R") - e0 <- estimate(PickandsEstimator(x,ParamFamily=GEVFamily( - loc = theta[1], scale = theta[2], shape = theta[3]))) + PF <- GEVFamily(loc = theta[1], scale = theta[2], shape = theta[3]) + e1 <- PickandsEstimator(x,ParamFamily=PF) + e0 <- estimate(e1) }else{ if(is(start0Est,"function")){ e1 <- start0Est(x, ...) @@ -365,14 +369,25 @@ imageDistr(RandVar = L2deriv, distr = distribution)) } - L2Fam at fam.call <- substitute(GEVFamily(loc = loc0, scale = scale0, + if(fromOfInt){ + L2Fam at fam.call <- substitute(GEVFamily(loc = loc0, scale = scale0, shape = shape0, of.interest = of.interest0, + p = p0, N = N0, + withPos = withPos0, withCentL2 = FALSE, + withL2derivDistr = FALSE, ..ignoreTrafo = TRUE), + list(loc0 = loc, scale0 = scale, shape0 = shape, + of.interest0 = of.interest, p0 = p, N0 = N, + withPos0 = withPos)) + }else{ + L2Fam at fam.call <- substitute(GEVFamily(loc = loc0, scale = scale0, + shape = shape0, of.interest = NULL, p = p0, N = N0, trafo = trafo0, withPos = withPos0, withCentL2 = FALSE, withL2derivDistr = FALSE), list(loc0 = loc, scale0 = scale, shape0 = shape, - of.interest0 = of.interest, p0 = p, N0 = N, - trafo0 = trafo, withPos0 = withPos)) + p0 = p, N0 = N, + withPos0 = withPos, trafo0 = trafo)) + } L2Fam at LogDeriv <- function(x){ x0 <- (x-loc)/scale Modified: branches/robast-0.9/pkg/RobExtremes/R/GParetoFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GParetoFamily.R 2013-05-27 13:04:23 UTC (rev 665) +++ branches/robast-0.9/pkg/RobExtremes/R/GParetoFamily.R 2013-05-27 20:27:32 UTC (rev 666) @@ -40,7 +40,8 @@ p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, withCentL2 = FALSE, - withL2derivDistr = FALSE){ + withL2derivDistr = FALSE, + ..ignoreTrafo = FALSE){ theta <- c(loc, scale, shape) of.interest <- .pretreat.of.interest(of.interest,trafo) @@ -57,6 +58,7 @@ if(!is.null(p)){ btq <- substitute({ q <- loc0 + theta[1]*((1-p0)^(-theta[2])-1)/theta[2] names(q) <- "quantile" + q }, list(loc0 = loc, p0 = p)) bDq <- substitute({ scale <- theta[1]; shape <- theta[2] @@ -98,10 +100,11 @@ D }, list(loc0 = loc, N0 = N)) } - if(is.null(trafo)) + fromOfInt <- FALSE + if(is.null(trafo)||..ignoreTrafo){fromOfInt <- TRUE trafo <- .define.tau.Dtau(of.interest, btq, bDq, btes, bDes, btel, bDel, p, N) - else if(is.matrix(trafo) & nrow(trafo) > 2) + }else if(is.matrix(trafo) & nrow(trafo) > 2) stop("number of rows of 'trafo' > 2") # code .define.tau.Dtau is in file GEVFamily.R @@ -119,9 +122,11 @@ ## Pickand estimator if(is.null(start0Est)){ - e0 <- estimate(medkMADhybr(x, k=10, ParamFamily=GParetoFamily(loc = theta[1], - scale = theta[2], shape = theta[3]), - q.lo = 1e-3, q.up = 15)) + PF <- GParetoFamily(loc = theta[1], + scale = theta[2], shape = theta[3]) + e1 <- medkMADhybr(c(x), k=10, ParamFamily = PF, + q.lo = 1e-3, q.up = 15) + e0 <- estimate(e1) }else{ if(is(start0Est,"function")){ e1 <- start0Est(x, ...) @@ -242,14 +247,26 @@ imageDistr(RandVar = L2deriv, distr = distribution)) } - L2Fam at fam.call <- substitute(GParetoFamily(loc = loc0, scale = scale0, + if(fromOfInt){ + L2Fam at fam.call <- substitute(GParetoFamily(loc = loc0, scale = scale0, shape = shape0, of.interest = of.interest0, + p = p0, N = N0, + withPos = withPos0, withCentL2 = FALSE, + withL2derivDistr = FALSE, ..ignoreTrafo = TRUE), + list(loc0 = loc, scale0 = scale, shape0 = shape, + of.interest0 = of.interest, p0 = p, N0 = N, + withPos0 = withPos)) + }else{ + L2Fam at fam.call <- substitute(GParetoFamily(loc = loc0, scale = scale0, + shape = shape0, of.interest = NULL, p = p0, N = N0, trafo = trafo0, withPos = withPos0, withCentL2 = FALSE, withL2derivDistr = FALSE), list(loc0 = loc, scale0 = scale, shape0 = shape, - of.interest0 = of.interest, p0 = p, N0 = N, - trafo0 = trafo, withPos0 = withPos)) + p0 = p, N0 = N, + withPos0 = withPos, trafo0 = trafo)) + } + L2Fam at LogDeriv <- function(x) (shape+1)/(scale+shape*(x-loc)) L2Fam at L2deriv <- L2deriv Modified: branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R 2013-05-27 13:04:23 UTC (rev 665) +++ branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R 2013-05-27 20:27:32 UTC (rev 666) @@ -38,7 +38,8 @@ p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, withCentL2 = FALSE, - withL2derivDistr = FALSE){ + withL2derivDistr = FALSE, + ..ignoreTrafo = FALSE){ theta <- c(scale, shape) of.interest <- .pretreat.of.interest(of.interest,trafo) @@ -55,7 +56,8 @@ if(!is.null(p)){ btq <- substitute({ q <- theta[1]*(-log(1-p0))^(1/theta[2]) names(q) <- "quantile" - }, list(loc0 = loc, p0 = p)) + q + }, list(p0 = p)) bDq <- substitute({ scale <- theta[1]; shape <- theta[2] lp <- -log(1-p0) @@ -68,9 +70,9 @@ s1 <- 1+1/theta[2] pg <- pgamma(-log(p0),s1, lower.tail = FALSE) g0 <- gamma(s1) - es <- theta[1] * g0 * pg /(1-p0) + loc0 } + es <- theta[1] * g0 * pg /(1-p0)} names(es) <- "expected shortfall" - es }, list(loc0 = loc, p0 = p)) + es }, list(p0 = p)) bDes <- substitute({ if(theta[2]>=1L){ D1 <- D2 <- NA} else { s1 <- 1+1/theta[2] pg <- pgamma(-log(p0), s1, lower.tail = FALSE) @@ -81,12 +83,12 @@ D <- t(c(D1, D2)) rownames(D) <- "expected shortfall" colnames(D) <- NULL - D }, list(loc0 = loc, p0 = p)) + D }, list(p0 = p)) } if(!is.null(N)){ btel <- substitute({ el <- N0*(theta[1]*gamma(1+1/theta[2])) names(el) <- "expected loss" - el }, list(loc0 = loc,N0 = N)) + el }, list(N0 = N)) bDel <- substitute({ scale <- theta[1]; shape <- theta[2] s1 <- 1+1/shape D1 <- N0*gamma(s1) @@ -94,13 +96,14 @@ D <- t(c(D1, D2)) rownames(D) <- "expected loss" colnames(D) <- NULL - D }, list(loc0 = loc, N0 = N)) + D }, list(N0 = N)) } - if(is.null(trafo)) + fromOfInt <- FALSE + if(is.null(trafo)||..ignoreTrafo){fromOfInt <- TRUE trafo <- .define.tau.Dtau(of.interest, btq, bDq, btes, bDes, btel, bDel, p, N) - else if(is.matrix(trafo) & nrow(trafo) > 2) + }else if(is.matrix(trafo) & nrow(trafo) > 2) stop("number of rows of 'trafo' > 2") # code .define.tau.Dtau is in file GEVFamily.R @@ -118,7 +121,8 @@ ## Pickand estimator if(is.null(start0Est)){ - e0 <- estimate(QuantileBCCEstimator(x)) + e1 <- QuantileBCCEstimator(x) + e0 <- estimate(e1) }else{ if(is(start0Est,"function")){ e1 <- start0Est(x, ...) @@ -232,14 +236,25 @@ imageDistr(RandVar = L2deriv, distr = distribution)) } - L2Fam at fam.call <- substitute(WeibullFamily(scale = scale0, + if(fromOfInt){ + L2Fam at fam.call <- substitute(WeibullFamily(scale = scale0, shape = shape0, of.interest = of.interest0, + p = p0, N = N0, + withPos = withPos0, withCentL2 = FALSE, + withL2derivDistr = FALSE, ..ignoreTrafo = TRUE), + list(scale0 = scale, shape0 = shape, + of.interest0 = of.interest, p0 = p, N0 = N, + withPos0 = withPos)) + }else{ + L2Fam at fam.call <- substitute(WeibullFamily(scale = scale0, + shape = shape0, of.interest = NULL, p = p0, N = N0, trafo = trafo0, withPos = withPos0, withCentL2 = FALSE, withL2derivDistr = FALSE), list(scale0 = scale, shape0 = shape, - of.interest0 = of.interest, p0 = p, N0 = N, - trafo0 = trafo, withPos0 = withPos)) + p0 = p, N0 = N, + withPos0 = withPos, trafo0 = trafo)) + } L2Fam at LogDeriv <- function(x){ z <- x/scale log(shape)-log(scale)+(shape-1)*log(z)-shape*z^(shape-1) Modified: branches/robast-0.9/pkg/RobExtremes/man/GEVFamily.Rd =================================================================== --- branches/robast-0.9/pkg/RobExtremes/man/GEVFamily.Rd 2013-05-27 13:04:23 UTC (rev 665) +++ branches/robast-0.9/pkg/RobExtremes/man/GEVFamily.Rd 2013-05-27 20:27:32 UTC (rev 666) @@ -9,7 +9,7 @@ \usage{ GEVFamily(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"), p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, - withCentL2 = FALSE, withL2derivDistr = FALSE) + withCentL2 = FALSE, withL2derivDistr = FALSE, ..ignoreTrafo = FALSE) } \arguments{ \item{loc}{ real: known/fixed threshold/location parameter } @@ -28,6 +28,7 @@ when set to \code{TRUE}.} \item{withL2derivDistr}{logical: shall the distribution of the L2 derivative be computed? Defaults to \code{FALSE} (to speeds up computations).} + \item{..ignoreTrafo}{logical: only used internally in \code{kStepEstimator}; do not change this.} } \details{ The slots of the corresponding L2 differentiable Modified: branches/robast-0.9/pkg/RobExtremes/man/GParetoFamily.Rd =================================================================== --- branches/robast-0.9/pkg/RobExtremes/man/GParetoFamily.Rd 2013-05-27 13:04:23 UTC (rev 665) +++ branches/robast-0.9/pkg/RobExtremes/man/GParetoFamily.Rd 2013-05-27 20:27:32 UTC (rev 666) @@ -9,7 +9,7 @@ \usage{ GParetoFamily(loc = 0, scale = 1, shape = 0.5, of.interest = c("scale", "shape"), p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, - withCentL2 = FALSE, withL2derivDistr = FALSE) + withCentL2 = FALSE, withL2derivDistr = FALSE, ..ignoreTrafo = FALSE) } \arguments{ \item{loc}{ real: known/fixed threshold/location parameter } @@ -28,6 +28,7 @@ when set to \code{TRUE}.} \item{withL2derivDistr}{logical: shall the distribution of the L2 derivative be computed? Defaults to \code{FALSE} (to speeds up computations).} + \item{..ignoreTrafo}{logical: only used internally in \code{kStepEstimator}; do not change this.} } \details{ The slots of the corresponding L2 differentiable Modified: branches/robast-0.9/pkg/RobExtremes/man/WeibullFamily.Rd =================================================================== --- branches/robast-0.9/pkg/RobExtremes/man/WeibullFamily.Rd 2013-05-27 13:04:23 UTC (rev 665) +++ branches/robast-0.9/pkg/RobExtremes/man/WeibullFamily.Rd 2013-05-27 20:27:32 UTC (rev 666) @@ -9,7 +9,7 @@ \usage{ WeibullFamily(scale = 1, shape = 0.5, of.interest = c("scale", "shape"), p = NULL, N = NULL, trafo = NULL, start0Est = NULL, withPos = TRUE, - withCentL2 = FALSE, withL2derivDistr = FALSE) + withCentL2 = FALSE, withL2derivDistr = FALSE, ..ignoreTrafo = FALSE) } \arguments{ \item{scale}{ positive real: scale parameter } @@ -27,6 +27,7 @@ when set to \code{TRUE}.} \item{withL2derivDistr}{logical: shall the distribution of the L2 derivative be computed? Defaults to \code{FALSE} (to speeds up computations).} + \item{..ignoreTrafo}{logical: only used internally in \code{kStepEstimator}; do not change this.} } \details{ The slots of the corresponding L2 differentiable parameteric family are filled. Modified: branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R 2013-05-27 13:04:23 UTC (rev 665) +++ branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R 2013-05-27 20:27:32 UTC (rev 666) @@ -71,7 +71,7 @@ #Peter baseDir0 <- "C:/rtest/RobASt" #Misha -baseDir0 <- "D:/SVN repositories/robast" +#baseDir0 <- "D:/SVN repositories/robast" interpolDir <- "branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation" interpolFile <- "plotInterpol.R" ## Added: branches/robast-0.9/pkg/RobExtremesBuffer/checkOfInterest.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/checkOfInterest.R (rev 0) +++ branches/robast-0.9/pkg/RobExtremesBuffer/checkOfInterest.R 2013-05-27 20:27:32 UTC (rev 666) @@ -0,0 +1,76 @@ + +require(RobExtremes) +G0 <- GParetoFamily(shape=0.7,of.interest="quantile", p=0.99) +IC1 <- optIC(InfRobModel(G0,ContNeighborhood(rad=0.5)), risk=asMSE()) +set.seed(20130527) +x <- r(G0)(2000) +res <- kStepEstimator(x, IC1) + +G0 <- GParetoFamily(shape=0.7,of.interest="quantile", p=0.99) +IC0 <- optIC(G0, risk=asCov()) +IC1 <- optIC(InfRobModel(G0,ContNeighborhood(rad=0.5)), risk=asMSE()) +plot(IC1) +IC2 <- optIC(InfRobModel(G0,ContNeighborhood(rad=0.5)), risk=asBias()) +plot(IC2) +IC3 <- radiusMinimaxIC(G0,ContNeighborhood(rad=0.5), risk=asMSE()) +IC3 +plot(IC3) +G0a <- GParetoFamily(shape=0.7,of.interest="expected shortfall", p=0.99) +IC0a <- optIC(G0a, risk=asCov()) +IC1a <- optIC(InfRobModel(G0a,ContNeighborhood(rad=0.5)), risk=asMSE()) +plot(IC1a) +IC2a <- optIC(InfRobModel(G0a,ContNeighborhood(rad=0.5)), risk=asBias()) +plot(IC2a) +IC3a <- radiusMinimaxIC(G0a,ContNeighborhood(rad=0.5), risk=asMSE()) +IC3a +plot(IC3a) +set.seed(20130527) +x <- r(G0)(200) +res <- kStepEstimator(x, IC1) +estimate(res) +confint(res,level=.95) +q(distribution(G0))(.99) +set.seed(20130527) +x <- r(G0)(20000) +res <- kStepEstimator(x, IC1) +estimate(res) +confint(res,level=.95) +res00 <- MLEstimator(x, G0) +res0 <- kStepEstimator(x, IC0,steps=20) +estimate(res0) +confint(res0,level=.95) + +G0 <- GEVFamily(shape=0.7,of.interest="quantile", p=0.99) +IC0 <- optIC(G0, risk=asCov()) +IC1 <- optIC(InfRobModel(G0,ContNeighborhood(rad=0.5)), risk=asMSE()) +plot(IC1) +set.seed(20130527) +x <- r(G0)(1500) +res <- kStepEstimator(x, IC1) +estimate(res) +confint(res,level=.95) +q(distribution(G0))(.99) +res00 <- MLEstimator(x, G0) +res0 <- kStepEstimator(x, IC0,steps=20) +estimate(res00) +estimate(res0) +confint(res0,level=.95) +q(distribution(G0))(.99) + +require(RobExtremes) +G0 <- WeibullFamily(shape=0.7,of.interest="quantile", p=0.99) +IC0 <- optIC(G0, risk=asCov()) +IC1 <- optIC(InfRobModel(G0,ContNeighborhood(rad=0.5)), risk=asMSE()) +plot(IC1) +set.seed(20130527) +x <- r(G0)(1500) +res <- kStepEstimator(x, IC1) +estimate(res) +confint(res,level=.95) +q(distribution(G0))(.99) +res00 <- MLEstimator(x, G0) +res0 <- kStepEstimator(x, IC0,steps=20) +estimate(res00) +estimate(res0) +confint(res0,level=.95) +q(distribution(G0))(.99) From noreply at r-forge.r-project.org Fri May 31 09:23:55 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 31 May 2013 09:23:55 +0200 (CEST) Subject: [Robast-commits] r667 - in branches/robast-0.9/pkg: . 13.05.31 - Wrapper for RobAStBase, RobExtremes Message-ID: <20130531072356.0748E184B6A@r-forge.r-project.org> Author: pupashenko Date: 2013-05-31 09:23:55 +0200 (Fri, 31 May 2013) New Revision: 667 Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_Trsp50_LegendFalse.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_Trsp50_LegendFalse.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_Trsp70.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data_Trsp70.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp50_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp50_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_GEV_Lo0_Up5_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_GPD_Lo0_Up10_LegendFalse.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_Gamma_Lo0_Up5.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_Weibull_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper.R branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_LegendTrue_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_LegendTrue_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_LegendTrue_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_LegendTrue_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp50_LegendFalse_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp50_LegendFalse_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp50_LegendFalse_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp50_LegendFalse_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_Trsp70_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_Trsp70_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_Trsp70_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_Trsp70_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp50_LegendTrue_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp50_LegendTrue_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp50_LegendTrue_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp50_LegendTrue_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper.R branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_GEV_Trsp100_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_GPD_Trsp50_LegendFalse.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_Gamma_Trsp70.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_Weibull_Trsp50_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/plotOutlyingness_Old.R Log: Die Wrapper Funktionen f?\195?\188r plot Methode (f?\195?\188r IC, in AllPlot?.R), InfoPlot Methode, outlyingPlot, cniperPointPlot. Extra Modifikation ist gemacht f?\195?\188r cniperCont.R File, damit die Wrappern richtig funktionieren k?\195?\182nnen. Die Beispiele sind auch gemacht. Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory =================================================================== --- branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory (rev 0) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory 2013-05-31 07:23:55 UTC (rev 667) @@ -0,0 +1,512 @@ +,cutoff.quantile.y = cutoff.quantile.y +,cutoff.x = cutoff() +,cutoff.y = cutoff.sememp() +,robCov.x = TRUE +,robCov.y = TRUE +,tf.x = function(x)log(x) +,cex.main = 1.5 +,cex.lab = 1.5 +,cex = 1.5 +#,col.lab=FhGred +,lwd.cutoff = 3 +#,jitt.fac = 300 +,col.abline = col.abline +,cex.abline = 1.2 +,adj.abline = c(0.8, 0.2) +,main = ""#"Outlyingness Plot" +,xlab="Theoretical log-quantiles" +,ylab="Mahalanobis distance" +) +} +##Example +require(RobExtremes) +X = GPareto() +fam = GParetoFamily() +x = r(X)(1000) +plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=75, with.legend = TRUE) +plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE) +########################################## +## ## +## Wrapper for outlyingnessPlot.R ## +## ## +## ## +########################################## +##projection distance +qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)} +QProj <- function(){new("NormType", name="Quantiles", fct=qfun)} +##@x - dataset +##@X - random variable +##@fam - parameter family +##@alpha - confidence level for quantile +# +plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){ +mc <- as.list(match.call(expand.dots = FALSE))[-1] +dots <- mc$"..." +if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100 +if(is.null(dots$with.legend)) dots$with.legend <- TRUE +if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'") +if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'") +if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'") +##logarithmic representation (for distributions with positive support) +fam at distribution = log(fam at distribution) +##classical IC +ICmle <- optIC(model=fam,risk=asCov()) +##parameter for plotting +if(with.legend) +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "black", col.lab = "black") +col.Abline = rgb(52,52,52,maxColorValue=255)} +else +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "white", col.lab = "white") +colAbline = "white"} +cutoff.quantile.x = alpha +cutoff.quantile.y = alpha +##call of routine from RobAStBase +outlyingPlotIC(x +,IC.x = ICmle +,IC.y = ICmle +,dist.x = QProj() +#NormType() - Euclidean norm, default - Mahalanobis norm +#,dist.y = NormType() +,adj = 0.1 +,pch = 21 +,col.idn = rgb(102,102,102,maxColorValue=255) +,cex.idn = 1.7 +,col.cutoff = rgb(202,202,202,maxColorValue=255) +,offset = 0 +,cutoff.quantile.x = cutoff.quantile.x +,cutoff.quantile.y = cutoff.quantile.y +,cutoff.x = cutoff() +,cutoff.y = cutoff.sememp() +,robCov.x = TRUE +,robCov.y = TRUE +,tf.x = function(x)log(x) +,cex.main = 1.5 +,cex.lab = 1.5 +,cex = 1.5 +#,col.lab=FhGred +,lwd.cutoff = 3 +#,jitt.fac = 300 +,col.abline = colAbline +,cex.abline = 1.2 +,adj.abline = c(0.8, 0.2) +,main = ""#"Outlyingness Plot" +,xlab="Theoretical log-quantiles" +,ylab="Mahalanobis distance" +) +} +##Example +require(RobExtremes) +X = GPareto() +fam = GParetoFamily() +x = r(X)(1000) +plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=75, with.legend = TRUE) +plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE) +########################################## +## ## +## Wrapper for outlyingnessPlot.R ## +## ## +## ## +########################################## +##projection distance +qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)} +QProj <- function(){new("NormType", name="Quantiles", fct=qfun)} +##@x - dataset +##@X - random variable +##@fam - parameter family +##@alpha - confidence level for quantile +# +plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){ +mc <- as.list(match.call(expand.dots = FALSE))[-1] +dots <- mc$"..." +if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100 +if(is.null(dots$with.legend)) dots$with.legend <- TRUE +if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'") +if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'") +if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'") +##logarithmic representation (for distributions with positive support) +fam at distribution = log(fam at distribution) +##classical IC +ICmle <- optIC(model=fam,risk=asCov()) +##parameter for plotting +if(with.legend) +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "black", col.lab = "black") +col.Abline = rgb(52,52,52,maxColorValue=255)} +else +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "white", col.lab = "white") +colAbline = "white"} +print(colAbline) +cutoff.quantile.x = alpha +cutoff.quantile.y = alpha +##call of routine from RobAStBase +outlyingPlotIC(x +,IC.x = ICmle +,IC.y = ICmle +,dist.x = QProj() +#NormType() - Euclidean norm, default - Mahalanobis norm +#,dist.y = NormType() +,adj = 0.1 +,pch = 21 +,col.idn = rgb(102,102,102,maxColorValue=255) +,cex.idn = 1.7 +,col.cutoff = rgb(202,202,202,maxColorValue=255) +,offset = 0 +,cutoff.quantile.x = cutoff.quantile.x +,cutoff.quantile.y = cutoff.quantile.y +,cutoff.x = cutoff() +,cutoff.y = cutoff.sememp() +,robCov.x = TRUE +,robCov.y = TRUE +,tf.x = function(x)log(x) +,cex.main = 1.5 +,cex.lab = 1.5 +,cex = 1.5 +#,col.lab=FhGred +,lwd.cutoff = 3 +#,jitt.fac = 300 +,col.abline = colAbline +,cex.abline = 1.2 +,adj.abline = c(0.8, 0.2) +,main = ""#"Outlyingness Plot" +,xlab="Theoretical log-quantiles" +,ylab="Mahalanobis distance" +) +} +##Example +require(RobExtremes) +X = GPareto() +fam = GParetoFamily() +x = r(X)(1000) +plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=75, with.legend = TRUE) +plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE) +########################################## +## ## +## Wrapper for outlyingnessPlot.R ## +## ## +## ## +########################################## +##projection distance +qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)} +QProj <- function(){new("NormType", name="Quantiles", fct=qfun)} +##@x - dataset +##@X - random variable +##@fam - parameter family +##@alpha - confidence level for quantile +# +plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){ +mc <- as.list(match.call(expand.dots = FALSE))[-1] +dots <- mc$"..." +if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100 +if(is.null(dots$with.legend)) dots$with.legend <- TRUE +if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'") +if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'") +if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'") +##logarithmic representation (for distributions with positive support) +fam at distribution = log(fam at distribution) +##classical IC +ICmle <- optIC(model=fam,risk=asCov()) +##parameter for plotting +if(with.legend) +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "black", col.lab = "black")} +else +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "white", col.lab = "white")} +cutoff.quantile.x = alpha +cutoff.quantile.y = alpha +##call of routine from RobAStBase +outlyingPlotIC(x +,IC.x = ICmle +,IC.y = ICmle +,dist.x = QProj() +#NormType() - Euclidean norm, default - Mahalanobis norm +#,dist.y = NormType() +,adj = 0.1 +,pch = 21 +,col.idn = rgb(102,102,102,maxColorValue=255) +,cex.idn = 1.7 +,col.cutoff = rgb(202,202,202,maxColorValue=255) +,offset = 0 +,cutoff.quantile.x = cutoff.quantile.x +,cutoff.quantile.y = cutoff.quantile.y +,cutoff.x = cutoff() +,cutoff.y = cutoff.sememp() +,robCov.x = TRUE +,robCov.y = TRUE +,tf.x = function(x)log(x) +,cex.main = 1.5 +,cex.lab = 1.5 +,cex = 1.5 +#,col.lab=FhGred +,lwd.cutoff = 3 +#,jitt.fac = 300 +,col.abline = rgb(52,52,52,maxColorValue=255) +,cex.abline = 1.2 +,adj.abline = c(0.8, 0.2) +,main = ""#"Outlyingness Plot" +,xlab="Theoretical log-quantiles" +,ylab="Mahalanobis distance" +) +} +##Example +require(RobExtremes) +X = GPareto() +fam = GParetoFamily() +x = r(X)(1000) +plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=75, with.legend = TRUE) +plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE) +########################################## +## ## +## Wrapper for outlyingnessPlot.R ## +## ## +## ## +########################################## +##projection distance +qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)} +QProj <- function(){new("NormType", name="Quantiles", fct=qfun)} +##@x - dataset +##@X - random variable +##@fam - parameter family +##@alpha - confidence level for quantile +# +plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){ +mc <- as.list(match.call(expand.dots = FALSE))[-1] +dots <- mc$"..." +if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100 +if(is.null(dots$with.legend)) dots$with.legend <- TRUE +if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'") +if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'") +if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'") +##logarithmic representation (for distributions with positive support) +fam at distribution = log(fam at distribution) +##classical IC +ICmle <- optIC(model=fam,risk=asCov()) +##parameter for plotting +if(with.legend) +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "black", col.lab = "black")} +else +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "white", col.lab = "white")} +cutoff.quantile.x = alpha +cutoff.quantile.y = alpha +##call of routine from RobAStBase +outlyingPlotIC(x +,IC.x = ICmle +,IC.y = ICmle +,dist.x = QProj() +#NormType() - Euclidean norm, default - Mahalanobis norm +#,dist.y = NormType() +,adj = 0.1 +,pch = 21 +,col.idn = rgb(102,102,102,maxColorValue=255) +,cex.idn = 1.7 +,col.cutoff = rgb(202,202,202,maxColorValue=255) +,offset = 0 +,cutoff.quantile.x = cutoff.quantile.x +,cutoff.quantile.y = cutoff.quantile.y +,cutoff.x = cutoff() +,cutoff.y = cutoff.sememp() +,robCov.x = TRUE +,robCov.y = TRUE +,tf.x = function(x)log(x) +,cex.main = 1.5 +,cex.lab = 1.5 +,cex = 1.5 +#,col.lab=FhGred +,lwd.cutoff = 3 +#,jitt.fac = 300 +,col.abline = rgb(52,52,52,maxColorValue=255) +,cex.abline = 1.2 +,adj.abline = c(0.8, 0.2) +,main = ""#"Outlyingness Plot" +,xlab="Theoretical log-quantiles" +,ylab="Mahalanobis distance" +) +} +##Example +require(RobExtremes) +X = GPareto() +fam = GParetoFamily() +x = r(X)(1000) +plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=50, with.legend = TRUE) +plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE) +myplot <- function(x,y, ..., withCall =TRUE){ +### +### 1. grab the dots (and probably manipulate it within the wrapper function) +### +dots <- as.list(match.call(expand.dots=FALSE))$"..." +### +## do something to fix the good default arguments +### +### 2. build up the argument list for the (powerful/fullfledged) +### graphics/diagnostics function; +### mind not to evaluate the x and (possibly) y args to provide automatic +### axis annotation +### +args <- c(list(x=substitute(x),y=substitute(y)),dots, type="l") +### +### 3. build up the call but grab it and write it into an object +### +cl <- substitute(do.call(plot,args0), list(args0=args)) +### manipulate it so that the wrapper do.call is ommitted +cl0 <- as.list(cl)[-1] +mycall <- c(cl0,unlist(cl0[-1])) +mycall <- as.call(mycall) +### +### 4. evaluate the call (i.e., produce the graphic) +### +eval(mycall) +### +### 5. return the call (if withCall==TRUE) +### +if(withCall) return(mycall) else return(invisible(NULL)) +} +x <- 1:20 +y <- rnorm(20) +cl <- myplot(x,y,col="red") +eval(cl) +cl <- myplot(x,y) +args <- c(list(x=substitute(x),y=substitute(y)),dots, type="l") +dots <- as.list(match.call(expand.dots=FALSE))$"..." +cl <- substitute(do.call(plot,args0), list(args0=args)) +cl0 <- as.list(cl)[-1] +mycall <- c(cl0,unlist(cl0[-1])) +mycall <- as.call(mycall) +### +### 4. evaluate the call (i.e., produce the graphic) +### +eval(mycall) +### +### 5. return the call (if withCall==TRUE) +### +if(withCall) return(mycall) else return(invisible(NULL)) +########################################## +## ## +## Wrapper for outlyingnessPlot.R ## +## ## +## ## +########################################## +##projection distance +qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)} +QProj <- function(){new("NormType", name="Quantiles", fct=qfun)} +##@x - dataset +##@X - random variable +##@fam - parameter family +##@alpha - confidence level for quantile +# +plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){ +mc <- as.list(match.call(expand.dots = FALSE))[-1] +dots <- mc$"..." +if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100 +if(is.null(dots$with.legend)) dots$with.legend <- TRUE +if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'") +if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'") +if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'") +args <- c(list(x=substitute(x),alpha=substitute(alpha),fam=substitute(fam)),dots, type="l") +cl <- substitute(do.call(plot,args0), list(args0=args)) +### manipulate it so that the wrapper do.call is ommitted +cl0 <- as.list(cl)[-1] +mycall <- c(cl0,unlist(cl0[-1])) +mycall <- as.call(mycall) +### +### 4. evaluate the call (i.e., produce the graphic) +### +eval(mycall) +##logarithmic representation (for distributions with positive support) +fam at distribution = log(fam at distribution) +##classical IC +ICmle <- optIC(model=fam,risk=asCov()) +##parameter for plotting +if(with.legend) +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "black", col.lab = "black")} +else +{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp), +col.main = "white", col.lab = "white")} +cutoff.quantile.x = alpha +cutoff.quantile.y = alpha +##call of routine from RobAStBase +outlyingPlotIC(x +,IC.x = ICmle +,IC.y = ICmle +,dist.x = QProj() +#NormType() - Euclidean norm, default - Mahalanobis norm +#,dist.y = NormType() +,adj = 0.1 +,pch = 21 +,col.idn = rgb(102,102,102,maxColorValue=255) +,cex.idn = 1.7 +,col.cutoff = rgb(202,202,202,maxColorValue=255) +,offset = 0 +,cutoff.quantile.x = cutoff.quantile.x +,cutoff.quantile.y = cutoff.quantile.y +,cutoff.x = cutoff() +,cutoff.y = cutoff.sememp() +,robCov.x = TRUE +,robCov.y = TRUE +,tf.x = function(x)log(x) +,cex.main = 1.5 +,cex.lab = 1.5 +,cex = 1.5 +#,col.lab=FhGred +,lwd.cutoff = 3 +#,jitt.fac = 300 +,col.abline = rgb(52,52,52,maxColorValue=255) +,cex.abline = 1.2 +,adj.abline = c(0.8, 0.2) +,main = ""#"Outlyingness Plot" +,xlab="Theoretical log-quantiles" +,ylab="Mahalanobis distance" +) +} +##Example +require(RobExtremes) +X = GPareto() +fam = GParetoFamily() +x = r(X)(1000) +plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=50, with.legend = TRUE) +plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE) +myplot <- function(x,y, ..., withCall = TRUE){ +### +### 1. grab the dots (and probably manipulate it within the wrapper function) +### +mc <- as.list(match.call(expand.dots = FALSE))[-1] +dots <- mc$"..." +if(is.null(mc$withCall)) mc$withCall <- TRUE +if(missing(x)) stop("Argument 'x' must be given as argument to 'myplot'") +if(missing(y)) stop("Argument 'y' must be given as argument to 'myplot'") +### +## do something to fix the good default arguments +### +### 2. build up the argument list for the (powerful/fullfledged) +### graphics/diagnostics function; +### mind not to evaluate the x and (possibly) y args to provide automatic +### axis annotation +### +args <- c(list(x=substitute(x),y=substitute(y)),dots,type="l") +### +### 3. build up the call but grab it and write it into an object +### +cl <- substitute(do.call(plot,args0), list(args0=args)) +### manipulate it so that the wrapper do.call is ommitted +cl0 <- as.list(cl)[-1] +mycall <- c(cl0[1],unlist(cl0[-1])) +mycall <- as.call(mycall) +### +### 4. evaluate the call (i.e., produce the graphic) +### +eval(mycall) +### +### 5. return the call (if withCall==TRUE) +### +if(mc$withCall) print(mycall) +} +x <- 1:20 +y <- rnorm(20) +cl <- myplot(x,y,col="red", withCall=TRUE) +cl <- myplot(x,y,col="blue") +cl <- myplot(x,y,col="green", withCall=FALSE) Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R =================================================================== --- branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R (rev 0) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R 2013-05-31 07:23:55 UTC (rev 667) @@ -0,0 +1,53 @@ + myplot <- function(x,y, ..., withCall = TRUE){ + ### + ### 1. grab the dots (and probably manipulate it within the wrapper function) + ### + mc <- as.list(match.call(expand.dots = FALSE))[-1] + dots <- mc$"..." + if(is.null(mc$withCall)) mc$withCall <- TRUE + + if(missing(x)) stop("Argument 'x' must be given as argument to 'myplot'") + if(missing(y)) stop("Argument 'y' must be given as argument to 'myplot'") + ### + ## do something to fix the good default arguments + ### + ### 2. build up the argument list for the (powerful/fullfledged) + ### graphics/diagnostics function; + ### mind not to evaluate the x and (possibly) y args to provide automatic + ### axis annotation + ### + args <- c(list(x=substitute(x),y=substitute(y)),dots,type="l") + print(args) + print("###################################################") + ### + ### 3. build up the call but grab it and write it into an object + ### + cl <- substitute(do.call(plot,args0), list(args0=args)) + print(cl) + print("###################################################") + ### manipulate it so that the wrapper do.call is ommitted + cl0 <- as.list(cl)[-1] + print(cl0) + print("###################################################") + mycall <- c(cl0[1],unlist(cl0[-1])) + print(mycall) + print("###################################################") + mycall <- as.call(mycall) + print(mycall) + print("###################################################") + ### + ### 4. evaluate the call (i.e., produce the graphic) + ### + eval(mycall) + ### + ### 5. return the call (if withCall==TRUE) + ### + if(mc$withCall) print(mycall) + +} + +x <- 1:20 +y <- rnorm(20) +cl <- myplot(x,y,col="red", withCall=TRUE) +cl <- myplot(x,y,col="blue") +cl <- myplot(x,y,col="green", withCall=FALSE) \ No newline at end of file Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R =================================================================== --- branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R (rev 0) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R 2013-05-31 07:23:55 UTC (rev 667) @@ -0,0 +1,172 @@ +########################################## +## ## +## Wrapper for AllPlot.R ## +## (plot method for IC) ## +## ## +########################################## + +##IC - influence curve +##y - dataset +## with.legend - optional legend indicator +## withCall - optional indicator of the function call +# +ICAllPlotWrapper = function(IC, y,...,alpha.trsp = 100,with.legend = TRUE, withCall = TRUE){ + ### + ### 1. grab the dots (and manipulate it within the wrapper function) + ### + ### + ### do something to fix the good default arguments + ### + mc <- as.list(match.call(expand.dots = FALSE))[-1] + dots <- mc$"..." + if(is.null(mc$alpha.trsp)) alpha.trsp <- 100 + if(is.null(mc$with.legend)) mc$with.legend <- TRUE + if(is.null(mc$withCall)) mc$withCall <- TRUE + if(missing(IC)) stop("Argument 'IC' must be given as argument to 'ICAllPlotWrapper'") + ### + ### 2. build up the argument list for the (powerful/fullfledged) + ### graphics/diagnostics function; + ## + + if(missing(y)){ + argsList <- list(x = substitute(IC) + ,withSweave = substitute(getdistrOption("withSweave")) + ,main = substitute(FALSE) + ,inner = substitute(TRUE) + ,sub = substitute(FALSE) + ,col.inner = substitute(par("col.main")) + ,cex.inner = substitute(0.8) + ,bmar = substitute(par("mar")[1]) + ,tmar = substitute(par("mar")[3]) + ,with.legend = substitute(FALSE) + ,legend = substitute(NULL) + ,legend.bg = substitute("white") + ,legend.location = substitute("bottomright") + ,legend.cex = substitute(0.8) + ,withMBR = substitute(FALSE) + ,MBRB = substitute(NA) + ,MBR.fac = substitute(2) + ,col.MBR = substitute(par("col")) + ,lty.MBR = substitute("dashed") + ,lwd.MBR = substitute(0.8) + ,scaleX = substitute(FALSE) + ,scaleX.fct = substitute(p(eval(IC at CallL2Fam))) + ,scaleX.inv = substitute(q(eval(IC at CallL2Fam))) + ,scaleY = substitute(FALSE) + ,scaleY.fct = substitute(pnorm) + ,scaleY.inv=substitute(qnorm) + ,scaleN = substitute(9) + ,x.ticks = substitute(NULL) + ,y.ticks = substitute(NULL) + ,mfColRow = substitute(TRUE) + ,to.draw.arg = substitute(NULL) + ,adj = substitute(0.1) + ,cex.main = substitute(1.5) + ,cex.lab = substitute(1.5) + ,cex = substitute(1.5) + ,bty = substitute("n") + ,panel.first= substitute(grid()) + ,col = substitute("blue") + ) + }else{ + argsList <- list(x = substitute(IC) + ,y = substitute(y) + ,cex.pts = substitute(0.3) + ,col.pts = substitute(addAlphTrsp2col(rgb(0,255,0,maxColorValue=255), substitute(alpha.trsp))) + ,pch.pts = substitute(1) + ,jitter.fac = substitute(1) + ,with.lab = substitute(FALSE) + ,lab.pts = substitute(NULL) + ,lab.font = substitute(NULL) + ,alpha.trsp = substitute(NA) + ,which.lbs = substitute(NULL) + ,which.Order = substitute(NULL) + ,return.Order = substitute(FALSE) + ,adj = substitute(0.1) + ,cex.main = substitute(1.5) + ,cex.lab = substitute(1.5) + ,cex = substitute(1.5) + ,bty = substitute("n") + ,panel.first= substitute(grid()) + ,col = substitute("blue") + ) + } + + + + ##parameter for plotting + if(mc$with.legend) + { + argsList$col.main <- "black" + argsList$col.lab <- "black" + } + else + { + argsList$col.main <- "white" + argsList$col.lab <- "white" + } + + args <- c(argsList, dots) + ### + ### 3. build up the call but grab it and write it into an object + ### + cl <- substitute(do.call(plot,args0), list(args0=args)) + ### manipulate it so that the wrapper do.call is ommitted + cl0 <- as.list(cl)[-1] + mycall <- c(cl0[1],unlist(cl0[-1])) + mycall <- as.call(mycall) + ### + ### 4. evaluate the call (i.e., produce the graphic) + ### + eval(mycall) + ### + ### 5. return the call (if withCall==TRUE) + ### + if(mc$withCall) print(mycall) + +} + +##Examples +require(RobExtremes) +require(distr) + +# GPD +fam = GParetoFamily() +IC <- optIC(model = fam, risk = asCov()) +Y=distribution(fam) +y = r(Y)(1000) +dev.new() +ICAllPlotWrapper(IC, alpha.trsp=50, with.legend = FALSE) +dev.new() +ICAllPlotWrapper(IC, y, alpha.trsp=50, with.legend = FALSE) + +# GEV +fam = GEVFamily() +IC <- optIC(model = fam, risk = asCov()) +Y=distribution(fam) +y = r(Y)(1000) +dev.new() +ICAllPlotWrapper(IC, with.legend = TRUE, withCall = TRUE) +dev.new() +ICAllPlotWrapper(IC, y, with.legend = TRUE, withCall = TRUE) + +# Gamma +fam = GammaFamily() +IC <- optIC(model = fam, risk = asCov()) +Y=distribution(fam) +y = r(Y)(1000) +dev.new() +ICAllPlotWrapper(IC, alpha.trsp=70) +dev.new() +ICAllPlotWrapper(IC, y, alpha.trsp=70) + +# Weibull +fam = WeibullFamily() +IC <- optIC(model = fam, risk = asCov()) +Y=distribution(fam) +y = r(Y)(1000) +dev.new() +ICAllPlotWrapper(IC, alpha.trsp=50, with.legend = TRUE, withCall = FALSE) +dev.new() +ICAllPlotWrapper(IC, y, alpha.trsp=50, with.legend = TRUE, withCall = FALSE) + Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_LegendTrue.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_LegendTrue.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_LegendTrue.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_LegendTrue.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_Trsp50_LegendFalse.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_Trsp50_LegendFalse.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_Trsp50_LegendFalse.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_Trsp50_LegendFalse.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_Trsp70.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_Trsp70.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data_Trsp70.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data_Trsp70.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp50_LegendTrue.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp50_LegendTrue.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp50_LegendTrue.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp50_LegendTrue.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R =================================================================== --- branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R (rev 0) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R 2013-05-31 07:23:55 UTC (rev 667) @@ -0,0 +1,252 @@ +.rescalefct <- RobAStBase:::.rescalefct +.plotRescaledAxis <- RobAStBase:::.plotRescaledAxis +.makedotsP <- RobAStBase:::.makedotsP +.makedotsLowLevel <- RobAStBase:::.makedotsLowLevel +.SelectOrderData <- RobAStBase:::.SelectOrderData + +.plotData <- function( + ## helper function for cniper-type plots to plot in data + data, # data to be plot in + dots, # dots from the calling function + origCl, # call from the calling function + fun, # function to determine risk difference + L2Fam, # L2Family + IC # IC1 in cniperContPlot and eta in cniperPointPlot +){ + dotsP <- .makedotsP(dots) + dotsP$col <- rep(eval(origCl$col.pts), length.out=n) + dotsP$pch <- rep(eval(origCl$pch.pts), length.out=n) + + al <- eval(origCl$alpha.trsp) + if(!is.na(al)) + dotsP$col <- sapply(dotsP$col, addAlphTrsp2col, alpha=al) + + n <- if(!is.null(dim(data))) nrow(data) else length(data) + if(!is.null(lab.pts)) + lab.pts <- rep(origCl$lab.pts, length.out=n) + + sel <- .SelectOrderData(data, function(x)sapply(x,fun), + eval(origCl$which.lbs), + eval(origCl$which.Order)) + i.d <- sel$ind + i0.d <- sel$ind1 + y.d <- sel$y + x.d <- sel$data + n <- length(i.d) + + resc.dat <- .rescalefct(x.d, function(x) sapply(x,fun), + eval(origCl$scaleX), origCl$scaleX.fct, origCl$scaleX.inv, + eval(origCl$scaleY), origCl$scaleY.fct, + dots$xlim, dots$ylim, dots) + + dotsP$x <- resc.dat$X + dotsP$y <- resc.dat$Y + + trafo <- trafo(L2Fam at param) + dims <- nrow(trafo) + QF <- diag(dims) + if(is(IC,"ContIC") & dims>1 ) + {if (is(normtype(IC),"QFNorm")) + QF <- QuadForm(normtype(IC))} + + absInfoEval <- function(x,y) sapply(x, y at Map[[1]]) + IC.rv <- as(diag(dims) %*% IC at Curve, "EuclRandVariable") + absy.f <- t(IC.rv) %*% QF %*% IC.rv + absy <- absInfoEval(x.d, absy.f) + + if(is.null(origCl$cex.pts)) origCl$cex.pts <- par("cex") + dotsP$cex <- log(absy+1)*3*rep(origCl$cex.pts, length.out=n) + + dotsT <- dotsP + dotsT$pch <- NULL + dotsT$cex <- dotsP$cex/2 + dotsT$labels <- if(is.null(lab.pts)) i.d else lab.pts[i.d] + do.call(points,dotsP) + if(!is.null(origCl$with.lab)) + if(origCl$with.lab) do.call(text,dotsT) + if(!is.null(origCl$return$order)) + if(origCl$return.Order) return(i0.d) + return(invisible(NULL)) + } + + +.getFunCnip <- function(IC1,IC2, risk, L2Fam, r, b20=NULL){ + + riskfct <- getRiskFctBV(risk, biastype(risk)) + + .getTrVar <- function(IC){ [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 667