From noreply at r-forge.r-project.org Mon Jul 1 15:53:49 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 1 Jul 2013 15:53:49 +0200 (CEST) Subject: [Robast-commits] r670 - branches/robast-0.9/pkg/RobExtremes/R Message-ID: <20130701135349.7D22818561D@r-forge.r-project.org> Author: ruckdeschel Date: 2013-07-01 15:53:49 +0200 (Mon, 01 Jul 2013) New Revision: 670 Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R Log: [RobExtremes] added Gerald's corrections as to Weibull and as to ddigamma Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-06-17 10:32:24 UTC (rev 669) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-07-01 13:53:49 UTC (rev 670) @@ -403,10 +403,10 @@ return(L2Fam) } -#ddigamma(t,s) is d/ds \int_t^\infty exp(-x) x^(-s) dx +#ddigamma(t,s) is d/ds \int_0^t exp(-x) x^(s-1) dx ddigamma <- function(t,s){ - int <- function(x) exp(-x)*(-log(x))*x^(-s) + int <- function(x) exp(-x)*(log(x))*x^(s-1) integrate(int, lower=0, upper=t)$value } \ No newline at end of file Modified: branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R 2013-06-17 10:32:24 UTC (rev 669) +++ branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R 2013-07-01 13:53:49 UTC (rev 670) @@ -66,18 +66,18 @@ D <- t(c(D1, D2)) rownames(D) <- "quantile"; colnames(D) <- NULL D }, list(p0 = p)) - btes <- substitute({ if(theta[2]>=1L) es <- NA else { + btes <- substitute({ if(theta[2]<= (-1L)) es <- NA else { s1 <- 1+1/theta[2] - pg <- pgamma(-log(p0),s1, lower.tail = FALSE) + pg <- pgamma(-log(1-p0),s1, lower.tail = FALSE) g0 <- gamma(s1) es <- theta[1] * g0 * pg /(1-p0)} names(es) <- "expected shortfall" es }, list(p0 = p)) - bDes <- substitute({ if(theta[2]>=1L){ D1 <- D2 <- NA} else { + bDes <- substitute({ if(theta[2]<= (-1L)){ D1 <- D2 <- NA} else { s1 <- 1+1/theta[2] - pg <- pgamma(-log(p0), s1, lower.tail = FALSE) + pg <- pgamma(-log(1-p0), s1, lower.tail = FALSE) g0 <- gamma(s1) - dd <- digamma(s1)*g0 - ddigamma(-log(p0),s1) + dd <- digamma(s1)*g0 - ddigamma(-log(1-p0),s1) D1 <- g0 * pg / (1-p0) D2 <- theta[1] * dd /(1-p0)} D <- t(c(D1, D2)) From noreply at r-forge.r-project.org Tue Jul 2 11:20:54 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 2 Jul 2013 11:20:54 +0200 (CEST) Subject: [Robast-commits] r671 - branches/robast-0.9/pkg/RobExtremes/R Message-ID: <20130702092054.1BB69180B3A@r-forge.r-project.org> Author: ruckdeschel Date: 2013-07-02 11:20:53 +0200 (Tue, 02 Jul 2013) New Revision: 671 Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R Log: [RobExtremes] added Gerald's second round of corrections as to Weibull and as to ddigamma Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-07-01 13:53:49 UTC (rev 670) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-07-02 09:20:53 UTC (rev 671) @@ -185,9 +185,9 @@ dd <- ddigamma(-log(p0),1-theta[2]) g0 <- gamma(1-theta[2]) D1 <- (g0*pg/(1-p0)-1)/theta[2] - D21 <- theta[1]*D1/theta[2] - D22 <- theta[1]*dd/(1-p0)/theta[2] - D2 <- -D21+D22} + D21 <- D1/theta[2] + D22 <- dd/(1-p0)/theta[2] + D2 <- -theta[1]*(D21+D22)} D <- t(c(D1, D2)) rownames(D) <- "expected shortfall" colnames(D) <- NULL Modified: branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R 2013-07-01 13:53:49 UTC (rev 670) +++ branches/robast-0.9/pkg/RobExtremes/R/WeibullFamily.R 2013-07-02 09:20:53 UTC (rev 671) @@ -77,10 +77,11 @@ s1 <- 1+1/theta[2] pg <- pgamma(-log(1-p0), s1, lower.tail = FALSE) g0 <- gamma(s1) + ## dd <- ddigamma(Inf,s1)-ddigamma(-log(1-p0),s1) dd <- digamma(s1)*g0 - ddigamma(-log(1-p0),s1) - D1 <- g0 * pg / (1-p0) - D2 <- theta[1] * dd /(1-p0)} - D <- t(c(D1, D2)) + D1 <- g0 * pg + D2 <- - theta[1] * dd /theta[2]^2} + D <- t(c(D1, D2))/(1-p0) rownames(D) <- "expected shortfall" colnames(D) <- NULL D }, list(p0 = p)) From noreply at r-forge.r-project.org Tue Jul 2 15:37:23 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 2 Jul 2013 15:37:23 +0200 (CEST) Subject: [Robast-commits] r672 - branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes Message-ID: <20130702133723.CFF6E184D98@r-forge.r-project.org> Author: pupashenko Date: 2013-07-02 15:37:23 +0200 (Tue, 02 Jul 2013) New Revision: 672 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/ICAllPlotWrapper.R branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_LegendFalse.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_LegendFalse.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp30_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_Trsp100_LegendTrue_rescaleTrue_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp30_LegendFalse_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp30_LegendFalse_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp30_LegendFalse_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp30_LegendFalse_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp30_LegendTrue_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp30_LegendTrue_2.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp30_LegendTrue_1.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp30_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_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_Trsp30_LegendTrue.jpeg branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/plotOutlyingness_Old.R Removed: 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: All plots are updated: - transparency is automatic - added box - labels and titles a centered - scaling is implemented and performed Deleted: 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 2013-07-02 09:20:53 UTC (rev 671) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory 2013-07-02 13:37:23 UTC (rev 672) @@ -1,512 +0,0 @@ -,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) Deleted: 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 2013-07-02 09:20:53 UTC (rev 671) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R 2013-07-02 13:37:23 UTC (rev 672) @@ -1,53 +0,0 @@ - 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/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-07-02 13:37:23 UTC (rev 672) @@ -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 Deleted: 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 2013-07-02 09:20:53 UTC (rev 671) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R 2013-07-02 13:37:23 UTC (rev 672) @@ -1,172 +0,0 @@ -########################################## -## ## -## 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.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-07-02 13:37:23 UTC (rev 672) @@ -0,0 +1,214 @@ +########################################## +## ## +## 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, rescale = FALSE ,withCall = TRUE){ + ### + ### 1. grab the dots (and manipulate it within the wrapper function) + ### + ### + ### do something to fix the good default arguments + ### + if(missing(IC)) stop("Argument 'IC' must be given as argument to 'ICAllPlotWrapper'") + mc <- as.list(match.call(expand.dots = FALSE))[-1] + dots <- mc$"..." + if(missing(y)){ + alpha.trsp <- 100 + } else { + if(is.null(mc$alpha.trsp)){ + alpha.trsp <- 30 + if(length(y) < 1000){ + alpha.trsp <- 50 + } + if(length(y) < 100){ + alpha.trsp <- 100 + } + } + } + if(is.null(mc$with.legend)) mc$with.legend <- TRUE + if(is.null(mc$rescale)) mc$rescale <- FALSE + if(is.null(mc$withCall)) mc$withCall <- TRUE + ### + ### 2. build up the argument list for the (powerful/fullfledged) + ### graphics/diagnostics function; + ## + + ## For GEVFamily we have to scale the axes + if((mc$rescale) & (as.list(IC at CallL2Fam)[[1]] == "GEVFamily")){ + if(missing(y)){ + scaleList <- list(scaleX = substitute(TRUE) + ,scaleX.fct = substitute(p(eval(IC at CallL2Fam))) + ,scaleX.inv = substitute(q(eval(IC at CallL2Fam))) + ,scaleY = substitute(TRUE) + ,scaleY.fct = substitute(pnorm) + ,scaleY.inv = substitute(qnorm) + ,x.ticks = substitute(NULL) + ,y.ticks = substitute(NULL) + ) + } else { + scaleList <- list(scaleX = substitute(TRUE) + ,scaleY = substitute(TRUE) + ) + } + }else{ + if(missing(y)){ + scaleList <- list(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) + ,x.ticks = substitute(NULL) + ,y.ticks = substitute(NULL) + ) + } else { + scaleList <- list(scaleX = substitute(FALSE) + ,scaleY = substitute(FALSE) + ) + } + } + + + if(missing(y)){ + argsList <- c(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) + ,scaleN = substitute(9) + ,mfColRow = substitute(TRUE) + ,to.draw.arg = substitute(NULL) + ,adj = substitute(0.5) + ,cex.main = substitute(1.5) + ,cex.lab = substitute(1.5) + ,cex = substitute(1.5) + ,bty = substitute("o") + ,panel.first= substitute(grid()) + ,col = substitute("blue") + ), scaleList) + }else{ + argsList <- c(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))) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 672 From noreply at r-forge.r-project.org Fri Jul 5 23:10:01 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 5 Jul 2013 23:10:01 +0200 (CEST) Subject: [Robast-commits] r673 - in branches/robast-0.9/pkg: RobAStRDA/R RobExtremes/inst/AddMaterial/interpolation RobExtremesBuffer Message-ID: <20130705211001.1FFE618476B@r-forge.r-project.org> Author: ruckdeschel Date: 2013-07-05 23:10:00 +0200 (Fri, 05 Jul 2013) New Revision: 673 Added: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBRE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GEV-OMSE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GEV-RMXE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GPD-MBRE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GPD-OMSE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GPD-RMXE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-MBRE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-OMSE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-RMXE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GeraldLMScripts.R branches/robast-0.9/pkg/RobExtremesBuffer/MatthiasLMScripts.R branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-MBRE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-OMSE-s.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-RMXE-s.pdf Modified: branches/robast-0.9/pkg/RobAStRDA/R/interpolAux.R branches/robast-0.9/pkg/RobAStRDA/R/sysdata.rda branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/plotInterpol.R branches/robast-0.9/pkg/RobExtremesBuffer/BernhardLMScripts.R branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBRE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GEV-OMSE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GEV-RMXE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GPD-MBRE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GPD-OMSE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/GPD-RMXE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-MBRE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-OMSE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Gamma-RMXE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/MishaLMScripts.R branches/robast-0.9/pkg/RobExtremesBuffer/PeterLMScripts.R branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-MBRE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-OMSE.pdf branches/robast-0.9/pkg/RobExtremesBuffer/Weibull-RMXE.pdf Log: RobAStRDA: finished smoothing of LMs Modified: branches/robast-0.9/pkg/RobAStRDA/R/interpolAux.R =================================================================== --- branches/robast-0.9/pkg/RobAStRDA/R/interpolAux.R 2013-07-02 13:37:23 UTC (rev 672) +++ branches/robast-0.9/pkg/RobAStRDA/R/interpolAux.R 2013-07-05 21:10:00 UTC (rev 673) @@ -50,9 +50,16 @@ for(i in 1:ncol(LMGrid)){ gmi <- gridRestrForSmooth[[i]] if(is.null(df[[i]])){ - LMGrid[gmi,i] <- smooth.spline(thGrid[gmi],LMGrid[gmi,i])$y +## LMGrid[gmi, i] <- smooth.spline(thGrid[gmi], LMGrid[gmi, +## i])$y + SmoothSpline <- smooth.spline(thGrid[gmi], LMGrid[gmi, i]) + LMGrid[, i] <- predict(SmoothSpline, thGrid)$y } else { - LMGrid[gmi,i] <- smooth.spline(thGrid[gmi],LMGrid[gmi,i],df=df[[i]])$y +## LMGrid[gmi, i] <- smooth.spline(thGrid[gmi], LMGrid[gmi, +## i], df = df[[i]])$y + SmoothSpline <- smooth.spline(thGrid[gmi], LMGrid[gmi, i], + df = df[[i]]) + LMGrid[, i] <- predict(SmoothSpline, thGrid)$y } } return(cbind(xi=thGrid,LM=LMGrid)) Modified: branches/robast-0.9/pkg/RobAStRDA/R/sysdata.rda =================================================================== (Binary files differ) Modified: branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/plotInterpol.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/plotInterpol.R 2013-07-02 13:37:23 UTC (rev 672) +++ branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation/plotInterpol.R 2013-07-05 21:10:00 UTC (rev 673) @@ -155,16 +155,16 @@ plotLM("MBRE","GE","all", type="l") plotLM("MBRE","GE","all", sm = TRUE, df = 10, gridR = -(1:15)) plotLM("MBRE","GE","all", sm = TRUE, df = 4, gridR = -(1:15)) -plotLM("OMSE","Gamma","all", plotG=-(1:8), pre=pdf("Gamma-OMSE.pdf"), post=dev.off()) -plotLM("OMSE","Gener","all", plotG=-(1:8), pre=pdf("GPD-OMSE.pdf"), post=dev.off()) -plotLM("OMSE","GEV","all", plotG=-(1:8), pre=pdf("GEV-OMSE.pdf"), post=dev.off()) -plotLM("OMSE","Wei","all", plotG=-(1:8), pre=pdf("Weibull-OMSE.pdf"), post=dev.off()) -plotLM("MBRE","Gam","all", plotG=-(1:8), pre=pdf("Gamma-MBRE.pdf"), post=dev.off()) -plotLM("MBRE","Gene","all", plotG=-(1:8), pre=pdf("GPD-MBRE.pdf"), post=dev.off()) -plotLM("MBRE","GE","all", plotG=-(1:8), pre=pdf("GEV-MBRE.pdf"), post=dev.off()) -plotLM("MBRE","Wei","all", plotG=-(1:8), pre=pdf("Weibull-MBRE.pdf"), post=dev.off()) -plotLM("RMXE","Gam","all", plotG=-(1:8), pre=pdf("Gamma-RMXE.pdf"), post=dev.off()) -plotLM("RMXE","Gene","all", plotG=-(1:8), pre=pdf("GPD-RMXE.pdf"), post=dev.off()) -plotLM("RMXE","GE","all", plotG=-(1:8), pre=pdf("GEV-RMXE.pdf"), post=dev.off()) -plotLM("RMXE","Wei","all", plotG=-(1:8), pre=pdf("Weibull-RMXE.pdf"), post=dev.off()) +plotLM("OMSE","Gamma","all", plotG=-(1:8), withS=TRUE, pre=pdf("Gamma-OMSE-s.pdf"), post=dev.off()) +plotLM("OMSE","Gener","all", plotG=-(1:8), withS=TRUE, pre=pdf("GPD-OMSE-s.pdf"), post=dev.off()) +plotLM("OMSE","GEV","all", plotG=-(1:8), withS=TRUE, pre=pdf("GEV-OMSE-s.pdf"), post=dev.off()) +plotLM("OMSE","Wei","all", plotG=-(1:8), withS=TRUE, pre=pdf("Weibull-OMSE-s.pdf"), post=dev.off()) +plotLM("MBRE","Gam","all", plotG=-(1:8), withS=TRUE, pre=pdf("Gamma-MBRE-s.pdf"), post=dev.off()) +plotLM("MBRE","Gene","all", plotG=-(1:8), withS=TRUE, pre=pdf("GPD-MBRE-s.pdf"), post=dev.off()) +plotLM("MBRE","GE","all", plotG=-(1:8), withS=TRUE, pre=pdf("GEV-MBRE-s.pdf"), post=dev.off()) +plotLM("MBRE","Wei","all", plotG=-(1:8), withS=TRUE, pre=pdf("Weibull-MBRE-s.pdf"), post=dev.off()) +plotLM("RMXE","Gam","all", plotG=-(1:8), withS=TRUE, pre=pdf("Gamma-RMXE-s.pdf"), post=dev.off()) +plotLM("RMXE","Gene","all", plotG=-(1:8),withS=TRUE, pre=pdf("GPD-RMXE-s.pdf"), post=dev.off()) +plotLM("RMXE","GE","all", plotG=-(1:8), withS=TRUE, pre=pdf("GEV-RMXE-s.pdf"), post=dev.off()) +plotLM("RMXE","Wei","all", plotG=-(1:8), withS=TRUE, pre=pdf("Weibull-RMXE-s.pdf"), post=dev.off()) } Modified: branches/robast-0.9/pkg/RobExtremesBuffer/BernhardLMScripts.R =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/BernhardLMScripts.R 2013-07-02 13:37:23 UTC (rev 672) +++ branches/robast-0.9/pkg/RobExtremesBuffer/BernhardLMScripts.R 2013-07-05 21:10:00 UTC (rev 673) @@ -31,6 +31,9 @@ # * RobRex # ## evtl naechste Zeile modifizieren +#Peter +baseDir0 <- "C:/rtest/RobASt" +#Bernhard baseDir0 <- "/home/bernhard/university/svn/r-forge/robast" interpolDir <- "branches/robast-0.9/pkg/RobExtremes/inst/AddMaterial/interpolation" interpolFile <- "plotInterpol.R" @@ -44,6 +47,7 @@ ############################################### ### WARNING: new .MakeSmoothGridList()!!! ### +#setwd(file.path(baseDir0,"branches/robast-0.9/pkg/RobExtremesBuffer")) source("MakeSmoothGridListBe.R") ############################################### @@ -136,7 +140,7 @@ ### schreiben der gegl?tteten Gitter ins rda-file, ## aber zun?chst noch woanders (myRDA1) gespeichert: -.saveGridToRda(CSVFiles2, toFileRDA = myRDA1, withMerge = TRUE, +.saveGridToRda(CSVFiles2, toFileRDA = myRDA1, withMerge = FALSE, withPrint = TRUE, withSmooth = TRUE, df = dfR2, gridRestrForSmooth=gridR2) @@ -170,7 +174,7 @@ myplot3("all", df=dfR3, gridR=gridR3, withSmooth=FALSE, pre=X11()) ### schreiben der gegl?tteten Gitter ins rda-file, ## aber zun?chst noch woanders (myRDA1) gespeichert: -.saveGridToRda(CSVFiles3, toFileRDA = myRDA1, withMerge = TRUE, +.saveGridToRda(CSVFiles3, toFileRDA = myRDA1, withMerge = FALSE, withPrint = TRUE, withSmooth = TRUE, df = dfR3, gridRestrForSmooth=gridR3) Added: branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBRE-s.pdf =================================================================== --- branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBRE-s.pdf (rev 0) +++ branches/robast-0.9/pkg/RobExtremesBuffer/GEV-MBRE-s.pdf 2013-07-05 21:10:00 UTC (rev 673) @@ -0,0 +1,341 @@ +%PDF-1.4 +%????????\r +1 0 obj +<< +/CreationDate (D:20130705225100) +/ModDate (D:20130705225100) +/Title (R Graphics Output) +/Producer (R 3.0.0) +/Creator (R) +>> +endobj +2 0 obj +<< /Type /Catalog /Pages 3 0 R >> +endobj +7 0 obj +<< /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> +endobj +8 0 obj +<< +/Length 53529 /Filter /FlateDecode +>> +stream +x???K?-???7??8?.?u?????Qn??2?.?=jPV?h?l +l??;?^k????d^]evI]1?+??yd???I???????_?????????????????W?K?u????????????o??^??W??w????h^?????*?})???W ?K???{??{?+Z??z??+??/??\??}is?K??{????k?????+?????????c????????????y~??U??????????W?_????????????/???L?????9~Y????|)?_?o???_j?9??h ?? '???5??2?)P"?)B&<7e????B?? +Y??4 k???e>?E????$K?? !7?v????bK??7??R$?J)??&?Q +??R? ??L?Y????L?nrR????W?U??? ?P??*3 +?2d???J???6>?Q?????w>hP?A?????5? +2R?t? ?2S&?r?l8?? ??j????>?CN>??m????~?i??|?Dy??????~?[{r9!9?Kf+?d???2????&??\?A6??A?@?^]?9?[t?^?)?D???%?gr?(d??Mv +g???v?2B??)?z???2?b??3 ?????:???????g??'{?.?A??\v???g?? +?5r? ?DW0Q?.?)?+t????F??>?!W?)?5R???b?*Sf*S?????k????"xc??r?%~?m??,Bk??F??(?)??t???M?D?)??}UN?????QE???dD??9_21?A??I??)p2)6?\?-e2???&??????K?j?|????&???}?^??m??P??&; 3B}(??MH????Fg??d?s??]??/]&??l$??y?VV??s at +??MN???z???/-???fu???2?*(QfR?-??A?~Uvh?????:??_?D???oL4??Q????W???Zw ?d ???1?d??|????5L6???>m?,?I????????_?IM?j?>j4 O&;d??????>*d??/???_?&r&??-.????@d????H?5 ++M ??O??&????????is~? ?0+y???W??????j??????~??v??F???? ?. ???d?$???Kz5??:??\]???-??Q?????#q?p???;?\????????&?S?0??r?7z??}M"2r????[].i-?p????d +?j?LH??^? ?[????p?tI/?/X}?+????????6??]2B?jv? +??3??,J?|?7??]P??????Q?L??^?? ?! ?}???{?*0B?>,^?F+32???J???Va?[?%m?.??/?M?t?????[?:?????????#??u?A ?????&??]?_NA[>wY!?C??XZ???@?0a?7??0Q*???q??gV??| ???????F7`?5?K???S*???? +?K?t???kBZ?eV?i??[EH?`?ri?ya?8??dJCK?dB?(Q???LQ??Uw?c?:s?.Y??c?? i??*QuN??}??S +{?K???J9??d?o????{??l?K?^??z5QEm mzY?&?X?CDf??????Id#1)??\?0????????d?l? + ????f? ?m?g???k?t??7Y?!ip?5?b?4?^{?????>??X??a?^+?.&?T+???W?X?[????}s??s???|?(BC???M?T+g?^ ???]?? F?? +L?N???$R???m,?-????)^???f?0????N?$??!f?t_??N?/'JdrP???? K??????~{-)e?{F?;??W?$?`G?"???B`U???Jcer:??JC?N?q?????[???6???x??^m?^?^%?^ +??xU&?+??$??:?A?l'^?D;?? +??*?r????@x?a?-??VR3??x??6?W?? +?Ax?-??[A?? +F&??d? ?}L?P??@??>P???T}??U??@??>P???T}??U??@??>P???T}??U?????y??7fL?t???|p{?=fO?????c?}??H?????1f??????b?????q???????????G??3?#???8?=]?;OqO?~:?]u????:h??????,???? 8b`?p???1??01??g ?l??9???cE??*Q?{?k??????=?!?3???_?XO???#??u??*????????C??-???r?z???]???\?????????????????????????;?W\?{?;?KW:!t???L??%?? ???b+>??? 5?q +DQ +u??Y?iZ?????^?f???i]??g?GKv ? +&???t?zW~eU???Uz?m??m?h5??)K?lW????RgX?F?? +B? ?<1]i???Ll=Qw?|?f????y+??V?:??6?Yk +?=?w??S??6??Nm???5"??>q??g??(6??'S? P??f??.??? ?J?????I#tD??????:?x??b? ????+5?X]????????ZK?H?t~?J?? +????]??0?=?? +6)?o??E7??, +?O??4e?g???tq]N??_?????5????`??????__?'?hLX???7??3a??x>|?J????R$??L'????B?b?????GQ?+?M??z?a#?~1??d??B??????}W??????A????4B?e?,z???????e?$?0]`?B???Vf?d???Q{?H,\?y]?q?f???e??~c?^*??+4??&/??c?.?h#?^?????&???4???c?[??SCy???`?k?/ +?k*OCy???????=?W???????9?????s?6?.,q???????????}:?j;??9;???e?+ +???a7M;a???*v=?"?lp9+\???HoF??m?????{?? ?f]Oh?@?2?^?:/Q'??Jg?????? ???)ymi,?=?pf?J?c'?#?z??C?g0(????G?jo?o???u???~??g? =?7g*???????_L|???????x~Sz??K?ms??'??F?0?b~f&y???p?R??F=a?Uzv???n?%?9?~?`?M +?????????1???!?Xf?JW?8"?????Ho,????N??F\fiX????{?^???{T???Q?y??<????C???@L???5?>??]?x2?pVy|?k?????'?<[?@???o??????v$X???a?????Z???????????????GU??s?M?a?p?<2La??sd????`???M? ??w?{`?/???Y??aU???x?|??6{???p??A?|?? +?????????E???????yD?1????C;??7? +)??0~??????Jhfz??U?O<??h??U?ox?E?????????`l/?%??=W???*~Gz???P?Dzsi??????4IQ??,???+>?]\? +????+|?????C<1?C?GFi~O??????????t ????3?O? +?4? +???? ?i??a???f{?@C> +??)????X?N]"0??XVrU??E?z??8????????z????t??TxC~??&?c??I??F?~2??[2-M? ??S?n???????,?#>]?)<1??H()?8??/z?;e*??7=?_??Yd4?574??/Ln?VT~?*t??:?d^??z?}????X?EE?w??2?f|????"-b<4??]?|?0??;*L?~??1??H????n??Q??? ???? +A?|i????)?@??_?iQ???wL?p~O7t?Zb}K?Mf??}?????d>??????G}???C?f??>?S??OU6?????4??4???G}M??F ??2uNg~??o???_H???Vz??W~ ?????0??4??.??}???????=>$luk??5???K???????Ml?a??????%?+?x?`?X?GJ??RR???9%?Wn?r???-a??????x??i?'??J,Y?? +?????>???W???O???~?7??g?/???c?IY???_?*}??????????4?zr??a??V??Y??;`?t??O???????7;Rk????????{????q?t?l?t???Gj?t?w7O_|?yz_'O?oy:????!??BM???????-???????x??O????????y?x?x????? +OW8yz/?V?????'?x?????u??'?O?^N???/???O???<]|[<]|;???l?t?'?.?N??_<]????h?t?????~O?^?xzS????????????4y????Kg???46j?? +???+?????g=?N????_?gO?????'?N?^?x????U???7??.???9???y???????'???7???O??[<=)????s?t??????????A?g?_??#????????I{?????x9y:????7???xz?'O_?[/O??????_m??????5y:?O??/O?N~?x:????KOn????68?'???V??C?c??????9yz'O?x?y??????o???=o??????????'O??????PGj??????????&Ogz?????<}?~??????O?4y:????=y?*???]??c??G ?3R?1?S~?????d??4y?E????????(?u_????????_???4??xEFo?]?W?t?????W??????7?L?WXSp????????????wW*3?S?q?5y?+????????'?? ???,?*\???? V??v? ?k? :?????K?2?3g???|????gO????Z_????ky +u??=Mx^??O?B??5?9M^:???L?? +O'?4yZ??gVx +?|????t%w??fY+A?o??r??fY? ?e +?ZM??????jV???Z?y?y???SH+?d????(??????k????????+?C??w?????????cT~F??gyb????4?$?fy??Na?7??}??,ORz???PW?N??????????|9S??QO????L>???hS?? ?Gj??G?f??L?y??????m???xS??OW|? ?'N??t???c??????1ti??)S???O?Z??[?+??T}?:P?v??????I?? ??4? %PG????a??J???9?X?2?z?I??{x???O??j?H???/?]???????H??SU??????c????+7sP??????9???g]?o:?? ??1?l?zb??u]??!}????#??uJ????????W?/??Vjk/9????p???yb:B?|?T?N?y??d&)???3??<~??{????xAVmg ????*/??? +?tB???3??v?w????&g???????}??? ??????????D????S????H??$Q??3?v???%???N;??)T4?%?W????????@? ?v???Hsi?c?x???H?~??C??2'?? +?[?#wej???n? ???S?N???0q?IR|?? ?/6???I????(~i{?????=????????i? ?4v2????\???wrd?S???N!?;?0_J??n?_???q?????cg =?Mg??????R`2=?ShHcgP????U2?C?|'R?.????5?????????4V??=D??tY:?W????J?g$?0?P_???Cov?I?h?~??+?7???g?W?/)|`g??R?s?????? ?/` ?:??4=Q?K[?Wtj?w~?^?-w??????? v???Rx???_z?f???????L'xR7???3F?y??C??\??H?w?(????????3U? v???N?? +=?3/??????<]<[<]??yzW??<]??O/?;O????????????????nw???/???K????#O_??x? Oo???]???3O????.???'O?z?x??????w+OO??????h??????#O_?{y???x?x?x??x???xz?&O_Z<}??o???=y???G{??????a??+?N??_Gy?~??s??O7}???~????Q??Q<????F?????Q??????<9?_s=?????a??<?Y?E??]???_~????B?^h?'O?E?O?E???Y??<=W?????p?t~????/?xzy???/??W?????7???x?????3???/?N??N????x??#Oo????????????????Z<}H#>?9O?????]????/n???u??$??<]???? +'O'?c??????C??7?????S<~?O?.?N??xzO????]? +|????'j?t?o???????O??&O/??5~??k??<}??^?????x;yzow???j?t~??????G??????.?N~L????OO?7 OW??yz}?????x??????/6O??Y?????????'yz?<9!~_??'?- +????????H???4?~??^?OW???T?G?^?yE???????G?i????[8y?????~?x6?Oi????#??o??U??1??3?z?2??zi]??^???_??{=~??=JJ????w]????a????=??/??o???????u?L?{XwL???T????j??o?y?>Q1M??]???????X?:I?????/DL?w??:#?>4??m +0?w?u?u?w????Gz???'??? ???S?n}?????N???wM?? ????N??]?j:R-]?u??z8?n???H%=?4???????:?5??????5????-?????j????]?q??-|??_???~ O??s??????^?]?[}?r?X????G~?????~48R?z???'??]?qE??+[??[?c??-??y?t?Y??8K???????7????K?????????y?W]?T[??n??{~????h4?Y???????t???C?T[??fy8~ }??????H?t????O???i9Ra|???k?3uz??O? =????t?q???R?????x?'oQ~??K???t?-??p,vM??@??4?t?k??^?u}??7?J?(O??????[????&j:?ui^??????R??CM??x??Y?H??T8?????I?C?#?J???4mX?q???!?p??G:????>???Q1???Xd??A?>?????3.?>? ?i???????????g}?#A?{X?3?X?T??t?2??(S?K??XS?g}s??yL??????n??) +?H?(??QlPW??BM?=???1?????S?w??f?x???X????25?&5???X??Q?ss? +|?%??8??Y?????d 1???U??y}?{h0???h?u????E?9*?X/???k????7:Rvj????c}'?A?Cw{???n?(}??A???BMG??????G???t????e??p???O? +G?????4Y;57?i:?b|38???M? +?OG?Q?'?;?;???O????0??_?a???Y????|?@"???D?"??^)j?????lH8f3?C??????4?>??`9??9?g}????6?h??;?x???3S??47?a??A???S???? ?????????9~???????=?Q??+?s??=;5???+et??{ =????OH??L????(?????5????_VllY????>6b????~kF???[??/Tj???????*??-?g-?????>??1? ?????}??mV???Ub??c9?K?r?_8??????Dw9??????F?"? ?wj>?R'????3????m|?x???g|?{z?#????? ????g?F?????????jC???C}j?h69?h ?+n?5??3?~7??zh????bz????k??e??m????8d??}b=????????t|2n???Rg????+6?N??vJ?G}l??f^???I????4?w??)>???@;m]?????????1????A??k"??m???P7n ????3~????w[K??p???/}mA{???G?s#?W?????S_;P??4?D}????L?s=??Z?s~?????=i~???'?'??E{??x?y???????s?K\c?Uz !?????X??#?S??????GQ?y????????r???????\cc?Pz??6?{F????Lw:?+=^????y?Bg??z?y??A??{?~?3?_C???"???p|??(?.?? ???7O_|??Z?Z<]Z?yi?t?m?ti??OZ<]<^<]?]<]Z<=S????l?.^????4J?,O?|b?p?OO?O?OW?????????????????/?=?'O_?(?tk?'O_?r??e_?<=H????x0I??x0?Pz??A???%?g??->.??p??_?wM~??`?t???+}??"????=??s??????????????g?(]?Z?Q?O_O???$?Z<]Z<=S???w??.???)O???xz?xu????]s? ??_??x???x??y????yz??z??r4??9?;???????x???x???????O????????O??|<=?o??/?L?^??y??????????A?<}?o???? ?????^*????e?p?/?o{?X?@??????????j??Jo???_u?O??.????y2??????????`??;x??S????>yz/w??6'O?zyz??? +P?????G?????]??4y??????????????x(?C???Pt?????C?????w?P?7?P??~(?]?????{(?C???P????????E???C???P????????E=???E??_???i?>????????????bps5.7?E?L??J???f?C???c+??qV8?~?????O??#??Zi???N??-???7_???????|??????_~????)?_???fx?w?$??????4?J#?O?s??O?B??Y!?TfR??? ?D?I5h?C? +???????? /??{up??~ ??k?S6???A??S?[?Xs??c??eU????7q?DRh8UEpCJ?P?`?????S?~;?????F?Z??;+pE?1.T??xT???s??M?? +v!??? ??P?;?????;l???v#~c?)+?? +????k?X????????????V.? x9?=?;tf]?Q1??M??M???8C?D.?2?????????pW?2!?`?U?T????X??????9C?d,q?qIk?GR??gF|?-vu?*???)#??;}??8??0F??????}??I @?ir2??s1?c?K{ns ???n???f xW???[Mz???d???'??9 +3? ?Kv$5?!9o??\2??V?t?????RFHu??G??/X???Y???mce?7??????Y??u???f?`@-???7j ????/???w??*v?v??&?W????|??I???}Y?Z????????2?????a?H??,#W????? +}Ns'otr ???????Y+?*?z2?????VT7Cr?-?T??yl+h)?????t??v?i??z?Y??\l?5?gS?KlX.??|?m???bd?(???vtI?H??lM)??X?r"?????????5?]?I??s???z???K????O???&}??&r??? + ?k?60s?WJC_'(??j????+Z +/????d???'S?'+C??7?Q??????? +$ ????&?]??d?:*?Q??XO??n,B?(?j?1X7 1??8??9W? +??~ ?%?n?w?l??9???G?Y??HL?n???i?0?G.???Hr??&,?Q-??`?g???1?J??? ?B??`????????6B??]??P?W?K? +D m??BN/?????-)1dps???^?Bx??? ???Ix?{?~ ? +o??7?J?? ???U???W??x?I}??d???Wy???W_?x5????o???L?^e??*S?.?J&?]x??^???W???*I-K3???W?^%???W)?W??G????Jb*??? ?"S^%?%^]<I??.?*)?J?*?J?*????W?[?UJ?U?V?????W _?g`??WI=?W?H?W?H??U??x??Tx?I????U?u???\?U7Kx???xU\??]?Sx?L?^?o?W?MN"R?U??l? +????o?e`? ?D?%?$????>W?2Q????;?xURx?^%??k????|u???9v?EL*??g`???Wy???*{~?Ua??W}J??j?o+f?b??|?&????????VW?WiW%^5?h-?j?iF?\NSV????}? _?$&??e/??2Y?????Fx??9/?????jd(???^%@u??=~??*?+?j ?$^???duQ<5o???*???j!O%^????xu0e??ID*?J?)?J?I??_?W???W _O"??j=yj?????H??AF +?^ +???Bx??l???aQx???)?J??T?????L?i?k?|D&^????&^??????A??L???^?r?|??"?2?????[&?Lb?\I?*r??.l?:H[+-????jBg.??1j???-??e??g?xt?U???W????????z??jfd???^????j&?^?????}???*??????x51W??C?K-`??W?$?? n$^_xU\3?vrM??D4?????&??@?????????8~}??A?O?:X7?W;Fv???";^@%^?IYx??????%^e???j ?$^Ou???m?Z?]???????W???y?'^?:Tx?X?U????C>????[???????T}=P???T}??U??@??>P???T}??U??@??>P???T}??U??@??>P?_%T???c+??9?????????A??1????G???N}??7u??>b??n??S?1n9[9??L??~???q??=2=????3?S ?{hz?aY_;5??s???.:????^#?c`?}????#??G???????nk?`7v?????1w?=??c???????z??j??1???k???!??+o?OaO9?Na?????4o?~;]?EOb????Q??w??A??? ??????????~?W?+?????????????N??dG?3??n?c????C??q????&?(??E?z?Ni0?????&?~`?V01pM????c?iz??,M??4}^b???Pz?\?Wy?O?n??N??c&?++??0??YI?M? ???$8z??0&???6??????]D???ejN$g??LrDj???????f?XGG????T?3?????????h???\?mN?N??o????gSxFx??i?v???B ~?&?? +?AW??C;q7?????ync?? ??{\'??7]?#??J???n??;?????????4_??? ?}???????????fB??F???4? ???]?Mc<?"?Q?????????U?m??>*??c?|e??O +??cT}?m=F}O?c?|f?3?S?????]w?+???r??????*?N????\???X ?????j?s1?@???n??j?K?>w??? ???????u??p`}??+??:???_???{??ar?3?fy???????;`F?z?K3??) ?J??^???S?|?0Z:?3?=???;a?%J1???j?Sw*b~=?"4?>7????f?P7???]Lw?????????*?a?G????M????????.0Tb|?Xz?F???N?z????]??rb=:??L?opx~?@?h?????*??H?~?????? ???YT>~/?? ??????????]???*??Z]W?ho??4???w?~??m~?$m????N?fv x>?r????@??z$ ??7m?}???'`x?=n?s?k????k??????788 ?S?-??M??|~??k?W???O???/?'\FBU}??+?????L{??;qb>???D?#?4m??Mka?r?V????g????O?:Rg?{?LWP5/?k????????B=????E?_??E?????t?wm??? ??W??g8??v~`? ?_???????n??4?&5?????9/??s?&???/6???^? ?????S??^?2????=s>l?????????>?>>???{8_6??~{??L??z:?^h??#????S???1>?00??G%?tc?C??????yR7????BV}??d??>?????tG??SO???+?#????tB??;Bd?uCxR???%?????A?X?B]?|??'L?s?&Y?3???y??t????????i?o??e?????a ????????+)r?[?E?g??????Mw??????}ba~?_???????? +???S?G?>??=|?????????????????!??????h?Nf8??????@W?d??y??WO??A?????????OA??????!?g?/04?????/)???sW`????i?o?~?G0?????O???z?4??_)???a??k>???}|>?`?w???????????L??'?????{????O??A?????;7\???A??S ???F8?sJh??? ???WJ/c)???Q??????+[?cW?:?"?K3 [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 673 From noreply at r-forge.r-project.org Sat Jul 6 00:32:31 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 6 Jul 2013 00:32:31 +0200 (CEST) Subject: [Robast-commits] r674 - in branches/robast-0.9/pkg: . Mail Message-ID: <20130705223231.7797118517F@r-forge.r-project.org> Author: ruckdeschel Date: 2013-07-06 00:32:31 +0200 (Sat, 06 Jul 2013) New Revision: 674 Added: branches/robast-0.9/pkg/Mail/ branches/robast-0.9/pkg/Mail/MailsAnCRAN.txt branches/robast-0.9/pkg/Mail/New versions for the RobASt-family of packages.txt Log: started with first mail templates for submission Added: branches/robast-0.9/pkg/Mail/MailsAnCRAN.txt =================================================================== --- branches/robast-0.9/pkg/Mail/MailsAnCRAN.txt (rev 0) +++ branches/robast-0.9/pkg/Mail/MailsAnCRAN.txt 2013-07-05 22:32:31 UTC (rev 674) @@ -0,0 +1,57 @@ +To: CRAN at R-project.org +Subj: CRAN submission RobAStBase 0.9 + +we just uploded a revised version (0.9) of our pkg RobAStBase. + + +================================================================================ +To: CRAN at R-project.org +Subj: CRAN submission ROptEst 0.9 + +we just uploded a revised version (0.9) of our pkg ROptEst. + + +================================================================================ +To: CRAN at R-project.org +Subj: CRAN submission RobLox 0.9 + +we just uploded a revised version (0.9) of our pkg RobLox. + + +================================================================================ +To: CRAN at R-project.org +Subj: CRAN submission RobLoxBioC 0.9 + +we just uploded a revised version (0.9) of our pkg RobLoxBioC. + + +================================================================================ +To: CRAN at R-project.org +Subj: CRAN submission RobExtremes 0.9 + +we just uploded a new pkg RobExtremes, the version of which +for consistency with the RobASt family is 0.9; + +We have read and agree with the CRAN Repository Policy as of 2013/07/10 from +http://cran.r-project.org/web/packages/policies.html + +Our licence is LGPL-3, as with the other pkgs of the RobASt family + +================================================================================ +To: CRAN at R-project.org +Subj: CRAN submission RobAStRDA 0.9 + +we just uploded a new pkg RobAStRDA, the version of which +for consistency with the RobASt family is 0.9; + +as agreed upon in the mail thread "large sysdata.rda file --- strategies?" +on r-devel, R-devel Digest, Vol 120, Issue 8, to save space in our other, +more frequently updated packages, this is a mere rda package containing +only a sysdata.rda file with interpolation grids and respective interpolating +functions and is documented accordingly. + +We have read and agree with the CRAN Repository Policy as of 2013/07/10 from +http://cran.r-project.org/web/packages/policies.html + +Our licence is LGPL-3, as with the other pkgs of the RobASt family + Added: branches/robast-0.9/pkg/Mail/New versions for the RobASt-family of packages.txt =================================================================== --- branches/robast-0.9/pkg/Mail/New versions for the RobASt-family of packages.txt (rev 0) +++ branches/robast-0.9/pkg/Mail/New versions for the RobASt-family of packages.txt 2013-07-05 22:32:31 UTC (rev 674) @@ -0,0 +1,12 @@ +######################################################################################### +# To r-packages: +######################################################################################### + +SUBJECT:: New versions for the RobASt-family of packages and of package startupmsg + +We would like to announce the availability on CRAN of new versions +of our packages in the "RobAStXXX"-family (version 0.9), +i.e.; "RobAStBase", "ROptEst", "RobLox", "RobBioC", +as well as the new packages "RobAStRDA", "RobExtremes" +[all of them require R >= 2.14.0] +----------------------------------------------------------------------------------------- From noreply at r-forge.r-project.org Sat Jul 6 18:35:17 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 6 Jul 2013 18:35:17 +0200 (CEST) Subject: [Robast-commits] r675 - branches/robast-0.9/pkg/RobAStBase/R Message-ID: <20130706163517.80A84184870@r-forge.r-project.org> Author: ruckdeschel Date: 2013-07-06 18:35:17 +0200 (Sat, 06 Jul 2013) New Revision: 675 Modified: branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R Log: RobAStBase: discovered a bug in plot-IC and infoPlot with transparency Modified: branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R =================================================================== --- branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R 2013-07-05 22:32:31 UTC (rev 674) +++ branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R 2013-07-06 16:35:17 UTC (rev 675) @@ -347,7 +347,7 @@ if(is(e1, "DiscreteDistribution")) ICy <- jitter(ICy, factor = jitter.fac0) - if(!is.na(al0)) col0 <- sapply(col0, addAlphTrsp2col,alpha=al0) + if(!is.na(al0)) col.pts <- sapply(col0, addAlphTrsp2col,alpha=al0) do.call(points, args=c(list(y1, ICy, cex = log(absy0+1)*3*cex0, col = col0, pch = pch0), dwo0)) Modified: branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R =================================================================== --- branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R 2013-07-05 22:32:31 UTC (rev 674) +++ branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R 2013-07-06 16:35:17 UTC (rev 675) @@ -339,7 +339,7 @@ f1c <- log(ICy0c+1)*3*cex0[2] if(!is.na(al0)) - col0 <- sapply(col0, addAlphTrsp2col,alpha=al0) + col.pts <- sapply(col0, addAlphTrsp2col,alpha=al0) do.pts(y0, ICy0, f1,col0[1],pch0[,1]) do.pts(y0c, ICy0c, f1c,col0[2],pch0[,2]) @@ -367,7 +367,7 @@ f1c <- log(ICy0c+1)*3*cex0[2] if(!is.na(al0)) - col0 <- sapply(col0, addAlphTrsp2col, alpha=al0[i1]) + col.pts <- sapply(col0, addAlphTrsp2col, alpha=al0[i1]) do.pts(y0, y0.vec, f1,col0[1],pch0[,1]) do.pts(y0c, y0c.vec, f1c,col0[2],pch0[,2]) From noreply at r-forge.r-project.org Mon Jul 8 22:12:57 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 8 Jul 2013 22:12:57 +0200 (CEST) Subject: [Robast-commits] r676 - in branches/robast-0.9/pkg/RobAStBase: R man Message-ID: <20130708201258.051921854E8@r-forge.r-project.org> Author: ruckdeschel Date: 2013-07-08 22:12:57 +0200 (Mon, 08 Jul 2013) New Revision: 676 Modified: branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R branches/robast-0.9/pkg/RobAStBase/R/plotRescaledAxis.R branches/robast-0.9/pkg/RobAStBase/man/infoPlot.Rd branches/robast-0.9/pkg/RobAStBase/man/internal_plots.Rd Log: can now reproduce Nataliya's nice information plot (see last example infoPlot) Modified: branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R =================================================================== --- branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R 2013-07-06 16:35:17 UTC (rev 675) +++ branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R 2013-07-08 20:12:57 UTC (rev 676) @@ -347,10 +347,10 @@ if(is(e1, "DiscreteDistribution")) ICy <- jitter(ICy, factor = jitter.fac0) - if(!is.na(al0)) col.pts <- sapply(col0, addAlphTrsp2col,alpha=al0) + col.pts <- if(!is.na(al0)) sapply(col0, addAlphTrsp2col,alpha=al0) else col0 do.call(points, args=c(list(y1, ICy, cex = log(absy0+1)*3*cex0, - col = col0, pch = pch0), dwo0)) + col = col.pts, pch = pch0), dwo0)) if(with.lab0){ text(x = y0s, y = ICy, labels = lab.pts0, cex = log(absy0+1)*1.5*cex0, col = col0) Modified: branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R =================================================================== --- branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R 2013-07-06 16:35:17 UTC (rev 675) +++ branches/robast-0.9/pkg/RobAStBase/R/infoPlot.R 2013-07-08 20:12:57 UTC (rev 676) @@ -30,13 +30,15 @@ scaleX.inv <- q(L2Fam) } - + withbox <- TRUE + if(!is.null(dots[["withbox"]])) withbox <- dots[["withbox"]] + dots["withbox"] <- NULL dots["type"] <- NULL xlab <- dots$xlab; if(is.null(xlab)) xlab <- "x" dots$xlab <- dots$ylab <- NULL trafO <- trafo(L2Fam at param) - dims <- nrow(trafO) + dimsA <- dims <- nrow(trafO) dimm <- ncol(trafO) to.draw <- 1:(dims+1) @@ -73,7 +75,7 @@ } if(is.null(legend)){ legend <- vector("list",dims0+in1to.draw) - legend <- distr:::.fillList(as.list(c("class. opt. IC", objectc)), + legend <- distr:::.fillList(list(as.list(c("class. opt. IC", objectc))), dims0+in1to.draw) } } @@ -151,7 +153,7 @@ if (is.logical(main)){ if (!main) mainL <- FALSE else - main <- gettextf("Plot for IC %%A") ### + main <- gettextf("Information Plot for IC %%A") ### ### double %% as % is special for gettextf } main <- .mpresubs(main) @@ -225,8 +227,8 @@ } - QFc <- diag(dims) - if(is(object,"ContIC") & dims>1 ) + QFc <- diag(dimsA) + if(is(object,"ContIC") & dimsA>1 ) {if (is(normtype(object),"QFNorm")) QFc <- QuadForm(normtype(object)) QFc0 <- solve( trafo %*% solve(L2Fam at FisherInfo) %*% t(trafo )) if (is(normtype(object),"SelfNorm")|is(normtype(object),"InfoNorm")) @@ -246,12 +248,12 @@ absInfoClass.f <- t(classIC) %*% QFc %*% classIC absInfoClass <- absInfoEval(x.vec, absInfoClass.f) - QF <- diag(dims) - if(is(object,"ContIC") & dims>1 ) + QF <- diag(dimsA) + if(is(object,"ContIC") & dimsA>1 ) {if (is(normtype(object),"QFNorm")) QF <- QuadForm(normtype(object))} QF.5 <- sqrt(PosSemDefSymmMatrix(QF)) - IC1 <- as(diag(dims) %*% object at Curve, "EuclRandVariable") + IC1 <- as(diag(dimsA) %*% object at Curve, "EuclRandVariable") absInfo.f <- t(IC1) %*% QF %*% IC1 absInfo <- absInfoEval(x.vec, absInfo.f) @@ -266,9 +268,25 @@ # devNew() omar <- par("mar") - parArgs <- list(mar = c(bmar,omar[2],tmar,omar[4])) - do.call(par,args=parArgs) + lpA <- max(length(to.draw),1) + parArgsL <- vector("list",lpA) + bmar <- rep(bmar, length.out=lpA) + tmar <- rep(tmar, length.out=lpA) + xaxt0 <- if(is.null(dots$xaxt)) { + if(is.null(dots$axes)||eval(dots$axes)) + rep(par("xaxt"),lpA) else rep("n",lpA) + }else rep(eval(dots$xaxt),lpA) + yaxt0 <- if(is.null(dots$yaxt)) { + if(is.null(dots$axes)||eval(dots$axes)) + rep(par("yaxt"),lpA) else rep("n",lpA) + }else rep(eval(dots$yaxt),lpA) + for( i in 1:lpA){ + parArgsL[[i]] <- list(mar = c(bmar[i],omar[2],tmar[i],omar[4]) + ,xaxt=xaxt0[i], yaxt= yaxt0[i] + ) + } + pL.rel <- pL.abs <- pL <- expression({}) if(!is.null(dots$panel.last)) @@ -309,10 +327,10 @@ scaleX, scaleX.fct, scaleX.inv, scaleY, scaleY.fct, dots$xlim, dots$ylim, dots) - x.d <- resc.dat$X - x.dC <- resc.datC$X - y.d <- resc.dat$Y - y.dC <- resc.datC$Y + x.dr <- resc.dat$X + x.dCr <- resc.datC$X + y.dr <- resc.dat$Y + y.dCr <- resc.datC$Y lab.pts <- if(is.null(lab.pts)) cbind(i.d, i.dC) @@ -338,18 +356,19 @@ f1 <- log(ICy0+1)*3*cex0[1] f1c <- log(ICy0c+1)*3*cex0[2] - if(!is.na(al0)) - col.pts <- sapply(col0, addAlphTrsp2col,alpha=al0) + col.pts <- if(!is.na(al0)) sapply(col0, + addAlphTrsp2col, alpha=al0) else col0 - do.pts(y0, ICy0, f1,col0[1],pch0[,1]) - do.pts(y0c, ICy0c, f1c,col0[2],pch0[,2]) + do.pts(y0, ICy0r, f1,col.pts[1],pch0[,1]) + do.pts(y0c, ICy0cr, f1c,col.pts[2],pch0[,2]) if(with.lab0){ - tx(y0, ICy0, lab.pts0, f1/2, col0[1]) - tx(y0c, ICy0c, lab.pts0C, f1c/2, col0[2]) + tx(y0, ICy0r, lab.pts0, f1/2, col0[1]) + tx(y0c, ICy0cr, lab.pts0C, f1c/2, col0[2]) } pL0 - }, list(ICy0 = y.d, ICy0c = y.dC, - pL0 = pL, y0 = x.d, y0c = x.dC, + }, list(ICy0c = y.dC, ICy0 = y.d, + ICy0r = y.dr, ICy0cr = y.dCr, + pL0 = pL, y0 = x.dr, y0c = x.dCr, cex0 = cex.pts, pch0 = pch.pts, al0 = alp.v[1], col0 = col.pts, with.lab0 = with.lab, n0 = n, lab.pts0 = lab.pts[i.d], lab.pts0C = lab.pts[i.dC], @@ -363,20 +382,29 @@ y0.vec <- jitter(y0.vec, factor = jitter.fac0[1]) y0c.vec <- jitter(y0c.vec, factor = jitter.fac0[2]) } - f1 <- log(ICy0+1)*3*cex0[1] - f1c <- log(ICy0c+1)*3*cex0[2] - if(!is.na(al0)) - col.pts <- sapply(col0, addAlphTrsp2col, alpha=al0[i1]) + col.pts <- if(!is.na(al0)) sapply(col0, + addAlphTrsp2col, alpha=al0[i1]) else col0 + dotsP0 <- dotsP + resc.rel <- .rescalefct(y0, cbind(y0.vec,ICy0), + scaleX, scaleX.fct, scaleX.inv, + FALSE, scaleY.fct, dots$xlim, dots$ylim, dotsP0) + resc.rel.c <- .rescalefct(y0c, cbind(y0c.vec,ICy0c), + scaleX, scaleX.fct, scaleX.inv, + FALSE, scaleY.fct, dots$xlim, dots$ylim, dotsP0) - do.pts(y0, y0.vec, f1,col0[1],pch0[,1]) - do.pts(y0c, y0c.vec, f1c,col0[2],pch0[,2]) + f1 <- resc.rel$scy*3*cex0[1] + f1c <- resc.rel.c$scy*3*cex0[2] + + do.pts(resc.rel$X, resc.rel$Y, f1,col.pts[1],pch0[,1]) + do.pts(resc.rel.c$X, resc.rel.c$Y, f1c,col.pts[2],pch0[,2]) if(with.lab0){ - tx(y0, y0.vec, lab.pts0, f1/2, col0[1]) - tx(y0c, y0c.vec, lab.pts0C, f1c/2, col0[2]) + tx(resc.rel$X, resc.rel$Y, lab.pts0, f1/2, col0[1]) + tx(resc.rel.c$X, resc.rel.c$Y, lab.pts0C, f1c/2, col0[2]) } pL0 }, list(ICy0c = y.dC, ICy0 = y.d, + ICy0r = y.dr, ICy0cr = y.dCr, pL0 = pL, y0 = x.d, y0c = x.dC, cex0 = cex.pts, pch0 = pch.pts, al0 = alp.v, col0 = col.pts, with.lab0 = with.lab,n0 = n, @@ -390,7 +418,7 @@ fac.leg <- if(dims0>1) 3/4 else .75/.8 - + dotsP$axes <- NULL if(1 %in% to.draw){ resc <-.rescalefct(x.vec, function(x) absInfoEval(x,absInfo.f), @@ -402,17 +430,23 @@ dotsP1 <- dotsP <- resc$dots dotsP$yaxt <- dots$yaxt - do.call(plot, args=c(list(resc$X, resc$Y, type = plty, + do.call(par, args = parArgsL[[1]]) + + do.call(plot, args=c(list(resc.C$X, resc.C$Y, type = plty, lty = ltyI, col = colI, lwd = lwdI, xlab = xlab, ylab = ylab.abs, panel.last = pL.abs), dotsP1)) - do.call(lines, args=c(list(resc.C$X, resc.C$Y, type = plty, + do.call(lines, args=c(list(resc$X, resc$Y, type = plty, lty = lty, lwd = lwd, col = col), dotsL)) - .plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv, - scaleY,scaleY.fct, scaleY.inv, + scaleX0 <- (xaxt0[1]!="n") + scaleY0 <- (yaxt0[1]!="n") + x.ticks0 <- if(xaxt0[1]!="n") x.ticks else NULL + y.ticks0 <- if(yaxt0[1]!="n") y.ticks[[1]] else NULL + .plotRescaledAxis(scaleX0, scaleX.fct, scaleX.inv, + scaleY0,scaleY.fct, scaleY.inv, dots$xlim, dots$ylim, resc$X, ypts = 400, - n = scaleN, x.ticks = x.ticks, - y.ticks = y.ticks[[1]]) + n = scaleN, x.ticks = x.ticks0, + y.ticks = y.ticks0, withbox = withbox) if(with.legend) legend(.legendCoord(legend.location[[1]], scaleX, scaleX.fct, scaleY, scaleY.fct), legend = legend[[1]], bg = legend.bg, @@ -426,15 +460,11 @@ } if(dims > 1 && length(to.draw[to.draw!=1])>0){ - nrows <- trunc(sqrt(dims)) - ncols <- ceiling(dims/nrows) + nrows <- trunc(sqrt(dims0)) + ncols <- ceiling(dims0/nrows) if (!withSweave||!mfColRow) - devNew() - if(mfColRow) - parArgs <- c(parArgs,list(mfrow = c(nrows, ncols))) + dN <- substitute({devNew()}) else substitute({}) - do.call(par,args=parArgs) - IC1.i.5 <- QF.5%*%IC1 classIC.i.5 <- QFc.5%*%classIC for(i in 1:dims0){ @@ -449,6 +479,12 @@ y.vec1C <- sapply(resc.C$x, classIC.i.5 at Map[[indi]])^2/ absInfoEval(resc.C$x,absInfoClass.f) + if(mfColRow){ + parArgsL[[i+in1to.draw]] <- c(parArgsL[[i+in1to.draw]],list(mfrow = c(nrows, ncols))) + eval(dN) + if(i==1) do.call(par,args=parArgsL[[i+in1to.draw]]) + }else{do.call(par,args=parArgsL[[i+in1to.draw]])} + do.call(plot, args=c(list(resc$X, y.vec1, type = plty, lty = lty, xlab = xlab, ylab = ylab.rel, col = col, lwd = lwd, panel.last = pL.rel), @@ -456,11 +492,15 @@ do.call(lines, args = c(list(resc.C$X, y.vec1C, type = plty, lty = ltyI, col = colI, lwd = lwdI), dotsL)) - .plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv, + scaleX0 <- (xaxt0[i+in1to.draw]!="n") + scaleY0 <- (yaxt0[i+in1to.draw]!="n") + x.ticks0 <- if(xaxt0[i+in1to.draw]!="n") x.ticks else NULL + y.ticks0 <- if(yaxt0[i+in1to.draw]!="n") y.ticks[[i+in1to.draw]] else NULL + .plotRescaledAxis(scaleX0, scaleX.fct, scaleX.inv, FALSE,scaleY.fct, scaleY.inv, dots$xlim, dots$ylim, resc$X, ypts = 400, n = scaleN, - x.ticks = x.ticks, - y.ticks = y.ticks[[i+in1to.draw]]) + x.ticks = x.ticks0, + y.ticks = y.ticks0, withbox = withbox) if(with.legend) legend(.legendCoord(legend.location[[i1]], scaleX, scaleX.fct, scaleY, scaleY.fct), Modified: branches/robast-0.9/pkg/RobAStBase/R/plotRescaledAxis.R =================================================================== --- branches/robast-0.9/pkg/RobAStBase/R/plotRescaledAxis.R 2013-07-06 16:35:17 UTC (rev 675) +++ branches/robast-0.9/pkg/RobAStBase/R/plotRescaledAxis.R 2013-07-08 20:12:57 UTC (rev 676) @@ -14,25 +14,29 @@ # return value: list with (thinned out) x and y, X and Y and modified dots X <- x + wI <- 1:length(x) if(scaleX){ if(!is.null(xlim)){ dots$xlim <- scaleX.fct(xlim) x <- x[x>=xlim[1] & x<=xlim[2]] } - X <- scaleX.fct(x) + Xo <- X <- scaleX.fct(x) X <- distr:::.DistrCollapse(X, 0*X)$supp + wI <- sapply(X, function(uu){ w<- which(uu==Xo); if(length(w)>0) w[1] else NA}) + wI <- wI[!is.na(wI)] x <- scaleX.inv(X) dots$axes <- NULL dots$xaxt <- "n" } - Y <- y <- fct(x) + Y <- y <- if(is.function(fct)) fct(x) else fct[wI,1] + scy <- if(is.function(fct)) NA else fct[wI,2] if(scaleY){ Y <- scaleY.fct(y) if(!is.null(ylim)) dots$ylim <- scaleY.fct(ylim) dots$axes <- NULL dots$yaxt <- "n" } - return(list(x=x,y=y,X=X,Y=Y,dots=dots)) + return(list(x=x,y=y,X=X,Y=Y,scy=scy,dots=dots)) } if(FALSE){ @@ -53,7 +57,7 @@ .plotRescaledAxis <- function(scaleX,scaleX.fct, scaleX.inv, scaleY,scaleY.fct, scaleY.inv, xlim, ylim, X, ypts = 400, n = 11, - x.ticks = NULL, y.ticks = NULL){ + x.ticks = NULL, y.ticks = NULL, withbox = TRUE){ # plots rescaled axes acc. to logicals scaleX, scaleY # to this end uses trafos scaleX.fct with inverse scale.inv # resp. scaleY.fct; it respects xlim and ylim (given in orig. scale) Modified: branches/robast-0.9/pkg/RobAStBase/man/infoPlot.Rd =================================================================== --- branches/robast-0.9/pkg/RobAStBase/man/infoPlot.Rd 2013-07-06 16:35:17 UTC (rev 675) +++ branches/robast-0.9/pkg/RobAStBase/man/infoPlot.Rd 2013-07-08 20:12:57 UTC (rev 676) @@ -46,8 +46,12 @@ \code{main} in \code{\link{plot.default}}.} \item{sub}{logical: is a sub-title to be used? or \cr just as argument \code{sub} in \code{\link{plot.default}}.} - \item{tmar}{top margin -- useful for non-standard main title sizes} - \item{bmar}{bottom margin -- useful for non-standard sub title sizes} + \item{tmar}{top margin -- useful for non-standard main title sizes; + may be a vector with individual values for + each of the panels to be plotted. } + \item{bmar}{bottom margin -- useful for non-standard sub title sizes; + may be a vector with individual values for + each of the panels to be plotted. } \item{col}{color of IC in argument \code{object}.} \item{lwd}{linewidth of IC in argument \code{object}.} \item{lty}{line-type of IC in argument \code{object}.} @@ -182,6 +186,15 @@ in panel "Abs", while the last 2*(number of plotted dimensions) are the values for \code{ylim} for the plotted dimensions of the IC, one pair for each dimension. + +Similarly, if argument \code{\dots} contains arguments \code{xaxt} or +\code{yaxt}, these may be vectorized, with one value for each of the panels +to be plotted. This is useful for stacking panels over each other, using +a common x-axis (see example below). + +The \code{\dots} argument may also contain an argument \code{withbox} which +if \code{TRUE} warrants that even if \code{xaxt} and \code{yaxt} both are +\code{FALSE}, a box is drawn around the respective panel. } %\value{} \references{ @@ -222,6 +235,19 @@ infoPlot(IC1, data=data[1:10], mfColRow = FALSE, panel.first= grid(), with.lab = TRUE, cex.pts=0.7) par(mfrow=c(1,1)) + +ICr <- makeIC(list(function(x)sign(x),function(x)sign(abs(x)-qnorm(.75))),N) +data <- r(N)(600) +data.c <- c(data, 1000*data[1:30]) +par(mfrow=c(3,1)) +infoPlot(ICr, data=data.c, tmar=c(4.1,0,0), bmar=c(0,0,4.1), + xaxt=c("n","n","s"), mfColRow = FALSE, panel.first= grid(), + cex.pts=c(.9,.9), alpha.trsp=20, lwd=2, lwdI=1.5, col=3, + col.pts=c(3,2), colI=2, pch.pts=c(20,20), inner=FALSE, + scaleX = TRUE, scaleX.fct=pnorm, scaleX.inv=qnorm, + scaleY=TRUE, scaleY.fct=function(x) pchisq(x,df=1), + scaleY.inv=function(x)qchisq(x,df=1),legend.cex = 1.0) + } } Modified: branches/robast-0.9/pkg/RobAStBase/man/internal_plots.Rd =================================================================== --- branches/robast-0.9/pkg/RobAStBase/man/internal_plots.Rd 2013-07-06 16:35:17 UTC (rev 675) +++ branches/robast-0.9/pkg/RobAStBase/man/internal_plots.Rd 2013-07-08 20:12:57 UTC (rev 676) @@ -17,7 +17,7 @@ xlim, ylim, dots) .plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv, scaleY,scaleY.fct, scaleY.inv, xlim, ylim, X, ypts = 400, n = 11, - x.ticks = NULL, y.ticks = NULL) + x.ticks = NULL, y.ticks = NULL, withbox = TRUE) .legendCoord(x, scaleX, scaleX.fct, scaleY, scaleY.fct) .SelectOrderData(data, fct, which.lbs, which.Order) } @@ -66,6 +66,10 @@ a possible thin-out by \code{which.lbs} and after ordering in descending order of the remaining observations. If this argument is \code{NULL} then no (further) observation is excluded.} + \item{withbox}{logical of length 1. If \code{TRUE}, even if \code{scaleX} and + \code{scaleY} are both \code{FALSE} and, simultaneously, \code{x.ticks} and + \code{y.ticks} are both \code{NULL}, a respective box is drawn around the + panel; otherwise no box is drawn in this case. } } \details{ \code{.rescalefct} rescales, if necessary, x and y axis for use in plot From noreply at r-forge.r-project.org Sat Jul 13 12:09:52 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 13 Jul 2013 12:09:52 +0200 (CEST) Subject: [Robast-commits] r677 - in branches/robast-0.9/pkg/RobAStBase: inst tests Message-ID: <20130713100952.C6F74180B3A@r-forge.r-project.org> Author: kroisand Date: 2013-07-13 12:09:52 +0200 (Sat, 13 Jul 2013) New Revision: 677 Added: branches/robast-0.9/pkg/RobAStBase/inst/unitTests/ branches/robast-0.9/pkg/RobAStBase/tests/doRUnit.R Log: Unit-Tests f?\195?\188r nicht-ausgef?\195?\188hrte Beispiele angefangen Added: branches/robast-0.9/pkg/RobAStBase/tests/doRUnit.R =================================================================== --- branches/robast-0.9/pkg/RobAStBase/tests/doRUnit.R (rev 0) +++ branches/robast-0.9/pkg/RobAStBase/tests/doRUnit.R 2013-07-13 10:09:52 UTC (rev 677) @@ -0,0 +1,61 @@ +## unit tests will not be done if RUnit is not available +if(require("RUnit", quietly=TRUE)) { + + ## --- Setup --- + + pkg <- "RobExtremes" + + if((Sys.getenv("RCMDCHECK") == "") + || (Sys.getenv("RCMDCHECK") == "FALSE")) { + ## Path to unit tests for standalone running under Makefile (not R CMD check) + ## PKG/tests/../inst/unitTests + path <- file.path(getwd(), "..", "inst", "unitTests") + } else { + ## Path to unit tests for R CMD check + ## PKG.Rcheck/tests/../PKG/unitTests + path <- system.file(package=pkg, "unitTests") + } + cat("\nRunning unit tests\n") + print(list(pkg=pkg, getwd=getwd(), pathToUnitTests=path)) + + library(package=pkg, character.only=TRUE) + + ## If desired, load the name space to allow testing of private functions + ## if (is.element(pkg, loadedNamespaces())) + ## attach(loadNamespace(pkg), name=paste("namespace", pkg, sep=":"), pos=3) + ## + ## or simply call PKG:::myPrivateFunction() in tests + + ## --- Testing --- + + ## Define tests + testSuite <- defineTestSuite(name=paste(pkg, "unit testing"), + dirs=path) + ## Run + tests <- runTestSuite(testSuite) + + ## Default report name + pathReport <- file.path(path, "report") + + ## Report to stdout and text files + cat("------------------- UNIT TEST SUMMARY ---------------------\n\n") + printTextProtocol(tests, showDetails=FALSE) + printTextProtocol(tests, showDetails=FALSE, + fileName=paste(pathReport, "Summary.txt", sep="")) + printTextProtocol(tests, showDetails=TRUE, + fileName=paste(pathReport, ".txt", sep="")) + + ## Report to HTML file + printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep="")) + + ## Return stop() to cause R CMD check stop in case of + ## - failures i.e. FALSE to unit tests or + ## - errors i.e. R errors + tmp <- getErrors(tests) + if(tmp$nFail > 0 | tmp$nErr > 0) { + stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, + ", #R errors: ", tmp$nErr, ")\n\n", sep="")) + } +} else { + warning("cannot run unit tests -- package RUnit is not available") +} From noreply at r-forge.r-project.org Sat Jul 13 12:17:15 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 13 Jul 2013 12:17:15 +0200 (CEST) Subject: [Robast-commits] r678 - branches/robast-0.9/pkg/RobAStBase Message-ID: <20130713101715.3952D180B3A@r-forge.r-project.org> Author: kroisand Date: 2013-07-13 12:17:14 +0200 (Sat, 13 Jul 2013) New Revision: 678 Modified: branches/robast-0.9/pkg/RobAStBase/DESCRIPTION Log: RUnit wird auch verwendet Modified: branches/robast-0.9/pkg/RobAStBase/DESCRIPTION =================================================================== --- branches/robast-0.9/pkg/RobAStBase/DESCRIPTION 2013-07-13 10:09:52 UTC (rev 677) +++ branches/robast-0.9/pkg/RobAStBase/DESCRIPTION 2013-07-13 10:17:14 UTC (rev 678) @@ -5,7 +5,7 @@ Description: Base S4-classes and functions for robust asymptotic statistics. Depends: R(>= 2.12.0), methods, rrcov, distr(>= 2.4), distrEx(>= 2.4), distrMod(>= 2.4), RandVar(>= 0.6.3) -Suggests: ROptEst +Suggests: ROptEst, RUnit (>= 0.4.26) Author: Matthias Kohl, Peter Ruckdeschel Maintainer: Matthias Kohl ByteCompile: yes From noreply at r-forge.r-project.org Wed Jul 17 09:28:20 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 17 Jul 2013 09:28:20 +0200 (CEST) Subject: [Robast-commits] r679 - branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes Message-ID: <20130717072820.D6B9F184FD6@r-forge.r-project.org> Author: pupashenko Date: 2013-07-17 09:28:20 +0200 (Wed, 17 Jul 2013) New Revision: 679 Modified: 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/cniperPointPlotWrapper.R 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/outlyingPlotWrapper.R Log: Update zu Wrappern Modified: 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 2013-07-13 10:17:14 UTC (rev 678) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R 2013-07-17 07:28:20 UTC (rev 679) @@ -5,6 +5,18 @@ ## ## ########################################## +### aditional function +merge.lists <- function(a, b){ + a.names <- names(a) + b.names <- names(b) + m.names <- sort(unique(c(a.names, b.names), fromLast = TRUE)) + sapply(m.names, function(i) { + if (is.list(a[[i]]) & is.list(b[[i]])) merge.lists(a[[i]], b[[i]]) + else if (i %in% b.names) b[[i]] + else a[[i]] + }, simplify = FALSE) +} + ##IC - influence curve ##y - dataset ## with.legend - optional legend indicator @@ -134,8 +146,6 @@ ), scaleList) } - - ##parameter for plotting if(mc$with.legend) { @@ -148,7 +158,7 @@ argsList$col.lab <- "white" } - args <- c(argsList, dots) + args <- merge.lists(argsList, dots) ### ### 3. build up the call but grab it and write it into an object ### @@ -177,38 +187,42 @@ IC <- optIC(model = fam, risk = asCov()) Y=distribution(fam) y = r(Y)(1000) +# dev.new() +# ICAllPlotWrapper(IC, with.legend = FALSE) dev.new() -ICAllPlotWrapper(IC, with.legend = FALSE) -dev.new() -ICAllPlotWrapper(IC, y, with.legend = FALSE) +ICAllPlotWrapper(IC, y, withCall = FALSE) # GEV fam = GEVFamily() IC <- optIC(model = fam, risk = asCov()) Y=distribution(fam) y = r(Y)(1000) +# dev.new() +# ICAllPlotWrapper(IC, alpha.trsp=100, with.legend = TRUE, rescale = TRUE, withCall = TRUE) dev.new() -ICAllPlotWrapper(IC, alpha.trsp=100, with.legend = TRUE, rescale = TRUE, withCall = TRUE) -dev.new() -ICAllPlotWrapper(IC, y, alpha.trsp=100, with.legend = TRUE, rescale = TRUE, withCall = TRUE) +ICAllPlotWrapper(IC, y, rescale = TRUE, withCall = FALSE) # Gamma fam = GammaFamily() +rfam = InfRobModel(fam, ContNeighborhood(0.5)) IC <- optIC(model = fam, risk = asCov()) +# ICr <- optIC(model = rfam, risk = asBias()) Y=distribution(fam) y = r(Y)(1000) +# dev.new() +# ICAllPlotWrapper(IC) +# dev.new() +# ICAllPlotWrapper(ICr) dev.new() -ICAllPlotWrapper(IC) -dev.new() -ICAllPlotWrapper(IC, y) +ICAllPlotWrapper(IC, y, withCall = FALSE) # Weibull fam = WeibullFamily() IC <- optIC(model = fam, risk = asCov()) Y=distribution(fam) y = r(Y)(1000) +# dev.new() +# ICAllPlotWrapper(IC, alpha.trsp=30, with.legend = TRUE, withCall = FALSE) dev.new() -ICAllPlotWrapper(IC, alpha.trsp=30, with.legend = TRUE, withCall = FALSE) -dev.new() -ICAllPlotWrapper(IC, y, alpha.trsp=30, with.legend = TRUE, withCall = FALSE) +ICAllPlotWrapper(IC, y, withCall = FALSE) Modified: 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.R 2013-07-13 10:17:14 UTC (rev 678) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R 2013-07-17 07:28:20 UTC (rev 679) @@ -5,6 +5,18 @@ ## ## ########################################## +### aditional function +merge.lists <- function(a, b){ + a.names <- names(a) + b.names <- names(b) + m.names <- sort(unique(c(a.names, b.names), fromLast = TRUE)) + sapply(m.names, function(i) { + if (is.list(a[[i]]) & is.list(b[[i]])) merge.lists(a[[i]], b[[i]]) + else if (i %in% b.names) b[[i]] + else a[[i]] + }, simplify = FALSE) +} + ##@fam - parameter family ## lower - left point of the x-axis ## upper - right point of the x-axis @@ -82,7 +94,7 @@ argsList$col.lab <- "white" } - args <- c(argsList, dots) + args <- merge.lists(argsList, dots) ### ### 3. build up the call but grab it and write it into an object ### @@ -107,25 +119,27 @@ require(distr) # WRite the correct path to the modified file cniperCont.R from the ROptEst package -source("D:/Dropbox/My Mathematics/Researches Misha/Current Research/11.06 - KL PhD/PhD Thesis/Reports for Project/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R") +source("D:/Dropbox/My Mathematics/Researches Misha/Current Research/11.06 - KL PhD/PhD Thesis/Reports for Project/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R") # GPD dev.new() fam = GParetoFamily() -cniperPointPlotWrapper(fam=fam, lower = 0, upper = 10, with.legend = FALSE) +cniperPointPlotWrapper(fam=fam, main = "GPD", lower = 0, upper = 10, withCall = FALSE) # GEV dev.new() fam = GEVFamily() -cniperPointPlotWrapper(fam=fam, lower = 0, upper = 5, with.legend = TRUE, withCall = TRUE) +cniperPointPlotWrapper(fam=fam, main = "GEV", lower = 0, upper = 5, withCall = FALSE) # Gamma dev.new() fam = GammaFamily() -cniperPointPlotWrapper(fam=fam, lower = 0, upper = 5) +cniperPointPlotWrapper(fam=fam, main = "Gamma", lower = 0, upper = 5, withCall = FALSE) # Weibull dev.new() fam = WeibullFamily() -cniperPointPlotWrapper(fam=fam, with.legend = TRUE, withCall = FALSE) +cniperPointPlotWrapper(fam=fam, main = "Weibull", withCall = FALSE) + + Modified: 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.R 2013-07-13 10:17:14 UTC (rev 678) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper.R 2013-07-17 07:28:20 UTC (rev 679) @@ -5,6 +5,18 @@ ## ## ########################################## +### aditional function +merge.lists <- function(a, b){ + a.names <- names(a) + b.names <- names(b) + m.names <- sort(unique(c(a.names, b.names), fromLast = TRUE)) + sapply(m.names, function(i) { + if (is.list(a[[i]]) & is.list(b[[i]])) merge.lists(a[[i]], b[[i]]) + else if (i %in% b.names) b[[i]] + else a[[i]] + }, simplify = FALSE) +} + ##IC - influence curve ##data - dataset ## with.legend - optional legend indicator @@ -109,9 +121,6 @@ ,panel.first= substitute(grid()) ,col = substitute("blue") ), scaleList) - - - ##parameter for plotting if(mc$with.legend) @@ -125,7 +134,7 @@ argsList$col.lab <- "white" } - args <- c(argsList, dots) + args <- merge.lists(argsList, dots) ### ### 3. build up the call but grab it and write it into an object ### @@ -154,10 +163,10 @@ IC <- optIC(model = fam, risk = asCov()) Y=distribution(fam) data = r(Y)(1000) +# dev.new() +# infoPlotWrapper(IC, alpha.trsp=30, with.legend = FALSE) dev.new() -infoPlotWrapper(IC, alpha.trsp=30, with.legend = FALSE) -dev.new() -infoPlotWrapper(IC, data, alpha.trsp=30, with.legend = FALSE) +infoPlotWrapper(IC, data, withCall = FALSE) # GEV @@ -165,29 +174,29 @@ IC <- optIC(model = fam, risk = asCov()) Y=distribution(fam) data = r(Y)(1000) +# dev.new() +# infoPlotWrapper(IC, alpha.trsp=100, with.legend = TRUE, rescale = TRUE, withCall = TRUE) dev.new() -infoPlotWrapper(IC, alpha.trsp=100, with.legend = TRUE, rescale = TRUE, withCall = TRUE) -dev.new() -infoPlotWrapper(IC, data, alpha.trsp=100, with.legend = TRUE, rescale = TRUE, withCall = TRUE) +infoPlotWrapper(IC, data, rescale = TRUE, withCall = FALSE) # Gamma fam = GammaFamily() IC <- optIC(model = fam, risk = asCov()) Y=distribution(fam) data = r(Y)(1000) +# dev.new() +# infoPlotWrapper(IC) dev.new() -infoPlotWrapper(IC) -dev.new() -infoPlotWrapper(IC, data) +infoPlotWrapper(IC, data, withCall = FALSE) # Weibull fam = WeibullFamily() IC <- optIC(model = fam, risk = asCov()) Y=distribution(fam) data = r(Y)(1000) +# dev.new() +# infoPlotWrapper(IC, alpha.trsp=30, with.legend = TRUE, withCall = FALSE) dev.new() -infoPlotWrapper(IC, alpha.trsp=30, with.legend = TRUE, withCall = FALSE) -dev.new() -infoPlotWrapper(IC, data, alpha.trsp=30, with.legend = TRUE, withCall = FALSE) +infoPlotWrapper(IC, data, withCall = FALSE) Modified: 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.R 2013-07-13 10:17:14 UTC (rev 678) +++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper.R 2013-07-17 07:28:20 UTC (rev 679) @@ -5,6 +5,18 @@ ## ## ########################################## +### aditional function +merge.lists <- function(a, b){ + a.names <- names(a) + b.names <- names(b) + m.names <- sort(unique(c(a.names, b.names), fromLast = TRUE)) + sapply(m.names, function(i) { + if (is.list(a[[i]]) & is.list(b[[i]])) merge.lists(a[[i]], b[[i]]) + else if (i %in% b.names) b[[i]] + else a[[i]] + }, simplify = FALSE) +} + ## projection distance qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)} QProj <- function(){new("NormType", name="Quantiles", fct=qfun)} @@ -95,7 +107,7 @@ argsList$col.lab <- "white" } - args <- c(argsList, dots) + args <- merge.lists(argsList, dots) ### ### 3. build up the call but grab it and write it into an object ### @@ -124,26 +136,25 @@ fam = GParetoFamily() X=distribution(fam) x = r(X)(1000) -outlyingPlotWrapper(x,alpha=0.99,fam=fam, alpha.trsp=50, with.legend = FALSE) +outlyingPlotWrapper(x,alpha=0.99,fam=fam, main = "GPD", withCall = FALSE) # GEV dev.new() fam = GEVFamily() X=distribution(fam) x = r(X)(1000) -outlyingPlotWrapper(x,alpha=0.95,fam=fam, with.legend = TRUE, withCall = TRUE) +outlyingPlotWrapper(x,alpha=0.95,fam=fam, main = "GEV", withCall = FALSE) # Gamma dev.new() fam = GammaFamily() X=distribution(fam) x = r(X)(1000) -outlyingPlotWrapper(x,alpha=0.95,fam=fam, alpha.trsp=70) +outlyingPlotWrapper(x,alpha=0.95,fam=fam, main = "Gamma", withCall = FALSE) # Weibull dev.new() fam = WeibullFamily() X=distribution(fam) x = r(X)(1000) -outlyingPlotWrapper(x,alpha=0.95,fam=fam, alpha.trsp=30, with.legend = TRUE, withCall = FALSE) - +outlyingPlotWrapper(x,alpha=0.95,fam=fam, main = "Weibull", withCall = FALSE) From noreply at r-forge.r-project.org Mon Jul 22 10:09:34 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 22 Jul 2013 10:09:34 +0200 (CEST) Subject: [Robast-commits] r680 - in branches/robast-0.9/pkg: . 13.07.16 - Wrapper for RobAStBase, RobExtremes Message-ID: <20130722080934.4FDBB1839D4@r-forge.r-project.org> Author: pupashenko Date: 2013-07-22 10:09:34 +0200 (Mon, 22 Jul 2013) New Revision: 680 Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/.Rhistory branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_LegendFalse.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_LegendFalse.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp30_LegendTrue.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_GEV_Lo0_Up5_LegendTrue.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_GPD_Lo0_Up10_LegendFalse.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_Gamma_Lo0_Up5.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_Weibull_LegendTrue.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper.R branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue_1.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue_2.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue_1.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue_2.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp30_LegendFalse_1.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp30_LegendFalse_2.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp30_LegendFalse_1.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp30_LegendFalse_2.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_1.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_2.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_1.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_2.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp30_LegendTrue_1.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp30_LegendTrue_2.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp30_LegendTrue_1.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp30_LegendTrue_2.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper.R branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_GEV_LegendTrue.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_GPD_Trsp50_LegendFalse.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_Gamma_Trsp70.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/plotOutlyingness_Old.R branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/rescaleFunction.R Log: New version of Wrappers. Separate function for rescaling is written. Rd comments are added. Some other improvements are also done. Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/.Rhistory =================================================================== Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R =================================================================== --- branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R (rev 0) +++ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R 2013-07-22 08:09:34 UTC (rev 680) @@ -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.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R =================================================================== --- branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R (rev 0) +++ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R 2013-07-22 08:09:34 UTC (rev 680) @@ -0,0 +1,263 @@ +########################################## +## ## +## Wrapper for AllPlot.R ## +## (plot method for IC) ## +## ## +########################################## + +### aditional function +merge.lists <- function(a, b){ + a.names <- names(a) + b.names <- names(b) + m.names <- sort(unique(c(a.names, b.names), fromLast = TRUE)) + sapply(m.names, function(i) { + if (is.list(a[[i]]) & is.list(b[[i]])) merge.lists(a[[i]], b[[i]]) + else if (i %in% b.names) b[[i]] + else a[[i]] + }, simplify = FALSE) +} + +# WRite the correct path to rescaleFunction.R file for rescaling +source("D:/Dropbox/My Mathematics/Researches Misha/Current Research/11.06 - KL PhD/PhD Thesis/Reports for Project/13.07.16 - Wrapper for RobAStBase, RobExtremes/rescaleFunction.R") + + +############################################################## +#' Wrapper function for plot method for IC +#' +#' The Wrapper takes most of arguments to the plot method +#' by default and gives a user possibility to run the +#' function with low number of arguments +#' +#' @param IC object of class \code{IC} +#' +#' @param ... additional parameters (in particular to be passed on to \code{plot}) +#' +#' @param alpha.trsp the transparency argument (0 to 100) for ploting the data +#' +#' @param with.legend the flag for showing the legend of the plot +#' +#' @param rescale the flag for rescaling the axes for better view of the plot +#' +#' @param withCall the flag for the call output +#' +#' @usage ICAllPlotWrapper(IC, y,...,alpha.trsp = 100, with.legend = TRUE, rescale = FALSE ,withCall = TRUE) +#' +#' @return Plots generated by plot method for IC are returned. If withCall = TRUE, the call of the function is returned +#' +#' @export +#' @docType function +#' @rdname ICAllPlotWrapper +#' +#' @import phylobase +#' @import vegan +#' @import igraph +#' @importFrom multtest mt.maxT +#' @importFrom multtest mt.minP +#' +#' @examples +#' # GPD +#' fam = GParetoFamily() +#' IC <- optIC(model = fam, risk = asCov()) +#' Y=distribution(fam) +#' y = r(Y)(1000) +#' ICAllPlotWrapper(IC, y, withCall = FALSE) +#' +#' # GEV +#' fam = GEVFamily() +#' IC <- optIC(model = fam, risk = asCov()) +#' Y=distribution(fam) +#' y = r(Y)(1000) +#' ICAllPlotWrapper(IC, y, rescale = TRUE, withCall = FALSE) +#' +#' # Gamma +#' fam = GammaFamily() +#' rfam = InfRobModel(fam, ContNeighborhood(0.5)) +#' IC <- optIC(model = fam, risk = asCov()) +#' Y=distribution(fam) +#' y = r(Y)(1000) +#' ICAllPlotWrapper(IC, y, withCall = FALSE) +#' +#' # Weibull +#' fam = WeibullFamily() +#' IC <- optIC(model = fam, risk = asCov()) +#' Y=distribution(fam) +#' y = r(Y)(1000) +#' ICAllPlotWrapper(IC, y, withCall = FALSE) +############################################################## + +##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, rescale = FALSE ,withCall = TRUE){ + ### + ### 1. grab the dots (and manipulate it within the wrapper function) + ### + ### + ### do something to fix the good default arguments + ### + if(missing(IC)) stop("Argument 'IC' must be given as argument to 'ICAllPlotWrapper'") + mc <- as.list(match.call(expand.dots = FALSE))[-1] + dots <- mc$"..." + if(missing(y)){ + alpha.trsp <- 100 + } else { + if(is.null(mc$alpha.trsp)){ + alpha.trsp <- 30 + if(length(y) < 1000){ + alpha.trsp <- 50 + } + if(length(y) < 100){ + alpha.trsp <- 100 + } + } + } + if(is.null(mc$with.legend)) mc$with.legend <- TRUE + if(is.null(mc$rescale)) mc$rescale <- FALSE + if(is.null(mc$withCall)) mc$withCall <- TRUE + ### + ### 2. build up the argument list for the (powerful/fullfledged) + ### graphics/diagnostics function; + ## + + ## Scaling of the axes + scaleList <- rescaleFunction(as.list(IC at CallL2Fam)[[1]], !missing(y), mc$rescale) + + if(missing(y)){ + argsList <- c(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) + ,scaleN = substitute(9) + ,mfColRow = substitute(TRUE) + ,to.draw.arg = substitute(NULL) + ,adj = substitute(0.5) + ,cex.main = substitute(1.5) + ,cex.lab = substitute(1.5) + ,cex = substitute(1.5) + ,bty = substitute("o") + ,panel.first= substitute(grid()) + ,col = substitute("blue") + ), scaleList) + }else{ + argsList <- c(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) + ,scaleN = substitute(9) + ,adj = substitute(0.5) + ,cex.main = substitute(1.5) + ,cex.lab = substitute(1.5) + ,cex = substitute(1.5) + ,bty = substitute("o") + ,panel.first= substitute(grid()) + ,col = substitute("blue") + ), scaleList) + } + + ##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 <- merge.lists(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, with.legend = FALSE) +dev.new() +ICAllPlotWrapper(IC, y, withCall = FALSE) + +# GEV +fam = GEVFamily() +IC <- optIC(model = fam, risk = asCov()) +Y=distribution(fam) +y = r(Y)(1000) +# dev.new() +# ICAllPlotWrapper(IC, alpha.trsp=100, with.legend = TRUE, rescale = TRUE, withCall = TRUE) +dev.new() +ICAllPlotWrapper(IC, y, rescale = TRUE, withCall = FALSE) + +# Gamma +fam = GammaFamily() +rfam = InfRobModel(fam, ContNeighborhood(0.5)) +IC <- optIC(model = fam, risk = asCov()) +# ICr <- optIC(model = rfam, risk = asBias()) +Y=distribution(fam) +y = r(Y)(1000) +# dev.new() +# ICAllPlotWrapper(IC) +# dev.new() +# ICAllPlotWrapper(ICr) +dev.new() +ICAllPlotWrapper(IC, y, withCall = FALSE) + +# Weibull +fam = WeibullFamily() +IC <- optIC(model = fam, risk = asCov()) +Y=distribution(fam) +y = r(Y)(1000) +# dev.new() +# ICAllPlotWrapper(IC, alpha.trsp=30, with.legend = TRUE, withCall = FALSE) +dev.new() +ICAllPlotWrapper(IC, y, withCall = FALSE) + Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_LegendFalse.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_LegendFalse.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_LegendFalse.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_LegendFalse.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp30_LegendTrue.jpeg =================================================================== (Binary files differ) Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp30_LegendTrue.jpeg ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R =================================================================== --- branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R (rev 0) +++ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R 2013-07-22 08:09:34 UTC (rev 680) @@ -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){ + R <- Risks(IC)[["trAsCov"]] + if(is.null(R)) R <- getRiskIC(IC, risk = trAsCov(), L2Fam = L2Fam) + if(length(R) > 1) R <- R$value + return(R) + } + R1 <- .getTrVar (IC1) + R2 <- .getTrVar (IC2) + + + fun <- function(x){ + y1 <- evalIC(IC1,as.matrix(x,ncol=1)) + r1 <- riskfct(var=R1,bias=r*fct(normtype(risk))(y1)) + if(!is.null(b20)) + r2 <- riskfct(var=R1,bias=b20) else{ + y2 <- sapply(x,function(x0) evalIC(IC2,x0)) + r2 <- riskfct(var=R2,bias=r*fct(normtype(risk))(y2)) + } + r1 - r2 + } + + return(fun) +} + +cniperCont <- function(IC1, IC2, data = NULL, ..., + neighbor, risk, lower=getdistrOption("DistrResolution"), + upper=1-getdistrOption("DistrResolution"), n = 101, + scaleX = FALSE, scaleX.fct, scaleX.inv, + scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm, + scaleN = 9, x.ticks = NULL, y.ticks = NULL, + cex.pts = 1, col.pts = par("col"), + pch.pts = 1, jitter.fac = 1, with.lab = FALSE, + lab.pts = NULL, lab.font = NULL, alpha.trsp = NA, + which.lbs = NULL, which.Order = NULL, + return.Order = FALSE){ + + mc <- match.call(expand.dots = FALSE) + dots <- as.list(mc$"...") + if(!is(IC1,"IC")) stop ("IC1 must be of class 'IC'") + if(!is(IC2,"IC")) stop ("IC2 must be of class 'IC'") + if(!identical(IC1 at CallL2Fam, IC2 at CallL2Fam)) + stop("IC1 and IC2 must be defined on the same model") + + L2Fam <- eval(IC1 at CallL2Fam) + + b20 <- NULL + fCpl <- eval(dots$fromCniperPlot) + if(!is.null(fCpl)) + if(fCpl) b20 <- neighbor at radius*Risks(IC2)$asBias$value + dots$fromCniperPlot <- NULL + + dots <- as.list(dots$"...") #!!!#otherwise extra parameters from cniperPointPlotWrapper appear to be in the $...$ field of dots + + fun <- .getFunCnip(IC1,IC2, risk, L2Fam, neighbor at radius, b20) + + if(missing(scaleX.fct)){ + scaleX.fct <- p(L2Fam) + scaleX.inv <- q(L2Fam) + } + + if(!is.null(as.list(mc)$lower)) lower <- p(L2Fam)(lower) + if(!is.null(as.list(mc)$upper)) upper <- p(L2Fam)(upper) + x <- q(L2Fam)(seq(lower,upper,length=n)) + if(is(distribution(L2Fam), "DiscreteDistribution")) + x <- seq(q(L2Fam)(lower),q(L2Fam)(upper),length=n) + resc <- .rescalefct(x, fun, scaleX, scaleX.fct, + scaleX.inv, scaleY, scaleY.fct, dots$xlim, dots$ylim, dots) + dots$x <- resc$X + dots$y <- resc$Y + + + dots$type <- "l" + if(is.null(dots$main)) dots$main <- gettext("Cniper region plot") + if(is.null(dots$xlab)) dots$xlab <- gettext("Dirac point") + if(is.null(dots$ylab)) + dots$ylab <- gettext("Asymptotic Risk difference (IC1 - IC2)") + + colSet <- ltySet <- lwdSet <- FALSE + if(!is.null(dots$col)) {colSet <- TRUE; colo <- eval(dots$col)} + if(colSet) { + colo <- rep(colo,length.out=2) + dots$col <- colo[1] + } + if(!is.null(dots$lwd)) {lwdSet <- TRUE; lwdo <- eval(dots$lwd)} + if(lwdSet) { + lwdo <- rep(lwdo,length.out=2) + dots$lwd <- lwdo[1] + } + if(!is.null(dots$lty)) {ltySet <- TRUE; ltyo <- eval(dots$lty)} + if(ltySet && ((!is.numeric(ltyo) && length(ltyo)==1)|| + is.numeric(ltyo))){ + ltyo <- list(ltyo,ltyo) + dots$lty <- ltyo[[1]] + }else{ if (ltySet && !is.numeric(ltyo) && length(ltyo)==2){ + dots$lty <- ltyo[[1]] + } + } + do.call(plot,dots) + + dots <- .makedotsLowLevel(dots) + dots$x <- dots$y <- NULL + if(colSet) dots$col <- colo[2] + if(lwdSet) dots$lwd <- lwdo[2] + if(ltySet) dots$lty <- ltyo[[2]] + + dots$h <- if(scaleY) scaleY.fct(0) else 0 + do.call(abline, dots) + + .plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv, scaleY,scaleY.fct, + scaleY.inv, dots$xlim, dots$ylim, resc$X, ypts = 400, + n = scaleN, x.ticks = x.ticks, y.ticks = y.ticks) + if(!is.null(data)) + return(.plotData(data, dots, mc, fun, L2Fam, IC1)) + invisible(NULL) +} + +cniperPoint <- function(L2Fam, neighbor, risk= asMSE(), + lower=getdistrOption("DistrResolution"), + upper=1-getdistrOption("DistrResolution")){ + + + mc <- match.call(expand.dots = FALSE) + + if(!is.null(as.list(mc)$lower)) lower <- p(L2Fam)(lower) + if(!is.null(as.list(mc)$upper)) upper <- p(L2Fam)(upper) + lower <- q(L2Fam)(lower) + upper <- q(L2Fam)(upper) + + robMod <- InfRobModel(center = L2Fam, neighbor = neighbor) + + psi <- optIC(model = L2Fam, risk = asCov()) + eta <- optIC(model = robMod, risk = risk) + + fun <- .getFunCnip(psi,eta, risk, L2Fam, neighbor at radius) + + res <- uniroot(fun, lower = lower, upper = upper)$root + names(res) <- "cniper point" + res +} + +cniperPointPlot <- function(L2Fam, data=NULL, ..., neighbor, risk= asMSE(), + lower=getdistrOption("DistrResolution"), + upper=1-getdistrOption("DistrResolution"), n = 101, + withMaxRisk = TRUE, + scaleX = FALSE, scaleX.fct, scaleX.inv, + scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm, + scaleN = 9, x.ticks = NULL, y.ticks = NULL, + cex.pts = 1, col.pts = par("col"), + pch.pts = 1, jitter.fac = 1, with.lab = FALSE, + lab.pts = NULL, lab.font = NULL, alpha.trsp = NA, + which.lbs = NULL, which.Order = NULL, + return.Order = FALSE){ + + mc <- as.list(match.call(expand.dots = FALSE))[-1] #!!!#otherwise the match.call works incorrectly, it takes the call of cniperPointPlotWrapper function instead +#!!!# mc <- match.call(call = sys.call(sys.parent(1)), +#!!!# expand.dots = FALSE) + mcl <- as.list(mc[-1]) + dots <- as.list(mc$"...") + + robMod <- InfRobModel(center = L2Fam, neighbor = neighbor) + + mcl$IC1 <- optIC(model = L2Fam, risk = asCov()) + mcl$IC2 <- optIC(model = robMod, risk = risk) + mcl$L2Fam <- NULL + mcl$withMaxRisk <- NULL #!!!#otherwise it passed to dots in cniperCont and recognized as a graphical parameter + if(is.null(dots$ylab)) + mcl$ylab <- gettext("Asymptotic Risk difference (classic - robust)") + if(is.null(dots$main)) + mcl$main <- gettext("Cniper point plot") + + if(withMaxRisk) mcl$fromCniperPlot <- TRUE + do.call(cniperCont, mcl) +} + + + Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R =================================================================== --- branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R (rev 0) +++ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R 2013-07-22 08:09:34 UTC (rev 680) @@ -0,0 +1,195 @@ +########################################## +## ## +## Wrapper for cniperPointPlot.R ## +## ## +## ## +########################################## + +### aditional function +merge.lists <- function(a, b){ + a.names <- names(a) + b.names <- names(b) + m.names <- sort(unique(c(a.names, b.names), fromLast = TRUE)) + sapply(m.names, function(i) { + if (is.list(a[[i]]) & is.list(b[[i]])) merge.lists(a[[i]], b[[i]]) + else if (i %in% b.names) b[[i]] + else a[[i]] + }, simplify = FALSE) +} + +############################################################## +#' Wrapper function for cniperPointPlot - Computation and Plot +#' of Cniper Contamination and Cniper Points +#' +#' The Wrapper takes most of arguments to the cniperPointPlot +#' function by default and gives a user possibility to run the +#' function with low number of arguments +#' +#' @param fam object of class L2ParamFamily +#' +#' @param ... additional parameters (in particular to be passed on to \code{plot}) +#' +#' @param lower the lower end point of the contamination interval +#' +#' @param upper the upper end point of the contamination interval +#' +#' @param with.legend the flag for showing the legend of the plot +#' +#' @param withCall the flag for the call output +#' +#' @usage cniperPointPlotWrapper(fam,...,lower = getdistrOption("DistrResolution"),upper=1-getdistrOption("DistrResolution"),with.legend = TRUE, withCall = TRUE) +#' +#' @return Plot generated by cniperPointPlot is returned. If withCall = TRUE, the call of the function is returned +#' +#' @export +#' @docType function +#' @rdname cniperPointPlotWrapper +#' +#' @import phylobase +#' @import vegan +#' @import igraph +#' @importFrom multtest mt.maxT +#' @importFrom multtest mt.minP +#' +#' @examples +#' # GPD +#' fam = GParetoFamily() +#' cniperPointPlotWrapper(fam=fam, main = "GPD", lower = 0, upper = 10, withCall = FALSE) +#' # GEV +#' fam = GEVFamily() +#' cniperPointPlotWrapper(fam=fam, main = "GEV", lower = 0, upper = 5, withCall = FALSE) +#' # Gamma +#' fam = GammaFamily() +#' cniperPointPlotWrapper(fam=fam, main = "Gamma", lower = 0, upper = 5, withCall = FALSE) +#' # Weibull +#' fam = WeibullFamily() +#' cniperPointPlotWrapper(fam=fam, main = "Weibull", withCall = FALSE) +############################################################## + +##@fam - parameter family +## lower - left point of the x-axis +## upper - right point of the x-axis +## alpha.trsp - optional transparency of the plot +## with.legend - optional legend indicator +## withCall - optional indicator of the function call +# +cniperPointPlotWrapper = function(fam,... + ,lower = getdistrOption("DistrResolution") + ,upper=1-getdistrOption("DistrResolution") + ,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$lower)) lower <- getdistrOption("DistrResolution") + if(is.null(mc$upper)) upper <- 1-getdistrOption("DistrResolution") + if(is.null(mc$with.legend)) mc$with.legend <- TRUE + if(is.null(mc$withCall)) mc$withCall <- TRUE + if(missing(fam)) stop("Argument 'fam' must be given as argument to 'cniperPointPlotWrapper'") + ### + ### 2. build up the argument list for the (powerful/fullfledged) + ### graphics/diagnostics function; + ## + + argsList <- list(L2Fam = substitute(fam) + ,data = substitute(NULL) + ,neighbor = substitute(ContNeighborhood(radius = 0.5)) + ,risk = substitute(asMSE()) + ,lower = substitute(lower) + ,upper = substitute(upper) + ,n = substitute(101) + ,withMaxRisk = substitute(TRUE) + ,scaleX = substitute(FALSE) + ,scaleX.fct = substitute(p(fam)) + ,scaleX.inv = substitute(q(fam)) + ,scaleY = substitute(FALSE) + ,scaleY.fct = substitute(pnorm) + ,scaleY.inv = substitute(qnorm) + ,scaleN = substitute(9) + ,x.ticks = substitute(NULL) + ,y.ticks = substitute(NULL) + ,cex.pts = substitute(1) + ,col.pts = substitute(par("col")) + ,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 = 0.5 + ,cex.main = substitute(1.5) + ,cex.lab = substitute(1.5) + ,main = ""#"Outlyingness Plot" + ,xlab=substitute("Dirac point") + ,ylab=substitute("Asymptotic Risk difference (classic - robust)") + ,bty = substitute("o") + ) + + ##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 <- merge.lists(argsList, dots) + ### + ### 3. build up the call but grab it and write it into an object + ### + cl <- substitute(do.call(cniperPointPlot,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) + +# WRite the correct path to the modified file cniperCont.R from the ROptEst package +source("D:/Dropbox/My Mathematics/Researches Misha/Current Research/11.06 - KL PhD/PhD Thesis/Reports for Project/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R") + +# GPD +dev.new() +fam = GParetoFamily() +cniperPointPlotWrapper(fam=fam, main = "GPD", lower = 0, upper = 10, withCall = FALSE) + +# GEV +dev.new() +fam = GEVFamily() +cniperPointPlotWrapper(fam=fam, main = "GEV", lower = 0, upper = 5, withCall = FALSE) + +# Gamma +dev.new() +fam = GammaFamily() +cniperPointPlotWrapper(fam=fam, main = "Gamma", lower = 0, upper = 5, withCall = FALSE) + +# Weibull +dev.new() +fam = WeibullFamily() +cniperPointPlotWrapper(fam=fam, main = "Weibull", withCall = FALSE) + + + [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 680 From noreply at r-forge.r-project.org Tue Jul 23 08:13:27 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 23 Jul 2013 08:13:27 +0200 (CEST) Subject: [Robast-commits] r681 - branches/robast-0.9/pkg Message-ID: <20130723061327.7D382180554@r-forge.r-project.org> Author: pupashenko Date: 2013-07-23 08:13:27 +0200 (Tue, 23 Jul 2013) New Revision: 681 Removed: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ Log: New version of Wrappers are uploaded to SVN repository in the new folder - Separate function "rescaleFunction.R" for rescaling is written. - Rd comments are added. - Some other improvements are also done. From noreply at r-forge.r-project.org Thu Jul 25 18:05:34 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 25 Jul 2013 18:05:34 +0200 (CEST) Subject: [Robast-commits] r682 - branches/robast-0.9/pkg/RobExtremes/R Message-ID: <20130725160534.14B5F18515D@r-forge.r-project.org> Author: ruckdeschel Date: 2013-07-25 18:05:33 +0200 (Thu, 25 Jul 2013) New Revision: 682 Added: branches/robast-0.9/pkg/RobExtremes/R/GEVFamilyMuUnknown.R Modified: branches/robast-0.9/pkg/RobExtremes/R/AllClass.R branches/robast-0.9/pkg/RobExtremes/R/getStartIC.R branches/robast-0.9/pkg/RobExtremes/R/internal-getpsi.R branches/robast-0.9/pkg/RobExtremes/R/move2bckRefParam.R Log: [RobExtremes] started with GEVFamilyMuUnknown Modified: branches/robast-0.9/pkg/RobExtremes/R/AllClass.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/AllClass.R 2013-07-23 06:13:27 UTC (rev 681) +++ branches/robast-0.9/pkg/RobExtremes/R/AllClass.R 2013-07-25 16:05:33 UTC (rev 682) @@ -24,6 +24,12 @@ .isEqual01 <- distr:::.isEqual01 +setClass("ParamWithLocAndScaleAndShapeFamParameter", + contains = c("ParamWithScaleFamParameter", + "ParamWithShapeFamParameter") + ) + + # parameter of Gumbel distribution setClass("GumbelParameter", representation(loc = "numeric", scale = "numeric"), @@ -244,7 +250,14 @@ setClass("GEVFamily", contains="L2ScaleShapeUnion") setClass("WeibullFamily", contains="L2ScaleShapeUnion") +## virtual in-between class for common parts in modifyModel - method +setClass("L2LocScaleShapeUnion", representation(scaleshapename ="character"), + contains = c("L2GroupParamFamily","VIRTUAL") + ) +setClass("GEVFamilyMuUnknown", contains="L2LocScaleShapeUnion") + + setClass("LDEstimate", representation(location = "numeric", dispersion = "numeric" Added: branches/robast-0.9/pkg/RobExtremes/R/GEVFamilyMuUnknown.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamilyMuUnknown.R (rev 0) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamilyMuUnknown.R 2013-07-25 16:05:33 UTC (rev 682) @@ -0,0 +1,322 @@ +################################# +## +## Class: GEVFamily for positive shape and mu unknown +## +################################ + +## methods +setMethod("validParameter",signature(object="GEVFamilyMuUnknown"), + function(object, param, tol =.Machine$double.eps){ + if (is(param, "ParamFamParameter")) + param <- main(param) + if (!all(is.finite(param))) + return(FALSE) + if (any(param[2] <= tol)) + return(FALSE) + if (any(param[3] <= tol)) + return(FALSE) + return(TRUE) + }) + + +## generating function +## loc: known/fixed threshold/location parameter +## scale: scale parameter +## shape: shape parameter +## trafo: optional parameter transformation +## start0Est: startEstimator for MLE and MDE --- if NULL HybridEstimator is used; + +GEVFamilyMuUnknown <- function(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, + ..ignoreTrafo = FALSE){ + theta <- c(loc, scale, shape) + .warningGEVShapeLarge(shape) + + of.interest <- .pretreat.of.interest(of.interest,trafo) + + ##symmetry + distrSymm <- NoSymmetry() + + ## parameters + names(theta) <- c("loc", "scale", "shape") + scaleshapename <- c("scale"="scale", "shape"="shape") + + + btq <- bDq <- btes <- bDes <- btel <- bDel <- NULL + if(!is.null(p)){ + btq <- substitute({ q <- theta[1] + theta[2]*((-log(p0))^(-theta[3])-1)/theta[3] + names(q) <- "quantile" + q + }, list(p0 = p)) + + bDq <- substitute({ loc <- theta[1]; scale <- theta[2]; shape <- theta[3] + D1 <- ((-log(p0))^(-shape)-1)/shape + D2 <- -scale/shape*(D1 + log(-log(p0))*(-log(p0))^(-shape)) + D <- t(c(1, D1, D2)) + rownames(D) <- "quantile"; colnames(D) <- NULL + D }, list(p0 = p)) + btes <- substitute({ if(theta[3]>=1L) es <- NA else { + pg <- pgamma(-log(p0),1-theta[3], lower.tail = TRUE) + es <- theta[2] * (gamma(1-theta[3]) * pg/ (1-p0) - 1 )/ + theta[3] + theta[1] } + names(es) <- "expected shortfall" + es }, list(p0 = p)) + bDes <- substitute({ if(theta[3]>=1L){ D0 <- NA, D1 <- D2 <- NA} else { + loc <- theta[1]; scale <- theta[2]; shape <- theta[3] + pg <- pgamma(-log(p0), 1-theta[3], lower.tail = TRUE) + dd <- ddigamma(-log(p0),1-theta[3]) + g0 <- gamma(1-theta[3]) + D0 <- 1 + D1 <- (g0*pg/(1-p0)-1)/theta[3] + D21 <- D1/theta[2] + D22 <- dd/(1-p0)/theta[2] + D2 <- -theta[1]*(D21+D22)} + D <- t(c(D0,D1, D2)) + rownames(D) <- "expected shortfall" + colnames(D) <- NULL + D }, list(p0 = p)) + } + if(!is.null(N)){ + btel <- substitute({ if(theta[3]>=1L) el <- NA else{ + el <- N0*(theta[1]+theta[2]*(gamma(1-theta[3])-1)/theta[3])} + names(el) <- "expected loss" + el }, list(N0 = N)) + bDel <- substitute({ if(theta[3]>=1L){ D0 <- D1 <- D2 <- NA}else{ + loc <- theta[1]; scale <- theta[2]; shape <- theta[3] + ga <- gamma(1-shape) + D0 <- 1 + D1 <- N0*(ga-1)/shape + D2 <- -N0*scale*ga*digamma(1-shape)/shape- + D1*scale/shape} + D <- t(c(D0, D1, D2)) + rownames(D) <- "expected loss" + colnames(D) <- NULL + D }, list(loc0 = loc, N0 = N)) + } + + 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) > 3) + stop("number of rows of 'trafo' > 3") +#### + param <- ParamFamParameter(name = "theta", main = c(theta[1],theta[2],theta[3]), + fixed = NULL, + trafo = trafo, withPosRestr = withPos, + .returnClsName ="ParamWithLocAndScaleAndShapeFamParameter") + + ## distribution + distribution <- GEV(loc = loc, scale = scale, shape = shape) + + ## starting parameters + startPar <- function(x,...){ + mu <- min(x) + + ## Pickand estimator + if(is.null(start0Est)){ + #source("kMedMad_Qn_Estimators.R") + 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, ...) + e0 <- if(is(e1,"Estimate")) estimate(e1) else e1 + }else stop("Argument 'start0Est' must be a function or NULL.") + if(!is.null(names(e0))) + e0 <- e0[c("scale", "shape")] + } +# print(e0); print(str(x)); print(head(summary(x))); print(mu) + if(any(x < mu-e0["scale"]/e0["shape"])) + stop("some data smaller than 'loc-scale/shape' ") + + names(e0) <- NULL + return(e0) + } + + ## what to do in case of leaving the parameter domain + makeOKPar <- function(theta) { + if(withPos){ + theta <- abs(theta) + }else{ + if(!is.null(names(theta))){ + theta["scale"] <- abs(theta["scale"]) + }else{ + theta[1] <- abs(theta[1]) + } + } + return(theta) + } + + modifyPar <- function(theta){ + theta <- makeOKPar(theta) + .warningGEVShapeLarge(theta["shape"]) + if(!is.null(names(theta))){ + loc <- theta["loc"] + sc <- theta["scale"] + sh <- theta["shape"] + }else{ + loc <- theta[1] + theta[2:3] <- abs(theta[2:3]) + sc <- theta[2] + sh <- theta[3] + } + GEV(loc = theta[1], scale = theta[2], shape = theta[3]) + } + + + ## L2-derivative of the distribution + L2deriv.fct <- function(param) { + sc <- force(main(param)[2]) + k <- force(main(param)[3]) + tr <- force(main(param)[1]) + .warningGEVShapeLarge(k) + + k1 <- k+1 + Lambda0 <- function(x) { + y <- x*0 + ind <- (x > tr-sc/k) # = [later] (x1>0) + x <- (x[ind]-tr)/sc + x1 <- 1 + k * x + t1 <- x1^(-1/k) + y[ind] <- (k1-t1)/x1/sc +# xi*(-1/xi-1)*(x[ind]-mu)/beta^2/(1+xi*(x[ind]-mu)/beta) - (x[ind]-mu)*(1+xi*(x[ind]-mu)/beta)^(-1/xi-1)/beta^2 + return(y) + } + + Lambda1 <- function(x) { + y <- x*0 + ind <- (x > tr-sc/k) # = [later] (x1>0) + x <- (x[ind]-tr)/sc + x1 <- 1 + k * x + y[ind] <- (x*(1-x1^(-1/k))-1)/x1/sc +# xi*(-1/xi-1)*(x[ind]-mu)/beta^2/(1+xi*(x[ind]-mu)/beta) - (x[ind]-mu)*(1+xi*(x[ind]-mu)/beta)^(-1/xi-1)/beta^2 + return(y) + } + Lambda2 <- function(x) { + y <- x*0 + ind <- (x > tr-sc/k) # = [later] (x1>0) + x <- (x[ind]-tr)/sc + x1 <- 1 + k * x + x2 <- x / x1 + y[ind]<- (1-x1^(-1/k))/k*(log(x1)/k-x2)-x2 +# log(1+xi*(x[ind]-mu)/beta)/xi^2+(-1/xi-1)*(x[ind]-mu)/beta/(1+xi*(x[ind]-mu)/beta) - (1+xi*(x[ind]-mu)/beta)^(-1/xi)*log(1+xi*(x[ind]-mu)/beta)/xi^2 + (1+xi*(x[ind]-mu)/beta)^(-1/xi-1)*(x[ind]-mu)/beta/xi + return(y) + } + ## additional centering of scores to increase numerical precision! + if(withCentL2){ + dist0 <- GEV(scale = sc, shape = k, loc = tr) + suppressWarnings({ + z0 <- E(dist0, fun=Lambda0) + z1 <- E(dist0, fun=Lambda1) + z2 <- E(dist0, fun=Lambda2) + }) + }else{z0 <- z1 <- z2 <- 0} + return(list(function(x){ Lambda0(x)-z0 }, + function(x){ Lambda1(x)-z1 },function(x){ Lambda2(x)-z2 })) + } + + ## Fisher Information matrix as a function of parameters + FisherInfo.fct <- function(param) { + tr <- force(main(param)[1]) + sc <- force(main(param)[2]) + k <- force(main(param)[3]) + k1 <- k+1 + .warningGEVShapeLarge(k) + G20 <- gamma(2*k) + G10 <- gamma(k) + G11 <- digamma(k)*gamma(k) + G01 <- -0.57721566490153 # digamma(1) + G02 <- 1.9781119906559 #trigamma(1)+digamma(1)^2 + x0 <- k1^2*2*k + I00 <- (2*k)*k1^2*G20/sc^2 + I01 <- (G10-k1*2*G20)*k1/sc^2 + I02 <- [k1*2 * gamma(2k)- k1* gamma(k) - gamma(k)-k * G11]*k1/k + I02 <- (2*k1*G20 -(k+2)*G10-k*G11)*k1/k/sc + I11 <- G20*x0-2*G10*k*(k+1)+1 + I11 <- I11/sc^2/k^2 + I12 <- G20*(-x0)+ G10*(k^3+4*k^2+3*k) - k -1 + I12 <- I12 + G11*(k^3+k^2) -G01*k + I12 <- I12/sc/k^3 + I22 <- G20*x0 +(k+1)^2 -G10*(x0+2*k*(k+1)) + I22 <- I22 - G11*2*k^2*(k+1) + G01*2*k*(1+k)+k^2 *G02 + I22 <- I22 /k^4 + mat <- PosSemDefSymmMatrix(matrix(c(I00,I01,I02,I01,I11,I12,I02,I12,I22),3,3)) + dimnames(mat) <- list(scaleshapename,scaleshapename) + return(mat) + } + + + + FisherInfo <- FisherInfo.fct(param) + name <- "GEV Family" + + ## initializing the GPareto family with components of L2-family + L2Fam <- new("GEVFamilyMuUnknown") + L2Fam at scaleshapename <- scaleshapename + L2Fam at name <- name + L2Fam at param <- param + L2Fam at distribution <- distribution + L2Fam at L2deriv.fct <- L2deriv.fct + L2Fam at FisherInfo.fct <- FisherInfo.fct + L2Fam at FisherInfo <- FisherInfo + L2Fam at startPar <- startPar + L2Fam at makeOKPar <- makeOKPar + L2Fam at modifyParam <- modifyPar + L2Fam at L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric()) + L2Fam at L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry()) + + L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param), + Domain = Reals())) + L2derivDistr <- NULL + if(withL2derivDistr){ + suppressWarnings(L2derivDistr <- + imageDistr(RandVar = L2deriv, distr = distribution)) + } + + 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, + p0 = p, N0 = N, + withPos0 = withPos, trafo0 = trafo)) + } + + L2Fam at LogDeriv <- function(x){ + x0 <- (x-loc)/scale + x1 <- 1 + x0 * shape + (shape+1)/scale/x1 + x1^(-1-1/shape)/scale + } + + L2Fam at L2deriv <- L2deriv + L2Fam at L2derivDistr <- L2derivDistr + L2Fam at .withMDE <- FALSE + L2Fam at .withEvalAsVar <- FALSE + L2Fam at .withEvalL2derivDistr <- FALSE + return(L2Fam) +} + +#ddigamma(t,s) is d/ds \int_0^t exp(-x) x^(s-1) dx + +ddigamma <- function(t,s){ + int <- function(x) exp(-x)*(log(x))*x^(s-1) + integrate(int, lower=0, upper=t)$value + } + \ No newline at end of file Modified: branches/robast-0.9/pkg/RobExtremes/R/getStartIC.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/getStartIC.R 2013-07-23 06:13:27 UTC (rev 681) +++ branches/robast-0.9/pkg/RobExtremes/R/getStartIC.R 2013-07-25 16:05:33 UTC (rev 682) @@ -37,3 +37,42 @@ return(do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2))) }) +setMethod("getStartIC",signature(model = "L2LocScaleShapeUnion", risk = "interpolRisk"), + function(model, risk, ...){ + + mc <- match.call(expand.dots=TRUE) + mc$risk <- if(type(risk)==".MBRE") asMSE() else asBias() + mc$neighbor <- ContNeighborhood(radius=0.5) + + gridn <- type(risk) + nam <- gsub(" ","",name(model)) + param1 <- param(model) + + scshnm <- scaleshapename(model) + shnam <- scshnm["shape"] + + nsng <- character(0) + sng <- try(getFromNamespace(gridn, ns = "RobAStRDA"), silent=TRUE) + if(!is(sng,"try-error")) nsng <- names(sng) + if(length(nsng)){ + if(nam %in% nsng){ + fctN <- .versionSuff("fun") + interpolfct <- sng[[nam]][[fctN]] + .modifyIC <- function(L2Fam, IC){ + para <- param(L2Fam) + if(!.is.na.Psi(para, interpolfct, shnam)) + return(.getPsi.wL(para, interpolfct, L2Fam, type(risk))) + else + return(do.call(getStartIC, as.list(mc[-1]), + envir=parent.frame(2))) + } + if(!.is.na.Psi(param1, interpolfct, shnam)){ + IC0 <- .getPsi.wL(param1, interpolfct, model, type(risk)) + IC0 at modifyIC <- .modifyIC + return(IC0) + } + } + } + return(do.call(getStartIC, as.list(mc[-1]), envir=parent.frame(2))) + }) + Modified: branches/robast-0.9/pkg/RobExtremes/R/internal-getpsi.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/internal-getpsi.R 2013-07-23 06:13:27 UTC (rev 681) +++ branches/robast-0.9/pkg/RobExtremes/R/internal-getpsi.R 2013-07-25 16:05:33 UTC (rev 682) @@ -55,6 +55,62 @@ return(IC) } + +.getPsi.wL <- function(param, fct, L2Fam , type){ + + scshnm <- scaleshapename(L2Fam) + shnam <- scshnm["shape"] + scnam <- scshnm["scale"] + xi <- main(param)[shnam] #[["shape"]] + beta <- main(param)[scnam] #[scaleshapename(model)["scale"]] + + #print(param) + #L2deriv <- L2Fam at L2deriv # .fct(param) + #print(get("tr",environment(get("Lambda1", environment(L2deriv[[1]]@Map[[1]]))))) + #print(get("k",environment(get("Lambda1", environment(L2deriv[[1]]@Map[[1]]))))) + #print(get("sc",environment(get("Lambda1", environment(L2deriv[[1]]@Map[[1]]))))) + + .dbeta <- diag(c(beta,beta,1)); .dbeta1 <- diag(c(1/beta,1/beta,1)) + b <- fct[[1]](xi) + a <- c(.dbeta%*%c(fct[[2]](xi),fct[[3]](xi),fct[[4]](xi))) + aw <- c(.dbeta1%*%c(fct[[5]](xi),fct[[6]](xi),fct[[7]](xi))) + am1 <- mean(c(fct[[9]](xi),fct[[11]](xi))) + am2 <- mean(c(fct[[10]](xi),fct[[14]](xi))) + am3 <- mean(c(fct[[13]](xi),fct[[15]](xi))) + A <- .dbeta%*%matrix(c(fct[[8]](xi),am1,am2,am1,fct[[12]](xi),am3,am2,am3,fct[[16]](xi)),3,3)%*%.dbeta + am1 <- mean(c(fct[[18]](xi),fct[[20]](xi))) + am2 <- mean(c(fct[[19]](xi),fct[[23]](xi))) + am3 <- mean(c(fct[[22]](xi),fct[[24]](xi))) + Aw <- matrix(c(fct[[17]](xi),am1,am2,am1,fct[[21]](xi),am3,am2,am3,fct[[25]](xi)),3,3)%*%.dbeta + + normt <- NormType() + biast <- symmetricBias() + nb <- ContNeighborhood(radius=0.5) + ICT <- paste("optimally robust IC for", switch(type, + ".OMSE"="maxMSE",".RMXE"="RMX", ".MBRE"="maxBias")) + riskT <- if(type!=".MBRE") "asGRisk" else "asBias" + + w <- new("HampelWeight") + stand(w) <- Aw + cent(w) <- aw + clip(w) <- b + + if(type!=".MBRE"){ + weight(w) <- getweight(w, neighbor = nb, biastype = biast, + normW = normt) + }else weight(w) <- minbiasweight(w, neighbor = nb, biastype = biast, + normW = normt) + + res <- list(a = a, A = A, b = b, d = 0*a, + normtype = normt, biastype = biast, w = w, + info = c("optIC", ICT), risk = list(), + modifyIC = NULL) + + + IC <- generateIC(nb, L2Fam, res) + return(IC) +} + if(FALSE){ res <- list(a = a, A = A, b = b, d = 0*a, w = w) Modified: branches/robast-0.9/pkg/RobExtremes/R/move2bckRefParam.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/move2bckRefParam.R 2013-07-23 06:13:27 UTC (rev 681) +++ branches/robast-0.9/pkg/RobExtremes/R/move2bckRefParam.R 2013-07-25 16:05:33 UTC (rev 682) @@ -25,4 +25,19 @@ CallL2Fam(IC) <- L2call return(IC)}) +setMethod("moveICBackFromRefParam", signature(IC = "IC", + L2Fam = "L2LocScaleShapeUnion"), function(IC, L2Fam, ...){ + param <- param(L2Fam) + L2call <- L2Fam at fam.call + param <- param(L2Fam) + loc <- main(param)[1] + scale <- main(param)[2] + IC.cf0 <- IC at Curve[[1]]@Map[[1]] + IC at Curve[[1]]@Map[[1]] <- function(x) scale*IC.cf0((x-loc)/scale) + IC.cf1 <- IC at Curve[[1]]@Map[[2]] + IC at Curve[[1]]@Map[[2]] <- function(x) scale*IC.cf1((x-loc)/scale) + IC.cf2 <- IC at Curve[[1]]@Map[[3]] + IC at Curve[[1]]@Map[[3]] <- function(x) IC.cf2((x-loc)/scale) + CallL2Fam(IC) <- L2call + return(IC)}) From noreply at r-forge.r-project.org Fri Jul 26 13:35:35 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 26 Jul 2013 13:35:35 +0200 (CEST) Subject: [Robast-commits] r683 - branches/robast-0.9/pkg/RobExtremes/R Message-ID: <20130726113535.E9BC81850D1@r-forge.r-project.org> Author: ruckdeschel Date: 2013-07-26 13:35:35 +0200 (Fri, 26 Jul 2013) New Revision: 683 Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R branches/robast-0.9/pkg/RobExtremes/R/GEVFamilyMuUnknown.R branches/robast-0.9/pkg/RobExtremes/R/GParetoFamily.R Log: [RobExtremes] added warning for ES, EL in case GPD, GEV, GEV-muUnknown for xi>=1 Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-07-25 16:05:33 UTC (rev 682) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamily.R 2013-07-26 11:35:35 UTC (rev 683) @@ -173,7 +173,10 @@ D <- t(c(D1, D2)) rownames(D) <- "quantile"; colnames(D) <- NULL D }, list(p0 = p)) - btes <- substitute({ if(theta[2]>=1L) es <- NA else { + btes <- substitute({ if(theta[2]>=1L){ + warning("Expected value is infinite for shape > 1") + es <- NA + }else{ pg <- pgamma(-log(p0),1-theta[2], lower.tail = TRUE) es <- theta[1] * (gamma(1-theta[2]) * pg/ (1-p0) - 1 )/ theta[2] + loc0 } @@ -194,7 +197,10 @@ D }, list(loc0 = loc, p0 = p)) } if(!is.null(N)){ - btel <- substitute({ if(theta[2]>=1L) el <- NA else{ + btel <- substitute({ if(theta[2]>=1L){ + warning("Expected value is infinite for shape > 1") + el <- NA + }else{ el <- N0*(loc0+theta[1]*(gamma(1-theta[2])-1)/theta[2])} names(el) <- "expected loss" el }, list(loc0 = loc,N0 = N)) Modified: branches/robast-0.9/pkg/RobExtremes/R/GEVFamilyMuUnknown.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GEVFamilyMuUnknown.R 2013-07-25 16:05:33 UTC (rev 682) +++ branches/robast-0.9/pkg/RobExtremes/R/GEVFamilyMuUnknown.R 2013-07-26 11:35:35 UTC (rev 683) @@ -59,7 +59,10 @@ D <- t(c(1, D1, D2)) rownames(D) <- "quantile"; colnames(D) <- NULL D }, list(p0 = p)) - btes <- substitute({ if(theta[3]>=1L) es <- NA else { + btes <- substitute({ if(theta[3]>=1L){ + warning("Expected value is infinite for shape > 1") + es <- NA + }else{ pg <- pgamma(-log(p0),1-theta[3], lower.tail = TRUE) es <- theta[2] * (gamma(1-theta[3]) * pg/ (1-p0) - 1 )/ theta[3] + theta[1] } @@ -81,7 +84,10 @@ D }, list(p0 = p)) } if(!is.null(N)){ - btel <- substitute({ if(theta[3]>=1L) el <- NA else{ + btel <- substitute({ if(theta[3]>=1L){ + warning("Expected value is infinite for shape > 1") + el <- NA + }else{ el <- N0*(theta[1]+theta[2]*(gamma(1-theta[3])-1)/theta[3])} names(el) <- "expected loss" el }, list(N0 = N)) Modified: branches/robast-0.9/pkg/RobExtremes/R/GParetoFamily.R =================================================================== --- branches/robast-0.9/pkg/RobExtremes/R/GParetoFamily.R 2013-07-25 16:05:33 UTC (rev 682) +++ branches/robast-0.9/pkg/RobExtremes/R/GParetoFamily.R 2013-07-26 11:35:35 UTC (rev 683) @@ -67,7 +67,10 @@ D <- t(c(D1, D2)) rownames(D) <- "quantile"; colnames(D) <- NULL D }, list(p0 = p)) - btes <- substitute({ if(theta[2]>=1L) es <- NA else { + btes <- substitute({ if(theta[2]>=1L){ + warning("Expected value is infinite for shape > 1") + es <- NA + }else{ q <- loc0 + theta[1]*((1-p0)^(-theta[2])-1)/theta[2] es <- (q + theta[1] - theta[2]*loc0)/(1-theta[2])} names(es) <- "expected shortfall" @@ -86,7 +89,10 @@ D }, list(loc0 = loc, p0 = p)) } if(!is.null(N)){ - btel <- substitute({ if(theta[2]>=1L) el <- NA else { + btel <- substitute({ if(theta[2]>=1L){ + warning("Expected value is infinite for shape > 1") + el <- NA + }else{ el <- N0*(loc0 + theta[1]/(1-theta[2]))} names(el) <- "expected loss" el }, list(loc0 = loc,N0 = N))