[Robast-commits] r952 - branches/robast-1.1/pkg/ROptEst/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jul 17 09:52:57 CEST 2018
Author: ruckdeschel
Date: 2018-07-17 09:52:57 +0200 (Tue, 17 Jul 2018)
New Revision: 952
Modified:
branches/robast-1.1/pkg/ROptEst/R/AllPlot.R
branches/robast-1.1/pkg/ROptEst/R/cniperCont.R
branches/robast-1.1/pkg/ROptEst/R/comparePlot.R
branches/robast-1.1/pkg/ROptEst/R/getAsRisk.R
branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R
branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asBias.R
branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asCov.R
branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R
branches/robast-1.1/pkg/ROptEst/R/getMaxIneff.R
branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R
branches/robast-1.1/pkg/ROptEst/R/internalutilsFromRobAStBase.R
branches/robast-1.1/pkg/ROptEst/R/lowerCaseRadius.R
branches/robast-1.1/pkg/ROptEst/R/plotWrapper.R
branches/robast-1.1/pkg/ROptEst/R/roptest.R
branches/robast-1.1/pkg/ROptEst/R/updateNorm.R
Log:
[ROptEst] branch 1.1 R-Code
+ converted calls to q() to calls to q.l()
+ additional functionality to return plot data (plotInfo) in comparePlot and cniperCont and cniperPointPlot
+ functionality to also show non-labelled points in comparePlot and cniperCont and cniperPointPlot
Modified: branches/robast-1.1/pkg/ROptEst/R/AllPlot.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/AllPlot.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/AllPlot.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -3,6 +3,7 @@
main = FALSE, inner = TRUE, sub = FALSE,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
+ with.automatic.grid = TRUE,
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"),
@@ -12,6 +13,27 @@
scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL, withSubst = TRUE){
+ args0 <- list(x = x, withSweave = withSweave,
+ main = main, inner = inner, sub = sub,
+ col.inner = col.inner, cex.inner = cex.inner,
+ bmar = bmar, tmar = tmar, with.automatic.grid = with.automatic.grid,
+ with.legend = with.legend, legend = legend, legend.bg = legend.bg,
+ legend.location = legend.location, legend.cex = legend.cex,
+ withMBR = withMBR, MBRB = MBRB, MBR.fac = MBR.fac, col.MBR = col.MBR,
+ lty.MBR = lty.MBR, lwd.MBR = lwd.MBR, n.MBR = n.MBR,
+ x.vec = x.vec, scaleX = scaleX,
+ scaleX.fct = if(!missing(scaleX.fct)) scaleX.fct else NULL,
+ scaleX.inv = if(!missing(scaleX.inv)) scaleX.inv else NULL,
+ scaleY = scaleY,
+ scaleY.fct = scaleY.fct,
+ scaleY.inv = scaleY.inv, scaleN = scaleN, x.ticks = x.ticks,
+ y.ticks = y.ticks, mfColRow = mfColRow, to.draw.arg = to.draw.arg,
+ withSubst = withSubst)
+ mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
+ plotInfo <- list(call = mc, dots=dots, args=args0)
+
mcl <- match.call(call = sys.call(sys.parent(1)), expand.dots = TRUE)
L2Fam <- eval(x at CallL2Fam); trafO <- trafo(L2Fam at param)
@@ -41,12 +63,17 @@
mcl$withMBR <- withMBR
plm <- getMethod("plot", signature(x = "IC", y = "missing"),
where="RobAStBase")
- do.call(plm, as.list(mcl[-1]), envir=parent.frame(2))
- return(invisible())
+
+ ret <- do.call(plm, as.list(mcl[-1]), envir=parent.frame(2))
+ ret$dots <- ret$args <- ret$call <- NULL
+ plotInfo <- c(plotInfo, ret)
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+
+ return(invisible(plotInfo))
})
.getExtremeCoordIC <- function(IC, D, indi, n = 10000){
- x <- q(D)(seq(1/2/n,1-1/2/n, length=n))
+ x <- q.l(D)(seq(1/2/n,1-1/2/n, length=n))
y <- (matrix(evalIC(IC,matrix(x,ncol=1)),ncol=n))[indi,,drop=FALSE]
return(cbind(min=apply(y,1,min),max=apply(y,1,max)))
-}
\ No newline at end of file
+}
Modified: branches/robast-1.1/pkg/ROptEst/R/cniperCont.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/cniperCont.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/cniperCont.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -12,9 +12,11 @@
L2Fam, # L2Family
IC, # IC1 in cniperContPlot and eta in cniperPointPlot
jit.fac,
- jit.tol
+ jit.tol,
+ plotInfo
){
dotsP <- .makedotsP(dots)
+ dotsP$attr.pre <- NULL
al <- dotsP$alpha.trsp
if(!is.null(al)) if(!is.na(al))
@@ -27,22 +29,73 @@
sel <- .SelectOrderData(data, function(x)sapply(x,fun),
- dots$which.lbs, dots$which.Order)
+ dots$which.lbs, dots$which.Order,
+ dots$which.nonlbs)
i.d <- sel$ind
i0.d <- sel$ind1
y.d <- sel$y
x.d <- sel$data
n <- length(i.d)
+ i.d.ns <- sel$ind.ns
+ y.d.ns <- sel$y.ns
+ x.d.ns <- sel$data.ns
+ n.ns <- length(i.d.ns)
+ if(dots$attr.pre){
+ col.pts <- col.pts[sel$ind]
+ col.npts <- col.pts[sel$ind.ns]
+ pch.pts <- pch.pts[sel$ind]
+ pch.npts <- pch.pts[sel$ind.ns]
+ cex.pts <- cex.pts[sel$ind]
+ cex.npts <- cex.pts[sel$ind.ns]
+ lab.pts <- lab.pts[sel$ind]
+ }else{
+ if(missing(pch.pts)) pch.pts <- 1
+ if(!length(pch.pts)==n)
+ pch.pts <- rep(pch.pts, length.out= n)
+ if(missing(col.pts)) col.pts <- par("col")
+ if(!length(col.pts)==n)
+ col.pts <- rep(col.pts, length.out= n)
+ if(missing(cex.pts)) cex.pts <- 1
+ if(!length(cex.pts)==n)
+ cex.pts <- rep(cex.pts, length.out= n)
+ lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
+
+ if(missing(pch.npts)) pch.npts <- 1
+ if(!length(pch.npts)==n.ns)
+ pch.npts <- rep(pch.npts, length.out= n.ns)
+ if(missing(col.npts)) col.npts <- par("col")
+ if(!length(col.npts)==n.ns)
+ col.npts <- rep(col.npts, length.out= n.ns)
+ if(missing(cex.npts)) cex.npts <- 1
+ if(!length(cex.npts)==n.ns)
+ cex.npts <- rep(cex.npts, length.out= n.ns)
+ }
+ pL <- dots$panel.last
+ dotsP$panel.last <- NULL
+
+
resc.dat <- .rescalefct(x.d, function(x) sapply(x,fun),
dots$scaleX, dots$scaleX.fct, dots$scaleX.inv,
dots$scaleY, dots$scaleY.fct,
dots$xlim, dots$ylim, dots)
+ plotInfo$resc.dat <- resc.dat
+ resc.dat.ns <- .rescalefct(x.d.ns, function(x) sapply(x,fun),
+ dots$scaleX, dots$scaleX.fct, dots$scaleX.inv,
+ dots$scaleY, dots$scaleY.fct,
+ dots$xlim, dots$ylim, dots)
+
+ plotInfo$resc.dat.ns <- resc.dat.ns
+
if(any(.isReplicated(resc.dat$X, jit.tol))&&jit.fac>0)
resc.dat$X <- jitter(resc.dat$X, factor = jit.fac)
if(any(.isReplicated(resc.dat$Y, jit.tol))&&jit.fac>0)
resc.dat$Y <- jitter(resc.dat$Y, factor = jit.fac)
+ if(any(.isReplicated(resc.dat.ns$X, jit.tol))&&jit.fac>0)
+ resc.dat.ns$X <- jitter(resc.dat.ns$X, factor = jit.fac)
+ if(any(.isReplicated(resc.dat.ns$Y, jit.tol))&&jit.fac>0)
+ resc.dat.ns$Y <- jitter(resc.dat.ns$Y, factor = jit.fac)
dotsP$scaleX <- dotsP$scaleY <- dotsP$scaleN <-NULL
dotsP$scaleX.fct <- dotsP$scaleY.fct <- NULL
@@ -52,7 +105,7 @@
dotsP$return.Order <- dotsP$cex.pts.fun <- NULL
dotsP$x.ticks <- dotsP$y.ticks <- NULL
dotsP$lab.font <- dotsP$which.lbs <- dotsP$which.lbs <- NULL
-
+ dotsP$which.nonlbs <- dotsP$attr.pre <- NULL
dotsP$x <- resc.dat$X
dotsP$y <- resc.dat$Y
@@ -74,15 +127,31 @@
dotsT$cex <- dotsP$cex/2
dotsP$cex <- .cexscale(absy,absy,cex=dots$cex.pts, fun = dots$cex.pts.fun)
dotsP$col <- dots$col.pts
+ dotsP$pch <- dots$pch.pts
dotsT$pch <- NULL
dotsT$labels <- if(is.null(dots$lab.pts)) i.d else dots$lab.pts[i.d]
do.call(points,dotsP)
+ plotInfo$PointSArg <- dotsP
+ dotsP$x <- resc.dat.ns$X
+ dotsP$y <- resc.dat.ns$Y
+ dotsP$cex <- .cexscale(absy,absy,cex=dots$cex.npts, fun = dots$cex.npts.fun)
+ dotsP$col <- dots$col.npts
+ dotsP$pch <- dots$pch.npts
+ do.call(points,dotsP)
+ plotInfo$PointSnsArg <- dotsP
+
+ plotInfo$labArg <- dotsT
+
if(!is.null(dots$with.lab))
if(dots$with.lab) do.call(text,dotsT)
+
+ plotInfo$retV <- i0.d
+
if(!is.null(dots$return.Order))
if(dots$return.Order) return(i0.d)
- return(invisible(NULL))
+
+ return(invisible(plotInfo))
}
@@ -123,21 +192,52 @@
cniperCont <- function(IC1, IC2, data = NULL, ...,
neighbor, risk, lower=getdistrOption("DistrResolution"),
upper=1-getdistrOption("DistrResolution"), n = 101,
+ with.automatic.grid = 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, cex.pts.fun = NULL, col.pts = par("col"),
- pch.pts = 19, jit.fac = 1, jit.tol = .Machine$double.eps, with.lab = FALSE,
+ pch.pts = 19, cex.npts = 0.6, cex.npts.fun = NULL,
+ col.npts = "red", pch.npts = 20, jit.fac = 1,
+ jit.tol = .Machine$double.eps, with.lab = FALSE,
lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
which.lbs = NULL, which.Order = NULL,
- return.Order = FALSE,
- draw.nonlbl = TRUE, ## should non-labelled observations also be drawn?
- cex.nonlbl = 0.3, ## character expansion(s) for non-labelled observations
- pch.nonlbl = ".", ## plotting symbol(s) for non-labelled observations
+ which.nonlbs = NULL, attr.pre = FALSE,
+ return.Order = FALSE,
withSubst = TRUE){
+ args0 <- list(IC1 = IC1, IC2 = IC2, data = data,
+ neighbor = if(missing(neighbor)) NULL else neighbor,
+ risk= if(missing(risk)) NULL else risk,
+ lower=lower, upper=upper, n = n,
+ with.automatic.grid = with.automatic.grid,
+ scaleX = scaleX,
+ scaleX.fct = if(missing(scaleX.fct)) NULL else scaleX.fct,
+ scaleX.inv = if(missing(scaleX.inv)) NULL else scaleX.inv,
+ scaleY = scaleY,
+ scaleY.fct = scaleY.fct,
+ scaleY.inv = scaleY.inv, scaleN = scaleN,
+ x.ticks = x.ticks, y.ticks = y.ticks,
+ cex.pts = cex.pts, cex.pts.fun = cex.pts.fun,
+ col.pts = col.pts, pch.pts = pch.pts,
+ cex.npts = cex.npts, cex.npts.fun = cex.npts.fun,
+ col.npts = col.npts, pch.npts = pch.npts,
+ jit.fac = jit.fac, jit.tol = jit.tol,
+ with.lab = with.lab,
+ lab.pts = lab.pts, lab.font = lab.font,
+ alpha.trsp = alpha.trsp,
+ which.lbs = which.lbs, which.Order = which.Order,
+ which.nonlbs = which.nonlbs, attr.pre = attr.pre,
+ return.Order = return.Order, withSubst = withSubst)
+
+
mcD <- match.call(expand.dots = FALSE)
+ mc <- match.call(expand.dots = TRUE)
dots <- as.list(mcD$"...")
+ plotInfo <- list(call = mc, dots=dots, args=args0)
+
+ mcD <- match.call(expand.dots = FALSE)
+ dots <- as.list(mcD$"...")
mc <- match.call(#call = sys.call(sys.parent(1)),
expand.dots = TRUE)
mcl <- as.list(mc[-1])
@@ -155,6 +255,8 @@
))
}else function(inx)inx
+ plotInfo$.mpresubs <- .mpresubs
+
if(!is.null(dots$main)) dots$main <- .mpresubs(dots$main)
if(!is.null(dots$sub)) dots$sub <- .mpresubs(dots$sub)
if(!is.null(dots$xlab)) dots$xlab <- .mpresubs(dots$xlab)
@@ -174,21 +276,23 @@
dots$fromCniperPlot <- NULL
fun <- .getFunCnip(IC1,IC2, risk, L2Fam, neighbor at radius, b20)
+ plotInfo$CnipFun <- fun
if(missing(scaleX.fct)){
scaleX.fct <- p(L2Fam)
- scaleX.inv <- q(L2Fam)
+ scaleX.inv <- q.l(L2Fam)
}
if("lower" %in% names(as.list(mc))) lower <- p(L2Fam)(lower)
if("upper" %in% names(as.list(mc))) upper <- p(L2Fam)(upper)
- x <- q(L2Fam)(seq(lower,upper,length=n))
+ x <- q.l(L2Fam)(seq(lower,upper,length=n))
if(is(distribution(L2Fam), "DiscreteDistribution"))
- x <- seq(q(L2Fam)(lower),q(L2Fam)(upper),length=n)
+ x <- seq(q.l(L2Fam)(lower),q.l(L2Fam)(upper),length=n)
resc <- .rescalefct(x, fun, scaleX, scaleX.fct,
scaleX.inv, scaleY, scaleY.fct, dots$xlim, dots$ylim, dots)
+ plotInfo$resc <- resc
dotsPl <- dots
dotsPl$x <- resc$X
@@ -219,8 +323,12 @@
dotsPl$lty <- ltyo[[1]]
}
}
+
+ plotInfo$plotArgs <- dotsPl
do.call(plot,dotsPl)
+ plotInfo$usr <- par("usr")
+
dots$x <- dots$y <- NULL
dotsl <- .makedotsLowLevel(dots)
if(colSet) dotsl$col <- colo[2]
@@ -229,10 +337,15 @@
dotsl$h <- if(scaleY) scaleY.fct(0) else 0
do.call(abline, dotsl)
+ plotInfo$abline <- dotsl
.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)
+ plotInfo$Axis <- list(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)){
dots$scaleX <- scaleX
dots$scaleX.fct <- scaleX.fct
@@ -247,19 +360,31 @@
dots$cex.pts.fun <- cex.pts.fun
dots$col.pts <- col.pts
dots$pch.pts <- pch.pts
- dots$jit.fac <- jit.fac
- dots$jit.tol <- jit.tol
+ dots$cex.npts <- cex.npts
+ dots$cex.npts.fun <- cex.npts.fun
+ dots$col.npts <- col.npts
+ dots$pch.npts <- pch.npts
dots$with.lab <- with.lab
dots$lab.pts <- lab.pts
dots$lab.font <- lab.font
dots$alpha.trsp <- alpha.trsp
dots$which.lbs <- which.lbs
+ dots$which.nonlbs <- which.nonlbs
dots$which.Order <- which.Order
dots$return.Order <- return.Order
+ dots$attr.pre <- attr.pre
- return(.plotData(data=data, dots=dots, fun=fun, L2Fam=L2Fam, IC=IC1, jit.fac=jit.fac, jit.tol=jit.tol))
+ dots$return.Order <- FALSE
+ plotInfo$PlotData <- list(data=data, dots=dots, fun=fun, L2Fam=L2Fam,
+ IC=IC1, jit.fac=jit.fac, jit.tol=jit.tol)
+ retV <- .plotData(data=data, dots=dots, fun=fun, L2Fam=L2Fam,
+ IC=IC1, jit.fac=jit.fac, jit.tol=jit.tol, plotInfo)
+
+ plotInfo <- c(plotInfo,retV)
}
- invisible(NULL)
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+ if(return.Order){return(plotInfo)}
+ invisible(plotInfo)
}
cniperPoint <- function(L2Fam, neighbor, risk= asMSE(),
@@ -269,8 +394,8 @@
mc <- match.call(expand.dots = FALSE)
- if(is.null(as.list(mc)$lower)) lower <- q(L2Fam)(lower)
- if(is.null(as.list(mc)$upper)) upper <- q(L2Fam)(upper)
+ if(is.null(as.list(mc)$lower)) lower <- q.l(L2Fam)(lower)
+ if(is.null(as.list(mc)$upper)) upper <- q.l(L2Fam)(upper)
# lower <- q(L2Fam)(lower)
# upper <- q(L2Fam)(upper)
@@ -289,24 +414,53 @@
lower=getdistrOption("DistrResolution"),
upper=1-getdistrOption("DistrResolution"), n = 101,
withMaxRisk = TRUE,
+ with.automatic.grid = 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, cex.pts.fun = NULL, col.pts = par("col"),
- pch.pts = 19, jit.fac = 1, jit.tol = .Machine$double.eps,
+ pch.pts = 19,
+ cex.npts = 1, cex.npts.fun = NULL, col.npts = par("col"),
+ pch.npts = 19,
+ jit.fac = 1, jit.tol = .Machine$double.eps,
with.lab = FALSE,
lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
- which.lbs = NULL, which.Order = NULL,
- return.Order = FALSE,
- draw.nonlbl = TRUE, ## should non-labelled observations also be drawn?
- cex.nonlbl = 0.3, ## character expansion(s) for non-labelled observations
- pch.nonlbl = ".", ## plotting symbol(s) for non-labelled observations
+ which.lbs = NULL, which.nonlbs = NULL,
+ which.Order = NULL, attr.pre = FALSE, return.Order = FALSE,
withSubst = TRUE){
+ args0 <- list(L2Fam = L2Fam, data=data,
+ neighbor = if(missing(neighbor)) NULL else neighbor,
+ risk= risk, lower=lower, upper=upper, n = n,
+ withMaxRisk = withMaxRisk,
+ with.automatic.grid = with.automatic.grid,
+ scaleX = scaleX,
+ scaleX.fct = if(missing(scaleX.fct)) NULL else scaleX.fct,
+ scaleX.inv = if(missing(scaleX.inv)) NULL else scaleX.inv,
+ scaleY = scaleY,
+ scaleY.fct = scaleY.fct,
+ scaleY.inv = scaleY.inv, scaleN = scaleN,
+ x.ticks = x.ticks, y.ticks = y.ticks,
+ cex.pts = cex.pts, cex.pts.fun = cex.pts.fun,
+ col.pts = col.pts, pch.pts = pch.pts,
+ cex.npts = cex.npts, cex.npts.fun = cex.npts.fun,
+ col.npts = col.npts, pch.npts = pch.npts,
+ jit.fac = jit.fac, jit.tol = jit.tol,
+ with.lab = with.lab,
+ lab.pts = lab.pts, lab.font = lab.font,
+ alpha.trsp = alpha.trsp,
+ which.lbs = which.lbs, which.Order = which.Order,
+ which.nonlbs = which.nonlbs, attr.pre = attr.pre,
+ return.Order = return.Order, withSubst = withSubst)
+
mc0 <- match.call(#call = sys.call(sys.parent(1)),
expand.dots = FALSE)
mc <- match.call(#call = sys.call(sys.parent(1)),
expand.dots = TRUE)
+ dots <- match.call(expand.dots = FALSE)$"..."
+ plotInfo <- list(call = mc, dots=dots, args=args0)
+
+
mcl <- as.list(mc[-1])
dots <- as.list(mc0$"...")
L2Famc <- as.character(deparse(L2Fam))
@@ -319,6 +473,7 @@
as.character(date())
))
}else function(inx)inx
+ plotInfo$.mpresubs <- .mpresubs
if(!is.null(dots$main)) dots$main <- .mpresubs(dots$main)
if(!is.null(dots$sub)) dots$sub <- .mpresubs(dots$sub)
@@ -341,18 +496,29 @@
if(withMaxRisk) mcl$fromCniperPlot <- TRUE
mcl$withMaxRisk <- NULL
mcl$withSubst <- FALSE
- do.call(cniperCont, mcl)
+ mcl$return.Order <- FALSE
+ plotInfo$PlotCall <- mcl
+ ret <- do.call(cniperCont, mcl)
+ ret$args <- ret$dots <- ret$call <- NULL
+ ret$.mpresubs <- NULL
+ plotInfo <- c(plotInfo, ret)
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+ if(return.Order){return(plotInfo)}
+ invisible(plotInfo)
}
.cexscale <- function(y, y1=y, maxcex=4,mincex=0.05,cex, fun=NULL){
+ if(length(y)==0||is.null(y)) return(NA)
+ if(is.list(y)) if(is.null(y[[1]])) return(NA)
if(is.null(fun)) fun <- function(x) log(1+abs(x))
ly <- fun(y)
ly1 <- fun(unique(c(y,y1)))
my <- min(ly1,na.rm=TRUE)
My <- max(ly1,na.rm=TRUE)
- ly0 <- (ly-my)/My
+ ly0 <- (ly-my)/(My-my)
ly1 <- ly0*(maxcex-mincex)+mincex
return(cex*ly1)
}
+
Modified: branches/robast-1.1/pkg/ROptEst/R/comparePlot.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/comparePlot.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/comparePlot.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -3,23 +3,59 @@
setMethod("comparePlot", signature("IC","IC"),
function(obj1,obj2, obj3 = NULL, obj4 = NULL, data = NULL,
..., withSweave = getdistrOption("withSweave"),
+ forceSameModel = forceSameModel,
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.automatic.grid = TRUE,
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, n.MBR = 10000,
- scaleX = FALSE, scaleX.fct, scaleX.inv,
+ x.vec = NULL, 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,
+ cex.pts = 1, cex.pts.fun = NULL,
+ col.pts = par("col"), pch.pts = 1,
+ cex.npts = 1, cex.npts.fun = NULL,
+ col.npts = par("col"), pch.npts = 2,
+ jitter.fac = 1, with.lab = FALSE,
lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
- which.lbs = NULL, which.Order = NULL, return.Order = FALSE){
+ which.lbs = NULL, which.Order = NULL, which.nonlbs = NULL,
+ attr.pre = FALSE, return.Order = FALSE, withSubst = TRUE){
+ args0 <- list(obj1 = obj1, obj2 = obj2, obj3 = obj3, obj4 = obj4,
+ data = data, withSweave = withSweave, forceSameModel = forceSameModel,
+ main = main, inner = inner, sub = sub, col = col, lwd = lwd,
+ lty = if(!missing(lty)) lty else NULL,
+ col.inner = col.inner, cex.inner = cex.inner,
+ bmar = bmar, tmar = tmar, with.automatic.grid = with.automatic.grid,
+ with.legend = with.legend, legend = legend, legend.bg = legend.bg,
+ legend.location = legend.location, legend.cex = legend.cex,
+ withMBR = withMBR, MBRB = MBRB, MBR.fac = MBR.fac, col.MBR = col.MBR,
+ lty.MBR = lty.MBR, lwd.MBR = lwd.MBR, n.MBR = n.MBR,
+ x.vec = x.vec, scaleX = scaleX,
+ scaleX.fct = if(!missing(scaleX.fct)) scaleX.fct else NULL,
+ scaleX.inv = if(!missing(scaleX.inv)) scaleX.inv else NULL,
+ scaleY = scaleY, scaleY.fct = scaleY.fct,
+ scaleY.inv = scaleY.inv, scaleN = scaleN, x.ticks = x.ticks,
+ y.ticks = y.ticks, mfColRow = mfColRow, to.draw.arg = to.draw.arg,
+ cex.pts = cex.pts, cex.pts.fun = cex.pts.fun, col.pts = col.pts,
+ pch.pts = pch.pts, cex.npts = cex.npts, cex.npts.fun = cex.npts.fun,
+ col.npts = col.npts, pch.npts = pch.npts,
+ jitter.fac = jitter.fac, with.lab = with.lab, lab.pts = lab.pts,
+ lab.font = lab.font, alpha.trsp = alpha.trsp,
+ which.lbs = which.lbs, which.Order = which.Order,
+ which.nonlbs = which.nonlbs, attr.pre = attr.pre,
+ return.Order = return.Order, withSubst = withSubst)
+
+ .mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
+ plotInfo <- list(call = .mc, dots=dots, args=args0)
+
mcl <- match.call(call = sys.call(sys.parent(1)), expand.dots = TRUE)
L2Fam <- eval(obj1 at CallL2Fam); trafO <- trafo(L2Fam at param)
@@ -47,7 +83,11 @@
}
mcl$MBRB <- MBRB
mcl$withMBR <- withMBR
- do.call(.oldcomparePlot, as.list(mcl[-1]),
- envir=parent.frame(2))
- return(invisible())
+ ret <- do.call(.oldcomparePlot, as.list(mcl[-1]),
+ envir=parent.frame(2))
+ ret$dots <- ret$args <- ret$call <- NULL
+ plotInfo <- c(plotInfo, ret)
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+
+ return(invisible(plotInfo))
})
Modified: branches/robast-1.1/pkg/ROptEst/R/getAsRisk.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getAsRisk.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/getAsRisk.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -38,7 +38,7 @@
neighbor = "ContNeighborhood",
biastype = "ANY"),
function(risk, L2deriv, neighbor, biastype, normtype = NULL, clip = NULL, cent = NULL, stand = NULL, trafo, ...){
- z <- q(L2deriv)(0.5)
+ z <- q.l(L2deriv)(0.5)
bias <- abs(as.vector(trafo))/E(L2deriv, function(x, z){abs(x - z)},
useApply = FALSE, z = z)
@@ -321,7 +321,7 @@
nu1 <- nu(biastype)[1]
nu2 <- nu(biastype)[2]
num <- nu2/(nu1+nu2)
- z <- q(L2deriv)(num)
+ z <- q.l(L2deriv)(num)
Int <- E(L2deriv, function(x, m){abs(x-m)}, m = z)
omega <- 2/(Int/nu1+Int/nu2)
bias <- abs(as.vector(trafo))*omega
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -47,7 +47,7 @@
} else f.low <- NULL
if(is.null(upper))
- upper <- max(4*lower,q(L2deriv)(eff^.5)*3)
+ upper <- max(4*lower,q.l(L2deriv)(eff^.5)*3)
e.up <- 0
while(e.up < eff){
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asBias.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asBias.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asBias.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -119,7 +119,7 @@
trafo, maxiter, tol, warn, Finfo, verbose = NULL){
zi <- sign(as.vector(trafo))
A <- as.matrix(zi)
- z <- q(L2deriv)(0.5)
+ z <- q.l(L2deriv)(0.5)
b <- zi*as.vector(trafo)/E(L2deriv, function(x, z){abs(x - z)}, z = z)
if(is(L2deriv, "AbscontDistribution"))
@@ -320,7 +320,7 @@
nu2 <- nu(biastype)[2]
zi <- sign(as.vector(trafo))
A <- as.matrix(zi)
- z <- q(L2deriv)(nu1/(nu1+nu2))
+ z <- q.l(L2deriv)(nu1/(nu1+nu2))
b <- zi*as.vector(trafo)/E(L2deriv, function(x, z){(x - z)*(x>z)/nu2 +
(z-x)*(z>x)/nu1}, z = z)
@@ -370,7 +370,7 @@
gettext(
"'tol'+ w_inf, w_inf = -1/inf_P psi or 1/sup_P psi).\n"
))
- w <- if(sign(biastype)>0) -1/q(L2deriv)(0) else 1/q(L2deriv)(1)
+ w <- if(sign(biastype)>0) -1/q.l(L2deriv)(0) else 1/q.l(L2deriv)(1)
if(warn) cat(warntxt)
bd <- tol + w
while (!is.list(try(
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asCov.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asCov.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asCov.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -12,7 +12,7 @@
info <- c("optimal IC in sense of Cramer-Rao bound")
A <- trafo %*% solve(Finfo)
- b <- abs(as.vector(A))*max(abs(q(L2deriv)(1)),abs(q(L2deriv)(0)))
+ b <- abs(as.vector(A))*max(abs(q.l(L2deriv)(1)),abs(q.l(L2deriv)(0)))
asCov <- A %*% t(trafo)
r <- neighbor at radius
@@ -44,8 +44,8 @@
info <- c("optimal IC in sense of Cramer-Rao bound")
A <- trafo %*% solve(Finfo)
- b <- abs(as.vector(A))*(q(L2deriv)(1)-q(L2deriv)(0))
- a <- -abs(as.vector(A))*q(L2deriv)(0)
+ b <- abs(as.vector(A))*(q.l(L2deriv)(1)-q.l(L2deriv)(0))
+ a <- -abs(as.vector(A))*q.l(L2deriv)(0)
asCov <- A %*% t(trafo)
r <- neighbor at radius
Risk <- list(asCov = asCov,
@@ -83,8 +83,8 @@
A <- trafo %*% solve(Finfo)
IC <- A %*% L2deriv
if(is(Distr, "UnivariateDistribution")){
- lower <- ifelse(is.finite(q(Distr)(0)), q(Distr)(1e-8), q(Distr)(0))
- upper <- ifelse(is.finite(q(Distr)(1)), q(Distr)(1-1e-8), q(Distr)(1))
+ lower <- ifelse(is.finite(q.l(Distr)(0)), q.l(Distr)(1e-8), q.l(Distr)(0))
+ upper <- ifelse(is.finite(q.l(Distr)(1)), q.l(Distr)(1-1e-8), q.l(Distr)(1))
x <- seq(from = lower, to = upper, length = 1e5)
x <- x[x!=0] # problems with NaN=log(0)!
ICx <- evalRandVar(IC, as.matrix(x))
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -18,7 +18,7 @@
b <- risk at bound
if(checkBounds){
- bmax <- abs(as.vector(A))*max(abs(q(L2deriv)(0)), q(L2deriv)(1))
+ bmax <- abs(as.vector(A))*max(abs(q.l(L2deriv)(0)), q.l(L2deriv)(1))
if(b >= bmax){
if(warn) cat("'b >= maximum asymptotic bias' => (classical) optimal IC\n",
"in sense of Cramer-Rao bound is returned\n")
Modified: branches/robast-1.1/pkg/ROptEst/R/getMaxIneff.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getMaxIneff.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/getMaxIneff.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -74,4 +74,4 @@
}
-
\ No newline at end of file
+
Modified: branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R 2018-07-16 21:32:40 UTC (rev 951)
+++ branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R 2018-07-17 07:52:57 UTC (rev 952)
@@ -1,155 +1,155 @@
-###############################################################################
-## internal functions/methods to fill slot modifyIC
-###############################################################################
-
-setMethod("getModifyIC", signature(L2FamIC = "L2ParamFamily",
- neighbor = "Neighborhood", risk = "asRisk"),
- function(L2FamIC, neighbor, risk, ...){
- dots <- list(...)
- dots$verbose <- NULL
- modIC <- function(L2Fam, IC){}
- body(modIC) <- substitute({ verbose <- getRobAStBaseOption("all.verbose")
- infMod <- InfRobModel(L2Fam, nghb)
- do.call(optIC, args = c(list(infMod, risk=R),
- dots0)) },
- list(nghb = neighbor, R = risk, dots0 = dots))
- return(modIC)
- })
-
-setMethod("getModifyIC", signature(L2FamIC = "L2LocationFamily",
- neighbor = "UncondNeighborhood", risk = "asGRisk"),
- function(L2FamIC, neighbor, risk, ...){
- modIC <- function(L2Fam, IC){
- D <- distribution(eval(CallL2Fam(IC)))
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 952
More information about the Robast-commits
mailing list