[Robast-commits] r1060 - branches/robast-1.1/pkg/RobAStBase/R branches/robast-1.1/pkg/RobAStBase/inst branches/robast-1.1/pkg/RobAStBase/man branches/robast-1.1/pkg/RobExtremes branches/robast-1.1/pkg/RobExtremes/R branches/robast-1.1/pkg/RobExtremes/inst/scripts branches/robast-1.1/pkg/RobExtremes/man branches/robast-1.2/pkg/RobAStBase/R branches/robast-1.2/pkg/RobAStBase/inst branches/robast-1.2/pkg/RobAStBase/man branches/robast-1.2/pkg/RobExtremes branches/robast-1.2/pkg/RobExtremes/R branches/robast-1.2/pkg/RobExtremes/man pkg/RobAStBase/R pkg/RobAStBase/inst pkg/RobAStBase/man pkg/RobExtremes pkg/RobExtremes/R pkg/RobExtremes/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jul 26 08:42:44 CEST 2018
Author: ruckdeschel
Date: 2018-07-26 08:42:44 +0200 (Thu, 26 Jul 2018)
New Revision: 1060
Modified:
branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R
branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R
branches/robast-1.1/pkg/RobAStBase/R/infoPlot.R
branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R
branches/robast-1.1/pkg/RobAStBase/R/qqplot.R
branches/robast-1.1/pkg/RobAStBase/R/returnlevelplot.R
branches/robast-1.1/pkg/RobAStBase/inst/NEWS
branches/robast-1.1/pkg/RobAStBase/man/comparePlot.Rd
branches/robast-1.1/pkg/RobAStBase/man/infoPlot.Rd
branches/robast-1.1/pkg/RobAStBase/man/plot-methods.Rd
branches/robast-1.1/pkg/RobAStBase/man/qqplot.Rd
branches/robast-1.1/pkg/RobAStBase/man/returnlevelplot.Rd
branches/robast-1.1/pkg/RobExtremes/DESCRIPTION
branches/robast-1.1/pkg/RobExtremes/R/getStartIC.R
branches/robast-1.1/pkg/RobExtremes/inst/scripts/RobFitsAtRealData.R
branches/robast-1.1/pkg/RobExtremes/man/0RobExtremes-package.Rd
branches/robast-1.2/pkg/RobAStBase/R/AllPlot.R
branches/robast-1.2/pkg/RobAStBase/R/comparePlot.R
branches/robast-1.2/pkg/RobAStBase/R/infoPlot.R
branches/robast-1.2/pkg/RobAStBase/R/plotWrapper.R
branches/robast-1.2/pkg/RobAStBase/R/qqplot.R
branches/robast-1.2/pkg/RobAStBase/R/returnlevelplot.R
branches/robast-1.2/pkg/RobAStBase/inst/NEWS
branches/robast-1.2/pkg/RobAStBase/man/comparePlot.Rd
branches/robast-1.2/pkg/RobAStBase/man/infoPlot.Rd
branches/robast-1.2/pkg/RobAStBase/man/plot-methods.Rd
branches/robast-1.2/pkg/RobAStBase/man/qqplot.Rd
branches/robast-1.2/pkg/RobAStBase/man/returnlevelplot.Rd
branches/robast-1.2/pkg/RobExtremes/DESCRIPTION
branches/robast-1.2/pkg/RobExtremes/R/getStartIC.R
branches/robast-1.2/pkg/RobExtremes/man/0RobExtremes-package.Rd
pkg/RobAStBase/R/AllPlot.R
pkg/RobAStBase/R/comparePlot.R
pkg/RobAStBase/R/infoPlot.R
pkg/RobAStBase/R/plotWrapper.R
pkg/RobAStBase/R/qqplot.R
pkg/RobAStBase/R/returnlevelplot.R
pkg/RobAStBase/inst/NEWS
pkg/RobAStBase/man/comparePlot.Rd
pkg/RobAStBase/man/infoPlot.Rd
pkg/RobAStBase/man/plot-methods.Rd
pkg/RobAStBase/man/qqplot.Rd
pkg/RobAStBase/man/returnlevelplot.Rd
pkg/RobExtremes/DESCRIPTION
pkg/RobExtremes/R/getStartIC.R
pkg/RobExtremes/man/0RobExtremes-package.Rd
Log:
[RobAStBase] [in trunk&branch1.1&branch1.2]
+ diagnostic plots now also have arguments cex.lbs, adj.lbs, col.lbs
+ the default for pch.pts is 19 and for pch.npts is 20 now,
+ some more explicit explanation of the selection mechanism by which.lbs, which.Order, which.nonlbs
+ consistent suffix endings in arguments lbs instead of lbl pts / npts instead of pch
+ package names wrapped in '.' in package DESCRIPTION
+ revised script RobFitsAtRealData.R
+ revised the package starting page
+ in the k Estimator, outliyingness now
+ the Weibull name was wrong in the RobAStRDA interpolator DB (.WeibullFamily instead of .Weibull)
Modified: branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R 2018-07-25 11:42:58 UTC (rev 1059)
+++ branches/robast-1.1/pkg/RobAStBase/R/AllPlot.R 2018-07-26 06:42:44 UTC (rev 1060)
@@ -319,10 +319,11 @@
setMethod("plot", signature(x = "IC",y = "numeric"),
function(x, y, ...,
cex.pts = 1, cex.pts.fun = NULL, col.pts = par("col"),
- pch.pts = 1,
+ pch.pts = 19,
cex.npts = 1, cex.npts.fun = NULL, col.npts = par("col"),
- pch.npts = 2,
- jitter.fac = 1, with.lab = FALSE,
+ pch.npts = 20,
+ jitter.fac = 1, with.lab = FALSE, cex.lbs = 1, adj.lbs = c(0,0),
+ col.lbs = col.pts,
lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
which.lbs = NULL, which.Order = NULL, which.nonlbs = NULL,
attr.pre = FALSE, return.Order = FALSE){
@@ -330,7 +331,10 @@
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,
+ jitter.fac = jitter.fac, with.lab = with.lab,
+ cex.lbs = cex.lbs, adj.lbs = adj.lbs,
+ col.lbs = if(!missing(col.lbs)) col.lbs else if(!missing(col.pts)) col.pts else par("col"),
+ 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,
@@ -341,6 +345,17 @@
plotInfo <- list(call = mc, dots=dots, args=args0)
n <- if(!is.null(dim(y))) nrow(y) else length(y)
+
+ L2Fam <- eval(x at CallL2Fam)
+ trafO <- trafo(L2Fam at param)
+ dims0 <- length(.getToDraw(nrow(trafO), trafO, L2Fam, eval(dots$to.draw.arg)))
+
+ if(missing(adj.lbs)) adj.lbs <- c(0,0)
+ if(!is.matrix(adj.lbs) ||
+ (is.matrix(adj.lbs)&&!all.equal(dim(adj.lbs),c(2,dims0)))){
+ adj.lbs <- matrix(rep(adj.lbs, length.out= dims0*2),nrow=2,ncol=dims0)
+ }
+
if(attr.pre){
if(missing(pch.pts)) pch.pts <- 1
if(!length(pch.pts)==n)
@@ -351,6 +366,14 @@
if(missing(cex.pts)) cex.pts <- 1
if(!length(cex.pts)==n)
cex.pts <- rep(cex.pts, length.out= n)
+ if(missing(cex.lbs)) cex.lbs <- 1
+ if(!is.matrix(cex.lbs) ||
+ (is.matrix(cex.lbs)&&!all.equal(dim(cex.lbs),c(n,dims0)))){
+ cex.lbs <- matrix(rep(cex.lbs, length.out= n*dims0),nrow=n,ncol=dims0)
+ }
+ if(missing(col.lbs)) col.lbs <- col.pts
+ if(!length(col.lbs)==n)
+ col.lbs <- rep(col.lbs, length.out= n)
lab.pts <- if(is.null(lab.pts)) paste(1:n) else rep(lab.pts,length.out=n)
}
@@ -380,7 +403,7 @@
i.d <- sel$ind
i0.d <- sel$ind1
- n <- length(i.d)
+ n.s <- length(i.d)
i.d.ns <- sel$ind.ns
n.ns <- length(i.d.ns)
@@ -393,17 +416,19 @@
cex.npts <- cex.pts[sel$ind.ns]
cex.pts <- cex.pts[sel$ind]
lab.pts <- lab.pts[sel$ind]
+ cex.lbs <- cex.lbs[sel$ind,]
+ col.lbs <- col.lbs[sel$ind]
}else{
if(missing(pch.pts)) pch.pts <- 1
- if(!length(pch.pts)==n)
- pch.pts <- rep(pch.pts, length.out= n)
+ if(!length(pch.pts)==n.s)
+ pch.pts <- rep(pch.pts, length.out= n.s)
if(missing(col.pts)) col.pts <- par("col")
- if(!length(col.pts)==n)
- col.pts <- rep(col.pts, length.out= n)
+ if(!length(col.pts)==n.s)
+ col.pts <- rep(col.pts, length.out= n.s)
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(!length(cex.pts)==n.s)
+ cex.pts <- rep(cex.pts, length.out= n.s)
+ lab.pts <- if(is.null(lab.pts)) paste(1:n.s) else rep(lab.pts,length.out=n.s)
if(missing(pch.npts)) pch.npts <- 1
if(!length(pch.npts)==n.ns)
@@ -414,6 +439,13 @@
if(missing(cex.npts)) cex.npts <- 1
if(!length(cex.npts)==n.ns)
cex.npts <- rep(cex.npts, length.out= n.ns)
+ if(!is.matrix(cex.lbs) ||
+ (is.matrix(cex.lbs)&&!all.equal(dim(cex.lbs),c(n.s,dims0)))){
+ cex.lbs <- matrix(rep(cex.lbs, length.out= n.s*dims0),nrow=n.s,ncol=dims0)
+ }
+ if(missing(col.lbs)) col.lbs <- col.pts
+ if(!length(col.lbs)==n.s)
+ col.lbs <- rep(col.lbs, length.out= n.s)
}
@@ -473,10 +505,10 @@
col = col.pts, pch = pch0), dwo0))
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)
+ text(x = y0s, y = ICy, adj=adj.lb0[,i], labels = lab.pts0,
+ cex = cex.lb0[,i], col = col.lb0)
+ pI$doLabs[[i]] <- list(x = y0s, y = ICy, adj=adj.lb0[,i],
+ labels = lab.pts0, cex = cex.lb0[,i], col = col.lb0)
}
}
@@ -512,7 +544,8 @@
with.lab0 = with.lab, lab.pts0 = lab.pts,
al0 = alpha.trsp, jitter.fac0 = jitter.fac,
cexfun=cex.pts.fun, cexnfun=cex.npts.fun,
- trEnv0 = trEnv
+ trEnv0 = trEnv, cex.lb0 = cex.lbs, adj.lb0 = adj.lbs,
+ col.lb0=col.lbs
))
assign("plotInfo", plotInfo, envir = trEnv)
@@ -526,3 +559,4 @@
return(invisible(plotInfo))
})
+
Modified: branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R 2018-07-25 11:42:58 UTC (rev 1059)
+++ branches/robast-1.1/pkg/RobAStBase/R/comparePlot.R 2018-07-26 06:42:44 UTC (rev 1060)
@@ -16,10 +16,11 @@
scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL,
cex.pts = 1, cex.pts.fun = NULL, col.pts = par("col"),
- pch.pts = 1,
+ pch.pts = 19,
cex.npts = 1, cex.npts.fun = NULL, col.npts = par("col"),
- pch.npts = 2,
- jitter.fac = 1, with.lab = FALSE, lab.pts = NULL,
+ pch.npts = 20,
+ jitter.fac = 1, with.lab = FALSE, cex.lbs = 1, adj.lbs = c(0,0),
+ col.lbs = col.pts, lab.pts = NULL,
lab.font = NULL, alpha.trsp = NA,
which.lbs = NULL, which.Order = NULL, which.nonlbs = NULL,
attr.pre = FALSE, return.Order = FALSE,
@@ -44,8 +45,10 @@
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,
+ jitter.fac = jitter.fac, with.lab = with.lab,
+ cex.lbs = cex.lbs, adj.lbs = adj.lbs,
+ col.lbs = if(!missing(col.lbs)) col.lbs else if(!missing(col.pts)) col.pts else par("col"),
+ 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)
@@ -280,6 +283,13 @@
if(!is.null(cex.npts.fun)){
cex.npts.fun <- .fillList(cex.npts.fun, dims0*ncomp)}
+ if(missing(adj.lbs)) cex.lbs <- c(0,0)
+ if(!is.array(adj.lbs) ||
+ (is.array(adj.lbs)&&!all.equal(dim(adj.lbs),c(2,ncomp,dims0)))){
+ adj.lbs <- array(rep(adj.lbs, length.out= 2*dims0*ncomp),
+ dim=c(2,ncomp,dims0))
+ }
+
if(attr.pre){
if(missing(pch.pts)) pch.pts <- 1
if(!is.matrix(pch.pts))
@@ -292,7 +302,19 @@
if(missing(cex.pts)) cex.pts <- 1
if(!is.matrix(cex.pts))
cex.pts <- matrix(rep(cex.pts, length.out= ncomp*n),n,ncomp)
+
+ if(missing(cex.lbs)) cex.lbs <- 1
+ if(!is.array(cex.lbs) ||
+ (is.array(cex.lbs)&&!all.equal(dim(cex.lbs),c(n,ncomp,dims0)))){
+ cex.lbs <- array(rep(cex.lbs, length.out= n*dims0*ncomp),
+ dim=c(n,ncomp,dims0))
+ }
+
+ if(missing(col.lbs)) col.lbs <- col.pts
+ if(!is.matrix(col.lbs))
+ col.lbs <- t(matrix(rep(col.lbs, length.out= ncomp*n),ncomp,n))
}
+
if(!is.null(lab.pts))
lab.pts <- matrix(rep(lab.pts, length.out=n*ncomp),n,ncomp)
@@ -337,6 +359,12 @@
lab0.pts <- lab.pts[sel1$ind,]
lab0.pts[,2] <- lab.pts[sel2$ind,2]
+ cex0.lbs <- cex.lbs[sel1$ind,,,drop=FALSE]
+ cex0.lbs[,2,] <- cex.lbs[sel2$ind,2,]
+
+ col0.lbs <- col.lbs[sel1$ind,]
+ col0.lbs[,2] <- col.lbs[sel2$ind,2]
+
col.npts <- col.pts[sel1$ind.ns,]
col.npts[,2] <- col.pts[sel2$ind.ns,2]
@@ -359,6 +387,8 @@
pch0.pts[,3] <- pch.pts[sel3$ind,3]
cex0.pts[,3] <- cex.pts[sel3$ind,3]
lab0.pts[,3] <- lab.pts[sel3$ind,3]
+ cex0.lbs[,3,] <- cex.lbs[sel3$ind,3,]
+ col0.lbs[,3] <- col.lbs[sel3$ind,3]
col.npts[,3] <- col.pts[sel3$ind.ns,3]
pch.npts[,3] <- pch.pts[sel3$ind.ns,3]
cex.npts[,3] <- cex.pts[sel3$ind.ns,3]
@@ -374,7 +404,9 @@
col0.pts[,4] <- col.pts[sel4$ind,4]
pch0.pts[,4] <- pch.pts[sel4$ind,4]
cex0.pts[,4] <- cex.pts[sel4$ind,4]
- lab0.pts[,4] <- lab.pts[sel3$ind,4]
+ lab0.pts[,4] <- lab.pts[sel4$ind,4]
+ cex0.lbs[,4,] <- cex.lbs[sel4$ind,4,]
+ col0.lbs[,4] <- col.lbs[sel4$ind,4]
col.npts[,4] <- col.pts[sel4$ind.ns,4]
pch.npts[,4] <- pch.pts[sel4$ind.ns,4]
cex.npts[,4] <- cex.pts[sel4$ind.ns,4]
@@ -386,6 +418,8 @@
pch.pts <- pch0.pts
cex.pts <- cex0.pts
lab.pts <- lab0.pts
+ cex.lbs <- cex0.lbs
+ col.lbs <- col0.lbs
}else{
n.s <- length(sel1$ind)
n.ns <- length(sel1$ind.ns)
@@ -410,6 +444,17 @@
if(!is.matrix(cex.npts))
cex.npts <- matrix(rep(cex.npts, length.out= ncomp*n.ns),n.ns,ncomp)
+ if(missing(cex.lbs)) cex.lbs <- 1
+ if(!is.array(cex.lbs) ||
+ (is.array(cex.lbs)&&all.equal(dim(cex.lbs),c(n.s,ncomp,dims0)))){
+ cex.lbs <- array(rep(cex.lbs, length.out= n.s*dims0*dims0),
+ dim=c(n.s,ncomp,dims0))
+ }
+
+ if(missing(col.lbs)) col.lbs <- col.pts
+ if(!is.matrix(col.lbs))
+ col.lbs <- t(matrix(rep(col.lbs, length.out= ncomp*n.s),ncomp,n.s))
+
if(missing(lab.pts)) lab.pts <- 1:n.s
if(!is.matrix(lab.pts))
lab.pts <- matrix(rep(lab.pts, length.out= ncomp*n.s),n.s,ncomp)
@@ -465,9 +510,9 @@
col = col.l, pch = pch.l), dwo0))
if(with.lab0){
text(rescd$X[i.l], rescd$Y[i.l], labels = lab.pts.l,
- cex = cex.l/2, col = col.l)
+ cex = cexl[,j.l,i], col = coll0[,j.l], adj=adjl[,j.l,i])
pI$doLabs[[(i-1)*ncomp+j.l]] <- list(rescd$X[i.l], rescd$Y[i.l], labels = lab.pts.l,
- cex = cex.l/2, col = col.l)
+ cex = cexl[,j.l,i], col = coll0[,j.l],adj=adjl[,j.l,i])
}
}
}
@@ -495,7 +540,8 @@
jitter.fac0 = jitter.fac, dwo0 = dots.points, al0 = alp.v,
with.lab0 = with.lab, lab0 = lab.pts, cexfun=cex.pts.fun,
cexn0 = cex.npts, pchn0 = pch.npts, coln0 = col.npts,
- cexnfun=cex.npts.fun, trEnv0 = trEnv)
+ cexnfun=cex.npts.fun, trEnv0 = trEnv, cexl0 = cex.lbs,
+ adjl0 = adj.lbs, coll0 = col.lbs)
#,scaleX = scaleX, scaleX.fct = scaleX.fct,
#scaleX.inv = scaleX.inv, scaleY = scaleY,
#scaleY.fct = scaleY.fct, scaleY.inv = scaleY.inv)
Modified: branches/robast-1.1/pkg/RobAStBase/R/infoPlot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/infoPlot.R 2018-07-25 11:42:58 UTC (rev 1059)
+++ branches/robast-1.1/pkg/RobAStBase/R/infoPlot.R 2018-07-26 06:42:44 UTC (rev 1060)
@@ -14,10 +14,11 @@
scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL,
cex.pts = 1, cex.pts.fun = NULL, col.pts = par("col"),
- pch.pts = 1,
+ pch.pts = 19,
cex.npts = 1, cex.npts.fun = NULL, col.npts = grey(.5),
- pch.npts = 2,
- jitter.fac = 1, with.lab = FALSE, lab.pts = NULL,
+ pch.npts = 20,
+ jitter.fac = 1, with.lab = FALSE, cex.lbs = 1, adj.lbs = c(0,0),
+ col.lbs = col.pts, lab.pts = NULL,
lab.font = NULL, alpha.trsp = NA,
which.lbs = NULL, which.Order = NULL, which.nonlbs = NULL,
attr.pre = FALSE, return.Order = FALSE,
@@ -43,8 +44,10 @@
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,
+ jitter.fac = jitter.fac, with.lab = with.lab,
+ cex.lbs = cex.lbs, adj.lbs = adj.lbs,
+ col.lbs = if(!missing(col.lbs)) col.lbs else if(!missing(col.pts)) col.pts else par("col"),
+ 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, ylab.abs = ylab.abs, ylab.rel= ylab.rel,
@@ -301,6 +304,16 @@
cex.npts.fun <- .fillList(cex.npts.fun, (dims1)*2)
}
+ if(missing(adj.lbs)) cex.lbs <- c(0,0)
+ if(!is.array(adj.lbs) ||
+ (is.array(adj.lbs)&&!all.equal(dim(adj.lbs),c(2,2,dims1)))){
+ adj.lbs <- array(rep(adj.lbs, length.out= 2*dims1*2),
+ dim=c(2,2,dims1))
+ }
+ adjC.lbs <- matrix(adj.lbs[,2,],nrow=2,ncol=dims1)
+ adj.lbs <- matrix(adj.lbs[,1,],nrow=2,ncol=dims1)
+
+
if(attr.pre){
if(missing(pch.pts)) pch.pts <- 1
if(!is.matrix(pch.pts))
@@ -313,6 +326,18 @@
if(missing(cex.pts)) cex.pts <- 1
if(!is.matrix(cex.pts))
cex.pts <- matrix(rep(cex.pts, length.out= 2*n),n,2)
+
+ if(missing(cex.lbs)) cex.lbs <- 1
+ if(!is.array(cex.lbs) ||
+ (is.array(cex.lbs)&&!all.equal(dim(cex.lbs),c(n,2,dims1)))){
+ cex.lbs <- array(rep(cex.lbs, length.out= n*dims1*2),
+ dim=c(n,2,dims1))
+ }
+
+ if(missing(col.lbs)) col.lbs <- col.pts
+ if(!is.matrix(col.lbs))
+ col.lbs <- t(matrix(rep(col.lbs, length.out= 2*n),2,n))
+
}
if(!is.null(lab.pts))
lab.pts <- rep(lab.pts, length.out=n)
@@ -372,6 +397,14 @@
lab0.pts <- lab.pts[sel$ind,1]
labC.pts <- lab.pts[sel.C$ind,2]
lab.pts <- lab0.pts
+
+ cex0.lbs <- matrix(cex.lbs[sel$ind,1,],nrow=n.s,ncol=dims1)
+ cexC.lbs <- matrix(cex.lbs[sel.C$ind,2,],nrow=n.s,ncol=dims1)
+ cex.lbs <- cex0.lbs
+
+ col0.lbs <- col.lbs[sel$ind,1]
+ colC.lbs <- col.lbs[sel$ind,2]
+ col.lbs <- col0.lbs
}else{
if(missing(pch.pts)) pch.pts <- 1
if(!is.matrix(pch.pts))
@@ -409,6 +442,21 @@
cexC.npts <- cex.npts[,2]
cex.npts <- cex.npts[,1]
+ if(missing(cex.lbs)) cex.lbs <- 1
+ if(!is.array(cex.lbs) ||
+ (is.array(cex.lbs)&&all.equal(dim(cex.lbs),c(n.s,2,dims1)))){
+ cex.lbs <- array(rep(cex.lbs, length.out= n.s*dims1*2),
+ dim=c(n.s,2,dims1))
+ }
+ cexC.lbs <- matrix(cex.lbs[,2,],nrow=n.s,ncol=dims1)
+ cex.lbs <- matrix(cex.lbs[,1,],nrow=n.s,ncol=dims1)
+
+ if(missing(col.lbs)) col.lbs <- col.pts
+ if(!is.matrix(col.lbs))
+ col.lbs <- t(matrix(rep(col.lbs, length.out= 2*n.s),2,n.s))
+ colC.lbs <- col.lbs[,2]
+ col.lbs <- col.lbs[,1]
+
if(!is.null(lab.pts)){
lab.pts <- matrix(rep(lab.pts, length.out= 2*n.s),n.s,2)
}
@@ -459,9 +507,9 @@
if(length(x)>0)
do.call(points,args=c(list(x,y,cex=cxa,col=ca,pch=pa),
dots.points))}
- tx <- function(xa,ya,lb,cx,ca){
+ tx <- function(xa,ya,lb,cx,ca,ad){
if(length(xa)>0)
- if(!is.null(lb)) text(x=xa,y=ya,labels=lb,cex=cx, col=ca)
+ if(!is.null(lb)) text(x=xa,y=ya,labels=lb,cex=cx, col=ca, adj=ad)
}
alp.v <- rep(alpha.trsp, length.out = dims1)
@@ -494,12 +542,12 @@
do.pts(x0c, ICy0cr1, f1c,colC.pts,pch0C)
if(with.lab0){
- tx(x0, ICy0r1, lab.pts0, f1/2, col.pts)
- tx(x0c, ICy0cr1, labC.pts0, f1c/2, colC.pts)
- pI$doLabsAbs <- list(x = x0, y = ICy0r1,
- lab = lab.pts0, cex = f1/2, col= col0)
- pI$doLabsCAbs <- list(x = x0c, y = ICy0cr1,
- lab = labC.pts0, cex = f1c/2, col= col0C)
+ tx(x0, ICy0r1, lab.pts0, cex.lbs0, col.lbs0, adj.lbs0)
+ tx(x0c, ICy0cr1, labC.pts0, cexC.lbs0, colC.lbs0, adjC.lbs0)
+ pI$doLabsAbs <- list(x = x0, y = ICy0r1, adj = adj.lbs0,
+ lab = lab.pts0, cex = cex.lbs0, col= col.lbs0)
+ pI$doLabsCAbs <- list(x = x0c, y = ICy0cr1, adj = adjC.lbs0,
+ lab = labC.pts0, cex = cexC.lbs0, col= colC.lbs0)
}
}
if(length(ICy0.ns)){
@@ -553,6 +601,12 @@
with.lab0 = with.lab, n0 = n,
jitter.fac0 = jitter.fac, cexfun = cex.pts.fun,
cexfun.ns = cex.npts.fun,
+ cex.lbs0 = cex.lbs[,1],
+ cexC.lbs0 = cexC.lbs[,1],
+ adj.lbs0 = adj.lbs[,1],
+ adjC.lbs0 = adjC.lbs[,1],
+ col.lbs0 = col.lbs,
+ colC.lbs0 = colC.lbs,
trEnv0 = trEnv)
)
@@ -601,12 +655,14 @@
do.pts(resc.rel.c$X, resc.rel.c$Y, f1c,colC.pts,pch0C)
if(with.lab0){
- tx(resc.rel$X, resc.rel$Y, lab.pts0, f1/2, col0)
- tx(resc.rel.c$X, resc.rel.c$Y, labC.pts0, f1c/2, col0C)
+ cexl <- cex.lbs0[,i1]; cexlC <- cexC.lbs0[,i1]
+ adjl <- adj.lbs0[,i1]; adjlC <- adjC.lbs0[,i1]
+ tx(resc.rel$X, resc.rel$Y, lab.pts0, cexl, col.lbs0, adjl)
+ tx(resc.rel.c$X, resc.rel.c$Y, labC.pts0, cexlC, colC.lbs0, adjlC)
pI$doLabsRel[[i]] <- list(x = resc.rel$X, y = resc.rel$Y,
- lab = lab.pts0, cex = f1/2, col= col0)
+ lab = lab.pts0, cex = cexl, col= col.lbs0, adj=adjl)
pI$doLabsCRel[[i]] <- list(x = resc.rel.c$X, y = resc.rel.c$Y,
- lab = labC.pts0, cex = f1c/2, col= col0C)
+ lab = labC.pts0, cex = cexlC, col= colC.lbs0, adj=adjl)
}
}
if(length(x0.ns)){
@@ -632,7 +688,7 @@
pI$resc.datC.rel.ns[[i]] <- resc.rel.c.ns
c1fun.ns <- if(is.null(cexfun.ns)) NULL else cexfun.ns[[(i1-1)*2+1]]
- c2fun.ns <- if(is.null(cexfun.ns)) NULL else cexfun.ns[[(i1-1)*2+1]]
+ c2fun.ns <- if(is.null(cexfun.ns)) NULL else cexfun.ns[[(i1-1)*2+2]]
f1.ns <- .cexscale(resc.rel.ns$scy,resc.rel.c.ns$scy,cex=cex0.ns, fun = c1fun.ns)
f1c.ns <- .cexscale(resc.rel.c.ns$scy,resc.rel.ns$scy,cex=cex0C.ns, fun = c2fun.ns)
@@ -673,6 +729,12 @@
with.lab0 = with.lab, n0 = n, al0 = alp.v,
jitter.fac0 = jitter.fac, cexfun = cex.pts.fun,
cexfun.ns = cex.npts.fun,
+ cex.lbs0 = cex.lbs,
+ cexC.lbs0 = cexC.lbs,
+ adj.lbs0 = adj.lbs,
+ adjC.lbs0 = adjC.lbs,
+ col.lbs0 = col.lbs,
+ colC.lbs0 = colC.lbs,
trEnv0 = trEnv)
)
Modified: branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R 2018-07-25 11:42:58 UTC (rev 1059)
+++ branches/robast-1.1/pkg/RobAStBase/R/plotWrapper.R 2018-07-26 06:42:44 UTC (rev 1060)
@@ -157,6 +157,9 @@
,pch.npts = substitute(20)
,jitter.fac = substitute(1)
,with.lab = substitute(FALSE)
+ ,cex.lbs = substitute(1)
+ ,adj.lbs = substitute(c(0,0))
+ ,col.lbs = substitute(par("col"))
,lab.pts = substitute(NULL)
,lab.font = substitute(NULL)
,alpha.trsp = substitute(alpha.trsp)
@@ -356,6 +359,9 @@
,pch.npts = substitute(20)
,jitter.fac = substitute(1)
,with.lab = substitute(FALSE)
+ ,cex.lbs = substitute(1)
+ ,adj.lbs = substitute(c(0,0))
+ ,col.lbs = substitute(par("col"))
,lab.pts = substitute(NULL)
,lab.font = substitute(NULL)
,alpha.trsp = substitute(alpha.trsp)
@@ -555,6 +561,9 @@
,pch.npts = substitute(20)
,jitter.fac = substitute(1)
,with.lab = substitute(FALSE)
+ ,cex.lbs = substitute(1)
+ ,adj.lbs = substitute(c(0,0))
+ ,col.lbs = substitute(par("col"))
,lab.pts = substitute(NULL)
,lab.font = substitute(NULL)
,alpha.trsp = substitute(alpha.trsp)
Modified: branches/robast-1.1/pkg/RobAStBase/R/qqplot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/qqplot.R 2018-07-25 11:42:58 UTC (rev 1059)
+++ branches/robast-1.1/pkg/RobAStBase/R/qqplot.R 2018-07-26 06:42:44 UTC (rev 1060)
@@ -58,7 +58,7 @@
xD <- fct(distance)(x)
x.cex <- 3/(1+log(1+xD))
- mcl$cex.pch <- x.cex
+ mcl$cex.pts <- x.cex
retv <- do.call(getMethod("qqplot", signature(x="ANY", y="ProbFamily")),
args=mcl)
@@ -126,7 +126,7 @@
x.cex <- 3/(1+.cexscale(xD,xD,cex=cex.pts, fun = cex.pts.fun))
- mcl$cex.pch <- x.cex
+ mcl$cex.pts <- x.cex
retv <- do.call(getMethod("qqplot", signature(x="ANY", y="ProbFamily")),
args=mcl)
@@ -143,19 +143,19 @@
withConf.pw = withConf, withConf.sim = withConf,
plot.it = TRUE, xlab = deparse(substitute(x)),
ylab = deparse(substitute(y)), ...,
- exp.cex2.lbl = -.15,
- exp.cex2.pch = -.35,
- exp.fadcol.lbl = 1.85,
- exp.fadcol.pch = 1.85,
+ exp.cex2.lbs = -.15,
+ exp.cex2.pts = -.35,
+ exp.fadcol.lbs = 1.85,
+ exp.fadcol.pts = 1.85,
bg = "white"
){
args0 <- list(x=x,y=y,n=n,withIdLine=withIdLine, withConf=withConf,
withConf.pw = if(!missing(withConf.pw)) withConf.pw else if(!missing(withConf)) withConf else NULL,
withConf.sim = if(!missing(withConf.sim)) withConf.sim else if(!missing(withConf)) withConf else NULL,
- plot.it = plot.it, xlab = xlab, ylab = ylab, exp.cex2.lbl=exp.cex2.lbl,
- exp.cex2.pch=exp.cex2.pch, exp.fadcol.lbl=exp.fadcol.lbl,
- exp.fadcol.pch=exp.fadcol.pch, bg=bg)
+ plot.it = plot.it, xlab = xlab, ylab = ylab, exp.cex2.lbs=exp.cex2.lbs,
+ exp.cex2.pts=exp.cex2.pts, exp.fadcol.lbs=exp.fadcol.lbs,
+ exp.fadcol.pts=exp.fadcol.pts, bg=bg)
mc <- match.call(call = sys.call(sys.parent(1)))
mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
@@ -184,19 +184,19 @@
w.fct <- function(x)
weight(weight(IC))(L.fct(matrix(x))[,,1])
- wx <- w.fct(x)
+ wx <- 1/(1+w.fct(x))
if(max(wx)>1) wx <- wx/max(wx)
mcl$order.traf <- function(x) 1/w.fct(x)
- cex.lbl <- if(is.null(mcl$cex.lbl)) par("cex") else eval(mcl$cex.lbl)
- cex.pch <- if(is.null(mcl$cex.pch)) par("cex") else eval(mcl$cex.pch)
- mcl$cex.lbl <- cex.lbl*wx^exp.cex2.lbl
- mcl$cex.pch <- cex.pch*wx^exp.cex2.pch
+ cex.lbs <- if(is.null(mcl$cex.lbs)) par("cex") else eval(mcl$cex.lbs)
+ cex.pts <- if(is.null(mcl$cex.pts)) par("cex") else eval(mcl$cex.pts)
+ mcl$cex.lbs <- cex.lbs*wx^exp.cex2.lbs
+ mcl$cex.pts <- cex.pts*wx^exp.cex2.pts
- col.lbl <- if(is.null(mcl$col.lbl)) par("col") else eval(mcl$col.lbl)
- col.pch <- if(is.null(mcl$col.pch)) par("col") else eval(mcl$col.pch)
- mcl$col.lbl <- .fadeColor(col.lbl,wx^exp.fadcol.lbl, bg = bg)
- mcl$col.pch <- .fadeColor(col.pch,wx^exp.fadcol.pch, bg = bg)
+ col.lbs <- if(is.null(mcl$col.lbs)) par("col") else eval(mcl$col.lbs)
+ col.pts <- if(is.null(mcl$col.pts)) par("col") else eval(mcl$col.pts)
+ mcl$col.lbs <- .fadeColor(col.lbs,wx^exp.fadcol.lbs, bg = bg)
+ mcl$col.pts <- .fadeColor(col.pts,wx^exp.fadcol.pts, bg = bg)
}
retv <- do.call(getMethod("qqplot", signature(x="ANY", y="ProbFamily")),
Modified: branches/robast-1.1/pkg/RobAStBase/R/returnlevelplot.R
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/R/returnlevelplot.R 2018-07-25 11:42:58 UTC (rev 1059)
+++ branches/robast-1.1/pkg/RobAStBase/R/returnlevelplot.R 2018-07-26 06:42:44 UTC (rev 1060)
@@ -46,7 +46,7 @@
xD <- fct(distance)(x)
x.cex <- 3/(1+log(1+xD))
- mcl$cex.pch <- x.cex
+ mcl$cex.pts <- x.cex
retv <- do.call(getMethod("returnlevelplot", signature(x="ANY", y="ProbFamily")),
args=mcl)
@@ -112,7 +112,7 @@
x.cex <- 3/(1+.cexscale(xD,xD,cex=cex.pts, fun = cex.pts.fun))
- mcl$cex.pch <- x.cex
+ mcl$cex.pts <- x.cex
retv <- do.call(getMethod("returnlevelplot", signature(x="ANY", y="ProbFamily")),
args=mcl)
@@ -129,18 +129,18 @@
withConf.pw = withConf, withConf.sim = withConf,
plot.it = TRUE, xlab = deparse(substitute(x)),
ylab = deparse(substitute(y)), ...,
- exp.cex2.lbl = -.15,
- exp.cex2.pch = -.35,
- exp.fadcol.lbl = 1.85,
- exp.fadcol.pch = 1.85,
+ exp.cex2.lbs = -.15,
+ exp.cex2.pts = -.35,
+ exp.fadcol.lbs = 1.85,
+ exp.fadcol.pts = 1.85,
bg = "white"
){
args0 <- list(x=x,y=y,n=n,withIdLine=withIdLine, withConf=withConf,
withConf.pw = if(!missing(withConf.pw)) withConf.pw else if(!missing(withConf)) withConf else NULL,
withConf.sim = if(!missing(withConf.sim)) withConf.sim else if(!missing(withConf)) withConf else NULL,
- plot.it = plot.it, xlab = xlab, ylab = ylab, exp.cex2.lbl=exp.cex2.lbl,
- exp.cex2.pch=exp.cex2.pch, exp.fadcol.lbl=exp.fadcol.lbl,
- exp.fadcol.pch=exp.fadcol.pch, bg=bg)
+ plot.it = plot.it, xlab = xlab, ylab = ylab, exp.cex2.lbs=exp.cex2.lbs,
+ exp.cex2.pts=exp.cex2.pts, exp.fadcol.lbs=exp.fadcol.lbs,
+ exp.fadcol.pts=exp.fadcol.pts, bg=bg)
mc <- match.call(call = sys.call(sys.parent(1)))
mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
@@ -169,19 +169,19 @@
w.fct <- function(x)
weight(weight(IC))(L.fct(matrix(x))[,,1])
- wx <- w.fct(x)
+ wx <- 1/(1+w.fct(x))
if(max(wx)>1) wx <- wx/max(wx)
mcl$order.traf <- function(x) 1/w.fct(x)
- cex.lbl <- if(is.null(mcl$cex.lbl)) par("cex") else eval(mcl$cex.lbl)
- cex.pch <- if(is.null(mcl$cex.pch)) par("cex") else eval(mcl$cex.pch)
- mcl$cex.lbl <- cex.lbl*wx^exp.cex2.lbl
- mcl$cex.pch <- cex.pch*wx^exp.cex2.pch
+ cex.lbs <- if(is.null(mcl$cex.lbs)) par("cex") else eval(mcl$cex.lbs)
+ cex.pts <- if(is.null(mcl$cex.pts)) par("cex") else eval(mcl$cex.pts)
+ mcl$cex.lbs <- cex.lbs*wx^exp.cex2.lbs
+ mcl$cex.pts <- cex.pts*wx^exp.cex2.pts
- col.lbl <- if(is.null(mcl$col.lbl)) par("col") else eval(mcl$col.lbl)
- col.pch <- if(is.null(mcl$col.pch)) par("col") else eval(mcl$col.pch)
- mcl$col.lbl <- .fadeColor(col.lbl,wx^exp.fadcol.lbl, bg = bg)
- mcl$col.pch <- .fadeColor(col.pch,wx^exp.fadcol.pch, bg = bg)
+ col.lbs <- if(is.null(mcl$col.lbs)) par("col") else eval(mcl$col.lbs)
+ col.pts <- if(is.null(mcl$col.pts)) par("col") else eval(mcl$col.pts)
+ mcl$col.lbs <- .fadeColor(col.lbs,wx^exp.fadcol.lbs, bg = bg)
+ mcl$col.pts <- .fadeColor(col.pts,wx^exp.fadcol.pts, bg = bg)
}
retv <- do.call(getMethod("returnlevelplot", signature(x="ANY", y="ProbFamily")),
Modified: branches/robast-1.1/pkg/RobAStBase/inst/NEWS
===================================================================
--- branches/robast-1.1/pkg/RobAStBase/inst/NEWS 2018-07-25 11:42:58 UTC (rev 1059)
+++ branches/robast-1.1/pkg/RobAStBase/inst/NEWS 2018-07-26 06:42:44 UTC (rev 1060)
@@ -12,7 +12,19 @@
#######################################
user-visible CHANGES:
-+ plot-methods now have arguments .nonlb to only plot (but not label) some points
++ plot-methods now have arguments .nonlbs to only plot (but not label) some points
++ all diagnostics (including qqplot and returnlevelplot) have adopted the same
+ argument naming (and selection paradigm)
+ the suffix is .lbs instead of .lbl,
+ the attributes of shown points have ending .pts
+ the observations are classed into three groups:
+ - the labelled observations selected through which.lbs and which.Order
+ - the shown non labelled observations (which are not in the previous set)
+ selected by which.nonlbs
+ - the non-shown observations (the remaining ones not contained in the former 2 grps)
+ -> point attributes may either refer to prior selection or to post-selection in
+ which case we have .npts variants
++ changed the default plotting symbol to 19
+ plot-methods are vectorized to a higher extent in all arguments
+ plot methods now return an S3 object of class \code{c("plotInfo","DiagnInfo")}, i.e., a list containing the
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1060
More information about the Robast-commits
mailing list