[Robast-commits] r1031 - in pkg/RobAStBase: . R inst inst/doc man tests/Examples
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jul 23 22:15:10 CEST 2018
Author: ruckdeschel
Date: 2018-07-23 22:15:10 +0200 (Mon, 23 Jul 2018)
New Revision: 1031
Added:
pkg/RobAStBase/R/getFiRisk.R
pkg/RobAStBase/R/internalSelectLabel.R
pkg/RobAStBase/R/plotUtils.R
pkg/RobAStBase/R/ptnorm-convtnorm.R
pkg/RobAStBase/R/returnlevelplot.R
pkg/RobAStBase/man/getFiRisk.Rd
pkg/RobAStBase/man/returnlevelplot.Rd
Removed:
pkg/RobAStBase/R/getFiRisk.R
pkg/RobAStBase/R/plotUtils.R
pkg/RobAStBase/man/getFiRisk.Rd
Modified:
pkg/RobAStBase/DESCRIPTION
pkg/RobAStBase/NAMESPACE
pkg/RobAStBase/R/AllPlot.R
pkg/RobAStBase/R/IC.R
pkg/RobAStBase/R/comparePlot.R
pkg/RobAStBase/R/cutoff-class.R
pkg/RobAStBase/R/ddPlot.R
pkg/RobAStBase/R/ddPlot_utils.R
pkg/RobAStBase/R/getBiasIC.R
pkg/RobAStBase/R/getRiskIC.R
pkg/RobAStBase/R/infoPlot.R
pkg/RobAStBase/R/internalGridHelpers.R
pkg/RobAStBase/R/kStepEstimator.R
pkg/RobAStBase/R/oneStepEstimator.R
pkg/RobAStBase/R/optIC.R
pkg/RobAStBase/R/outlyingPlot.R
pkg/RobAStBase/R/plotRescaledAxis.R
pkg/RobAStBase/R/plotWrapper.R
pkg/RobAStBase/R/qqplot.R
pkg/RobAStBase/R/selectorder.R
pkg/RobAStBase/R/utils.R
pkg/RobAStBase/inst/NEWS
pkg/RobAStBase/inst/TOBEDONE
pkg/RobAStBase/inst/doc/InfluenceCurve.eps
pkg/RobAStBase/inst/doc/InfluenceCurve.pdf
pkg/RobAStBase/inst/doc/Neighborhood.eps
pkg/RobAStBase/inst/doc/Neighborhood.pdf
pkg/RobAStBase/inst/doc/RobModel.eps
pkg/RobAStBase/inst/doc/RobModel.pdf
pkg/RobAStBase/inst/doc/RobWeight.eps
pkg/RobAStBase/inst/doc/RobWeight.pdf
pkg/RobAStBase/man/0RobAStBase-package.Rd
pkg/RobAStBase/man/ComparePlotWrapper.Rd
pkg/RobAStBase/man/HampIC-class.Rd
pkg/RobAStBase/man/InfoPlotWrapper.Rd
pkg/RobAStBase/man/PlotICWrapper.Rd
pkg/RobAStBase/man/comparePlot.Rd
pkg/RobAStBase/man/ddPlot-methods.Rd
pkg/RobAStBase/man/getBiasIC.Rd
pkg/RobAStBase/man/getRiskIC.Rd
pkg/RobAStBase/man/infoPlot.Rd
pkg/RobAStBase/man/internal_GridHelpers.Rd
pkg/RobAStBase/man/internal_plots.Rd
pkg/RobAStBase/man/internals.Rd
pkg/RobAStBase/man/internals_ddPlot.Rd
pkg/RobAStBase/man/kStepEstimator.Rd
pkg/RobAStBase/man/makeIC-methods.Rd
pkg/RobAStBase/man/oneStepEstimator.Rd
pkg/RobAStBase/man/optIC.Rd
pkg/RobAStBase/man/outlyingPlotIC.Rd
pkg/RobAStBase/man/plot-methods.Rd
pkg/RobAStBase/man/qqplot.Rd
pkg/RobAStBase/tests/Examples/RobAStBase-Ex.Rout.save
Log:
[RobAStBase] merged branch 1.1 to trunk
Modified: pkg/RobAStBase/DESCRIPTION
===================================================================
--- pkg/RobAStBase/DESCRIPTION 2018-07-23 20:09:27 UTC (rev 1030)
+++ pkg/RobAStBase/DESCRIPTION 2018-07-23 20:15:10 UTC (rev 1031)
@@ -1,18 +1,22 @@
Package: RobAStBase
-Version: 1.0.2
-Date: 2018-05-29
+Version: 1.1.0
+Date: 2018-07-08
Title: Robust Asymptotic Statistics
Description: Base S4-classes and functions for robust asymptotic statistics.
-Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2), RandVar(>= 0.9.2)
+Depends: R(>= 2.14.0), methods, rrcov, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2),
+ RandVar(>= 0.9.2)
Suggests: ROptEst, RUnit (>= 0.4.26)
Imports: startupmsg
-Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"), email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel",
- role=c("aut", "cph")), person("Mykhailo", "Pupashenko", role="ctb", comment="contributed wrapper functions for diagnostic
- plots"), person("Gerald", "Kroisandt", role="ctb", comment="contributed testing routines"), person("R Core Team", role = c("ctb", "cph"), comment="for source file 'format.perc'"))
+Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph", "aut"),
+ email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel",role=c("aut", "cph")),
+ person("Mykhailo", "Pupashenko", role="ctb", comment="contributed wrapper functions for
+ diagnostic plots"), person("Gerald", "Kroisandt", role="ctb", comment="contributed
+ testing routines"), person("R Core Team", role = c("ctb", "cph"), comment="for source
+ file 'format.perc'"))
ByteCompile: yes
License: LGPL-3
Encoding: latin1
URL: http://robast.r-forge.r-project.org/
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-SVNRevision: 930
+VCS/SVNRevision: 940
Modified: pkg/RobAStBase/NAMESPACE
===================================================================
--- pkg/RobAStBase/NAMESPACE 2018-07-23 20:09:27 UTC (rev 1030)
+++ pkg/RobAStBase/NAMESPACE 2018-07-23 20:15:10 UTC (rev 1031)
@@ -69,7 +69,7 @@
exportMethods("moveL2Fam2RefParam",
"moveICBackFromRefParam",
"rescaleFunction")
-exportMethods("ddPlot", "qqplot")
+exportMethods("ddPlot", "qqplot", "returnlevelplot")
exportMethods("cutoff.quantile", "cutoff.quantile<-")
exportMethods("samplesize<-", "samplesize")
exportMethods("getRiskFctBV", "getFiRisk")
@@ -85,4 +85,4 @@
export("getRiskFctBV")
export(".rescalefct",".plotRescaledAxis",".makedotsP",".makedotsLowLevel",".SelectOrderData")
export(".merge.lists")
-export("InfoPlot", "ComparePlot", "PlotIC")
\ No newline at end of file
+export("InfoPlot", "ComparePlot", "PlotIC")
Modified: pkg/RobAStBase/R/AllPlot.R
===================================================================
--- pkg/RobAStBase/R/AllPlot.R 2018-07-23 20:09:27 UTC (rev 1030)
+++ pkg/RobAStBase/R/AllPlot.R 2018-07-23 20:15:10 UTC (rev 1031)
@@ -13,158 +13,135 @@
scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL, withSubst = TRUE){
- xc <- match.call(call = sys.call(sys.parent(1)))$x
+ 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,
+ 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)
+
+ xc <- mc$x
xcc <- as.character(deparse(xc))
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
dotsLeg <- dotsT <- dotsL <- .makedotsLowLevel(dots)
- .mpresubs <- if(withSubst){
- function(inx)
- .presubs(inx, c("%C", "%A", "%D" ),
- c(as.character(class(x)[1]),
- as.character(date()),
- xcc))
- }else function(inx)inx
+ dotsP <- dots
+ dotsP$type <- dotsP$lty <- dotsP$col <- dotsP$lwd <- NULL
+ dotsP$xlab <- dotsP$ylab <- NULL
- if(!is.logical(inner)){
- if(!is.list(inner))
- inner <- as.list(inner)
- #stop("Argument 'inner' must either be 'logical' or a 'list'")
- inner <- .fillList(inner,4)
- innerD <- inner[1:3]
- innerL <- inner[4]
- }else{innerD <- innerL <- inner}
+ pF.0 <- expression({})
+ if(!is.null(dots[["panel.first"]])){
+ pF.0 <- .panel.mingle(dots,"panel.first")
+ }
+ pL.0 <- expression({})
+ if(!is.null(dots[["panel.last"]])){
+ pL.0 <- .panel.mingle(dots,"panel.last")
+ }
+ dotsP$panel.first <- NULL
+ dotsP$panel.last <- NULL
-
L2Fam <- eval(x at CallL2Fam)
if(missing(scaleX.fct)){
scaleX.fct <- p(L2Fam)
- scaleX.inv <- q(L2Fam)
+ scaleX.inv <- q.l(L2Fam)
}
trafO <- trafo(L2Fam at param)
dims <- nrow(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))
- to.draw <- pmatch(to.draw.arg, dimnms)
- else if(is.numeric(to.draw.arg))
- to.draw <- to.draw.arg
- }
+ to.draw <- .getToDraw(dims, trafO, L2Fam, to.draw.arg)
dims0 <- length(to.draw)
nrows <- trunc(sqrt(dims0))
ncols <- ceiling(dims0/nrows)
- if(!is.null(x.ticks)) dots$xaxt <- "n"
+ yaxt0 <- xaxt0 <- rep("s",dims0)
+ if(!is.null(dots$xaxt)) xaxt0 <- rep(dots$xaxt, length.out=dims0)
+ if(!is.null(dots$yaxt)) yaxt0 <- rep(dots$yaxt, length.out=dims0)
+
+ logArg <- NULL
+ if(!is.null(dots[["log"]]))
+ logArg <- rep(dots[["log"]], length.out=dims0)
+ dotsP$log <- dots$log <- NULL
+
+ dotsP0 <- vector("list",dims0)
+ if(!is.null(dotsP)) for(i in 1:dims0) dotsP0[[i]] <- dotsP
+ dotsP <- dotsP0
+
+ for(i in 1:dims0){dotsP[[i]]$xaxt <- xaxt0[i];dotsP[[i]]$yaxt <- yaxt0[i]}
+
+ if(!is.null(logArg))
+ for(i in 1:dims0) dotsP[[i]]$log <- logArg[i]
+
+ if(!is.null(x.ticks)){
+ x.ticks <- .fillList(x.ticks, dims0)
+ for(i in 1:dims0){
+ if(!is.null(x.ticks[[i]]))
+ if(!is.null(logArg)) if(!grepl("x",logArg[i])) dotsP[[i]]$xaxt <- "n"
+ }
+ }
if(!is.null(y.ticks)){
y.ticks <- .fillList(y.ticks, dims0)
- dots$yaxt <- "n"
+ for(i in 1:dims0){
+ if(!is.null(y.ticks[[i]]))
+ if(!is.null(logArg)) if(!grepl("y",logArg[i])) dotsP[[i]]$yaxt <- "n"
+ }
}
+ scaleX <- rep(scaleX, length.out=dims0)
+ scaleY <- rep(scaleY, length.out=dims0)
+ scaleX <- scaleX & (xaxt0!="n")
+ scaleY <- scaleY & (yaxt0!="n")
+
+ scaleX.fct <- .fillList(scaleX.fct, dims0)
+ scaleX.inv <- .fillList(scaleX.inv, dims0)
+
scaleY.fct <- .fillList(scaleY.fct, dims0)
scaleY.inv <- .fillList(scaleY.inv, dims0)
- pF <- expression({})
- if(!is.null(dots[["panel.first"]])){
- pF <- .panel.mingle(dots,"panel.first")
- }
- ..panelFirst <- .fillList(pF,dims0)
- if(with.automatic.grid)
- ..panelFirst <- .producePanelFirstS(
- ..panelFirst,x, to.draw.arg, FALSE,
- x.ticks = x.ticks, scaleX = scaleX, scaleX.fct = scaleX.fct,
- y.ticks = y.ticks, scaleY = scaleY, scaleY.fct = scaleY.fct)
- gridS <- if(with.automatic.grid)
- substitute({grid <- function(...){}}) else expression({})
- pF <- vector("list",dims0)
- if(dims0>0)
- for(i in 1:dims0){
- pF[[i]] <- substitute({ gridS0
- pF0},
- list(pF0=..panelFirst[[i]], gridS0=gridS))
- }
+ distr <- L2Fam at distribution
+ if(!is(distr, "UnivariateDistribution")) stop("not yet implemented")
- pL <- expression({})
- if(!is.null(dots[["panel.last"]])){
- pL <- .panel.mingle(dots,"panel.last")
- }
- ..panelLast <- .fillList(pL,dims0)
- pL <- vector("list",dims0)
- if(dims0>0)
- for(i in 1:dims0)
- pL[[i]] <- if(is.null(..panelLast[[i]])) expression({}) else ..panelLast[[i]]
- dots$panel.last <- dots$panel.first <- NULL
-
MBRB <- matrix(rep(t(MBRB), length.out=dims0*2),ncol=2, byrow=T)
MBRB <- MBRB * MBR.fac
- e1 <- L2Fam at distribution
- if(!is(e1, "UnivariateDistribution")) stop("not yet implemented")
- if(is(e1, "UnivariateDistribution")){
- xlim <- eval(dots$xlim)
- if(!is.null(xlim)){
- xm <- min(xlim)
- xM <- max(xlim)
- if(!length(xlim) %in% c(2,2*dims0))
- stop("Wrong length of Argument xlim");
- xlim <- matrix(xlim, 2,dims0)
- }
- if(is(e1, "AbscontDistribution")){
- lower0 <- getLow(e1, eps = getdistrOption("TruncQuantile")*2)
- upper0 <- getUp(e1, eps = getdistrOption("TruncQuantile")*2)
- me <- median(e1); s <- IQR(e1)
- lower1 <- me - 6 * s
- upper1 <- me + 6 * s
- lower <- max(lower0, lower1)
- upper <- min(upper0, upper1)
- if(!is.null(xlim)){
- lower <- min(lower,xm)
- upper <- max(upper,xM)
- }
- h <- upper - lower
- if(is.null(x.vec)){
- if(scaleX){
- xpl <- scaleX.fct(lower - 0.1*h)
- xpu <- scaleX.fct(upper + 0.1*h)
- xp.vec <- seq(from = xpl, to = xpu, length = 1000)
- x.vec <- scaleX.inv(xp.vec)
- }else{
- x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
- }
- }
- plty <- "l"
- lty <- "solid"
- }else{
- if(!is.null(x.vec)){
- if(is(e1, "DiscreteDistribution"))
- x.vec <- intersect(x.vec,support(e1))
- }else{
- if(is(e1, "DiscreteDistribution")) x.vec <- support(e1)
- else{
- x.vec <- r(e1)(1000)
- x.vec <- sort(unique(x.vec))
- }
- }
- plty <- "p"
- lty <- "dotted"
- if(!is.null(dots$xlim)) x.vec <- x.vec[(x.vec>=xm) & (x.vec<=xM)]
+ xlim <- eval(dots$xlim)
+ ylim <- eval(dots$ylim)
+ .xylim <- .getXlimYlim(dots,dotsP, dims0, xlim, ylim)
+ dots <- .xylim$dots; dotsP <- .xylim$dotsP
+ xlim <- .xylim$xlim; ylim <- .xylim$ylim
- }
- }
- ylim <- eval(dots$ylim)
- if(!is.null(ylim)){
- if(!length(ylim) %in% c(2,2*dims0))
- stop("Wrong length of Argument ylim");
- ylim <- matrix(ylim, 2,dims0)
- }
+ if(missing(x.vec)) x.vec <- NULL
+ x.v.ret <- .getX.vec(distr, dims0, dots$lty, x.vec, scaleX, scaleX.fct, scaleX.inv, .xylim$xm, .xylim$xM)
+ lty <- x.v.ret$lty; plty <- x.v.ret$plty; x.vec <- x.v.ret$x.vec
+ .pFL <- .preparePanelFirstLast(with.automatic.grid , dims0, pF.0, pL.0,
+ logArg, scaleX, scaleY, x.ticks, y.ticks,
+ scaleX.fct, scaleY.fct)
+ pF <- .pFL$pF; pL <- .pFL$pL; gridS <- .pFL$gridS
+
+
+ plotInfo$to.draw <- to.draw
+ plotInfo$panelFirst <- pF
+ plotInfo$panelLast <- pL
+ plotInfo$gridS <- gridS
+
if(!is.null(dots[["lty"]])) dots["lty"] <- NULL
if(!is.null(dots[["type"]])) dots["type"] <- NULL
@@ -174,78 +151,19 @@
IC1 <- as(diag(dims) %*% x at Curve, "EuclRandVariable")
- mainL <- FALSE
- subL <- FALSE
- lineT <- NA
+ .pT <- .prepareTitles(withSubst,
+ presubArg2 = c("%C", "%D", "%A"),
+ presubArg3 = c(as.character(class(x)[1]),
+ as.character(date()),
+ xcc),
+ dots,
+ mainText = gettextf("Plot for IC %%A"), ###
+ L2Fam, inner, dims0, dims, to.draw, trafO, x, type = "all", bmar, tmar)
+ dots <- .pT$dots; main <- .pT$main; mainL <- .pT$mainL; lineT <- .pT$lineT
+ sub <- .pT$sub; subL <- .pT$subL; bmar <- .pT$bmar; tmar <- .pT$tmar;
+ innerT <- .pT$innerT; innerL <- .pT$innerL; .mpresubs <- .pT$.mpresubs
- if (hasArg(main)){
- mainL <- TRUE
- if (is.logical(main)){
- if (!main) mainL <- FALSE
- else
- main <- gettextf("Plot for IC %%A") ###
- ### 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
- }
- }
- 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
- }
-
- if(is.logical(innerL)){
- tnm <- c(rownames(trafO))
- tnms <- if(is.null(tnm)) paste(1:dims) else
- paste("'", tnm, "'", sep = "")
- mnm <- names(L2Fam at param@main)
- mnms <- if(is.null(mnm)) NULL else paste("'", mnm, "' = ", sep = "")
- mss <- paste(mnms, round(L2Fam at param@main, 3), collapse=", ",sep="")
- innerT <- paste(gettextf("Component "), tnms,
- gettextf("\nof"), #gettextf(" of L_2 derivative\nof"),
- name(x)[1],
- gettextf("\nwith main parameter ("), mss,")")
- if(!is.null(L2Fam at param@nuisance)){
- nnm <- names(L2Fam at param@nuisance)
- nnms <- if(is.null(nnm)) NULL else paste("'", nnm, "' = ", sep = "")
- innerT <- paste(innerT,
- gettextf("\nand nuisance parameter ("),
- paste(nnms,round(L2Fam at param@nuisance, 3), collapse = ", "),
- ")",
- sep="" )
- }
- if(!is.null(L2Fam at param@fixed)){
- fnm <- names(L2Fam at param@fixed)
- fnms <- if(is.null(fnm)) NULL else paste("'", fnm, "' = ", sep = "")
- innerT <- paste(innerT,
- gettextf("\nand fixed known parameter ("),
- paste(fnms, round(L2Fam at param@fixed, 3), collapse = ", "),
- ")",
- sep="" )
- }
- }else{
- innerT <- lapply(inner, .mpresubs)
- innerT <- .fillList(innerT,dims)
- if(dims0<dims){
- innerT0 <- innerT
- for(i in 1:dims0) innerT[to.draw[i]] <- innerT0[i]
- }
- }
-
if(with.legend){
fac.leg <- if(dims0>1) 3/4 else .75/.8
if(missing(legend.location)){
@@ -264,35 +182,42 @@
w0 <- getOption("warn")
options(warn = -1)
on.exit(options(warn = w0))
- opar <- par(no.readonly = TRUE)
-# opar$cin <- opar$cra <- opar$csi <- opar$cxy <- opar$din <- NULL
- on.exit(par(opar))
if (!withSweave)
devNew()
- parArgs <- NULL
- if(mfColRow)
- parArgs <- list(mfrow = c(nrows, ncols))
-
+ opar <- par(no.readonly = TRUE)
omar <- par("mar")
- parArgs <- c(parArgs,list(mar = c(bmar,omar[2],tmar,omar[4])))
+ if(mfColRow){ on.exit(par(opar));
+ par(mfrow = c(nrows, ncols),mar = c(bmar,omar[2],tmar,omar[4])) }
- do.call(par,args=parArgs)
+ dotsT$main <- dotsT$cex.main <- dotsT$col.main <- dotsT$line <- NULL
-
dotsT["pch"] <- dotsT["cex"] <- NULL
dotsT["col"] <- dotsT["lwd"] <- NULL
dotsL["cex"] <- dotsLeg["bg"] <- dotsLeg["cex"] <- NULL
dots$ylim <- NULL
+ plotInfo$resc.D <- plotInfo$resc <- vector("list", dims0)
+ plotInfo$PlotLinesD <- plotInfo$PlotUsr <- vector("list", dims0)
+ plotInfo$PlotArgs <- plotInfo$Axis <- vector("list", dims0)
+ plotInfo$MBR <- plotInfo$Legend <- plotInfo$innerTitle <- vector("list", dims0)
+
+ IC.f <- function(x,i) .msapply(x, IC1 at Map[[i]])
+
+ plotInfo$IC.f <- IC.f
+
for(i in 1:dims0){
+
indi <- to.draw[i]
if(!is.null(ylim)) dots$ylim <- ylim[,i]
- fct <- function(x) sapply(x, IC1 at Map[[indi]])
- print(xlim[,i])
- resc <-.rescalefct(x.vec, fct, scaleX, scaleX.fct,
- scaleX.inv, scaleY, scaleY.fct[[i]], xlim[,i],
+
+ IC.f.i <- function(x) IC.f(x,indi)
+
+ resc <-.rescalefct(x.vec[[i]], IC.f.i, scaleX[i], scaleX.fct[[i]],
+ scaleX.inv[[i]], scaleY[i], scaleY.fct[[i]], xlim[,i],
ylim[,i], dots)
+
+ plotInfo$resc[[i]] <- resc
dots <- resc$dots
dots$xlim <- xlim[,i]
dots$ylim <- ylim[,i]
@@ -301,8 +226,8 @@
finiteEndpoints <- rep(FALSE,4)
if(scaleX){
- finiteEndpoints[1] <- is.finite(scaleX.inv(min(x.vec1, xlim[1,i])))
- finiteEndpoints[2] <- is.finite(scaleX.inv(max(x.vec1, xlim[2,i])))
+ finiteEndpoints[1] <- is.finite(scaleX.inv[[i]](min(x.vec1, xlim[1,i])))
+ finiteEndpoints[2] <- is.finite(scaleX.inv[[i]](max(x.vec1, xlim[2,i])))
}
if(scaleY){
finiteEndpoints[3] <- is.finite(scaleY.inv[[i]](min(y.vec1, ylim[1,i])))
@@ -310,68 +235,124 @@
}
+ plotInfo$PlotArgs[[i]] <- c(list(x=x.vec1, y=y.vec1, type = plty, lty = lty,
+ xlab = .mpresubs(xlab), ylab = .mpresubs(ylab),
+ panel.first = pF[[i]],
+ panel.last = pL), dotsP[[i]])
do.call(plot, args=c(list(x=x.vec1, y=y.vec1, type = plty, lty = lty,
xlab = .mpresubs(xlab), ylab = .mpresubs(ylab),
panel.first = pF[[i]],
- panel.last = pL[[i]]), dots))
- .plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv,
- scaleY,scaleY.fct[[i]], scaleY.inv[[i]],
+ panel.last = pL), dotsP[[i]]))
+
+ x.ticks0 <- if(xaxt0[i]!="n") x.ticks[[i]] else NULL
+ y.ticks0 <- if(yaxt0[i]!="n") y.ticks[[i]] else NULL
+
+
+ plotInfo$PlotUsr[[i]] <- par("usr")
+ .plotRescaledAxis(scaleX[i], scaleX.fct[[i]], scaleX.inv[[i]],
+ scaleY[i],scaleY.fct[[i]], scaleY.inv[[i]],
xlim[,i], ylim[,i], x.vec1, ypts = 400, n = scaleN,
finiteEndpoints = finiteEndpoints,
- x.ticks = x.ticks, y.ticks = y.ticks[[i]])
+ x.ticks = x.ticks[[i]], y.ticks = y.ticks[[i]])
+ plotInfo$Axis[[i]] <- list(scaleX[i], scaleX.fct[[i]], scaleX.inv[[i]],
+ scaleY[i],scaleY.fct[[i]], scaleY.inv[[i]],
+ xlim[,i], ylim[,i], x.vec1, ypts = 400, n = scaleN,
+ finiteEndpoints = finiteEndpoints,
+ x.ticks = x.ticks[[i]], y.ticks = y.ticks[[i]])
if(withMBR){
MBR.i <- MBRB[i,]
- if(scaleY) MBR.i <- scaleY.fct(MBR.i)
+ if(scaleY) MBR.i <- scaleY.fct[[i]](MBR.i)
abline(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR)
+ plotInfo$MBR[[i]] <- list(h=MBR.i, col=col.MBR, lty=lty.MBR, lwd = lwd.MBR)
}
- if(is(e1, "DiscreteDistribution")){
- x.vec1D <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
- rescD <-.rescalefct(x.vec1D, fct, scaleX, scaleX.fct,
- scaleX.inv, scaleY, scaleY.fct[[i]], xlim[,i],
- ylim[,i], dots)
+ if(is(distr, "DiscreteDistribution")){
+ x.vec1D <- seq(from = min(x.vec[[i]]), to = max(x.vec[[i]]), length = 1000)
+ rescD <-.rescalefct(x.vec1D, IC.f.i, scaleX[i], scaleX.fct[[i]],
+ scaleX.inv[[i]], scaleY[i], scaleY.fct[[i]], xlim[,i],
+ ylim[,i], dotsP[[i]])
+ plotInfo$resc.D[[i]] <- rescD
x.vecD <- rescD$X
y.vecD <- rescD$Y
dotsL$lty <- NULL
do.call(lines,args=c(list(x.vecD, y.vecD,
lty = "dotted"), dotsL))
+ plotInfo$PlotLinesD[[i]] <- c(list(x.vecD, y.vecD,
+ lty = "dotted"), dotsL)
}
- do.call(title,args=c(list(main = innerT[indi]), dotsT, line = lineT,
+ do.call(title,args=c(list(main = innerT[i]), dotsT, line = lineT,
cex.main = cex.inner, col.main = col.inner))
- if(with.legend)
- legend(.legendCoord(legend.location[[i]], scaleX, scaleX.fct,
- scaleY, scaleY.fct), bg = legend.bg,
+ plotInfo$innerTitle[[i]] <- c(list(main = innerT[i]), dotsT, line = lineT,
+ cex.main = cex.inner, col.main = col.inner)
+
+ if(with.legend){
+ legend(.legendCoord(legend.location[[i]], scaleX[i], scaleX.fct[[i]],
+ scaleY[i], scaleY.fct[[i]]), bg = legend.bg,
legend = legend[[i]], dotsLeg, cex = legend.cex*fac.leg)
+ plotInfo$Legend[[i]] <- list(.legendCoord(legend.location[[i]],
+ scaleX[i], scaleX.fct[[i]], scaleY[i], scaleY.fct[[i]]), bg = legend.bg,
+ legend = legend[[i]], dotsLeg, cex = legend.cex*fac.leg)
+ }
}
cex.main <- if(!hasArg(cex.main)) par("cex.main") else dots$"cex.main"
col.main <- if(!hasArg(col.main)) par("col.main") else dots$"col.main"
- if (mainL)
+ if (mainL){
mtext(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
-
+ plotInfo$mainL <- list(text = main, side = 3, cex = cex.main, adj = .5,
+ outer = TRUE, padj = 1.4, col = col.main)
+ }
cex.sub <- if(!hasArg(cex.sub)) par("cex.sub") else dots$"cex.sub"
col.sub <- if(!hasArg(col.sub)) par("col.sub") else dots$"col.sub"
- if (subL)
+ if (subL){
mtext(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
-
- invisible()
+ plotInfo$subL <- list(text = sub, side = 1, cex = cex.sub, adj = .5,
+ outer = TRUE, line = -1.6, col = col.sub)
+ }
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+ return(invisible(plotInfo))
})
setMethod("plot", signature(x = "IC",y = "numeric"),
- function(x, y, ..., cex.pts = 1, col.pts = par("col"),
- pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
+ function(x, y, ...,
+ 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){
- dots <- match.call(call = sys.call(sys.parent(1)),
+ args0 <- list(x = x, y = y, 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)
+ 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)
n <- if(!is.null(dim(y))) nrow(y) else length(y)
- pch.pts <- rep(pch.pts, length.out=n)
- lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,n)
+ if(attr.pre){
+ 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)
+ }
L2Fam <- eval(x at CallL2Fam)
@@ -387,58 +368,161 @@
absInfo <- t(IC1) %*% QF %*% IC1
ICMap <- IC1 at Map
- sel <- .SelectOrderData(y, function(x)sapply(x, absInfo at Map[[1]]),
- which.lbs, which.Order)
+ ICabs.f <- function(x) .msapply(x, absInfo at Map[[1]])
+ plotInfo$ICabs.f <- ICabs.f
+
+ IC.f <- function(x,i) .msapply(x, IC1 at Map[[i]])
+ plotInfo$IC.f <- IC.f
+
+ sel <- .SelectOrderData(y, ICabs.f, which.lbs, which.Order, which.nonlbs)
+ plotInfo$sel <- sel
+ plotInfo$obj <- sel$ind1
+
i.d <- sel$ind
i0.d <- sel$ind1
n <- length(i.d)
+ i.d.ns <- sel$ind.ns
+ n.ns <- length(i.d.ns)
+
+ if(attr.pre){
+ col.pts <- col.pts[sel$ind]
+ col.npts <- col.pts[sel$ind.ns]
+ pch.npts <- pch.pts[sel$ind.ns]
+ pch.pts <- pch.pts[sel$ind]
+ cex.npts <- cex.pts[sel$ind.ns]
+ cex.pts <- cex.pts[sel$ind]
+ 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)
+ }
+
+
dots.without <- dots
dots.without$col <- dots.without$cex <- dots.without$pch <- NULL
dims0 <- .getDimsTD(L2Fam,dots[["to.draw.arg"]])
+ if(!is.null(cex.pts.fun)){
+ cex.pts.fun <- .fillList(cex.pts.fun)}
+ if(!is.null(cex.npts.fun)){
+ cex.npts.fun <- .fillList(cex.npts.fun)}
+
pL <- expression({})
if(!is.null(dots$panel.last))
pL <- .panel.mingle(dots,"panel.last")
- pL <- .fillList(pL, dims0)
- if(dims0) for(i in 1:dims0){
- if(is.null(pL[[i]])) pL[[i]] <- expression({})
+ if(is.list(pL)){
+ pL <- .fillList(pL, dims0)
+
+ if(dims0) for(i in 1:dims0){
+ if(is.null(pL[[i]])) pL[[i]] <- expression({})
+ }
+ pL <- substitute({pL1 <- pL0
+ pL1[[i]]},
+ list(pL0=pL))
}
+
dots$panel.last <- NULL
+ plotInfo$resc.dat <- plotInfo$resc.dat.ns <- vector("list", dims0)
+ plotInfo$doPts <- plotInfo$doPts.ns <- plotInfo$doLabs <- vector("list", dims0)
+ trEnv <- new.env()
+
pL <- substitute({
- y1 <- y0s
- ICy <- sapply(y0s,ICMap0[[indi]])
- #print(xlim[,i])
- resc.dat <-.rescalefct(y0s, function(x) sapply(x,ICMap0[[indi]]),
- scaleX, scaleX.fct, scaleX.inv,
- scaleY, scaleY.fct[[i]], xlim[,i], ylim[,i],
- dwo0)
- y1 <- resc.dat$X
- ICy <- resc.dat$Y
+ pI <- get("plotInfo", envir = trEnv0)
- if(is(e1, "DiscreteDistribution"))
- ICy <- jitter(ICy, factor = jitter.fac0)
+ IC.f.i <- function(x) IC.f.0(x,indi)
- col.pts <- if(!is.na(al0)) sapply(col0, addAlphTrsp2col,alpha=al0) else col0
+ if(length(y0s)){
+ resc.dat <-.rescalefct(y0s, IC.f.i,
+ scaleX[i], scaleX.fct[[i]], scaleX.inv[[i]],
+ scaleY[i], scaleY.fct[[i]], xlim[,i], ylim[,i],
+ dwo0)
+ pI$resc.dat[[i]] <- resc.dat
+ y1 <- resc.dat$X
+ ICy <- resc.dat$Y
+ if(is(distr, "DiscreteDistribution")){
+ if(length(ICy)) ICy <- jitter(ICy, factor = jitter.fac0) }
+ col.pts <- if(!is.na(al0)) .msapply(col0, addAlphTrsp2col,alpha=al0) else col0
+ cfun <- if(is.null(cexfun)) NULL else cexfun[[i]]
+ cex.l <- .cexscale(absy0,absy0,cex=cex0, fun = cfun) ##.cexscale in infoPlot.R
- do.call(points, args=c(list(y1, ICy, cex = log(absy0+1)*3*cex0,
+ pI$doPts[[i]] <- c(list(y1, ICy, cex = cex.l,
+ col = col.pts, pch = pch0), dwo0)
+ do.call(points, args=c(list(y1, ICy, cex = cex.l,
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)
+
+ if(with.lab0){
+ text(x = y0s, y = ICy, labels = lab.pts0,
+ cex = cex.l/2, col = col0)
+ pI$doLabs[[i]] <- list(x = y0s, y = ICy, labels = lab.pts0,
+ cex = cex.l/2, col = col0)
+ }
}
+
+ if(length(y0s.ns)){
+ resc.dat.ns <-.rescalefct(y0s.ns, IC.f.i,
+ scaleX[i], scaleX.fct[[i]], scaleX.inv[[i]],
+ scaleY[i], scaleY.fct[[i]], xlim[,i], ylim[,i],
+ dwo0)
+ pI$resc.dat.ns[[i]] <- resc.dat.ns
+ y1.ns <- resc.dat.ns$X
+ ICy.ns <- resc.dat.ns$Y
+ if(is(distr, "DiscreteDistribution"))
+ {if(length(ICy.ns)) ICy.ns <- jitter(ICy.ns, factor = jitter.fac0) }
+
+ col.npts <- if(!is.na(al0)) .msapply(col0.ns, addAlphTrsp2col,alpha=al0) else col0.ns
+ cfun.ns <- if(is.null(cexnfun)) NULL else cexnfun[[i]]
+ cex.l.ns <- .cexscale(absy0.ns,absy0.ns, cex=cex0.ns, fun = cfun.ns) ##.cexscale in infoPlot.R
+
+ pI$doPts.ns[[i]] <- c(list(y1.ns, ICy.ns, cex = cex.l.ns,
+ col = col.npts, pch = pch0.ns), dwo0)
+ do.call(points, args=c(list(y1.ns, ICy.ns, cex = cex.l.ns,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1031
More information about the Robast-commits
mailing list