[Robast-commits] r692 - in pkg/RobAStBase: R tests/Examples
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 11 16:21:01 CEST 2013
Author: ruckdeschel
Date: 2013-09-11 16:21:01 +0200 (Wed, 11 Sep 2013)
New Revision: 692
Modified:
pkg/RobAStBase/R/IC.R
pkg/RobAStBase/R/InfluenceCurve.R
pkg/RobAStBase/R/ddPlot_utils.R
pkg/RobAStBase/R/infoPlot.R
pkg/RobAStBase/R/kStepEstimator.R
pkg/RobAStBase/R/oneStepEstimator.R
pkg/RobAStBase/R/qqplot.R
pkg/RobAStBase/tests/Examples/RobAStBase-Ex.Rout.save
Log:
forgot some files in trunk RobAStBase
Modified: pkg/RobAStBase/R/IC.R
===================================================================
--- pkg/RobAStBase/R/IC.R 2013-09-11 14:07:52 UTC (rev 691)
+++ pkg/RobAStBase/R/IC.R 2013-09-11 14:21:01 UTC (rev 692)
@@ -75,6 +75,8 @@
if(out){
cat("precision of Fisher consistency:\n")
print(consist)
+ cat("precision of Fisher consistency - relativ error [%]:\n")
+ print(100*consist/trafo)
}
prec <- max(abs(cent), abs(consist))
Modified: pkg/RobAStBase/R/InfluenceCurve.R
===================================================================
--- pkg/RobAStBase/R/InfluenceCurve.R 2013-09-11 14:07:52 UTC (rev 691)
+++ pkg/RobAStBase/R/InfluenceCurve.R 2013-09-11 14:21:01 UTC (rev 692)
@@ -28,10 +28,27 @@
return(IC1)
}
+### helper function to recursively evaluate list
+.evalListRec <- function(list0){ ## a list
+ len <- length(list0)
+ if(len==0L) return(list0)
+ for(i in 1:len) {
+ if(is.list(list0[[i]])){ list0[[i]] <- .evalListRec(list0[[i]])
+ }else list0[[i]] <- eval(list0[[i]])
+ }
+ return(list0)
+}
+
## access methods
setMethod("name", "InfluenceCurve", function(object) object at name)
setMethod("Curve", "InfluenceCurve", function(object) object at Curve)
-setMethod("Risks", "InfluenceCurve", function(object) object at Risks)
+setMethod("Risks", "InfluenceCurve", function(object){
+ risks <- object at Risks
+ risks <- .evalListRec(risks)
+ eval.parent(object at Risks <- risks)
+ risks
+})
+
setMethod("Infos", "InfluenceCurve", function(object) object at Infos)
## add risk or information
Modified: pkg/RobAStBase/R/ddPlot_utils.R
===================================================================
--- pkg/RobAStBase/R/ddPlot_utils.R 2013-09-11 14:07:52 UTC (rev 691)
+++ pkg/RobAStBase/R/ddPlot_utils.R 2013-09-11 14:21:01 UTC (rev 692)
@@ -1,23 +1,34 @@
-.presubs <- distr:::.presubs
+.ddPlot.MatNtNtCoCo <- function(data, ...,
+ dist.x = NormType(),
+ dist.y = NormType(),
+ cutoff.x = cutoff(norm = dist.x, cutoff.quantile = cutoff.quantile.x),
+ cutoff.y = cutoff(norm = dist.y, cutoff.quantile = cutoff.quantile.y),
+ cutoff.quantile.x = 0.95,
+ cutoff.quantile.y = cutoff.quantile.x,
+ transform.x,
+ transform.y = transform.x,
+ id.n,
+ lab.pts,
+ adj =0,
+ cex.idn = 1,
+ col.idn = par("col"),
+ lty.cutoff,
+ lwd.cutoff,
+ col.cutoff = "red",
+ 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%%",
+ jitt.fac = 10){
-.ddPlot.MatNtNtCoCo <- function(data, ..., dist.x = NormType(), dist.y = NormType(),
- cutoff.x = cutoff(norm = dist.x, cutoff.quantile = cutoff.quantile.x),
- cutoff.y = cutoff(norm = dist.y, cutoff.quantile = cutoff.quantile.y),
- cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
- transform.x, transform.y = transform.x,
- id.n, lab.pts, adj =0, cex.idn,
- col.idn, lty.cutoff,
- lwd.cutoff, col.cutoff = "red", 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%%"){
+ dots <- match.call(expand.dots = FALSE)$"..."
- dots <- match.call(expand.dots = FALSE)$"..."
- print(dots)
id.n1 <- 1:ncol(data)
if(missing(id.n) || is.null(id.n))
@@ -25,7 +36,7 @@
if(missing(lab.pts)|| is.null(lab.pts)){
- lab.pts <- if(!is.null(colnames(data))) colnames(data) else 1:ncol(data)
+ lab.pts <- if(!is.null(colnames(data))) colnames(data) else id.n1
}
data <- data[,id.n, drop = FALSE]
@@ -46,9 +57,17 @@
if(is.null(dist.x)) dist.x <- NormType()
if(is.null(dist.y)) dist.y <- NormType()
+
if(is.null(dots$xlab)) dots$xlab <- name(dist.x)
if(is.null(dots$ylab)) dots$ylab <- name(dist.y)
+ if(!is.null(dots$log)){
+ if(grepl("x",dots$log)) dots$xlab <- paste(dots$xlab, "(log-scale)",
+ sep=" ")
+ if(grepl("y",dots$log)) dots$ylab <- paste(dots$ylab, "(log-scale)",
+ sep=" ")
+ }
+
if(is.null(cutoff.quantile.x))
cutoff.quantile.x <- 0.95
@@ -72,106 +91,116 @@
ndata.x <- fct(dist.x)(data.x)
ndata.y <- fct(dist.y)(data.y)
+
+# print(head(ndata.x))
co.x <- fct(cutoff.x)(data.x)
co.y <- fct(cutoff.y)(data.y)
-
if(is.null(adj)) adj <- 0
- if(missing(cex.idn)||is.null(cex.idn)) cex.idn <- if(is.null(dots$cex)) 1 else dots$cex
- if(missing(col.idn)||is.null(col.idn)) col.idn <- if(is.null(dots$col)) par("col") else dots$col
- if(is.null(col.cutoff)) col.cutoff <- "red"
- print(cex.idn)
- print(col.idn)
+ if(missing(cex.idn)||is.null(cex.idn))
+ cex.idn <- if(is.null(dots$cex)) 1 else dots$cex
+ if(missing(col.idn)||is.null(col.idn))
+ col.idn <- if(is.null(dots$col)) par("col") else dots$col
+
if(is.null(dots$lwd)) dots$lwd <- par("lwd")
if(is.null(dots$lty)) dots$lty <- par("lty")
+ 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
- pdots <- dots
- pdots$type <- NULL
+ pdots <- .makedotsLowLevel(dots)
+ pdots$xlab <- dots$xlab
+ pdots$ylab <- dots$ylab
+ pdots$nsim <- NULL
pdots$x <- NULL
pdots$y <- NULL
pdots$offset <- NULL
pdots$pos <- NULL
- pdots$log <- NULL
pdots$untf <- NULL
- abdots <- pdots
- 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
-
+ 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$pos <- NULL
- abdots$untf <- dots$untf
- abdots$adj <- NULL
+ abdots$jitt.fac <- dots$jitt.fac
abdots <- list(abdots,abdots)
-
- 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]
-
+ 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]
+
ab.textL <- rep(text.abline,length.out=2)
- 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)
+ 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)
font.abline <- rep(font.abline, length.out = 2)
adj.abline <- matrix(rep(adj.abline,length.out=4),2,2)
- .mpresubs <- function(inx)
+ .mpresubs <- function(inx)
.presubs(inx, c("%qx", "%qy", "%cx", "%cy"),
- c(gettextf(text.abline.x.fmt.qx, round(cutoff.quantile.x*100,1)),
- gettextf(text.abline.y.fmt.qy, round(cutoff.quantile.y*100,1)),
- gettextf(text.abline.x.fmt.cx, round(co.x,2)),
- gettextf(text.abline.y.fmt.cy, round(co.y,2))))
+ c(gettextf(text.abline.x.fmt.qx,
+ round(cutoff.quantile.x*100,1)),
+ gettextf(text.abline.y.fmt.qy,
+ round(cutoff.quantile.y*100,1)),
+ gettextf(text.abline.x.fmt.cx,
+ 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))
+ 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))
abtdots.x$cex <- cex.abline[1]
- abtdots.x$col <- col.abline[1]
- abtdots.x$font <- font.abline[1]
- abtdots.x$srt <- NULL
- abtdots.x$adj <- adj.abline[,1]
+ abtdots.x$col <- col.abline[1]
+ abtdots.x$font <- font.abline[1]
+ abtdots.x$srt <- NULL
+ 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))
- abtdots.y$cex <- cex.abline[2]
- abtdots.y$col <- col.abline[2]
- abtdots.y$font <- font.abline[2]
- abtdots.y$srt <- NULL
- abtdots.y$adj <- adj.abline[,2]
-
- adots <- pdots
- adots$col <- pdots$col.axis
- adots$lty <- pdots$lty.axis
- adots$adj <- par("adj")
+ 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))
+ abtdots.y$cex <- cex.abline[2]
+ abtdots.y$col <- col.abline[2]
+ abtdots.y$font <- font.abline[2]
+ abtdots.y$srt <- NULL
+ abtdots.y$adj <- adj.abline[,2]
- tdots <- pdots
+ tdots <- .makedotsT(dots)
tdots$cex <- cex.idn
tdots$col <- col.idn
tdots$offset <- dots$offset
tdots$pos <- dots$pos
tdots$adj <- adj
- pdots$axes <- FALSE
pdots$log <- dots$log
pdots$adj <- par("adj")
+ adots <- pdots
+ adots$col <- pdots$col.axis
+ adots$lty <- pdots$lty.axis
+ adots$adj <- par("adj")
+
+ pdots$axes <- FALSE
+ pdots$adj <- par("adj")
####
# print(quantile(ndata.x))
@@ -201,27 +230,32 @@
id0.xy <- id.n1[id.xy]
id0.x <- id.n1[id.x]
id0.y <- id.n1[id.y]
+ do.call(plot, args = c(list(x = ndata.x, y=ndata.y, type = "p"), pdots))
+ do.call(box,args=c(adots))
- do.call(plot, args = c(list(x = ndata.x,ndata.y, type = "p"), pdots))
- do.call(box,args=c(adots))
- do.call(abline, args = c(list(v=co.x), abdots[[1]]))
- do.call(abline, args = c(list(h=co.y), abdots[[2]]))
-
pusr <- par("usr")
- mid.x = mean(pusr[c(1,2)])
- mid.y = mean(pusr[c(3,4)])
+ 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
-
+ do.call(abline, args = c(list(v=co.x), abdots[[1]]))
+ do.call(abline, args = c(list(h=co.y), abdots[[2]]))
+
if(ab.textL[1])
do.call(text, args = c(list(y=co.y*1.03), abtdots.y))
+# 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))
+# 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(ndata.x[id.xy], ndata.y[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))
+ #axis(side=4)
+# axis(side=1)
+
return(list(id.x=id0.x, id.y= id0.y, id.xy = id0.xy,
qtx = quantile(ndata.x), qty = quantile(ndata.y),
cutoff.x.v = co.x, cutoff.y.v = co.y
Modified: pkg/RobAStBase/R/infoPlot.R
===================================================================
--- pkg/RobAStBase/R/infoPlot.R 2013-09-11 14:07:52 UTC (rev 691)
+++ pkg/RobAStBase/R/infoPlot.R 2013-09-11 14:21:01 UTC (rev 692)
@@ -6,12 +6,15 @@
main = FALSE, inner = TRUE, sub = FALSE,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
- with.legend = TRUE, legend.bg = "white",
+ with.legend = TRUE, legend = NULL, legend.bg = "white",
legend.location = "bottomright", legend.cex = 0.8,
+ scaleX = FALSE, scaleX.fct, scaleX.inv,
+ scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
+ scaleN = 9, x.ticks = NULL, y.ticks = NULL,
mfColRow = TRUE, to.draw.arg = NULL,
cex.pts = 1, col.pts = par("col"),
pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
- lab.pts = NULL, lab.font = NULL,
+ lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
which.lbs = NULL, which.Order = NULL, return.Order = FALSE,
ylab.abs = "absolute information",
ylab.rel= "relative information"){
@@ -20,16 +23,22 @@
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
-
L2Fam <- eval(object at CallL2Fam)
-
- if(!is.null(dots[["type"]])) dots["type"] <- NULL
- if(!is.null(dots[["xlab"]])) dots["xlab"] <- NULL
- if(!is.null(dots[["ylab"]])) dots["ylab"] <- NULL
-
+ if(missing(scaleX.fct)){
+ scaleX.fct <- p(L2Fam)
+ scaleX.inv <- q(L2Fam)
+ }
+
+ withbox <- TRUE
+ if(!is.null(dots[["withbox"]])) withbox <- dots[["withbox"]]
+ dots["withbox"] <- NULL
+ dots["type"] <- NULL
+ xlab <- dots$xlab; if(is.null(xlab)) xlab <- "x"
+ dots$xlab <- dots$ylab <- NULL
+
trafO <- trafo(L2Fam at param)
- dims <- nrow(trafO)
+ dimsA <- dims <- nrow(trafO)
dimm <- ncol(trafO)
to.draw <- 1:(dims+1)
@@ -50,29 +59,41 @@
ncols <- ceiling(dims0/nrows)
in1to.draw <- (1%in%to.draw)
- if(missing(legend.location)){
- legend.location <- distr:::.fillList(list("topright"), dims0+in1to.draw )
- if (in1to.draw) legend.location[[1]] <- "bottomright"
- }else{
- legend.location <- as.list(legend.location)
- legend.location <- distr:::.fillList(legend.location, dims0+in1to.draw )
+ if(!is.null(x.ticks)) dots$xaxt <- "n"
+ if(!is.null(y.ticks)){
+ y.ticks <- .fillList(list(y.ticks), dims0+in1to.draw)
+ dots$yaxt <- "n"
}
- e1 <- L2Fam at distribution
- if(!is(e1, "UnivariateDistribution") | is(e1, "CondDistribution"))
+ if(with.legend){
+ if(missing(legend.location)){
+ legend.location <- .fillList(list("topright"), dims0+in1to.draw )
+ if (in1to.draw) legend.location[[1]] <- "bottomright"
+ }else{
+ legend.location <- as.list(legend.location)
+ legend.location <- .fillList(legend.location, dims0+in1to.draw )
+ }
+ if(is.null(legend)){
+ legend <- vector("list",dims0+in1to.draw)
+ legend <- .fillList(list(as.list(c("class. opt. IC", objectc))),
+ dims0+in1to.draw)
+ }
+ }
+ distr <- L2Fam at distribution
+ if(!is(distr, "UnivariateDistribution") | is(distr, "CondDistribution"))
stop("not yet implemented")
- if(is(e1, "UnivariateDistribution")){
+ if(is(distr, "UnivariateDistribution")){
xlim <- eval(dots$xlim)
if(!is.null(xlim)){
xm <- min(xlim)
xM <- max(xlim)
dots$xlim <- NULL
}
- if(is(e1, "AbscontDistribution")){
- lower0 <- getLow(e1, eps = getdistrOption("TruncQuantile")*2)
- upper0 <- getUp(e1, eps = getdistrOption("TruncQuantile")*2)
- me <- median(e1); s <- IQR(e1)
+ if(is(distr, "AbscontDistribution")){
+ lower0 <- getLow(distr, eps = getdistrOption("TruncQuantile")*2)
+ upper0 <- getUp(distr, eps = getdistrOption("TruncQuantile")*2)
+ me <- median(distr); s <- IQR(distr)
lower1 <- me - 6 * s
upper1 <- me + 6 * s
lower <- max(lower0, lower1)
@@ -86,9 +107,9 @@
plty <- "l"
if(missing(lty)) lty <- "solid"
}else{
- if(is(e1, "DiscreteDistribution")) x.vec <- support(e1)
+ if(is(distr, "DiscreteDistribution")) x.vec <- support(distr)
else{
- x.vec <- r(e1)(1000)
+ x.vec <- r(distr)(1000)
x.vec <- sort(unique(x.vec))
}
plty <- "p"
@@ -104,9 +125,14 @@
dots$ylim <- NULL
}
- dotsP <- dotsL <- dotsT <- dots
- dotsL$lwd <- dotsL$col <- dotsL$lty <- NULL
- dotsP$lwd <- dotsP$col <- dotsP$lty <- NULL
+ dotsP <- dots
+ dotsP$type <- dotsP$lty <- dotsP$col <- dotsP$lwd <- NULL
+ dotsP$xlab <- dotsP$ylab <- NULL
+
+ dotsL <- .makedotsLowLevel(dotsP)
+ dotsT <- dotsL
+ dotsT["main"] <- dotsT["cex.main"] <- dotsT["col.main"] <- NULL
+ dotsT["line"] <- NULL
dotsP$xlim <- xlim
trafo <- trafo(L2Fam at param)
@@ -117,7 +143,7 @@
lineT <- NA
.mpresubs <- function(inx)
- distr:::.presubs(inx, c("%C", "%D", "%A"),
+ .presubs(inx, c("%C", "%D", "%A"),
c(as.character(class(object)[1]),
as.character(date()),
as.character(deparse(objectc))))
@@ -127,7 +153,7 @@
if (is.logical(main)){
if (!main) mainL <- FALSE
else
- main <- gettextf("Plot for IC %%A") ###
+ main <- gettextf("Information Plot for IC %%A") ###
### double %% as % is special for gettextf
}
main <- .mpresubs(main)
@@ -179,7 +205,7 @@
#stop("Argument 'inner' must either be 'logical' or a 'list'")
if(!is.list(inner))
inner <- as.list(inner)
- innerT <- distr:::.fillList(inner,1+dims)
+ innerT <- .fillList(inner,1+dims)
if(dims0<dims){
innerT0 <- innerT
for(i in 1:dims0) innerT[1+to.draw[i]] <- innerT0[1+i]
@@ -201,8 +227,8 @@
}
- QFc <- diag(dims)
- if(is(object,"ContIC") & dims>1 )
+ QFc <- diag(dimsA)
+ if(is(object,"ContIC") & dimsA>1 )
{if (is(normtype(object),"QFNorm")) QFc <- QuadForm(normtype(object))
QFc0 <- solve( trafo %*% solve(L2Fam at FisherInfo) %*% t(trafo ))
if (is(normtype(object),"SelfNorm")|is(normtype(object),"InfoNorm"))
@@ -222,12 +248,12 @@
absInfoClass.f <- t(classIC) %*% QFc %*% classIC
absInfoClass <- absInfoEval(x.vec, absInfoClass.f)
- QF <- diag(dims)
- if(is(object,"ContIC") & dims>1 )
+ QF <- diag(dimsA)
+ if(is(object,"ContIC") & dimsA>1 )
{if (is(normtype(object),"QFNorm")) QF <- QuadForm(normtype(object))}
QF.5 <- sqrt(PosSemDefSymmMatrix(QF))
- IC1 <- as(diag(dims) %*% object at Curve, "EuclRandVariable")
+ IC1 <- as(diag(dimsA) %*% object at Curve, "EuclRandVariable")
absInfo.f <- t(IC1) %*% QF %*% IC1
absInfo <- absInfoEval(x.vec, absInfo.f)
@@ -242,28 +268,50 @@
# devNew()
omar <- par("mar")
- parArgs <- list(mar = c(bmar,omar[2],tmar,omar[4]))
- do.call(par,args=parArgs)
+ lpA <- max(length(to.draw),1)
+ parArgsL <- vector("list",lpA)
+ bmar <- rep(bmar, length.out=lpA)
+ tmar <- rep(tmar, length.out=lpA)
+ xaxt0 <- if(is.null(dots$xaxt)) {
+ if(is.null(dots$axes)||eval(dots$axes))
+ rep(par("xaxt"),lpA) else rep("n",lpA)
+ }else rep(eval(dots$xaxt),lpA)
+ yaxt0 <- if(is.null(dots$yaxt)) {
+ if(is.null(dots$axes)||eval(dots$axes))
+ rep(par("yaxt"),lpA) else rep("n",lpA)
+ }else rep(eval(dots$yaxt),lpA)
+ for( i in 1:lpA){
+ parArgsL[[i]] <- list(mar = c(bmar[i],omar[2],tmar[i],omar[4])
+ ,xaxt=xaxt0[i], yaxt= yaxt0[i]
+ )
+ }
+
pL.rel <- pL.abs <- pL <- expression({})
- if(!is.null(dotsP$panel.last))
- {pL.rel <- pL.abs <- pL <- dotsP$panel.last}
- dotsP$panel.last <- NULL
+ if(!is.null(dots$panel.last))
+ {pL.rel <- pL.abs <- pL <- dots$panel.last}
if(!is.null(data)){
n <- if(!is.null(dim(data))) nrow(data) else length(data)
- oN0 <- oN0Class <- NULL
- if(is.null(which.lbs))
- which.lbs <- 1:n
- which.lbs0 <- (1:n) %in% which.lbs
- which.lbx <- rep(which.lbs0, length.out=length(data))
- data0C <- data0 <- data[which.lbx]
- n <- if(!is.null(dim(data0))) nrow(data0) else length(data0)
- oNC <- oN <- (1:n)[which.lbs0]
+ if(!is.null(lab.pts))
+ lab.pts <- matrix(rep(lab.pts, length.out=2*n),n,2)
- cex.pts <- rep(cex.pts, length.out=2)
+ sel <- .SelectOrderData(data, function(x)absInfoEval(x,absInfo.f),
+ which.lbs, which.Order)
+ sel.C <- .SelectOrderData(data, function(x)absInfoEval(x,absInfoClass.f),
+ which.lbs, which.Order)
+ i.d <- sel$ind
+ i.dC <- sel.C$ind
+ i0.d <- sel$ind1
+ i0.dC <- sel.C$ind1
+ y.d <- sel$y
+ y.dC <- sel.C$y
+ x.d <- sel$data
+ x.dC <- sel.C$data
+ n <- length(i.d)
+
if(missing(col.pts)) col.pts <- c(col, colI)
col.pts <- rep(col.pts, length.out=2)
pch.pts <- matrix(rep(pch.pts, length.out=2*n),n,2)
@@ -271,158 +319,192 @@
with.lab <- rep(with.lab, length.out=2)
lab.font <- rep(lab.font, length.out=2)
- absInfoClass.data <- absInfoEval(data,absInfoClass.f)
- absInfo.data <- absInfoEval(data,absInfo.f)
- absInfo0.data <- absInfo.data[which.lbs]
- absInfo0Class.data <- absInfoClass.data[which.lbs]
- aIC.data.m <- max(absInfo0Class.data)
- aI.data.m <- max(absInfo0.data)
+ resc.dat <-.rescalefct(x.d, function(x) absInfoEval(x,absInfo.f),
+ scaleX, scaleX.fct, scaleX.inv,
+ scaleY, scaleY.fct, dots$xlim, dots$ylim, dots)
+ resc.datC <-.rescalefct(x.d, function(x) absInfoEval(x,absInfoClass.f),
+ scaleX, scaleX.fct, scaleX.inv,
+ scaleY, scaleY.fct, dots$xlim, dots$ylim, dots)
- if (n==length(data0)) {
- oN <- order(absInfo0.data)
- oNC <- order(absInfo0Class.data)
+ x.dr <- resc.dat$X
+ x.dCr <- resc.datC$X
+ y.dr <- resc.dat$Y
+ y.dCr <- resc.datC$Y
- oN0 <- order(absInfo.data)
- oN0 <- oN0[oN0 %in% which.lbs]
- oN0Class <- order(absInfoClass.data)
- oN0Class <- oN0Class[oN0Class %in% which.lbs]
+ lab.pts <- if(is.null(lab.pts))
+ cbind(i.d, i.dC)
+ else cbind(lab.pts[i.d],lab.pts[i.dC])
- data0 <- data0[oN0]
- data0C <- data0[oN0Class]
- if(!is.null(which.Order)){
- oN <- oN0[(n+1)-which.Order]
- oNC <- oN0Class[(n+1)-which.Order]
- data0 <- data[oN]
- data0C <- data[oNC]
- absInfo0.data <- absInfo.data[oN]
- absInfo0Class.data <- absInfoClass.data[oNC]
- }
- n <- length(oN)
- }
- lab.pts <- if(is.null(lab.pts))
- matrix(paste(c(oN,oNC)),n,2)
- else matrix(rep(lab.pts, length.out=2*n),n,2)
+ dots.points <- .makedotsPt(dots)
+ do.pts <- function(x,y,cxa,ca,pa)
+ do.call(points,args=c(list(x,y,cex=cxa,col=ca,pch=pa),
+ dots.points))
+ tx <- function(xa,ya,lb,cx,ca)
+ text(x=xa,y=ya,labels=lb,cex=cx, col=ca)
- dots.points <- dots
- dots.points$col <- dots.points$cex <- dots.points$pch <- NULL
+ alp.v <- rep(alpha.trsp, length.out = dims0+in1to.draw)
+
pL.abs <- substitute({
- if(is(e1, "DiscreteDistribution")){
+ if(is(distr, "DiscreteDistribution")){
ICy0 <- jitter(ICy0, factor = jitter.fac0[1])
ICy0c <- jitter(ICy0c, factor = jitter.fac0[2])
}
- do.call(points, args=c(list(y0, ICy0, cex = log(ICy0+1)*3*cex0[1],
- col = col0[1], pch = pch0[,1]), dwo0))
- do.call(points, args=c(list(y0c, ICy0c, cex = log(ICy0c+1)*3*cex0[2],
- col = col0[2], pch = pch0[,2]), dwo0))
+ f1 <- log(ICy0+1)*3*cex0[1]
+ f1c <- log(ICy0c+1)*3*cex0[2]
+
+ col.pts <- if(!is.na(al0)) sapply(col0,
+ addAlphTrsp2col, alpha=al0) else col0
+
+ do.pts(y0, ICy0r, f1,col.pts[1],pch0[,1])
+ do.pts(y0c, ICy0cr, f1c,col.pts[2],pch0[,2])
if(with.lab0){
- text(x = y0, y = ICy0, labels = lab.pts0[,1],
- cex = log(ICy0+1)*1.5*cex0[1], col = col0[1])
- text(x = y0c, y = ICy0c, labels = lab.pts0[,2],
- cex = log(ICy0+1)*1.5*cex0[2], col = col0[2])
+ tx(y0, ICy0r, lab.pts0, f1/2, col0[1])
+ tx(y0c, ICy0cr, lab.pts0C, f1c/2, col0[2])
}
pL0
- }, list(ICy0 = absInfo0.data, ICy0c = absInfo0Class.data,
- pL0 = pL, y0 = data0, y0c = data0C,
- dwo0 = dots.points, cex0 = cex.pts, pch0 = pch.pts,
- col0 = col.pts, with.lab0 = with.lab,
- lab.pts0 = lab.pts, n0 = n,
- jitter.fac0 = jitter.fac, aIC.data.m0=aIC.data.m,
- aI.data.m0=aI.data.m
- ))
+ }, list(ICy0c = y.dC, ICy0 = y.d,
+ ICy0r = y.dr, ICy0cr = y.dCr,
+ pL0 = pL, y0 = x.dr, y0c = x.dCr,
+ cex0 = cex.pts, pch0 = pch.pts, al0 = alp.v[1],
+ col0 = col.pts, with.lab0 = with.lab, n0 = n,
+ lab.pts0 = lab.pts[i.d], lab.pts0C = lab.pts[i.dC],
+ jitter.fac0 = jitter.fac)
+ )
pL.rel <- substitute({
- y0.vec <- sapply(y0, IC1.i.5 at Map[[indi]])^2/ICy0
- y0c.vec <- sapply(y0c, classIC.i.5 at Map[[indi]])^2/ICy0c
- if(is(e1, "DiscreteDistribution")){
+ y0.vec <- sapply(y0, IC1.i.5 at Map[[indi]])^2/ICy0
+ y0c.vec <- sapply(y0c, classIC.i.5 at Map[[indi]])^2/ICy0c
+ if(is(distr, "DiscreteDistribution")){
y0.vec <- jitter(y0.vec, factor = jitter.fac0[1])
y0c.vec <- jitter(y0c.vec, factor = jitter.fac0[2])
}
- do.call(points, args=c(list(y0, y0.vec, cex = log(ICy0+1)*3*cex0[1],
- col = col0[1], pch = pch0[,1]), dwo0))
- do.call(points, args=c(list(y0, y0c.vec, cex = log(ICy0c+1)*3*cex0[2],
- col = col0[2], pch = pch0[,2]), dwo0))
+
+ col.pts <- if(!is.na(al0)) sapply(col0,
+ addAlphTrsp2col, alpha=al0[i1]) else col0
+ dotsP0 <- dotsP
+ resc.rel <- .rescalefct(y0, cbind(y0.vec,ICy0),
+ scaleX, scaleX.fct, scaleX.inv,
+ FALSE, scaleY.fct, dots$xlim, dots$ylim, dotsP0)
+ resc.rel.c <- .rescalefct(y0c, cbind(y0c.vec,ICy0c),
+ scaleX, scaleX.fct, scaleX.inv,
+ FALSE, scaleY.fct, dots$xlim, dots$ylim, dotsP0)
+
+ f1 <- resc.rel$scy*0.3*cex0[1]
+ f1c <- resc.rel.c$scy*0.3*cex0[2]
+
+ do.pts(resc.rel$X, resc.rel$Y, f1,col.pts[1],pch0[,1])
+ do.pts(resc.rel.c$X, resc.rel.c$Y, f1c,col.pts[2],pch0[,2])
if(with.lab0){
- text(x = y0, y = y0.vec, labels = lab.pts0[,1],
- cex = log(ICy0+1)*1.5*cex0[1], col = col0[1])
- text(x = y0, y = y0c.vec, labels = lab.pts0[,2],
- cex = log(ICy0c+1)*1.5*cex0[2], col = col0[2])
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 692
More information about the Robast-commits
mailing list