[Robast-commits] r968 - in branches/robast-1.1/pkg/RobAStBase: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jul 18 17:15:33 CEST 2018
Author: ruckdeschel
Date: 2018-07-18 17:15:32 +0200 (Wed, 18 Jul 2018)
New Revision: 968
Modified:
branches/robast-1.1/pkg/RobAStBase/R/ddPlot.R
branches/robast-1.1/pkg/RobAStBase/R/ddPlot_utils.R
branches/robast-1.1/pkg/RobAStBase/R/outlyingPlot.R
branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R
branches/robast-1.1/pkg/RobAStBase/man/ComparePlotWrapper.Rd
branches/robast-1.1/pkg/RobAStBase/man/InfoPlotWrapper.Rd
branches/robast-1.1/pkg/RobAStBase/man/PlotICWrapper.Rd
branches/robast-1.1/pkg/RobAStBase/man/ddPlot-methods.Rd
branches/robast-1.1/pkg/RobAStBase/man/internals_ddPlot.Rd
branches/robast-1.1/pkg/RobAStBase/man/outlyingPlotIC.Rd
Log:
[RobAStBase] branch 1.1: unified argument names for ddPlot, outlyingPlotIC; wrapper functions gain return value; tricky treatment of missings...
Modified: branches/robast-1.1/pkg/RobAStBase/R/ddPlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/ddPlot.R 2018-07-18 12:24:20 UTC (rev 967)
+++ branches/robast-1.1/pkg/RobAStBase/R/ddPlot.R 2018-07-18 15:15:32 UTC (rev 968)
@@ -3,8 +3,9 @@
cutoff.x, cutoff.y, ...,
cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
transform.x, transform.y = transform.x,
- id.n, cex.pts = 1,lab.pts, jit.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
- col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
+ id.n, cex.pts = 1,lab.pts, jitter.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
+ 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),
@@ -12,29 +13,45 @@
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%%",
- jit.fac, jit.tol = .Machine$double.eps,doplot = TRUE){
+ jitter.fac, jitter.tol = .Machine$double.eps,doplot = TRUE){
+ if(missing(dist.x)) dist.x <- NormType()
+ if(missing(dist.y)) dist.y <- NormType()
+ if(missing(cutoff.x)) cutoff.x <- NULL
+ if(missing(cutoff.y)) cutoff.y <- NULL
+ if(missing(transform.x)) transform.x <- NULL
+ if(missing(transform.y)) transform.y <- NULL
+ if(missing(id.n)) id.n <- NULL
+ if(missing(lab.pts)) lab.pts <- NULL
+ if(missing(cex.idn)) cex.idn <- NULL
+ if(missing(col.idn)) col.idn <- NULL
+ if(missing(lty.cutoff)) lty.cutoff <- NULL
+ if(missing(lwd.cutoff)) lwd.cutoff <- NULL
+ if(missing(col.cutoff)) col.cutoff <- NULL
+ if(missing(col.abline)) col.abline <- NULL
+ if(missing(jitter.fac)) jitter.fac <- NULL
+
args0 <- list(data = data,
- dist.x = if(!missing(dist.x)) dist.x else NULL,
- dist.y = if(!missing(dist.y)) dist.y else NULL,
- cutoff.x = if(!missing(cutoff.x)) cutoff.x else NULL,
- cutoff.y = if(!missing(cutoff.y)) cutoff.y else NULL,
+ dist.x = dist.x,
+ dist.y = dist.y,
+ cutoff.x = cutoff.x,
+ cutoff.y = cutoff.y,
cutoff.quantile.x = cutoff.quantile.x,
cutoff.quantile.y = cutoff.quantile.y,
- transform.x = if(!missing(transform.x)) transform.x else NULL,
- transform.y = if(!missing(transform.y)) transform.y else NULL,
- id.n = if(!missing(id.n)) id.n else NULL,
+ transform.x = transform.x,
+ transform.y = transform.y,
+ id.n = id.n,
cex.pts = cex.pts,
- lab.pts = if(!missing(lab.pts)) lab.pts else NULL,
- jit.pts = jit.pts, alpha.trsp = alpha.trsp, adj = adj,
- cex.idn =if(!missing(cex.idn)) cex.idn else NULL,
- col.idn =if(!missing(col.idn)) col.idn else NULL,
- lty.cutoff =if(!missing(lty.cutoff)) lty.cutoff else NULL,
- lwd.cutoff =if(!missing(lwd.cutoff)) lwd.cutoff else NULL,
- col.cutoff =if(!missing(col.cutoff)) col.cutoff else NULL,
+ lab.pts = lab.pts,
+ jitter.pts = jitter.pts, alpha.trsp = alpha.trsp, adj = adj,
+ cex.idn = cex.idn,
+ col.idn = col.idn,
+ lty.cutoff = lty.cutoff,
+ lwd.cutoff = lwd.cutoff,
+ col.cutoff = col.cutoff,
text.abline = text.abline, text.abline.x = text.abline.x,
text.abline.y = text.abline.y, cex.abline = cex.abline,
- col.abline = if(!missing(col.abline)) col.abline else NULL,
+ col.abline = col.abline,
font.abline = font.abline,
adj.abline = adj.abline, text.abline.x.x = text.abline.x.x,
text.abline.x.y = text.abline.x.y,
@@ -44,8 +61,8 @@
text.abline.x.fmt.qx = text.abline.x.fmt.cx,
text.abline.y.fmt.cy = text.abline.y.fmt.cy,
text.abline.y.fmt.qy = text.abline.y.fmt.qy,
- jit.fac = if(!missing(jit.fac)) jit.fac else NULL,
- jit.tol = jit.tol,
+ jitter.fac = jitter.fac,
+ jitter.tol = jitter.tol,
doplot = doplot)
mc <- match.call(expand.dots = TRUE, call = sys.call(sys.parent(1)))
@@ -53,6 +70,7 @@
plotInfo <- list(call = mc, dots=dots, args=args0)
mc <- as.list(mc)[-1]
mc$data <- data
+# ret <- do.call(.ddPlot.MatNtNtCoCo, args = mc)
ret <- do.call(RobAStBase:::.ddPlot.MatNtNtCoCo, args = mc)
if(!doplot) return(ret)
ret$call <- ret$dots <- ret$args <- NULL
@@ -67,7 +85,7 @@
cutoff.x, cutoff.y, ...,
cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
transform.x, transform.y = transform.x,
- id.n, cex.pts = 1,lab.pts, jit.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
+ id.n, cex.pts = 1,lab.pts, jitter.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
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,
@@ -76,29 +94,45 @@
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%%",
- jit.fac, jit.tol = .Machine$double.eps,doplot = TRUE){
+ jitter.fac, jitter.tol = .Machine$double.eps,doplot = TRUE){
+ if(missing(dist.x)) dist.x <- NormType()
+ if(missing(dist.y)) dist.y <- NormType()
+ if(missing(cutoff.x)) cutoff.x <- NULL
+ if(missing(cutoff.y)) cutoff.y <- NULL
+ if(missing(transform.x)) transform.x <- NULL
+ if(missing(transform.y)) transform.y <- NULL
+ if(missing(id.n)) id.n <- NULL
+ if(missing(lab.pts)) lab.pts <- NULL
+ if(missing(cex.idn)) cex.idn <- NULL
+ if(missing(col.idn)) col.idn <- NULL
+ if(missing(lty.cutoff)) lty.cutoff <- NULL
+ if(missing(lwd.cutoff)) lwd.cutoff <- NULL
+ if(missing(col.cutoff)) col.cutoff <- NULL
+ if(missing(col.abline)) col.abline <- NULL
+ if(missing(jitter.fac)) jitter.fac <- NULL
+
args0 <- list(data = data,
- dist.x = if(!missing(dist.x)) dist.x else NULL,
- dist.y = if(!missing(dist.y)) dist.y else NULL,
- cutoff.x = if(!missing(cutoff.x)) cutoff.x else NULL,
- cutoff.y = if(!missing(cutoff.y)) cutoff.y else NULL,
+ dist.x = dist.x,
+ dist.y = dist.y,
+ cutoff.x = cutoff.x,
+ cutoff.y = cutoff.y,
cutoff.quantile.x = cutoff.quantile.x,
cutoff.quantile.y = cutoff.quantile.y,
- transform.x = if(!missing(transform.x)) transform.x else NULL,
- transform.y = if(!missing(transform.y)) transform.y else NULL,
- id.n = if(!missing(id.n)) id.n else NULL,
+ transform.x = transform.x,
+ transform.y = transform.y,
+ id.n = id.n,
cex.pts = cex.pts,
- lab.pts = if(!missing(lab.pts)) lab.pts else NULL,
- jit.pts = jit.pts, alpha.trsp = alpha.trsp, adj = adj,
- cex.idn =if(!missing(cex.idn)) cex.idn else NULL,
- col.idn =if(!missing(col.idn)) col.idn else NULL,
- lty.cutoff =if(!missing(lty.cutoff)) lty.cutoff else NULL,
- lwd.cutoff =if(!missing(lwd.cutoff)) lwd.cutoff else NULL,
- col.cutoff =if(!missing(col.cutoff)) col.cutoff else NULL,
+ lab.pts = lab.pts,
+ jitter.pts = jitter.pts, alpha.trsp = alpha.trsp, adj = adj,
+ cex.idn = cex.idn,
+ col.idn = col.idn,
+ lty.cutoff = lty.cutoff,
+ lwd.cutoff = lwd.cutoff,
+ col.cutoff = col.cutoff,
text.abline = text.abline, text.abline.x = text.abline.x,
text.abline.y = text.abline.y, cex.abline = cex.abline,
- col.abline = if(!missing(col.abline)) col.abline else NULL,
+ col.abline = col.abline,
font.abline = font.abline,
adj.abline = adj.abline, text.abline.x.x = text.abline.x.x,
text.abline.x.y = text.abline.x.y,
@@ -108,9 +142,10 @@
text.abline.x.fmt.qx = text.abline.x.fmt.cx,
text.abline.y.fmt.cy = text.abline.y.fmt.cy,
text.abline.y.fmt.qy = text.abline.y.fmt.qy,
- jit.fac = if(!missing(jit.fac)) jit.fac else NULL,
- jit.tol = jit.tol,
+ jitter.fac = jitter.fac,
+ jitter.tol = jitter.tol,
doplot = doplot)
+
mc <- match.call(expand.dots = TRUE, call = sys.call(sys.parent(1)))
dots <- mc$"..."
plotInfo <- list(call = mc, dots=dots, args=args0)
@@ -129,7 +164,7 @@
cutoff.x, cutoff.y, ...,
cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
transform.x, transform.y = transform.x,
- id.n, cex.pts = 1,lab.pts, jit.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
+ id.n, cex.pts = 1,lab.pts, jitter.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
col.idn, lty.cutoff, lwd.cutoff, col.cutoff,
text.abline = TRUE,
text.abline.x = NULL, text.abline.y = NULL,
@@ -139,29 +174,45 @@
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%%",
- jit.fac, jit.tol = .Machine$double.eps, doplot = TRUE){
+ jitter.fac, jitter.tol = .Machine$double.eps, doplot = TRUE){
+ if(missing(dist.x)) dist.x <- NormType()
+ if(missing(dist.y)) dist.y <- NormType()
+ if(missing(cutoff.x)) cutoff.x <- NULL
+ if(missing(cutoff.y)) cutoff.y <- NULL
+ if(missing(transform.x)) transform.x <- NULL
+ if(missing(transform.y)) transform.y <- NULL
+ if(missing(id.n)) id.n <- NULL
+ if(missing(lab.pts)) lab.pts <- NULL
+ if(missing(cex.idn)) cex.idn <- NULL
+ if(missing(col.idn)) col.idn <- NULL
+ if(missing(lty.cutoff)) lty.cutoff <- NULL
+ if(missing(lwd.cutoff)) lwd.cutoff <- NULL
+ if(missing(col.cutoff)) col.cutoff <- NULL
+ if(missing(col.abline)) col.abline <- NULL
+ if(missing(jitter.fac)) jitter.fac <- NULL
+
args0 <- list(data = data,
- dist.x = if(!missing(dist.x)) dist.x else NULL,
- dist.y = if(!missing(dist.y)) dist.y else NULL,
- cutoff.x = if(!missing(cutoff.x)) cutoff.x else NULL,
- cutoff.y = if(!missing(cutoff.y)) cutoff.y else NULL,
+ dist.x = dist.x,
+ dist.y = dist.y,
+ cutoff.x = cutoff.x,
+ cutoff.y = cutoff.y,
cutoff.quantile.x = cutoff.quantile.x,
cutoff.quantile.y = cutoff.quantile.y,
- transform.x = if(!missing(transform.x)) transform.x else NULL,
- transform.y = if(!missing(transform.y)) transform.y else NULL,
- id.n = if(!missing(id.n)) id.n else NULL,
+ transform.x = transform.x,
+ transform.y = transform.y,
+ id.n = id.n,
cex.pts = cex.pts,
- lab.pts = if(!missing(lab.pts)) lab.pts else NULL,
- jit.pts = jit.pts, alpha.trsp = alpha.trsp, adj = adj,
- cex.idn =if(!missing(cex.idn)) cex.idn else NULL,
- col.idn =if(!missing(col.idn)) col.idn else NULL,
- lty.cutoff =if(!missing(lty.cutoff)) lty.cutoff else NULL,
- lwd.cutoff =if(!missing(lwd.cutoff)) lwd.cutoff else NULL,
- col.cutoff =if(!missing(col.cutoff)) col.cutoff else NULL,
+ lab.pts = lab.pts,
+ jitter.pts = jitter.pts, alpha.trsp = alpha.trsp, adj = adj,
+ cex.idn = cex.idn,
+ col.idn = col.idn,
+ lty.cutoff = lty.cutoff,
+ lwd.cutoff = lwd.cutoff,
+ col.cutoff = col.cutoff,
text.abline = text.abline, text.abline.x = text.abline.x,
text.abline.y = text.abline.y, cex.abline = cex.abline,
- col.abline = if(!missing(col.abline)) col.abline else NULL,
+ col.abline = col.abline,
font.abline = font.abline,
adj.abline = adj.abline, text.abline.x.x = text.abline.x.x,
text.abline.x.y = text.abline.x.y,
@@ -171,9 +222,10 @@
text.abline.x.fmt.qx = text.abline.x.fmt.cx,
text.abline.y.fmt.cy = text.abline.y.fmt.cy,
text.abline.y.fmt.qy = text.abline.y.fmt.qy,
- jit.fac = if(!missing(jit.fac)) jit.fac else NULL,
- jit.tol = jit.tol,
+ jitter.fac = jitter.fac,
+ jitter.tol = jitter.tol,
doplot = doplot)
+
mc <- match.call(expand.dots = TRUE, call = sys.call(sys.parent(1)))
dots <- mc$"..."
plotInfo <- list(call = mc, dots=dots, args=args0)
Modified: branches/robast-1.1/pkg/RobAStBase/R/ddPlot_utils.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/ddPlot_utils.R 2018-07-18 12:24:20 UTC (rev 967)
+++ branches/robast-1.1/pkg/RobAStBase/R/ddPlot_utils.R 2018-07-18 15:15:32 UTC (rev 968)
@@ -10,7 +10,7 @@
id.n,
cex.pts = 1,
lab.pts,
- jitt.pts = 0,
+ jitter.pts = 0,
alpha.trsp = NA,
adj =0,
cex.idn = 1,
@@ -28,13 +28,19 @@
text.abline.x.fmt.qx = "%4.2f%%",
text.abline.y.fmt.cy = "%7.2f",
text.abline.y.fmt.qy = "%4.2f%%",
- jitt.fac = 10,
+ jitter.fac = 10,
+ jitter.tol = .Machine$double.eps,
doplot = TRUE){
mc <- match.call(expand.dots = FALSE)
dots <- mc$"..."
- jitt.pts <- rep(jitt.pts,length.out=2)
+ if(missing(jitter.pts)||is.null(jitter.pts)) jitter.pts <- 0
+ jitter.pts <- rep(jitter.pts,length.out=2)
+ if(missing(jitter.tol)||is.null(jitter.tol)) jitter.tol <- .Machine$double.eps
+ jitter.tol <- rep(jitter.tol,length.out=2)
+ if(missing(jitter.fac)||is.null(jitter.fac)) jitter.fac <- 10
+ jitter.fac <- rep(jitter.fac,length.out=2)
col <- if(is.null(dots$col)) par("col") else dots$col
if(!is.na(alpha.trsp)) col <- addAlphTrsp2col(col, alpha.trsp)
@@ -122,13 +128,16 @@
if(is.null(dots$lwd)) dots$lwd <- par("lwd")
if(is.null(dots$lty)) dots$lty <- par("lty")
- if(is.null(col.cutoff)) col.cutoff <- "red"
+ if(missing(col.cutoff) || is.null(col.cutoff)) col.cutoff <- "red"
col.cutoff <- rep(col.cutoff,length.out=2)
- if(missing(lty.cutoff) && !is.null(dots$lty)) lty.cutoff <- dots$lty
- if(missing(lwd.cutoff) && !is.null(dots$lwd)) lwd.cutoff <- dots$lwd
- if(missing(cex.abline) && !is.null(dots$cex)) cex.abline <- dots$cex
- if(missing(adj.abline) && !is.null(dots$adj)) lty.abline <- dots$adj
- if(missing(font.abline) && !is.null(dots$font)) font.abline <- dots$font
+ if((missing(lty.cutoff)|| is.null(lty.cutoff)) && !is.null(dots$lty)) lty.cutoff <- dots$lty
+ if((missing(lwd.cutoff)|| is.null(lwd.cutoff)) && !is.null(dots$lwd)) lwd.cutoff <- dots$lwd
+ if((missing(cex.abline)|| is.null(cex.abline)) && !is.null(dots$cex)) cex.abline <- dots$cex
+ if((missing(cex.abline)|| is.null(cex.abline))) cex.abline <- par("cex")
+ if((missing(adj.abline)|| is.null(adj.abline)) && !is.null(dots$adj)) adj.abline <- dots$adj
+ if((missing(adj.abline)|| is.null(adj.abline))) adj.abline <- c(0.5,0.5)
+ if((missing(font.abline)|| is.null(font.abline)) && !is.null(dots$font)) font.abline <- dots$font
+ if((missing(font.abline)|| is.null(font.abline))) font.abline <- par("font")
pdots <- .makedotsLowLevel(dots)
pdots$pch <- if(is.null(dots$pch)) "." else dots$pch
@@ -145,19 +154,21 @@
abdots <- .makedotsAB(dots)
if(!missing(lty.cutoff)) abdots$lty <- lty.cutoff[[1]]
if(!missing(lwd.cutoff)) abdots$lwd <- lwd.cutoff[1]
- abdots$col <- col.cutoff[1]
- abdots$jitt.fac <- dots$jitt.fac
+ if(!missing(col.cutoff)) abdots$col <- col.cutoff[1]
abdots <- list(abdots,abdots)
- abdots$jitt.fac <- pdots$jitt.fac
if(!is.null(abdots$lty))
if(is.list(lty.cutoff)) abdots[[2]]$lty <- lty.cutoff[[2]]
if(!is.null(abdots$lwd))
if(length(lwd.cutoff)>1) abdots[[2]]$lwd <- lwd.cutoff[2]
+ if(!is.null(abdots$col))
+ if(length(col.cutoff)>1) abdots[[2]]$col <- col.cutoff[2]
+ if(missing(text.abline)||is.null(text.abline)) text.abline <- TRUE
ab.textL <- rep(text.abline,length.out=2)
- abtdots.x <- abtdots.y <- vector("list",0)
+
+ abtdots.x <- abtdots.y <- vector("list",0)
cex.abline <- rep(cex.abline, length.out = 2)
col.abline <- rep(if(!is.null(col.abline))
col.abline else "red", length.out = 2)
@@ -165,6 +176,10 @@
adj.abline <- matrix(rep(adj.abline,length.out=4),2,2)
+ if(is.null(text.abline.x.fmt.cx)) text.abline.x.fmt.cx <- "%7.2f"
+ if(is.null(text.abline.x.fmt.qx)) text.abline.x.fmt.qx <- "%4.2f%%"
+ if(is.null(text.abline.y.fmt.cy)) text.abline.y.fmt.cy <- "%7.2f"
+ if(is.null(text.abline.y.fmt.qy)) text.abline.y.fmt.qy <- "%4.2f%%"
.mpresubs <- function(inx)
.presubs(inx, c("%qx", "%qy", "%cx", "%cy"),
c(gettextf(text.abline.x.fmt.qx,
@@ -175,16 +190,10 @@
round(co.x,2)),
gettextf(text.abline.y.fmt.cy,
round(co.y,2))))
-
- if(!missing(lwd.cutoff)) abdots$lwd <- lwd.cutoff
- if(!missing(lty.cutoff)) abdots$lty <- lty.cutoff
- abdots$jitt.fac <- dots$jitt.fac
-
- abtdots.x$labels <- if(! is.null(text.abline.x))
- .mpresubs(text.abline.x) else gettextf(
- paste(text.abline.x.fmt.qx,"-cutoff = ",
- text.abline.x.fmt.cx,sep=""),
- cutoff.quantile.x*100,round(co.x,digits=2))
+ if(!is.null(text.abline.x)){abtdots.x$labels <- .mpresubs(text.abline.x)
+ }else{
+ abtdots.x$labels <- .mpresubs(gettextf("%%qx-cutoff =%%cx"))
+ }
abtdots.x$cex <- cex.abline[1]
abtdots.x$col <- col.abline[1]
abtdots.x$font <- font.abline[1]
@@ -192,10 +201,8 @@
abtdots.x$adj <- adj.abline[,1]
abtdots.y$labels <- if(! is.null(text.abline.y))
- .mpresubs(text.abline.y) else gettextf(
- paste(text.abline.y.fmt.qy,"-cutoff = ",
- text.abline.y.fmt.cy,sep=""),
- cutoff.quantile.y*100,round(co.y,digits=2))
+ .mpresubs(text.abline.y) else .mpresubs(gettextf(
+ "%%qy-cutoff =%%cy"))
abtdots.y$cex <- cex.abline[2]
abtdots.y$col <- col.abline[2]
abtdots.y$font <- font.abline[2]
@@ -252,11 +259,12 @@
ndata.x0 <- ndata.x
ndata.y0 <- ndata.y
isna <- is.na(ndata.x0)|is.na(ndata.y0)
- if(any(duplicated(ndata.x0[!isna])))
- ndata.x0[!isna] <- jitter(ndata.x0[!isna], factor=jitt.pts[1])
- if(any(duplicated(ndata.y0[!isna])))
- ndata.y0[!isna] <- jitter(ndata.y0[!isna], factor=jitt.pts[2])
+ if(any(duplicated(ndata.x0[!isna]/jitter.tol[1])))
+ ndata.x0[!isna] <- jitter(ndata.x0[!isna], factor=jitter.pts[1])
+ if(any(duplicated(ndata.y0[!isna]/jitter.tol[2])))
+ ndata.y0[!isna] <- jitter(ndata.y0[!isna], factor=jitter.pts[2])
+
pdots$col <- col
retV <- list(id.x=id0.x, id.y= id0.y, id.xy = id0.xy,
qtx = quantile(ndata.x), qty = quantile(ndata.y),
@@ -268,38 +276,37 @@
plotInfo$PlotArgs <- c(list(x = ndata.x0, y=ndata.y0, type = "p"), pdots)
plotInfo$BoxArgs <- c(adots)
- do.call(plot, args = c(list(x = ndata.x0, y=ndata.y0, type = "p"), pdots))
- do.call(box,args=c(adots))
+ do.call(plot, args = plotInfo$PlotArgs)
+ do.call(box,args=plotInfo$BoxArgs)
pusr <- par("usr")
+ plotInfo$usr <- pusr
+
mid.x <- mean(pusr[c(1,2)])
mid.y <- mean(pusr[c(3,4)])
abtdots.y$x <- if(is.null(text.abline.y.x)) mid.x else text.abline.y.x
abtdots.x$y <- if(is.null(text.abline.x.y)) mid.y else text.abline.x.y
- plotInfo$usr <- pusr
plotInfo$ablineV <- c(list(v=co.x), abdots[[1]])
plotInfo$ablineH <- c(list(h=co.y), abdots[[2]])
- do.call(abline, args = c(list(v=co.x), abdots[[1]]))
- do.call(abline, args = c(list(h=co.y), abdots[[2]]))
+ do.call(abline, args = plotInfo$ablineV)
+ do.call(abline, args = plotInfo$ablineH)
if(ab.textL[1]){
- do.call(text, args = c(list(y=co.y*1.03), abtdots.y))
plotInfo$abtextV <- c(list(y=co.y*1.03), abtdots.y)
+ do.call(text, args = plotInfo$abtextV)
# do.call(text, args = c(list(co.x-5,mid.y,paste(cutoff.quantile.y*100,"%-cutoff = ",round(co.x,digits=2)),srt=90)))
}
if(ab.textL[2]){
- do.call(text, args = c(list(x=co.x*1.03), abtdots.x,srt=90))
plotInfo$abtextH <- c(list(x=co.x*1.03), abtdots.x,srt=90)
+ do.call(text, args = plotInfo$abtextH)
# do.call(text, args = c(list(mid.x,co.y+5,paste(cutoff.quantile.x*100," %-cutoff = ",round(co.y,digits=2)))))
}
if(length(id.xy)){
- do.call(text, args = c(list(jitter(ndata.x[id.xy],factor=jitt.fac),
- jitter(ndata.y[id.xy],factor=jitt.fac),
- labels=lab.pts[id.xy]), tdots))
- plotInfo$Lab <- c(list(jitter(ndata.x[id.xy],factor=jitt.fac),
- jitter(ndata.y[id.xy],factor=jitt.fac),
+ plotInfo$Lab <- c(list(jitter(ndata.x[id.xy],factor=jitter.fac[1]),
+ jitter(ndata.y[id.xy],factor=jitter.fac[2]),
labels=lab.pts[id.xy]), tdots)
+ do.call(text, args = plotInfo$Lab)
}
plotInfo$retV <- retV
class(plotInfo) <- c("plotInfo","DiagnInfo")
Modified: branches/robast-1.1/pkg/RobAStBase/R/outlyingPlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/outlyingPlot.R 2018-07-18 12:24:20 UTC (rev 967)
+++ branches/robast-1.1/pkg/RobAStBase/R/outlyingPlot.R 2018-07-18 15:15:32 UTC (rev 968)
@@ -11,7 +11,7 @@
id.n,
cex.pts = 1,
lab.pts,
- jitt.pts = 0,
+ jitter.pts = 0,
alpha.trsp = NA,
adj,
cex.idn,
@@ -19,34 +19,70 @@
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.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%%",
robCov.x = TRUE,
robCov.y = TRUE,
- tf.x = data,
- tf.y = data,
- jitt.fac=10,
+ tf.x = NULL,
+ tf.y = NULL,
+ jitter.fac=10,
+ jitter.tol=.Machine$double.eps,
doplot = TRUE,
main = gettext("Outlyingness \n by means of a distance-distance plot")
){
+
+ if(missing(dist.x)) dist.x <- NormType()
+ if(missing(dist.y)) dist.y <- NULL
+ if(missing(id.n)) id.n <- NULL
+ if(missing(lab.pts)) lab.pts <- NULL
+ if(missing(adj)) adj <- NULL
+ if(missing(cex.idn)) cex.idn <- NULL
+ if(missing(col.idn)) col.idn <- NULL
+ if(missing(lty.cutoff)) lty.cutoff <- NULL
+ if(missing(lwd.cutoff)) lwd.cutoff <- NULL
+ if(missing(col.cutoff)) col.cutoff <- NULL
+
args0 <- list(data = data, IC.x = IC.x, IC.y = IC.y,
- dist.x = dist.x,
- dist.y = if(missing(dist.y)) NULL else dist.y,
+ dist.x = dist.x, dist.y = dist.y,
cutoff.x = cutoff.x, cutoff.y = cutoff.y,
cutoff.quantile.x = cutoff.quantile.x,
cutoff.quantile.y = cutoff.quantile.y,
- id.n = if(missing(id.n)) NULL else id.n,
- cex.pts = cex.pts,
- lab.pts = if(missing(lab.pts)) NULL else lab.pts,
- jitt.pts = jitt.pts,
- alpha.trsp = alpha.trsp,
- adj =if(missing(adj)) NULL else adj,
- cex.idn =if(missing(cex.idn)) NULL else cex.idn,
- col.idn =if(missing(col.idn)) NULL else col.idn,
- lty.cutoff =if(missing(lty.cutoff)) NULL else lty.cutoff,
- lwd.cutoff =if(missing(lwd.cutoff)) NULL else lwd.cutoff,
- col.cutoff =if(missing(col.cutoff)) NULL else col.cutoff,
+ id.n = id.n, cex.pts = cex.pts, lab.pts = lab.pts,
+ jitter.pts = jitter.pts, alpha.trsp = alpha.trsp,
+ adj = adj, cex.idn = cex.idn, col.idn = col.idn,
+ lty.cutoff = lty.cutoff, lwd.cutoff = lwd.cutoff,
+ col.cutoff = col.cutoff,
+ text.abline = text.abline,
+ text.abline.x = text.abline.x,
+ text.abline.y = text.abline.y,
+ cex.abline = cex.abline,
+ col.abline = col.abline,
+ font.abline = font.abline,
+ adj.abline = adj.abline,
+ text.abline.x.x = text.abline.x.x,
+ text.abline.x.y = text.abline.x.y,
+ text.abline.y.x = text.abline.y.x,
+ text.abline.y.y = text.abline.y.y,
+ text.abline.x.fmt.cx = text.abline.x.fmt.cx,
+ text.abline.x.fmt.qx = text.abline.x.fmt.qx,
+ text.abline.y.fmt.cy = text.abline.y.fmt.cy,
+ text.abline.y.fmt.qy = text.abline.y.fmt.qy,
robCov.x = robCov.x,robCov.y = robCov.x,
- tf.x = tf.x, tf.y = tf.x, jitt.fac=jitt.fac,
- doplot = doplot,
+ tf.x = tf.x, tf.y = tf.y, jitter.fac=jitter.fac,
+ jitter.tol = jitter.tol, doplot = doplot,
main = main)
mc <- match.call(expand.dots = FALSE)
dots <- mc$"..."
@@ -73,7 +109,7 @@
}else{
dimevIC <- dim(evIC)[1]
devIC <- data.frame(t(evIC[1:dimevIC,,drop=FALSE]))
- CMcd <- PosSemDefSymmMatrix(getCov(CovMcd(devIC,alpha=0.5)))
+ CMcd <- PosSemDefSymmMatrix(rrcov::getCov(rrcov::CovMcd(devIC,alpha=0.5)))
asVar <- CMcd
# asVar <- solve(CMcd)
# cat("\n", sep="", gettext("Robust asVar"), ":\n")
@@ -106,7 +142,7 @@
}else{
dimevIC <- dim(evIC)[1]
devIC <- data.frame(t(evIC[1:dimevIC,,drop=FALSE]))
- CMcd <- PosSemDefSymmMatrix(getCov(CovMcd(devIC,alpha=0.5)))
+ CMcd <- PosSemDefSymmMatrix(rrcov::getCov(rrcov::CovMcd(devIC,alpha=0.5)))
asVar <- CMcd
cat("Fall 1\n\n")
print(asVar)
@@ -129,10 +165,10 @@
}
- if(missing(tf.x)){
+ if(missing(tf.x)||is.null(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)){
+ if(missing(tf.y)||is.null(tf.y)){
tf.y <- function(x) apply(x,2,function(xx) evalIC(IC.y,xx))
}else{tf.y <- mc$tf.y}
@@ -145,6 +181,7 @@
cutoff.y = cutoff.y,
cutoff.quantile.x = mc$cutoff.quantile.x,
cutoff.quantile.y = mc$cutoff.quantile.y,
+ jitter.pts = mc$jitter.pts,
transform.x = tf.x,
transform.y = tf.y,
id.n = mc$id.n,
@@ -157,31 +194,26 @@
lty.cutoff = mc$lty.cutoff,
lwd.cutoff = mc$lwd.cutoff,
col.cutoff = mc$col.cutoff,
- jitt.fac = mc$jitt.fac,
+ text.abline = mc$text.abline,
+ text.abline.x = mc$text.abline.x,
+ text.abline.y = mc$text.abline.y,
+ cex.abline = mc$cex.abline,
+ col.abline = mc$col.abline,
+ font.abline = mc$font.abline,
+ adj.abline = mc$adj.abline,
+ text.abline.x.x = mc$text.abline.x.x,
+ text.abline.x.y = mc$text.abline.x.y,
+ text.abline.y.x = mc$text.abline.y.x,
+ text.abline.y.y = mc$text.abline.y.y,
+ text.abline.x.fmt.cx = mc$text.abline.x.fmt.cx,
+ text.abline.x.fmt.qx = mc$text.abline.x.fmt.qx,
+ text.abline.y.fmt.cy = mc$text.abline.y.fmt.cy,
+ text.abline.y.fmt.qy = mc$text.abline.y.fmt.qy,
+ jitter.fac = mc$jitter.fac,
+ jitter.tol = mc$jitter.tol,
doplot = doplot,
main = main))
- ret <- do.call(ddPlot,args=c(list(data=data),dots,
- list(dist.x = mc$dist.x,
- dist.y = mc$dist.y,
- cutoff.x = cutoff.x,
- cutoff.y = 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,
- alpha.trsp = alpha.trsp,
- cex.pts = cex.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,
- doplot = doplot,
- main = main)))
+ ret <- do.call(ddPlot,args=plotInfo$ddPlotArgs)
if(!doplot) return(ret)
ret$args<- NULL
ret$call<- NULL
Modified: branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R 2018-07-18 12:24:20 UTC (rev 967)
+++ branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R 2018-07-18 15:15:32 UTC (rev 968)
@@ -202,12 +202,14 @@
###
### 4. evaluate the call (i.e., produce the graphic)
###
- eval(mycall)
+ retV <- eval(mycall)
+ retV$wrapcall <- mc
+ retV$wrappedcall <- mycall
###
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 968
More information about the Robast-commits
mailing list