[Robast-commits] r693 - in pkg/RobAStBase: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 11 16:31:28 CEST 2013
Author: ruckdeschel
Date: 2013-09-11 16:31:27 +0200 (Wed, 11 Sep 2013)
New Revision: 693
Added:
pkg/RobAStBase/R/getRiskBV.R
pkg/RobAStBase/R/interpolRisks.R
pkg/RobAStBase/R/makedots.R
pkg/RobAStBase/R/move2bckRefParam.R
pkg/RobAStBase/R/plotRescaledAxis.R
pkg/RobAStBase/R/plotWrapper.R
pkg/RobAStBase/R/rescaleFct.R
pkg/RobAStBase/R/selectorder.R
Modified:
pkg/RobAStBase/R/ddPlot.R
pkg/RobAStBase/R/outlyingPlot.R
pkg/RobAStBase/man/0RobAStBase-package.Rd
Log:
next try: RobAStBase in trunc
Modified: pkg/RobAStBase/R/ddPlot.R
===================================================================
--- pkg/RobAStBase/R/ddPlot.R 2013-09-11 14:21:01 UTC (rev 692)
+++ pkg/RobAStBase/R/ddPlot.R 2013-09-11 14:31:27 UTC (rev 693)
@@ -8,14 +8,15 @@
text.abline.x = NULL, text.abline.y = NULL,
cex.abline = par("cex"), col.abline = col.cutoff,
font.abline = par("font"), adj.abline = c(0,0),
- text.abline.x.x = NULL, text.abline.x.y = NULL,
+ text.abline.x.x = NULL, text.abline.x.y = NULL,
text.abline.y.x = NULL, text.abline.y.y = NULL,
text.abline.x.fmt.cx = "%7.2f", text.abline.x.fmt.qx = "%4.2f%%",
- text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%"){
+ text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%",
+ jitt.fac){
mc <- as.list(match.call(expand.dots = TRUE,
call = sys.call(sys.parent(1)))[-1])
mc$data <- data
- do.call(.ddPlot.MatNtNtCoCo, args = mc)
+ do.call(RobAStBase:::.ddPlot.MatNtNtCoCo, args = mc)
})
setMethod("ddPlot", signature = signature(data = "data.frame"),
@@ -28,10 +29,11 @@
text.abline.x = NULL, text.abline.y = NULL,
cex.abline = par("cex"), col.abline = col.cutoff,
font.abline = par("font"), adj.abline = c(0,0),
- text.abline.x.x = NULL, text.abline.x.y = NULL,
+ text.abline.x.x = NULL, text.abline.x.y = NULL,
text.abline.y.x = NULL, text.abline.y.y = NULL,
text.abline.x.fmt.cx = "%7.2f", text.abline.x.fmt.qx = "%4.2f%%",
- text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%"){
+ text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%",
+ jitt.fac){
mc <- match.call(call = sys.call(sys.parent(1)))
mc$data <- t(as.matrix(data))
@@ -44,14 +46,16 @@
cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
transform.x, transform.y = transform.x,
id.n, lab.pts, adj, cex.idn,
- col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
+ col.idn, lty.cutoff, lwd.cutoff, col.cutoff,
+ text.abline = TRUE,
text.abline.x = NULL, text.abline.y = NULL,
cex.abline = par("cex"), col.abline = col.cutoff,
font.abline = par("font"), adj.abline = c(0,0),
- text.abline.x.x = NULL, text.abline.x.y = NULL,
+ text.abline.x.x = NULL, text.abline.x.y = NULL,
text.abline.y.x = NULL, text.abline.y.y = NULL,
text.abline.x.fmt.cx = "%7.2f", text.abline.x.fmt.qx = "%4.2f%%",
- text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%"){
+ text.abline.y.fmt.cy = "%7.2f", text.abline.y.fmt.qy = "%4.2f%%",
+ jitt.fac){
mc <- match.call(call = sys.call(sys.parent(1)))
mc$data <- matrix(data,nrow=1)
Added: pkg/RobAStBase/R/getRiskBV.R
===================================================================
--- pkg/RobAStBase/R/getRiskBV.R (rev 0)
+++ pkg/RobAStBase/R/getRiskBV.R 2013-09-11 14:31:27 UTC (rev 693)
@@ -0,0 +1,24 @@
+setMethod("getRiskFctBV", signature(risk = "asGRisk", biastype = "ANY"),
+ function(risk) function(bias, var)stop("not yet implemented"))
+
+setMethod("getRiskFctBV", signature(risk = "asMSE", biastype = "ANY"),
+ function(risk) function(bias, var) bias^2+var)
+
+setMethod("getRiskFctBV", signature(risk = "asSemivar", biastype = "onesidedBias"),
+ function(risk, biastype=biastype(risk))
+ function(bias,var){
+ v <- var^.5
+ b <- if(sign(biastype)>0) bias else -bias
+ w <- b/v
+ return((v^2+b^2)*pnorm(w)-b*v*dnorm(w))})
+
+setMethod("getRiskFctBV", signature(risk = "asSemivar", biastype = "asymmetricBias"),
+ function(risk, biastype=biastype(risk)){
+ nu1 <- nu(biastype)[1]
+ nu2 <- nu(biastype)[2]
+ function(bias,var){
+ v <- var^.5
+ b <- if(sign(biastype)>0) bias else -bias
+ w <- b/v
+ return((v^2+b^2)*(nu1*pnorm(w)+nu2*pnorm(-w))+(nu2-nu1)*b*v*dnorm(w))}})
+
Added: pkg/RobAStBase/R/interpolRisks.R
===================================================================
--- pkg/RobAStBase/R/interpolRisks.R (rev 0)
+++ pkg/RobAStBase/R/interpolRisks.R 2013-09-11 14:31:27 UTC (rev 693)
@@ -0,0 +1,7 @@
+#### Generating functions for subclasses of interpolRisk
+OMSRRisk <- function(samplesize = 100) new("OMSRRisk",type=".OMSE", samplesize = samplesize)
+MBRRisk <- function(samplesize = 100) new("MBRRisk",type=".MBRE", samplesize = samplesize)
+RMXRRisk <- function(samplesize = 100) new("RMXRRisk",type=".RMXE", samplesize = samplesize)
+setMethod("samplesize","interpolRisk", function(object)object at samplesize)
+setReplaceMethod("samplesize","interpolRisk", function(object, value){
+ object at samplesize <- value; object})
\ No newline at end of file
Added: pkg/RobAStBase/R/makedots.R
===================================================================
--- pkg/RobAStBase/R/makedots.R (rev 0)
+++ pkg/RobAStBase/R/makedots.R 2013-09-11 14:31:27 UTC (rev 693)
@@ -0,0 +1,42 @@
+## dots modifications
+.makedotsLowLevel <- function(dots){
+ dots$sub <- dots$xlab <- dots$ylab <- dots$main <- dots$type <- NULL
+ dots$xlim <- dots$ylim <- dots$yaxt <- dots$axes <- dots$xaxt <- NULL
+ dots$panel.last <- dots$panel.first <- dots$frame.plot <- dots$ann <-NULL
+ dots$log <- dots$asp <- NULL
+ return(dots)
+}
+.deleteDotsABLINE <- function(dots){
+ dots$reg <- dots$a <- dots$b <- NULL
+ dots$untf <- dots$h <- dots$v <- NULL
+ dots
+}
+.deleteDotsTEXT <- function(dots){
+ dots$labels <- dots$offset <- dots$vfont <- dots$pos <- dots$font <- NULL
+ dots
+}
+.makedotsL <- function(dots){
+ dots <- .makedotsLowLevel(dots)
+ dots$pch <- dots$cex <- NULL
+ .deleteDotsABLINE(.deleteDotsTEXT(dots))
+}
+.makedotsP <- function(dots){
+ dots <- .makedotsLowLevel(dots)
+ dots$lwd <- NULL
+ .deleteDotsABLINE(.deleteDotsTEXT(dots))
+}
+.makedotsPt <- function(dots){
+ dots <- dots[names(dots) %in% c("bg", "lwd", "lty")]
+ if (length(dots) == 0 ) dots <- NULL
+ return(dots)
+}
+.makedotsAB <- function(dots){
+ dots <- .makedotsLowLevel(dots)
+ dots <- .deleteDotsTEXT(dots)
+ dots$pch <- dots$cex <- NULL
+}
+.makedotsT <- function(dots){
+ dots <- .makedotsLowLevel(dots)
+ dots <- .deleteDotsABLINE(dots)
+ dots
+}
Added: pkg/RobAStBase/R/move2bckRefParam.R
===================================================================
--- pkg/RobAStBase/R/move2bckRefParam.R (rev 0)
+++ pkg/RobAStBase/R/move2bckRefParam.R 2013-09-11 14:31:27 UTC (rev 693)
@@ -0,0 +1,114 @@
+setMethod("moveL2Fam2RefParam", signature(L2Fam = "L2ParamFamily"),
+ function(L2Fam, ...) L2Fam)
+
+setMethod("moveL2Fam2RefParam", signature(L2Fam = "L2LocationFamily"),
+ function(L2Fam, ...){ param <- param(L2Fam)
+ par0 <- 0; names(par0) <- L2Fam at locscalename
+ main(param) <- par0
+ modifyModel(L2Fam, param)})
+
+setMethod("moveL2Fam2RefParam", signature(L2Fam = "L2ScaleFamily"),
+ function(L2Fam, ...){ param <- param(L2Fam)
+ locscalename <- L2Fam at locscalename
+ param0 <- 1
+ names(param0) <- locscalename["scale"]
+ param1 <- 0
+ names(param1) <- locscalename["loc"]
+ main(param) <- param0
+ fixed(param) <- param1
+ modifyModel(L2Fam, param)})
+
+setMethod("moveL2Fam2RefParam", signature(L2Fam = "L2LocationScaleFamily"),
+ function(L2Fam, ...){
+ param <- param(L2Fam)
+ lcsname <- L2Fam at locscalename
+ lc <- lcsname["loc"]; sc <- lcsname["scale"]
+ nms.main <- names(main(param))
+ w <- which(length(lc%in% nms.main))
+ if(length(w)){
+ mp <- main(param); mp[lc] <- 0; main(param) <- mp }
+ w <- which(length(sc%in% nms.main))
+ if(length(w)){
+ mp <- main(param); mp[sc] <- 0; main(param) <- mp }
+ nms.nuis <- names(nuisance(param))
+ w <- which(length(lc%in% nms.nuis))
+ if(length(w)){
+ mp <- nuisance(param); mp[lc] <- 0; nuisance(param) <- mp }
+ w <- which(length(sc%in% nms.nuis))
+ if(length(w)){
+ mp <- nuisance(param); mp[sc] <- 0; nuisance(param) <- mp }
+ nms.fixed <- names(fixed(param))
+ w <- which(length(lc%in% nms.fixed))
+ if(length(w)){
+ mp <- fixed(param); mp[lc] <- 0; fixed(param) <- mp }
+ w <- which(length(sc%in% nms.fixed))
+ if(length(w)){
+ mp <- fixed(param); mp[sc] <- 0; fixed(param) <- mp }
+ modifyModel(L2Fam, param)})
+
+
+################################################################################
+
+### remains to be done: Risk trafo !!!
+
+setMethod("moveICBackFromRefParam", signature(IC = "IC", L2Fam = "L2ParamFamily"),
+ function(IC, L2Fam,...) IC)
+
+
+setMethod("moveICBackFromRefParam", signature(IC = "IC",
+ L2Fam = "L2LocationFamily"), function(IC, L2Fam, ...){
+ L2call <- L2Fam at fam.call
+ param <- param(L2Fam)
+ mu <- main(param)
+ IC.cf <- IC at Curve[[1]]@Map[[1]]
+ IC at Curve[[1]]@Map[[1]] <- function(x) IC.cf(x-mu)
+ CallL2Fam(IC) <- L2call
+ return(IC)})
+
+setMethod("moveICBackFromRefParam", signature(IC = "IC",
+ L2Fam = "L2ScaleFamily"), function(IC, L2Fam, ...){
+ L2call <- L2Fam at fam.call
+ param <- param(L2Fam)
+ mu <- fixed(param)
+ sig <- main(param)
+ IC.cf <- IC at Curve[[1]]@Map[[1]]
+ IC at Curve[[1]]@Map[[1]] <- function(x) sig*IC.cf((x-mu)/sig)
+ CallL2Fam(IC) <- L2call
+ return(IC)})
+
+setMethod("moveICBackFromRefParam", signature(IC = "IC",
+ L2Fam = "L2LocationScaleFamily"), function(IC, L2Fam, ...){
+ L2call <- L2Fam at fam.call
+ param <- param(L2Fam)
+ lcsname <- L2Fam at locscalename
+ lc <- lcsname["loc"]; sc <- lcsname["scale"]
+ nms.main <- names(main(param))
+ w <- which(length(lc%in% nms.main))
+ if(length(w)) mu<- main(param)[lc]
+ w <- which(length(sc%in% nms.main))
+ if(length(w)) sig <- main(param)[sc]
+ nms.nuis <- names(nuisance(param))
+ w <- which(length(lc%in% nms.nuis))
+ if(length(w)) mu<- nuisance(param)[lc]
+ w <- which(length(sc%in% nms.nuis))
+ if(length(w)) sig<- nuisance(param)[sc]
+ nms.fixed <- names(fixed(param))
+ w <- which(length(lc%in% nms.fixed))
+ if(length(w)) mu<- fixed(param)[lc]
+ w <- which(length(sc%in% nms.fixed))
+ if(length(w)) sig<- fixed(param)[sc]
+ IC.cf1 <- IC at Curve[[1]]@Map[[1]]
+ IC at Curve[[1]]@Map[[1]] <- function(x) sig*IC.cf1((x-mu)/sig)
+ if(length(IC at Curve[[1]]@Map)==2){
+ IC.cf2 <- IC at Curve[[1]]@Map[[2]]
+ IC at Curve[[1]]@Map[[2]] <- function(x) sig*IC.cf2((x-mu)/sig)
+ }
+ CallL2Fam(IC) <- L2call
+ return(IC)})
+
+setMethod("moveICBackFromRefParam", signature(IC = "HampIC",
+ L2Fam = "L2ParamFamily"), function(IC, L2Fam, ...){
+ IC <- moveICBackFromRefParam(as(IC,"IC"), L2Fam,...)
+ IC at modifyIC(L2Fam, IC)
+ return(IC)})
+
Modified: pkg/RobAStBase/R/outlyingPlot.R
===================================================================
--- pkg/RobAStBase/R/outlyingPlot.R 2013-09-11 14:21:01 UTC (rev 692)
+++ pkg/RobAStBase/R/outlyingPlot.R 2013-09-11 14:31:27 UTC (rev 693)
@@ -1,11 +1,28 @@
-outlyingPlotIC <- function(data, IC.x, IC.y = IC.x, dist.x = NormType(),
- dist.y, cutoff.y = cutoff.chisq(), cutoff.x = cutoff.sememp(), ...,
- cutoff.quantile.x = 0.95,
- cutoff.quantile.y = cutoff.quantile.x,
- id.n, lab.pts, adj, cex.idn,
- col.idn, lty.cutoff, lwd.cutoff, col.cutoff,
- main = gettext("Outlyingness by means of a distance-distance plot")
- ){
+outlyingPlotIC <- function(data,
+ IC.x,
+ IC.y = IC.x,
+ dist.x = NormType(),
+ dist.y,
+ cutoff.y = cutoff.chisq(),
+ cutoff.x = cutoff.sememp(),
+ ...,
+ cutoff.quantile.x = 0.95,
+ cutoff.quantile.y = cutoff.quantile.x,
+ id.n,
+ lab.pts,
+ adj,
+ cex.idn,
+ col.idn,
+ lty.cutoff,
+ lwd.cutoff,
+ col.cutoff,
+ robCov.x = TRUE,
+ robCov.y = TRUE,
+ tf.x = data,
+ tf.y = data,
+ jitt.fac=10,
+ main = gettext("Outlyingness \n by means of a distance-distance plot")
+ ){
mc <- as.list(match.call(expand.dots = FALSE))[-1]
dots <- mc$"..."
if(is.null(dots$xlim)) dots$xlim <- TRUE
@@ -16,33 +33,94 @@
if(is.null(mc$cutoff.y)) mc$cutoff.y <- cutoff.chisq()
if(missing(IC.x)) stop("Argument 'IC.x' must be given as argument to 'outlyingPlot'")
if(missing(data)) stop("Argument 'data' must be given as argument to 'outlyingPlot'")
-
+
if(missing(dist.y)){
- if("asCov" %in% names(Risks(IC.y)))
- if(is.matrix(Risks(IC.y)$asCov) || length(Risks(IC.y)$asCov) == 1)
- asVar <- Risks(IC.y)$asCov
- else
- asVar <- Risks(IC.y)$asCov$value
- else
- asVar <- getRiskIC(IC.y, risk = asCov())$asCov$value
-
+ if(robCov.y){
+ evIC = evalIC(IC.y,as.matrix(data))
+ asVar = solve(getCov(CovMcd(data.frame(evIC[1,],evIC[2,]),alpha=0.5)))
+ cat("\n", sep="", gettext("Robust asVar"), ":\n")
+ print(asVar)
+ }else{
+ if("asCov" %in% names(Risks(IC.y)))
+ if(is.matrix(Risks(IC.y)$asCov) || length(Risks(IC.y)$asCov) == 1)
+ {asVar <- Risks(IC.y)$asCov
+ cat("\n", sep="", gettext("asVar"));# print("HHHH");
+ print(asVar)
+ }
+ else{asVar <- Risks(IC.y)$asCov$value
+ cat("\n", sep="", gettext("asVar"));#print("HHHH");
+ print(asVar)
+ }
+ else{asVar <- getRiskIC(IC.y, risk = asCov())$asCov$value
+ cat("\n", sep="", gettext("Classic asVar"));
+ # print("HHHH");
+ print(asVar)
+ }}
+
asVar <- PosSemDefSymmMatrix(solve(asVar))
mc$dist.y <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = asVar)
}
- if(missing(dist.x))
- mc$dist.x <- NormType()
+ if(missing(dist.x)){
+ #mc$dist.x <- NormType()
+ if(robCov.x){
+ evIC = evalIC(IC.x,as.matrix(data))
+ asVar = getCov(CovMcd(data.frame(evIC[1,],evIC[2,]),alpha=0.5))
+ #cat("\nRobust asVar:") ;print("KKKKK")
+ #print(asVar)
+ }
+ else{
+ if("asCov" %in% names(Risks(IC.y)))
+ if(is.matrix(Risks(IC.x)$asCov) || length(Risks(IC.y)$asCov) == 1)
+ {asVar <- Risks(IC.x)$asCov
+ cat("\n", sep="", gettext("asVar"));
+ #print("KKKKK2");
+ print(asVar)
+ }
+ else
+ {asVar <- Risks(IC.x)$asCov$value
+ cat("\n", sep="", gettext("asVar"));
+ # print("KKKKK3");
+ print(asVar)
+ }
+ else
+ {asVar <- getRiskIC(IC.x, risk = asCov())$asCov$value
+ cat("\n", sep="", gettext("Classic asVar"));
+ #print("KKKKK4");
+ print(asVar)
+ }
+ }
+
+ asVar <- PosSemDefSymmMatrix(solve(asVar))
+ mc$dist.x <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = asVar)
+ }
+
+ if(missing(tf.x)){
tf.x <- function(x) apply(x,2,function(xx) evalIC(IC.x,xx))
+ }else{tf.x <- mc$tf.x}
+ if(missing(tf.y)){
tf.y <- function(x) apply(x,2,function(xx) evalIC(IC.y,xx))
+ }else{tf.y <- mc$tf.y}
+ do.call(ddPlot,args=c(list(data=data),dots,
+ list(dist.x = mc$dist.x,
+ dist.y = mc$dist.y,
+ cutoff.x = mc$cutoff.x,
+ cutoff.y = mc$cutoff.y,
+ cutoff.quantile.x = mc$cutoff.quantile.x,
+ cutoff.quantile.y = mc$cutoff.quantile.y,
+ transform.x = tf.x,
+ transform.y = tf.y,
+ id.n = mc$id.n,
+ lab.pts = mc$lab.pts,
+ adj = mc$adj,
+ cex.idn = mc$cex.idn,
+ col.idn = mc$col.idn,
+ lty.cutoff = mc$lty.cutoff,
+ lwd.cutoff = mc$lwd.cutoff,
+ col.cutoff = mc$col.cutoff,
+ jitt.fac = mc$jitt.fac,
+ main = main)))
- do.call(ddPlot,args=c(list(data=data), dots, list(dist.x = mc$dist.x,
- dist.y = mc$dist.y, cutoff.x = mc$cutoff.x, cutoff.y = mc$cutoff.y,
- cutoff.quantile.x = mc$cutoff.quantile.x, cutoff.quantile.y = mc$cutoff.quantile.y,
- transform.x = tf.x, transform.y = tf.y,
- id.n = mc$id.n, lab.pts = mc$lab.pts, adj = mc$adj, cex.idn = mc$cex.idn,
- col.idn = mc$col.idn, lty.cutoff = mc$lty.cutoff,
- lwd.cutoff = mc$lwd.cutoff, col.cutoff = mc$col.cutoff, main = main)))
-
}
Added: pkg/RobAStBase/R/plotRescaledAxis.R
===================================================================
--- pkg/RobAStBase/R/plotRescaledAxis.R (rev 0)
+++ pkg/RobAStBase/R/plotRescaledAxis.R 2013-09-11 14:31:27 UTC (rev 693)
@@ -0,0 +1,216 @@
+## helper functions for rescaling x and y axis in various diagnostic plots
+
+.rescalefct <- function(x, fct,
+ scaleX = FALSE, scaleX.fct, scaleX.inv,
+ scaleY = FALSE, scaleY.fct = pnorm,
+ xlim, ylim, dots){
+
+# if scaleX rescales x, if scaleY rescales fct(x);
+# to this end uses trafos scaleX.fct with inverse scale.inv
+# resp. scaleY.fct; it respects xlim and ylim (given in orig. scale)
+# thins out the scaled values if necessary and accordingly modifies
+# slots xaxt, yaxt, axes of dots to indicate the new axes have to be drawn
+# paradigm small letters = orig. scale, capital letters = transformed scale
+# 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]]
+ }
+ Xo <- X <- scaleX.fct(x)
+ X <- .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 <- 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,scy=scy,dots=dots))
+}
+
+if(FALSE){
+ set.seed(1); x<- sort(rnorm(10))
+ res <- .rescalefct(x, fct=function(s) sin(s), xlim=c(-2,1),ylim=c(0,1),dots=list(NULL))
+ res2 <- .rescalefct(x, fct=function(s) sin(s), scaleY=T, xlim=c(-2,1),ylim=c(0,1),dots=list(NULL))
+ res3 <- .rescalefct(x, fct=function(s) sin(s),
+ scaleX=T, scaleX.fct=function(x)exp(x)/(exp(x)+1),
+ scaleX.inv = function(x)log(x/(1-x)), scaleY=T,
+ xlim=c(-2,1),ylim=c(0,1),dots=list(NULL))
+ distroptions("DistrResolution"=0.05)
+ res4 <- .rescalefct(x, fct=function(s) sin(s),
+ scaleX=T, scaleX.fct=function(x)exp(x)/(exp(x)+1),
+ scaleX.inv = function(x)log(x/(1-x)), scaleY=T,
+ xlim=c(-2,1),ylim=c(0,1),dots=list(NULL))
+}
+
+.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, 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)
+# return value: none
+ if(scaleX){
+ if(is.null(x.ticks)){
+ x <- pretty(scaleX.inv(X))
+ if(!is.null(xlim)) x <- pmax(x, xlim[1])
+ if(!is.null(xlim)) x <- pmin(x, xlim[2])
+ X <- .DistrCollapse(scaleX.fct(x),0*x)$supp
+ x <- scaleX.inv(X)
+ x <- x[is.finite(x)]
+ x <- pretty(x,n=n)
+ X <- .DistrCollapse(scaleX.fct(x),0*x)$supp
+ x <- scaleX.inv(X)
+ x <- x[is.finite(x)]
+ x <- pretty(x,n=length(x))
+ x[.isEqual01(x)&x<0.4] <- 0
+ X <- scaleX.fct(x)
+ xf <- prettyNum(x)
+ i01 <- !.isEqual01(X)
+ xf <- xf[i01]
+ Xi <- X
+ X <- X[i01]
+ i0 <- any(!i01&Xi<0.5)
+ i1 <- any(!i01&Xi>0.5)
+ if(i0){ xf <- c(NA,xf); X <- c(0, X)}
+ if(i1){ xf <- c(xf,NA); X <- c(X, 1)}
+ axis(1,at=X,labels=xf)
+ if(i0) axis(1,at=0,labels=expression(-infinity))
+ if(i1) axis(1,at=1,labels=expression(infinity))
+ }else{
+ if(is.null(xlim)){ xlim <- c(-Inf,Inf)}else{
+ if(is.na(xlim[1])) xlim[1] <- -Inf
+ if(is.na(xlim[2])) xlim[2] <- Inf }
+ x.ticks <- sort(unique(x.ticks[!is.na(x.ticks)]))
+ xf <- pmin(pmax(x.ticks[is.finite(x.ticks)],xlim[1]),xlim[2])
+ Xf <- scaleX.fct(xf)
+ axis(1,at=Xf,labels=xf)
+ if(-Inf %in% x.ticks) axis(1,at=0,labels=expression(-infinity))
+ if(Inf %in% x.ticks) axis(1,at=1,labels=expression(infinity))
+ }
+ box()
+ }else{
+ if(!is.null(x.ticks)){
+ if(is.null(xlim)){ xlim <- c(-Inf,Inf)}else{
+ if(is.na(xlim[1])) xlim[1] <- -Inf
+ if(is.na(xlim[2])) xlim[2] <- Inf }
+ x.ticks <- sort(unique(x.ticks[!is.na(x.ticks)]))
+ xf <- pmin(pmax(x.ticks[is.finite(x.ticks)],xlim[1]),xlim[2])
+ axis(1,at=xf,labels=xf)
+ if(-Inf %in% x.ticks) axis(1,at=0,labels=expression(-infinity))
+ if(Inf %in% x.ticks) axis(1,at=1,labels=expression(infinity))
+ box()
+ }
+ }
+ if(scaleY){
+ if(is.null(y.ticks)){
+ Y0 <- if(!is.null(ylim)) max(0, scaleY.fct(ylim[1])) else 0
+ Y1 <- if(!is.null(ylim)) min(1, scaleY.fct(ylim[2])) else 1
+ Y <- seq(Y0,Y1, length=ypts)
+ y <- pretty(scaleY.inv(Y),n=n)
+ Y <- .DistrCollapse(scaleY.fct(y),0*y)$supp
+ y <- scaleY.inv(Y)
+ y <- y[is.finite(y)]
+ y <- pretty(y,n=length(y))
+ y[.isEqual01(y)&y<0.4] <- 0
+ Y <- scaleX.fct(y)
+ yf <- prettyNum(y)
+ Y <- scaleY.fct(y)
+ i01 <- !.isEqual01(Y)
+ yf <- yf[i01]
+ Yi <- Y
+ Y <- Y[i01]
+ i0 <- any(!i01&Yi<0.5)
+ i1 <- any(!i01&Yi>0.5)
+ if(i0){ yf <- c(NA,yf); Y <- c(0, Y)}
+ if(i1){ yf <- c(yf,NA); Y <- c(Y, 1)}
+ axis(2,at=Y,labels=yf)
+ if(i0) axis(2,at=0,labels=expression(-infinity))
+ if(i1) axis(2,at=1,labels=expression(infinity))
+ }else{
+ if(is.null(ylim)){ ylim <- c(-Inf,Inf)}else{
+ if(is.na(ylim[1])) ylim[1] <- -Inf
+ if(is.na(ylim[2])) ylim[2] <- Inf }
+ y.ticks <- sort(unique(y.ticks[!is.na(y.ticks)]))
+ yf <- pmin(pmax(y.ticks[is.finite(y.ticks)],ylim[1]),ylim[2])
+ Yf <- scaleY.fct(yf)
+ axis(2,at=Yf,labels=yf)
+ if(-Inf %in% y.ticks) axis(2,at=0,labels=expression(-infinity))
+ if(Inf %in% y.ticks) axis(2,at=1,labels=expression(infinity))
+ }
+ box()
+ }else{
+ if(!is.null(y.ticks)){
+ if(is.null(ylim)){ ylim <- c(-Inf,Inf)}else{
+ if(is.na(ylim[1])) ylim[1] <- -Inf
+ if(is.na(ylim[2])) ylim[2] <- Inf }
+ y.ticks <- sort(unique(y.ticks[!is.na(y.ticks)]))
+ yf <- pmin(pmax(y.ticks[is.finite(y.ticks)],ylim[1]),ylim[2])
+ axis(2,at=yf,labels=yf)
+ if(-Inf %in% y.ticks) axis(2,at=0,labels=expression(-infinity))
+ if(Inf %in% y.ticks) axis(2,at=1,labels=expression(infinity))
+ box()
+ }
+ }
+ return(invisible(NULL))
+}
+if(FALSE){
+ set.seed(1); x<- sort(c(-10,rnorm(100),10))
+ xlim0 <- c(-2,1.6)
+ ylim0 <- c(-0.8,1)
+ xlim01 <- ex0(xlim0)
+ ylim01 <- ex0(ylim0)
+ xlim0 <- NULL
+ ylim0 <- NULL
+ xlim01 <- NULL
+ ylim01 <-NULL
+ distroptions("DistrResolution"=0.000001)
+ res3 <- .rescalefct(x, fct=function(s) sin(s),
+ scaleX=T, scaleX.fct=function(x)exp(x)/(exp(x)+1),
+ scaleX.inv = function(x)log(x/(1-x)), scaleY=T,
+ xlim=xlim0,ylim=ylim0,dots=list(NULL))
+ ex1 <- function(x)log(x/(1-x))
+ ex0 <- function(x)exp(x)/(exp(x)+1)
+ res4 <- .rescalefct(x, fct=function(s) sin(s),
+ scaleX=T, scaleX.fct=ex0,
+ scaleX.inv = ex1, scaleY=T,
+ xlim=xlim0,ylim=ylim0,dots=list(NULL))
+ plot(res3$X,res3$Y,axes=F, xlim=xlim01,ylim=ylim01)
+ .plotRescaledAxis(scaleX=T, scaleX.fct=function(x)exp(x)/(exp(x)+1),
+ scaleX.inv = function(x)log(x/(1-x)), scaleY=T, scaleY.fct=pnorm,
+ scaleY.inv = qnorm, X= res3$X, xlim=xlim0,ylim=ylim0, m = 19)
+ plot(res3$X,res3$Y,axes=F, xlim=xlim01,ylim=ylim01)
+ .plotRescaledAxis(scaleX=T, scaleX.fct=function(x)exp(x)/(exp(x)+1),
+ scaleX.inv = function(x)log(x/(1-x)), scaleY=T, scaleY.fct=pnorm,
+ scaleY.inv = qnorm, X= res3$X, xlim=xlim0,ylim=ylim0,
+ x.ticks = c(-100,-3,-1,-0.3,0,0.5,2,5,100),
+ y.ticks = c(-1,-0.7,-0.1,0,0.2,.5,1))
+ plot(res3$X,res3$Y,axes=F, xlim=xlim01,ylim=ylim01)
+ .plotRescaledAxis(scaleX=T, scaleX.fct=function(x)exp(x)/(exp(x)+1),
+ scaleX.inv = function(x)log(x/(1-x)), scaleY=T, scaleY.fct=pnorm,
+ scaleY.inv = qnorm, X= res3$X, xlim=xlim0,ylim=ylim0,
+ x.ticks = c(-Inf,-3,-1,-0.3,0,0.5,2,5,Inf),
+ y.ticks = c(-1,-0.7,-0.1,0,0.2,.5,1))
+
+}
+
+.legendCoord <- function(x, scaleX, scaleX.fct, scaleY, scaleY.fct){
+# rescaled legend coordinates axes acc. to logicals scaleX, scaleY
+# return value: transformed legend coordinates
+ if (is.character(x)) return(x)
+ x1 <- if(scaleX) scaleX.fct(x[1]) else x[1]
+ x2 <- if(scaleY) scaleY.fct(x[2]) else x[2]
+ return(c(x1,x2))
+ }
Added: pkg/RobAStBase/R/plotWrapper.R
===================================================================
--- pkg/RobAStBase/R/plotWrapper.R (rev 0)
+++ pkg/RobAStBase/R/plotWrapper.R 2013-09-11 14:31:27 UTC (rev 693)
@@ -0,0 +1,557 @@
+##########################################
+## ##
+## Wrapper for infoPlot.R ##
+## (infoPlot method for IC) ##
+## ##
+##########################################
+
+##############################################################
+#' Merging Lists
+#'
+#' \code{.merge.lists} takes two lists and merges them.
+#'
+#' @param a the first list
+#'
+#' @param b the second list
+#'
+#' @return the merged list
+#'
+#' @keywords internal
+#' @rdname mergelists
+#'
+##############################################################
+
+### 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 information plot method
+#'
+#' 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 data optional data argument --- for plotting observations into the plot
+#'
+#' @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
+#'
+#' @return invisible(NULL)
+#
+#' @section Details: Calls \code{infoPlot} with suitably chosen defaults. If \code{withCall == TRUE}, the call to \code{infoPlot} is returned
+#'
+#' @export
+#' @rdname InfoPlotWrapper
+#'
+#'
+#' @examples
+#' # Gamma
+#' fam <- GammaFamily()
+#' IC <- optIC(model = fam, risk = asCov())
+#' Y <- distribution(fam)
+#' data <- r(Y)(1000)
+#' InfoPlot(IC, data, withCall = FALSE)
+#'
+##############################################################
+
+##IC - influence curve
+##data - dataset
+## with.legend - optional legend indicator
+## withCall - optional indicator of the function call
+#
+InfoPlot <- function(IC, data,...,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 'InfoPlot'")
+ if(missing(data)) data <- NULL
+ mc <- as.list(match.call(expand.dots = FALSE))[-1]
+ dots <- mc$"..."
+ if(missing(data)){
+ alpha.trsp <- 100
+ } else {
+ if(is.null(mc$alpha.trsp)){
+ alpha.trsp <- 30
+ if(length(data) < 1000){
+ alpha.trsp <- 50
+ }
+ if(length(data) < 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(eval(IC at CallL2Fam), FALSE, mc$rescale)
+
+ argsList <- c(list(object = substitute(IC)
+ ,data = substitute(data)
+ ,withSweave = substitute(getdistrOption("withSweave"))
+ ,lwd = substitute(par("lwd"))
+ ,lty = substitute("solid")
+ ,colI = substitute(grey(0.5))
+ ,lwdI = substitute(0.7*par("lwd"))
+ ,ltyI = substitute("dotted")
+ ,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(TRUE)
+ ,legend = substitute(NULL)
+ ,legend.bg = substitute("white")
+ ,legend.location = substitute("bottomright")
+ ,legend.cex = substitute(0.8)
+ ,scaleN = substitute(9)
+ ,mfColRow = substitute(TRUE)
+ ,to.draw.arg = substitute(NULL)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 693
More information about the Robast-commits
mailing list