[Robast-commits] r530 - in branches/robast-0.9/pkg: ROptEst ROptEst/R ROptEst/man RobAStBase/R RobAStBase/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jan 11 21:50:47 CET 2013
Author: ruckdeschel
Date: 2013-01-11 21:50:47 +0100 (Fri, 11 Jan 2013)
New Revision: 530
Added:
branches/robast-0.9/pkg/ROptEst/R/AllPlot.R
branches/robast-0.9/pkg/ROptEst/R/comparePlot.R
branches/robast-0.9/pkg/ROptEst/man/comparePlot.Rd
branches/robast-0.9/pkg/ROptEst/man/plot-methods.Rd
branches/robast-0.9/pkg/RobAStBase/R/makedots.R
Removed:
branches/robast-0.9/pkg/ROptEst/R/makedots.R
Modified:
branches/robast-0.9/pkg/ROptEst/NAMESPACE
branches/robast-0.9/pkg/ROptEst/R/cniperCont.R
branches/robast-0.9/pkg/ROptEst/man/cniperCont.Rd
branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R
branches/robast-0.9/pkg/RobAStBase/R/comparePlot.R
branches/robast-0.9/pkg/RobAStBase/R/ddPlot_utils.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/R/selectorder.R
branches/robast-0.9/pkg/RobAStBase/man/comparePlot.Rd
branches/robast-0.9/pkg/RobAStBase/man/infoPlot.Rd
branches/robast-0.9/pkg/RobAStBase/man/plot-methods.Rd
Log:
go on debugging...
Modified: branches/robast-0.9/pkg/ROptEst/NAMESPACE
===================================================================
--- branches/robast-0.9/pkg/ROptEst/NAMESPACE 2013-01-11 12:38:28 UTC (rev 529)
+++ branches/robast-0.9/pkg/ROptEst/NAMESPACE 2013-01-11 20:50:47 UTC (rev 530)
@@ -28,7 +28,7 @@
"getModifyIC",
"cniperCont", "cniperPoint", "cniperPointPlot")
exportMethods("updateNorm", "scaleUpdateIC", "eff",
- "get.asGRisk.fct", "getStartIC")
+ "get.asGRisk.fct", "getStartIC", "plot")
export("getL2normL2deriv",
"asAnscombe", "asL1", "asL4",
"getReq", "getMaxIneff")
Added: branches/robast-0.9/pkg/ROptEst/R/AllPlot.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/AllPlot.R (rev 0)
+++ branches/robast-0.9/pkg/ROptEst/R/AllPlot.R 2013-01-11 20:50:47 UTC (rev 530)
@@ -0,0 +1,48 @@
+setMethod("plot", signature(x = "IC", y = "missing"),
+ function(x, ...,withSweave = getdistrOption("withSweave"),
+ main = FALSE, inner = TRUE, sub = FALSE,
+ col.inner = par("col.main"), cex.inner = 0.8,
+ bmar = par("mar")[1], tmar = par("mar")[3],
+ with.legend = FALSE, legend = NULL, legend.bg = "white",
+ legend.location = "bottomright", legend.cex = 0.8,
+ withMBR = FALSE, MBRB = NA, MBR.fac = 2, col.MBR = par("col"),
+ lty.MBR = "dashed", lwd.MBR = 0.8,
+ scaleX = FALSE, scaleX.fct, scaleX.inv,
+ scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
+ scaleN = 9, x.ticks = NULL, y.ticks = NULL,
+ mfColRow = TRUE, to.draw.arg = NULL){
+
+ mcl <- match.call(call = sys.call(sys.parent(1)))
+
+ L2Fam <- eval(x at CallL2Fam); trafO <- trafo(L2Fam at param)
+ dims <- nrow(trafO); to.draw <- 1:dims
+ if(! is.null(to.draw.arg)){
+ if(is.character(to.draw.arg))
+ to.draw <- pmatch(to.draw.arg, dimnms)
+ else if(is.numeric(to.draw.arg))
+ to.draw <- to.draw.arg
+ }
+ dims0 <- length(to.draw)
+
+ MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
+ if(withMBR && all(is.na(MBRB))){
+ robModel <- InfRobModel(center = L2fam, neighbor =
+ ContNeighborhood(radius = 0.5))
+ ICmbr <- try(optIC(model = robModel, risk = asBias()), silent=TRUE)
+ if(!is(ICmbr,"try-error"))
+ MBRB <- .getExtremeCoordIC(ICmbr, distribution(L2Fam), todraw)
+ else withMBR <- FALSE
+ }
+ mcl$MBRB <- MBRB
+ mcl$withMBR <- withMBR
+ do.call(getMethod("plot", signature(x = "IC", y = "missing"),
+ where="RobAStBase"), mcl)
+ })
+
+.getExtremeCoordIC <- function(IC, D, indi, n = 50000){
+ x <- q(D)(seq(1/2/n,1-1/2/n, length=n))
+ li <- length(indi)
+ ICx <- matrix(0,li,n)
+ for( i in 1:li) ICx[i,] <- sapply(x, IC at Map[[indi[i]]])
+ return(cbind(min=apply(ICx,1,min),max=apply(ICx,1,max)))
+}
\ No newline at end of file
Modified: branches/robast-0.9/pkg/ROptEst/R/cniperCont.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/cniperCont.R 2013-01-11 12:38:28 UTC (rev 529)
+++ branches/robast-0.9/pkg/ROptEst/R/cniperCont.R 2013-01-11 20:50:47 UTC (rev 530)
@@ -54,8 +54,6 @@
neighbor = "ContNeighborhood",
risk = "asMSE"),
function(L2Fam, neighbor, risk, lower, upper, n = 101, ...,
- scaleX = FALSE, scaleX.fct, scaleX.inv,
- scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
){
dots <- as.list(match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"...")
@@ -180,6 +178,7 @@
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,
@@ -263,7 +262,8 @@
do.call(abline, dots)
.plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv, scaleY,scaleY.fct,
- scaleY.inv, dots$xlim, dots$ylim, x, ypts = 400)
+ scaleY.inv, dots$xlim, dots$ylim, 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)
@@ -307,6 +307,7 @@
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,
@@ -389,7 +390,8 @@
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, x, ypts = 400)
+ scaleY.inv, dots$xlim, dots$ylim, x, ypts = 400,
+ n = scaleN, x.ticks = x.ticks, y.ticks = y.ticks)
if(!is.null(data))
return(.plotData(data, dots, mc, fun, L2Fam, eta))
return(invisible(NULL))
Added: branches/robast-0.9/pkg/ROptEst/R/comparePlot.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/comparePlot.R (rev 0)
+++ branches/robast-0.9/pkg/ROptEst/R/comparePlot.R 2013-01-11 20:50:47 UTC (rev 530)
@@ -0,0 +1,41 @@
+setMethod("comparePlot", signature("IC","IC"),
+ function(obj1,obj2, obj3 = NULL, obj4 = NULL, data = NULL,
+ ..., withSweave = getdistrOption("withSweave"),
+ main = FALSE, inner = TRUE, sub = FALSE,
+ col = par("col"), lwd = par("lwd"), lty,
+ col.inner = par("col.main"), cex.inner = 0.8,
+ bmar = par("mar")[1], tmar = par("mar")[3],
+ with.legend = TRUE, legend.bg = "white",
+ legend.location = "bottomright", legend.cex = 0.8,
+ mfColRow = TRUE, to.draw.arg = NULL,
+ cex.pts = 1, col.pts = par("col"),
+ pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
+ lab.pts = NULL, lab.font = NULL,
+ which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
+
+ mcl <- match.call(call = sys.call(sys.parent(1)))
+
+ L2Fam <- eval(x at CallL2Fam); trafO <- trafo(L2Fam at param)
+ dims <- nrow(trafO); to.draw <- 1:dims
+ if(! is.null(to.draw.arg)){
+ if(is.character(to.draw.arg))
+ to.draw <- pmatch(to.draw.arg, dimnms)
+ else if(is.numeric(to.draw.arg))
+ to.draw <- to.draw.arg
+ }
+ dims0 <- length(to.draw)
+
+ MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
+ if(withMBR && all(is.na(MBRB))){
+ robModel <- InfRobModel(center = L2fam, neighbor =
+ ContNeighborhood(radius = 0.5))
+ ICmbr <- try(optIC(model = robModel, risk = asBias()), silent=TRUE)
+ if(!is(ICmbr,"try-error"))
+ MBRB <- .getExtremeCoordIC(ICmbr, distribution(L2Fam), todraw)
+ else withMBR <- FALSE
+ }
+ mcl$MBRB <- MBRB
+ mcl$withMBR <- withMBR
+ do.call(getMethod("comparePlot", signature("IC","IC"),
+ where="RobAStBase"), mcl)
+ })
Deleted: branches/robast-0.9/pkg/ROptEst/R/makedots.R
===================================================================
--- branches/robast-0.9/pkg/ROptEst/R/makedots.R 2013-01-11 12:38:28 UTC (rev 529)
+++ branches/robast-0.9/pkg/ROptEst/R/makedots.R 2013-01-11 20:50:47 UTC (rev 530)
@@ -1,42 +0,0 @@
-## 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
-}
Modified: branches/robast-0.9/pkg/ROptEst/man/cniperCont.Rd
===================================================================
--- branches/robast-0.9/pkg/ROptEst/man/cniperCont.Rd 2013-01-11 12:38:28 UTC (rev 529)
+++ branches/robast-0.9/pkg/ROptEst/man/cniperCont.Rd 2013-01-11 20:50:47 UTC (rev 530)
@@ -22,6 +22,7 @@
% 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,
@@ -33,6 +34,7 @@
% 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,
@@ -80,6 +82,11 @@
% \item{scaleY.inv}{an isotone, vectorized function mapping for each coordinate
% the range [0,1] into the range of the respective coordinate of the IC(s);
% defaulting to the quantile function of \eqn{{\cal N}(0,1)}{N(0,1)}.}
+% \item{scalen}{integer; defaults to 9; on rescaled axes, number of x and y ticks if drawn automatically;}
+% \item{x.ticks}{numeric; defaults to NULL; (then ticks are chosen automatically);
+% if non-NULL, user-given x-ticks (on original scale);}
+% \item{y.ticks}{numeric; defaults to NULL; (then ticks are chosen automatically);
+% if non-NULL, user-given y-ticks (on original scale);}
% \item{cex.pts}{size of the points of the second argument plotted}
% \item{col.pts}{color of the points of the second argument plotted}
% \item{pch.pts}{symbol of the points of the second argument plotted}
Added: branches/robast-0.9/pkg/ROptEst/man/comparePlot.Rd
===================================================================
--- branches/robast-0.9/pkg/ROptEst/man/comparePlot.Rd (rev 0)
+++ branches/robast-0.9/pkg/ROptEst/man/comparePlot.Rd 2013-01-11 20:50:47 UTC (rev 530)
@@ -0,0 +1,30 @@
+\name{comparePlot-methods}
+\docType{methods}
+\alias{comparePlot}
+\alias{comparePlot-methods}
+\alias{comparePlot,IC,IC-method}
+
+\title{Compare - Plots}
+\description{
+ Plots 2-4 influence curves to the same model.
+}
+\details{
+S4-Method \code{comparePlot} for signature \code{IC,IC} has been enhanced compared to
+its original definition in \pkg{RobAStBase} so that if
+argument \code{MBRB} is \code{NA}, it is filled automatically by a call
+to \code{optIC} which computes the MBR-IC on the fly.}
+}
+\examples{
+if(require(ROptEst)){
+
+N0 <- NormLocationScaleFamily(mean=0, sd=1)
+N0.Rob1 <- InfRobModel(center = N0,
+ neighbor = ContNeighborhood(radius = 0.5))
+
+IC1 <- optIC(model = N0, risk = asCov())
+IC2 <- optIC(model = N0.Rob1, risk = asMSE())
+
+comparePlot(IC1,IC2, withMBR=TRUE, MBRB=FALSE)
+}
+}
+\keyword{robust}
Added: branches/robast-0.9/pkg/ROptEst/man/plot-methods.Rd
===================================================================
--- branches/robast-0.9/pkg/ROptEst/man/plot-methods.Rd (rev 0)
+++ branches/robast-0.9/pkg/ROptEst/man/plot-methods.Rd 2013-01-11 20:50:47 UTC (rev 530)
@@ -0,0 +1,23 @@
+\name{plot-methods}
+\docType{methods}
+\alias{plot}
+\alias{plot-methods}
+\alias{plot,IC,missing-method}
+\title{ Methods for Function plot in Package `ROptEst' }
+\description{plot-methods}
+\details{
+S4-Method \code{plot} for for signature \code{IC,missing} has been enhanced
+compared to its original definition in \pkg{RobAStBase} so that if
+argument \code{MBRB} is \code{NA}, it is filled automatically by a call
+to \code{optIC} which computes the MBR-IC on the fly.}
+}
+\examples{
+N <- NormLocationScaleFamily(mean=0, sd=1)
+IC <- optIC(model = N, risk = asCov())
+plot(IC2, main = TRUE, panel.first= grid(),
+ col = "blue", cex.main = 2, cex.inner = 0.6,
+ withMBR=TRUE, MBRB=FALSE)
+}
+\keyword{methods}
+\keyword{distribution}
+
Modified: branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R 2013-01-11 12:38:28 UTC (rev 529)
+++ branches/robast-0.9/pkg/RobAStBase/R/AllPlot.R 2013-01-11 20:50:47 UTC (rev 530)
@@ -9,6 +9,7 @@
lty.MBR = "dashed", lwd.MBR = 0.8,
scaleX = FALSE, scaleX.fct, scaleX.inv,
scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
+ scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL){
xc <- match.call(call = sys.call(sys.parent(1)))$x
@@ -49,15 +50,25 @@
nrows <- trunc(sqrt(dims0))
ncols <- ceiling(dims0/nrows)
- MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
- if(withMBR && all(is.na(MBRB))){
- robModel <- InfRobModel(center = L2fam, neighbor =
- ContNeighborhood(radius = 0.5))
- ICmbr <- try(optIC(model = robModel, risk = asBias()), silent=TRUE)
- if(!is(ICmbr,"try-error"))
- MBRB <- .getExtremeCoordIC(ICmbr, distribution(L2Fam), todraw)
- else withMBR <- FALSE
+ if(!is.null(x.ticks)) dots$xaxt <- "n"
+ if(!is.null(y.ticks)){
+ y.ticks <- distr:::.fillList(list(y.ticks), dims0)
+ dots$yaxt <- "n"
}
+
+ MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
+
+# Code only useable from ROptEst on...
+#
+# if(withMBR && all(is.na(MBRB))){
+# robModel <- InfRobModel(center = L2fam, neighbor =
+# ContNeighborhood(radius = 0.5))
+# ICmbr <- try(optIC(model = robModel, risk = asBias()), silent=TRUE)
+# if(!is(ICmbr,"try-error"))
+# MBRB <- .getExtremeCoordIC(ICmbr, distribution(L2Fam), todraw)
+# else withMBR <- FALSE
+# }
+
MBRB <- MBRB * MBR.fac
e1 <- L2Fam at distribution
@@ -107,8 +118,9 @@
if(!is.null(dots[["lty"]])) dots["lty"] <- NULL
if(!is.null(dots[["type"]])) dots["type"] <- NULL
- if(!is.null(dots[["xlab"]])) dots["xlab"] <- NULL
- if(!is.null(dots[["ylab"]])) dots["ylab"] <- NULL
+ xlab <- dots$xlab; if(is.null(xlab)) xlab <- "x"
+ ylab <- dots$ylab; if(is.null(ylab)) ylab <- "(partial) IC"
+ dots$xlab <- dots$ylab <- NULL
IC1 <- as(diag(dims) %*% x at Curve, "EuclRandVariable")
@@ -190,6 +202,7 @@
}
if(with.legend){
+ fac.leg <- if(dims0>1) 3/4 else .75/.8
if(missing(legend.location)){
legend.location <- distr:::.fillList(list("bottomright"), dims0)
}else{
@@ -230,49 +243,36 @@
for(i in 1:dims0){
indi <- to.draw[i]
if(!is.null(ylim)) dots$ylim <- ylim[,i]
- resc <-.rescalefct(x.vec, IC1 at Map[[indi]], scaleX, scaleX.fct,
+ fct <- function(x) sapply(x, IC1 at Map[[indi]])
+ resc <-.rescalefct(x.vec, fct, scaleX, scaleX.fct,
scaleX.inv, scaleY, scaleY.fct, xlim[,i],
ylim[,i], dots)
dots <- resc$dots
x.vec1 <- resc$X
y.vec1 <- resc$Y
- do.call(plot, args=c(list(x.vec1, y.vec1,
- type = plty, lty = lty,
- xlab = "x", ylab = "(partial) IC"),
- dots))
+ do.call(plot, args=c(list(x.vec1, y.vec1, type = plty, lty = lty,
+ xlab = xlab, ylab = ylab, dots)))
.plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv,
scaleY,scaleY.fct, scaleY.inv,
- xlim[,i], ylim[,i], x.vec1, ypts = 400)
+ xlim[,i], ylim[,i], x.vec1, ypts = 400, n = scaleN,
+ x.ticks = x.ticks, y.ticks = y.ticks[[i]])
if(withMBR){
MBR.i <- MBRB[i,]
if(scaleY) MBR.i <- scaleY.fct(MBR.i)
abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR)
}
if(is(e1, "DiscreteDistribution")){
- x.vec1a <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
- if(scaleX){
- if(!is.null(xlim)){
- dots$xlim <- scaleX.fct(xlim[,i])
- x.vec10 <- x.vec1a[xvec1a>=xlim[1,i] & xvec1a<=xlim[2,i]]
- }
- x.vec1 <- scaleX.fct(x.vec10)
- x.vec1 <- distr:::.DistrCollapse(x.vec1, 0*x.vec1+1/length(x.vec1))
- dots$axes <- NULL
- dots$xaxt <- "n"
- }
- y.vec1 <- sapply(x.vec1, IC1 at Map[[indi]])
- if(scaleY){
- y.vec1 <- scaleY.fct(y.vec)
- if(!is.null(ylim)) dots$ylim <- scaleY.fct(ylim[,i])
- dots$axes <- NULL
- dots$yaxt <- "n"
- }
+ x.vec1D <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
+ rescD <-.rescalefct(x.vecD, fct, scaleX, scaleX.fct,
+ scaleX.inv, scaleY, scaleY.fct, xlim[,i],
+ ylim[,i], dotsP)
+ x.vecD <- rescD$X
+ y.vecD <- rescD$Y
dotsL$lty <- NULL
- do.call(lines,args=c(list(x.vec1, y.vec1,
+ do.call(lines,args=c(list(x.vecD, y.vecD,
lty = "dotted"), dotsL))
-
}
do.call(title,args=c(list(main = innerT[indi]), dotsT, line = lineT,
cex.main = cex.inner, col.main = col.inner))
@@ -323,8 +323,6 @@
absInfo <- t(IC1) %*% QF %*% IC1
ICMap <- IC1 at Map
- absInfo <- sapply(y, absInfo at Map[[1]])
-
sel <- .SelectOrderData(y, function(x)sapply(x, absInfo at Map[[1]]),
which.lbs, which.Order)
i.d <- sel$ind
@@ -371,10 +369,3 @@
invisible()
})
-.getExtremeCoordIC <- function(IC, D, indi, n = 50000){
- x <- q(D)(seq(1/2/n,1-1/2/n, length=n))
- li <- length(indi)
- ICx <- matrix(0,li,n)
- for( i in 1:li) ICx[i,] <- sapply(x, IC at Map[[indi[i]]])
- return(cbind(min=apply(ICx,1,min),max=apply(ICx,1,max)))
-}
\ No newline at end of file
Modified: branches/robast-0.9/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-0.9/pkg/RobAStBase/R/comparePlot.R 2013-01-11 12:38:28 UTC (rev 529)
+++ branches/robast-0.9/pkg/RobAStBase/R/comparePlot.R 2013-01-11 20:50:47 UTC (rev 530)
@@ -1,32 +1,37 @@
setMethod("comparePlot", signature("IC","IC"),
function(obj1,obj2, obj3 = NULL, obj4 = NULL, data = NULL,
- ..., withSweave = getdistrOption("withSweave"),
- main = FALSE, inner = TRUE, sub = FALSE,
- col = par("col"), lwd = par("lwd"), lty,
- col.inner = par("col.main"), cex.inner = 0.8,
- bmar = par("mar")[1], tmar = par("mar")[3],
- with.legend = TRUE, legend.bg = "white",
+ ..., withSweave = getdistrOption("withSweave"),
+ main = FALSE, inner = TRUE, sub = FALSE,
+ col = par("col"), lwd = par("lwd"), lty,
+ col.inner = par("col.main"), cex.inner = 0.8,
+ bmar = par("mar")[1], tmar = par("mar")[3],
+ with.legend = FALSE, legend = NULL, legend.bg = "white",
legend.location = "bottomright", legend.cex = 0.8,
+ withMBR = FALSE, MBRB = NA, MBR.fac = 2, col.MBR = par("col"),
+ lty.MBR = "dashed", lwd.MBR = 0.8,
+ scaleX = FALSE, scaleX.fct, scaleX.inv,
+ scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
+ scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL,
cex.pts = 1, col.pts = par("col"),
pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
lab.pts = NULL, lab.font = NULL,
which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
- xc1 <- as.character(deparse(match.call(call = sys.call(sys.parent(1)))$obj1))
- xc2 <- as.character(deparse(match.call(call = sys.call(sys.parent(1)))$obj2))
- xc <- c(xc1,xc2)
- if(!is.null(obj3))
- xc <- c(xc,as.character(deparse(match.call(call = sys.call(sys.parent(1)))$obj3)))
- if(!is.null(obj4))
- xc <- c(xc,as.character(deparse(match.call(call = sys.call(sys.parent(1)))$obj4)))
-
- dots <- match.call(call = sys.call(sys.parent(1)),
+ .xc <- function(obj) as.character(deparse(match.call(
+ call = sys.call(sys.parent(1)))[[obj]]))
+ xc <- c(.xc("obj1"), .xc("obj2"))
+ if(!is.null(obj3)) xc <- c(xc, .xc("obj3"))
+ if(!is.null(obj4)) xc <- c(xc, .xc("obj4"))
+
+ dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
+ dotsP <- dots
+ dotsLeg <- dotsT <- dotsL <- .makedotsLowLevel(dots)
- ncomp <- 2+ (!missing(obj3)|!is.null(obj3)) +
+ ncomp <- 2+ (!missing(obj3)|!is.null(obj3)) +
(!missing(obj4)|!is.null(obj4))
-
+
if(missing(col)) col <- 1:ncomp
else col <- rep(col, length.out = ncomp)
if(missing(lwd)) lwd <- rep(1,ncomp)
@@ -34,54 +39,64 @@
if(!missing(lty)) rep(lty, length.out = ncomp)
if(missing(col.pts)) col.pts <- 1:ncomp
-
- if(!is.null(dots[["type"]])) dots["type"] <- NULL
- if(!is.null(dots[["xlab"]])) dots["xlab"] <- NULL
- if(!is.null(dots[["ylab"]])) dots["ylab"] <- NULL
-
- dotsP <- dotsL <- dotsT <- dots
+ dots["type"] <- NULL
+ xlab <- dots$xlab; if(is.null(xlab)) xlab <- "x"
+ ylab <- dots$ylab; if(is.null(ylab)) ylab <- "(partial) IC"
+ dots$xlab <- dots$ylab <- NULL
L2Fam <- eval(obj1 at CallL2Fam)
- L2Fam1c <- obj1 at CallL2Fam
- L2Fam2c <- obj2 at CallL2Fam
- if(!identical(L2Fam1c,L2Fam2c))
+ if(!identical(CallL2Fam(obj1),CallL2Fam(obj2)))
stop("ICs need to be defined for the same model")
+ if(missing(scaleX.fct)){
+ scaleX.fct <- p(L2Fam)
+ scaleX.inv <- q(L2Fam)
+ }
+
trafO <- trafo(L2Fam at param)
dims <- nrow(trafO)
dimm <- ncol(trafO)
-
+
to.draw <- 1:dims
dimnms <- c(rownames(trafO))
if(is.null(dimnms))
dimnms <- paste("dim",1:dims,sep="")
if(! is.null(to.draw.arg)){
- if(is.character(to.draw.arg))
+ if(is.character(to.draw.arg))
to.draw <- pmatch(to.draw.arg, dimnms)
- else if(is.numeric(to.draw.arg))
+ else if(is.numeric(to.draw.arg))
to.draw <- to.draw.arg
}
dims0 <- length(to.draw)
nrows <- trunc(sqrt(dims0))
ncols <- ceiling(dims0/nrows)
- e1 <- L2Fam at distribution
- if(!is(e1, "UnivariateDistribution")) stop("not yet implemented")
+ if(!is.null(x.ticks)) dotsP$xaxt <- "n"
+ if(!is.null(y.ticks)){
+ y.ticks <- distr:::.fillList(list(y.ticks), dims0)
+ dotsP$yaxt <- "n"
+ }
- xlim <- eval(dots$xlim)
- if(!is.null(xlim)){
+ MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
+ MBRB <- MBRB * MBR.fac
+
+ distr <- L2Fam at distribution
+ if(!is(distr, "UnivariateDistribution")) stop("not yet implemented")
+
+ xlim <- dotsP$xlim <- eval(dots$xlim)
+ if(!is.null(xlim)){
xm <- min(xlim)
xM <- max(xlim)
}
- if(is(e1, "AbscontDistribution")){
- lower0 <- getLow(e1, eps = getdistrOption("TruncQuantile")*2)
- upper0 <- getUp(e1, eps = getdistrOption("TruncQuantile")*2)
- me <- median(e1); s <- IQR(e1)
+ if(is(distr, "AbscontDistribution")){
+ lower0 <- getLow(distr, eps = getdistrOption("TruncQuantile")*2)
+ upper0 <- getUp(distr, eps = getdistrOption("TruncQuantile")*2)
+ me <- median(distr); s <- IQR(distr)
lower1 <- me - 6 * s
upper1 <- me + 6 * s
lower <- max(lower0, lower1)
upper <- min(upper0, upper1)
- if(!is.null(xlim)){
+ if(!is.null(xlim)){
lower <- min(lower,xm)
upper <- max(upper,xM)
}
@@ -90,9 +105,8 @@
plty <- "l"
if(missing(lty)) lty <- "solid"
}else{
- if(is(e1, "DiscreteDistribution")) x.vec <- support(e1)
- else{
- x.vec <- r(e1)(1000)
+ if(is(distr, "DiscreteDistribution")) x.vec <- support(distr) else{
+ x.vec <- r(distr)(1000)
x.vec <- sort(unique(x.vec))
}
plty <- "p"
@@ -100,359 +114,266 @@
if(!is.null(xlim)) x.vec <- x.vec[(x.vec>=xm) & (x.vec<=xM)]
}
ylim <- eval(dots$ylim)
- if(!is.null(ylim)){
- if(! length(ylim) %in% c(2,2*dims0))
- stop("Wrong length of Argument ylim");
+ if(!is.null(ylim)){
+ if(! length(ylim) %in% c(2,2*dims0))
+ stop("Wrong length of Argument ylim");
ylim <- matrix(ylim, 2,dims0)
}
- dots$ylim <- NULL
- dotsP$xlim <- xlim
- dots$xlim <- NULL
+ dots$ylim <- dots$xlim <- NULL
- dims <- nrow(trafo(L2Fam at param))
- IC1 <- as(diag(dims) %*% obj1 at Curve, "EuclRandVariable")
- IC2 <- as(diag(dims) %*% obj2 at Curve, "EuclRandVariable")
+ dims <- nrow(trafo(L2Fam at param)); ID <- diag(dims)
+ IC1 <- as(ID %*% obj1 at Curve, "EuclRandVariable")
+ IC2 <- as(ID %*% obj2 at Curve, "EuclRandVariable")
-
- obj <- obj3
- if(is(obj, "IC"))
- {
- if(!identical(L2Fam1c,obj at CallL2Fam))
+ if(is(obj3, "IC")){
+ if(!identical(CallL2Fam(obj1),CallL2Fam(obj3)))
stop("ICs need to be defined for the same model")
- IC3 <- as(diag(dims) %*% obj3 at Curve, "EuclRandVariable")
- }
+ IC3 <- as(ID %*% obj3 at Curve, "EuclRandVariable")
+ }
- obj <- obj4
- if(is(obj, "IC"))
- {
- if(!identical(L2Fam1c,obj at CallL2Fam))
+ if(is(obj4, "IC")){
+ if(!identical(CallL2Fam(obj1),CallL2Fam(obj4)))
stop("ICs need to be defined for the same model")
- IC4 <- as(diag(dims) %*% obj4 at Curve, "EuclRandVariable")
- }
+ IC4 <- as(ID %*% obj4 at Curve, "EuclRandVariable")
+ }
lineT <- NA
.mpresubs <- function(inx)
- distr:::.presubs(inx, c(paste("%C",1:ncomp,sep=""),
- "%D",
- paste("%A",1:ncomp,sep="")),
- c(as.character(class(obj1)[1]),
- as.character(class(obj2)[1]),
- if(is.null(obj3))NULL else as.character(class(obj3)[1]),
- if(is.null(obj4))NULL else as.character(class(obj4)[1]),
- as.character(date()),
- xc))
-
+ distr:::.presubs(inx, c(paste("%C",1:ncomp,sep=""),
+ "%D",
+ paste("%A",1:ncomp,sep="")),
+ c(as.character(class(obj1)[1]),
+ as.character(class(obj2)[1]),
+ if(is.null(obj3))NULL else as.character(class(obj3)[1]),
+ if(is.null(obj4))NULL else as.character(class(obj4)[1]),
+ as.character(date()),
+ xc))
+
mainL <- FALSE
if (hasArg(main)){
- mainL <- TRUE
- if (is.logical(main)){
- if (!main) mainL <- FALSE
- else
- main <- paste(gettextf("Plot for ICs"),
- paste("%A", 1:ncomp, sep="", collapse=", "),
- sep=" ") ###
- ### double %% as % is special for gettextf
- }
- main <- .mpresubs(main)
- if (mainL) {
- if(missing(tmar))
- tmar <- 5
- if(missing(cex.inner))
- cex.inner <- .65
- lineT <- 0.6
- }
- }
+ mainL <- TRUE
+ if (is.logical(main)){
+ if (!main) mainL <- FALSE else
+ main <- paste(gettextf("Plot for ICs"),
+ paste("%A", 1:ncomp, sep="", collapse=", "),
+ sep=" ")
+ }
+ main <- .mpresubs(main)
+ if (mainL) {
+ if(missing(tmar)) tmar <- 5
+ if(missing(cex.inner)) cex.inner <- .65
+ lineT <- 0.6
+ }
+ }
subL <- FALSE
if (hasArg(sub)){
- subL <- TRUE
- if (is.logical(sub)){
- if (!sub) subL <- FALSE
- else sub <- gettextf("generated %%D")
- ### double %% as % is special for gettextf
- }
- sub <- .mpresubs(sub)
- if (subL)
- if (missing(bmar)) bmar <- 6
- }
- mnm <- names(L2Fam at param@main)
- mnms <- if(is.null(mnm)) NULL else paste("'", mnm, "' = ", sep = "")
- innerParam <- paste(gettext("\nwith main parameter ("),
- paste(mnms, round(L2Fam at param@main, 3),
- collapse = ", "),
- ")", sep = "")
- if(!is.null(L2Fam at param@nuisance)){
- nnm <- names(L2Fam at param@nuisance)
- nnms <- if(is.null(nnm)) NULL else paste("'", nnm, "' = ", sep = "")
- innerParam <- paste(innerParam,
- gettext("\nand nuisance parameter ("),
- paste(nnms, round(L2Fam at param@nuisance, 3),
- collapse = ", "),
- ")", sep ="")
+ subL <- TRUE
+ if (is.logical(sub)){
+ if (!sub) subL <- FALSE else sub <- gettextf("generated %%D")
+ }
+ sub <- .mpresubs(sub)
+ if (subL) if (missing(bmar)) bmar <- 6
}
- if(!is.null(L2Fam at param@fixed)){
- fnm <- names(L2Fam at param@fixed)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 530
More information about the Robast-commits
mailing list