[Robast-commits] r244 - in branches/robast-0.7/pkg/RobAStBase: R chm man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jan 28 05:39:13 CET 2009
Author: ruckdeschel
Date: 2009-01-28 05:39:13 +0100 (Wed, 28 Jan 2009)
New Revision: 244
Modified:
branches/robast-0.7/pkg/RobAStBase/R/AllPlot.R
branches/robast-0.7/pkg/RobAStBase/R/comparePlot.R
branches/robast-0.7/pkg/RobAStBase/R/infoPlot.R
branches/robast-0.7/pkg/RobAStBase/chm/RobAStBase.chm
branches/robast-0.7/pkg/RobAStBase/chm/comparePlot.html
branches/robast-0.7/pkg/RobAStBase/chm/infoPlot.html
branches/robast-0.7/pkg/RobAStBase/chm/plot-methods.html
branches/robast-0.7/pkg/RobAStBase/man/comparePlot.Rd
branches/robast-0.7/pkg/RobAStBase/man/infoPlot.Rd
branches/robast-0.7/pkg/RobAStBase/man/plot-methods.Rd
Log:
+realized suggestions by A. Unwin, Augsburg;
plot for ICs, infoPlot, and comparePlot may be restricted to selected subplots;
+also named parameters are used in axis annotation if available.
+fixed xlim and ylim args for plots;
+ylim can now be matrix-valued...
Modified: branches/robast-0.7/pkg/RobAStBase/R/AllPlot.R
===================================================================
--- branches/robast-0.7/pkg/RobAStBase/R/AllPlot.R 2009-01-12 21:41:36 UTC (rev 243)
+++ branches/robast-0.7/pkg/RobAStBase/R/AllPlot.R 2009-01-28 04:39:13 UTC (rev 244)
@@ -3,12 +3,13 @@
main = FALSE, inner = TRUE, sub = FALSE,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
- mfColRow = TRUE){
+ mfColRow = TRUE, to.draw.arg = NULL){
xc <- match.call(call = sys.call(sys.parent(1)))$x
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
+
if(!is.logical(inner)){
if(!is.list(inner))
inner <- as.list(inner)
@@ -20,28 +21,66 @@
L2Fam <- eval(x at CallL2Fam)
+
+ trafO <- trafo(L2Fam at param)
+ dims <- nrow(trafO)
+ dimm <- length(L2Fam at param)
+
+ to.draw <- 1:dims
+ dimnms <- c(rownames(trafO))
+ if(is.null(dimnms))
+ dimnms <- paste("dim",1:dims,sep="")
+ if(!mfColRow && ! 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
+ }
+ dims0 <- length(to.draw)
+ nrows <- trunc(sqrt(dims0))
+ ncols <- ceiling(dims0/nrows)
+
+
e1 <- L2Fam at distribution
if(!is(e1, "UnivariateDistribution")) stop("not yet implemented")
- if(is(e1, "AbscontDistribution")){
- lower <- ifelse(is.finite(q(e1)(0)), q(e1)(0), q(e1)(getdistrOption("TruncQuantile")))
- upper <- ifelse(is.finite(q(e1)(1)), q(e1)(1), q(e1)(1 - getdistrOption("TruncQuantile")))
- h <- upper - lower
- x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
- plty <- "l"
- lty <- "solid"
- }else{
- if(is(e1, "DiscreteDistribution")){
- x.vec <- support(e1)
- plty <- "p"
- lty <- "dotted"
+ if(is(e1, "UnivariateDistribution")){
+ xlim <- eval(dots$xlim)
+ if(!is.null(xlim)){
+ xm <- min(xlim)
+ xM <- max(xlim)
+ }
+ if(is(e1, "AbscontDistribution")){
+ lower <- if(is.finite(q(e1)(0)))
+ q(e1)(0) else q(e1)(getdistrOption("TruncQuantile"))
+ upper <- if(is.finite(q(e1)(1)))
+ q(e1)(1) else q(e1)(1 - getdistrOption("TruncQuantile"))
+ if(!is.null(xlim)){
+ lower <- min(lower,xm)
+ upper <- max(upper,xM)
+ }
+ h <- upper - lower
+ x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
+ plty <- "l"
+ lty <- "solid"
}else{
- x.vec <- r(e1)(1000)
- x.vec <- sort(unique(x.vec))
+ 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)]
+
}
- }
+ }
+ 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(!is.null(dots[["lty"]])) dots["lty"] <- NULL
@@ -49,8 +88,7 @@
if(!is.null(dots[["xlab"]])) dots["xlab"] <- NULL
if(!is.null(dots[["ylab"]])) dots["ylab"] <- NULL
- dims <- nrow(L2Fam at param@trafo)
- IC1 <- as(diag(dims) %*% x at Curve, "EuclRandVariable")
+ IC1 <- as(diag(dimm) %*% x at Curve, "EuclRandVariable")
mainL <- FALSE
subL <- FALSE
@@ -92,25 +130,41 @@
}
if(is.logical(innerL)){
- innerT <- paste(gettextf("Component "), 1:dims,
- gettextf(" of (partial) IC\nfor"),
- name(L2Fam)[1],
- gettextf("\nwith main parameter ("),
- paste(round(L2Fam at param@main, 3), collapse = ", "),")")
- if(!is.null(L2Fam at param@nuisance))
+ 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(" 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(round(L2Fam at param@nuisance, 3), collapse = ", "),
+ paste(nnms,round(L2Fam at param@nuisance, 3), collapse = ", "),
")",
sep="" )
- if(!is.null(L2Fam at param@fixed))
+ }
+ 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(round(L2Fam at param@fixed, 3), collapse = ", "),
+ paste(fnms, round(L2Fam at param@fixed, 3), collapse = ", "),
")",
sep="" )
+ }
}else{
innerT <- lapply(inner, .mpresubs)
+ innerT <- distr:::.fillList(innerT,dims)
+ if(dims0<dims){
+ innerT0 <- innerT
+ for(i in 1:dims0) innerT[to.draw[i]] <- innerT0[i]
+ }
}
@@ -121,9 +175,8 @@
on.exit(par=opar)
if (!withSweave)
devNew()
- nrows <- trunc(sqrt(dims))
- ncols <- ceiling(dims/nrows)
+ parArgs <- NULL
if(mfColRow)
parArgs <- list(mfrow = c(nrows, ncols))
@@ -139,17 +192,20 @@
dotsT["line"] <- NULL
- for(i in 1:dims){
- do.call(plot, args=c(list(x.vec, sapply(x.vec, IC1 at Map[[i]]),
+ dots$ylim <- NULL
+ for(i in 1:dims0){
+ indi <- to.draw[i]
+ if(!is.null(ylim)) dots$ylim <- ylim[,i]
+ do.call(plot, args=c(list(x.vec, sapply(x.vec, IC1 at Map[[indi]]),
type = plty, lty = lty,
xlab = "x", ylab = "(partial) IC"),
dots))
if(is(e1, "DiscreteDistribution")){
x.vec1 <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
- do.call(lines,args=c(list(x.vec1, sapply(x.vec1, IC1 at Map[[i]]),
+ do.call(lines,args=c(list(x.vec1, sapply(x.vec1, IC1 at Map[[indi]]),
lty = "dotted"), dots))
}
- do.call(title,args=c(list(main = innerT[i]), dotsT, line = lineT,
+ do.call(title,args=c(list(main = innerT[indi]), dotsT, line = lineT,
cex.main = cex.inner, col.main = col.inner))
}
if(!hasArg(cex.main)) cex.main <- par("cex.main") else cex.main <- dots$"cex.main"
Modified: branches/robast-0.7/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-0.7/pkg/RobAStBase/R/comparePlot.R 2009-01-12 21:41:36 UTC (rev 243)
+++ branches/robast-0.7/pkg/RobAStBase/R/comparePlot.R 2009-01-28 04:39:13 UTC (rev 244)
@@ -4,7 +4,7 @@
main = FALSE, inner = TRUE, sub = FALSE,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
- mfColRow = TRUE){
+ mfColRow = TRUE, to.draw.arg = NULL){
xc1 <- as.character(deparse(match.call(call = sys.call(sys.parent(1)))$obj1))
xc2 <- as.character(deparse(match.call(call = sys.call(sys.parent(1)))$obj2))
@@ -32,39 +32,74 @@
dotsP <- dotsL <- dotsT <- dots
-
L2Fam <- eval(obj1 at CallL2Fam)
L2Fam1c <- obj1 at CallL2Fam
L2Fam2c <- obj2 at CallL2Fam
if(!identical(L2Fam1c,L2Fam2c))
stop("ICs need to be defined for the same model")
+ trafO <- trafo(L2Fam at param)
+ dims <- nrow(trafO)
+ dimm <- length(L2Fam at param)
+
+ to.draw <- 1:dims
+ dimnms <- c(rownames(trafO))
+ if(is.null(dimnms))
+ dimnms <- paste("dim",1:dims,sep="")
+ if(!mfColRow && ! 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
+ }
+ dims0 <- length(to.draw)
+ nrows <- trunc(sqrt(dims0))
+ ncols <- ceiling(dims0/nrows)
+
e1 <- L2Fam at distribution
if(!is(e1, "UnivariateDistribution")) stop("not yet implemented")
+ xlim <- eval(dots$xlim)
+ if(!is.null(xlim)){
+ xm <- min(xlim)
+ xM <- max(xlim)
+ }
if(is(e1, "AbscontDistribution")){
- lower <- ifelse(is.finite(q(e1)(0)), q(e1)(0), q(e1)(getdistrOption("TruncQuantile")))
- upper <- ifelse(is.finite(q(e1)(1)), q(e1)(1), q(e1)(1 - getdistrOption("TruncQuantile")))
+ lower <- if(is.finite(q(e1)(0)))
+ q(e1)(0) else q(e1)(getdistrOption("TruncQuantile"))
+ upper <- if(is.finite(q(e1)(1)))
+ q(e1)(1) else q(e1)(1 - getdistrOption("TruncQuantile"))
+ if(!is.null(xlim)){
+ lower <- min(lower,xm)
+ upper <- max(upper,xM)
+ }
h <- upper - lower
x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
plty <- "l"
lty <- "solid"
}else{
- if(is(e1, "DiscreteDistribution")){
- x.vec <- support(e1)
- plty <- "p"
- lty <- "dotted"
- }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"
}
+ plty <- "p"
+ lty <- "dotted"
+ if(!is.null(xlim)) x.vec <- x.vec[(x.vec>=xm) & (x.vec<=xM)]
}
+ 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)
+ }
+ dots$ylim <- NULL
+ dotsP$xlim <- xlim
+ dots$xlim <- NULL
dims <- nrow(L2Fam at param@trafo)
- IC1 <- as(diag(dims) %*% obj1 at Curve, "EuclRandVariable")
- IC2 <- as(diag(dims) %*% obj2 at Curve, "EuclRandVariable")
+ IC1 <- as(diag(dimm) %*% obj1 at Curve, "EuclRandVariable")
+ IC2 <- as(diag(dimm) %*% obj2 at Curve, "EuclRandVariable")
obj <- obj3
@@ -72,7 +107,7 @@
{
if(!identical(L2Fam1c,obj at CallL2Fam))
stop("ICs need to be defined for the same model")
- IC3 <- as(diag(dims) %*% obj3 at Curve, "EuclRandVariable")
+ IC3 <- as(diag(dimm) %*% obj3 at Curve, "EuclRandVariable")
}
obj <- obj4
@@ -80,7 +115,7 @@
{
if(!identical(L2Fam1c,obj at CallL2Fam))
stop("ICs need to be defined for the same model")
- IC4 <- as(diag(dims) %*% obj4 at Curve, "EuclRandVariable")
+ IC4 <- as(diag(dimm) %*% obj4 at Curve, "EuclRandVariable")
}
lineT <- NA
@@ -128,29 +163,40 @@
if (subL)
if (missing(bmar)) bmar <- 6
}
- innerParam <- paste(gettext("\nwith main parameter ("),
- paste(round(L2Fam at param@main, 3),
+ mnm <- names(L2Fam at param@main)
+ mnms <- if(is.null(mnm)) NULL else paste("'", mnm, "' = ", sep = "")
+ innerParam <- paste(gettext("\nwith main parameter ("),
+ paste(mnms, round(L2Fam at param@main, 3),
collapse = ", "),
")", sep = "")
- if(!is.null(L2Fam at param@nuisance))
- innerParam <- paste(innerParam,
+ if(!is.null(L2Fam at param@nuisance)){
+ nnm <- names(L2Fam at param@nuisance)
+ nnms <- if(is.null(nnm)) NULL else paste("'", nnm, "' = ", sep = "")
+ innerParam <- paste(innerParam,
gettext("\nand nuisance parameter ("),
- paste(round(L2Fam at param@nuisance, 3),
+ paste(nnms, round(L2Fam at param@nuisance, 3),
collapse = ", "),
")", sep ="")
- if(!is.null(L2Fam at param@fixed))
- innerParam <- paste(innerParam,
+ }
+ if(!is.null(L2Fam at param@fixed)){
+ fnm <- names(L2Fam at param@fixed)
+ fnms <- if(is.null(fnm)) NULL else paste("'", fnm, "' = ", sep = "")
+ innerParam <- paste(innerParam,
gettext("\nand fixed known parameter ("),
- paste(round(L2Fam at param@fixed, 3),
+ paste(fnms, round(L2Fam at param@fixed, 3),
collapse = ", "),
")", sep ="")
-
+ }
if(!is.logical(inner)){
# if(!is.character(inner))
# stop("Argument 'inner' must either be 'logical' or a character vector")
if(!is.list(inner))
inner <- as.list(inner)
innerT <- distr:::.fillList(inner,dims)
+ if(dims0<dims){
+ innerT0 <- innerT
+ for(i in 1:dims0) innerT[to.draw[i]] <- innerT0[i]
+ }
innerL <- TRUE
}else{if(any(is.na(inner))||any(!inner)) {
innerT <- as.list(rep("",dims)); innerL <- FALSE
@@ -167,40 +213,42 @@
on.exit(options(warn = w0))
opar <- par()
on.exit(par(opar))
- nrows <- trunc(sqrt(dims))
- ncols <- ceiling(dims/nrows)
- par(mfrow = c(nrows, ncols))
+
+ if(mfColRow)
+ par(mfrow = c(nrows, ncols))
if(is(e1, "DiscreteDistribution"))
x.vec1 <- seq(from = min(x.vec), to = max(x.vec), length = 1000)
-
+
dotsT["main"] <- NULL
dotsT["cex.main"] <- NULL
dotsT["col.main"] <- NULL
dotsT["line"] <- NULL
- for(i in 1:dims){
- matp <- cbind(sapply(x.vec, IC1 at Map[[i]]),sapply(x.vec, IC2 at Map[[i]]))
+ for(i in 1:dims0){
+ indi <- to.draw[i]
+ if(!is.null(ylim)) dotsP$ylim <- ylim[,i]
+ matp <- cbind(sapply(x.vec, IC1 at Map[[indi]]),sapply(x.vec, IC2 at Map[[indi]]))
if(is(obj3, "IC"))
- matp <- cbind(matp,sapply(x.vec, IC3 at Map[[i]]))
+ matp <- cbind(matp,sapply(x.vec, IC3 at Map[[indi]]))
if(is(obj4, "IC"))
- matp <- cbind(matp,sapply(x.vec, IC4 at Map[[i]]))
+ matp <- cbind(matp,sapply(x.vec, IC4 at Map[[indi]]))
do.call(matplot, args=c(list( x= x.vec, y=matp,
type = plty, lty = lty,
xlab = "x", ylab = "(partial) IC"), dotsP))
if(is(e1, "DiscreteDistribution")){
- matp1 <- cbind(sapply(x.vec1, IC1 at Map[[i]]),sapply(x.vec1, IC2 at Map[[i]]))
+ matp1 <- cbind(sapply(x.vec1, IC1 at Map[[indi]]),sapply(x.vec1, IC2 at Map[[indi]]))
if(is(obj3, "IC"))
- matp1 <- cbind(matp1,sapply(x.vec1, IC3 at Map[[i]]))
+ matp1 <- cbind(matp1,sapply(x.vec1, IC3 at Map[[indi]]))
if(is(obj4, "IC"))
- matp1 <- cbind(matp1,sapply(x.vec1, IC4 at Map[[i]]))
+ matp1 <- cbind(matp1,sapply(x.vec1, IC4 at Map[[indi]]))
do.call(matlines, c(list(x.vec1, matp1, lty = "dotted"),dotsL))
}
if(innerL)
- do.call(title, args=c(list(main = innerT[[i]]), dotsT,
+ do.call(title, args=c(list(main = innerT[[indi]]), dotsT,
line = lineT, cex.main = cex.inner, col.main = col.inner))
}
Modified: branches/robast-0.7/pkg/RobAStBase/R/infoPlot.R
===================================================================
--- branches/robast-0.7/pkg/RobAStBase/R/infoPlot.R 2009-01-12 21:41:36 UTC (rev 243)
+++ branches/robast-0.7/pkg/RobAStBase/R/infoPlot.R 2009-01-28 04:39:13 UTC (rev 244)
@@ -4,7 +4,7 @@
main = FALSE, inner = TRUE, sub = FALSE,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
- mfColRow = TRUE){
+ mfColRow = TRUE, to.draw.arg = NULL){
objectc <- match.call(call = sys.call(sys.parent(1)))$object
dots <- match.call(call = sys.call(sys.parent(1)),
@@ -21,29 +21,74 @@
if(!is.null(dots[["xlab"]])) dots["xlab"] <- NULL
if(!is.null(dots[["ylab"]])) dots["ylab"] <- NULL
- dotsP <- dotsL <- dotsT <- dots
+ trafO <- trafo(L2Fam at param)
+ dims <- nrow(trafO)
+ dimm <- length(L2Fam at param)
+
+ to.draw <- 1:(dims+1)
+ dimnms <- c(rownames(trafO))
+ if(is.null(dimnms))
+ dimnms <- paste("dim",1:dims,sep="")
+ pdimnms <- c("Abs",dimnms)
+ if(!mfColRow && ! is.null(to.draw.arg)){
+ if(is.character(to.draw.arg))
+ to.draw <- pmatch(to.draw.arg, pdimnms)
+ else if(is.numeric(to.draw.arg))
+ to.draw <- to.draw.arg
+ }
+
+ to.draw1 <- to.draw[to.draw>1]
+ dims0 <- length(to.draw1)
+ nrows <- trunc(sqrt(dims0))
+ ncols <- ceiling(dims0/nrows)
e1 <- L2Fam at distribution
if(!is(e1, "UnivariateDistribution") | is(e1, "CondDistribution"))
stop("not yet implemented")
if(is(e1, "UnivariateDistribution")){
+ xlim <- eval(dots$xlim)
+ if(!is.null(xlim)){
+ xm <- min(xlim)
+ xM <- max(xlim)
+ dots$xlim <- NULL
+ }
if(is(e1, "AbscontDistribution")){
- ifelse(is.finite(q(e1)(0)), lower <- q(e1)(0), lower <- q(e1)(getdistrOption("TruncQuantile")))
- ifelse(is.finite(q(e1)(1)), upper <- q(e1)(1), upper <- q(e1)(1 - getdistrOption("TruncQuantile")))
+ lower <- if(is.finite(q(e1)(0)))
+ q(e1)(0) else q(e1)(getdistrOption("TruncQuantile"))
+ upper <- if(is.finite(q(e1)(1)))
+ q(e1)(1) else q(e1)(1 - getdistrOption("TruncQuantile"))
+ if(!is.null(xlim)){
+ lower <- min(lower,xm)
+ upper <- max(upper,xM)
+ }
h <- upper - lower
x.vec <- seq(from = lower - 0.1*h, to = upper + 0.1*h, length = 1000)
plty <- "l"
lty <- "solid"
- }
- if(is(e1, "DiscreteDistribution")){
- x.vec <- support(e1)
- plty <- "o"
+ }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(xlim)) x.vec <- x.vec[(x.vec>=xm) & (x.vec<=xM)]
}
+ }
+ ylim <- eval(dots$ylim)
+ if(!is.null(ylim)){
+ if(!length(ylim) %in% c(2,2*(dims0+(1%in%to.draw))))
+ stop("Wrong length of Argument ylim");
+ ylim <- matrix(ylim, nrow=2,ncol=dims0+(1%in%to.draw))
+ dots$ylim <- NULL
+ }
- trafo <- L2Fam at param@trafo
- dims <- nrow(trafo)
+ dotsP <- dotsL <- dotsT <- dots
+ dotsP$xlim <- xlim
+
+ trafo <- L2Fam at param@trafo
mainL <- FALSE
@@ -84,44 +129,58 @@
if (subL)
if (missing(bmar)) bmar <- 6
}
- innerParam <- paste(gettext("\nwith main parameter ("),
- paste(round(L2Fam at param@main, 3),
- collapse = ", "),
- ")", sep = "")
- if(!is.null(L2Fam at param@nuisance))
- innerParam <- paste(innerParam,
- gettext("\nand nuisance parameter ("),
- paste(round(L2Fam at param@nuisance, 3),
- collapse = ", "),
- ")", sep ="")
- if(!is.null(L2Fam at param@fixed))
- innerParam <- paste(innerParam,
- gettext("\nand fixed known parameter ("),
- paste(round(L2Fam at param@fixed, 3),
- collapse = ", "),
- ")", sep ="")
-
- if(!is.logical(inner)){
+ mnm <- names(L2Fam at param@main)
+ mnms <- if(is.null(mnm)) NULL else paste("'", mnm, "' = ", sep = "")
+ innerParam <- paste(gettext("\nwith main parameter ("),
+ paste(mnms, round(L2Fam at param@main, 3),
+ collapse = ", "),
+ ")", sep = "")
+ if(!is.null(L2Fam at param@nuisance)){
+ nnm <- names(L2Fam at param@nuisance)
+ nnms <- if(is.null(nnm)) NULL else paste("'", nnm, "' = ", sep = "")
+ innerParam <- paste(innerParam,
+ gettext("\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 = "")
+ innerParam <- paste(innerParam,
+ gettext("\nand fixed known parameter ("),
+ paste(fnms, round(L2Fam at param@fixed, 3),
+ collapse = ", "),
+ ")", sep ="")
+ }
+ if(!is.logical(inner)){
#if(!is.character(inner))
#stop("Argument 'inner' must either be 'logical' or a 'list'")
if(!is.list(inner))
inner <- as.list(inner)
innerT <- distr:::.fillList(inner,1+dims)
+ if(dims0<dims){
+ innerT0 <- innerT
+ for(i in 1:dims0) innerT[1+to.draw[i]] <- innerT0[1+i]
+ }
innerL <- TRUE
}else{if(any(is.na(inner))||any(!inner)) {
innerT <- as.list(rep("",1+dims)); innerL <- FALSE
}else{innerL <- TRUE
+ tnm <- c(rownames(trafO))
+ tnms <- if(is.null(tnm)) paste(1:dims) else
+ paste("'", tnm, "'", sep = "")
innerT <- as.list(paste(c( paste(gettext("Absolute information of (partial) IC for"),
name(L2Fam)[1], sep =""),
paste(gettext("Relative information of \ncomponent "),
- 1:dims,
- gettext("of (partial) IC\nfor "),
+ tnms,
+ gettext(" of (partial) IC\nfor "),
name(L2Fam)[1], sep ="")), innerParam))
}
}
- QFc <- diag(dims)
+ QFc <- diag(dimm)
if(is(object,"ContIC") & dims>1 )
{if (is(normtype(object),"QFNorm")) QFc <- QuadForm(normtype(object))
QFc0 <- solve( trafo %*% solve(L2Fam at FisherInfo) %*% t(trafo ))
@@ -134,12 +193,12 @@
absInfoClass <- t(classIC) %*% QFc %*% classIC
absInfoClass <- sapply(x.vec, absInfoClass at Map[[1]])
- QF <- diag(dims)
+ QF <- diag(dimm)
if(is(object,"ContIC") & dims>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(dimm) %*% object at Curve, "EuclRandVariable")
absInfo <- t(IC1) %*% QF %*% IC1
absInfo <- sapply(x.vec, absInfo at Map[[1]])
@@ -160,34 +219,35 @@
dotsP["col"] <- NULL
dotsP["lwd"] <- NULL
- if(!hasArg(ylim)) dots["ylim"] <- c(0, 2*max(absInfo, na.rm = TRUE))
+ if(!is.null(ylim))
+ dotsP$ylim <- ylim[,1]
+ if(1 %in% to.draw){
+ do.call(plot, args=c(list(x.vec, absInfoClass, type = plty,
+ lty = "dashed", col = colI, lwd = lwdI,
+ xlab = "x", ylab = "absolute information"), dotsP))
+ do.call(lines, args=c(list(x.vec, absInfo, type = plty, lty = lty),
+ dotsL))
+ legend("top",
+ legend = c("class. opt. IC", objectc),
+ lty = c(lty,"dashed"), col = c(colI, col),
+ lwd=c(lwdI, lwd), cex = 0.75)
- do.call(plot, args=c(list(x.vec, absInfoClass, type = plty,
- lty = "dashed", col = colI, lwd = lwdI,
- xlab = "x",
- ylab = "absolute information"), dotsP))
- do.call(lines, args=c(list(x.vec, absInfo, type = plty, lty = lty),
- dotsL))
- legend("top",
- legend = c("class. opt. IC", objectc),
- lty = c(lty,"dashed"), col = c(colI, col),
- lwd=c(lwdI, lwd), cex = 0.75)
-
- dotsT["main"] <- NULL
- dotsT["cex.main"] <- NULL
- dotsT["col.main"] <- NULL
- dotsT["line"] <- NULL
- if(innerL)
- do.call(title, args=c(list(main = innerT[[1]]), dotsT,
- line = lineT, cex.main = cex.inner, col.main = col.inner))
+ dotsT["main"] <- NULL
+ dotsT["cex.main"] <- NULL
+ dotsT["col.main"] <- NULL
+ dotsT["line"] <- NULL
+ if(innerL)
+ do.call(title, args=c(list(main = innerT[[1]]), dotsT,
+ line = lineT, cex.main = cex.inner, col.main = col.inner))
+ }
- if(dims > 1){
+ if(dims0 > 1){
dotsP["ylim"] <- NULL
dotsL["ylim"] <- NULL
dotsT["ylim"] <- NULL
nrows <- trunc(sqrt(dims))
ncols <- ceiling(dims/nrows)
- if (!withSweave)
+ if (!withSweave||!mfColRow)
devNew()
if(mfColRow)
parArgs <- c(parArgs,list(mfrow = c(nrows, ncols)))
@@ -196,15 +256,18 @@
IC1.i.5 <- QF.5%*%IC1
classIC.i.5 <- QFc.5%*%classIC
- for(i in 1:dims){
- y.vec <- sapply(x.vec, IC1.i.5 at Map[[i]])^2/absInfo
+ for(i in 1:dims0){
+ indi <- to.draw1[i]-1
+ if(!is.null(ylim))
+ dotsP$ylim <- ylim[,(1%in%to.draw)+i]
+ else dotsP$ylim <- c(0,1)
+ y.vec <- sapply(x.vec, IC1.i.5 at Map[[indi]])^2/absInfo
do.call(plot, args=c(list(x.vec, y.vec, type = plty,
lty = lty, xlab = "x",
ylab = "relative information",
- ylim = c(0, 1.1),
col = colI, lwd = lwdI), dotsP))
- yc.vec <- sapply(x.vec, classIC.i.5 at Map[[i]])^2/absInfoClass
+ yc.vec <- sapply(x.vec, classIC.i.5 at Map[[indi]])^2/absInfoClass
do.call(lines, args=c(list(x.vec, yc.vec, type = plty,
lty = "dashed"), dotsL))
legend("topright",
@@ -212,7 +275,7 @@
col = c(colI, col), lwd=c(lwdI, lwd),
cex = 0.6)
if(innerL)
- do.call(title, args=c(list(main = innerT[[1+i]]), dotsT,
+ do.call(title, args=c(list(main = innerT[[1+indi]]), dotsT,
line = lineT, cex.main = cex.inner, col.main = col.inner))
}
}
@@ -229,6 +292,7 @@
outer = TRUE, line = -1.6, col = col.sub)
+ invisible()
}
- })
+ )
\ No newline at end of file
Modified: branches/robast-0.7/pkg/RobAStBase/chm/RobAStBase.chm
===================================================================
(Binary files differ)
Modified: branches/robast-0.7/pkg/RobAStBase/chm/comparePlot.html
===================================================================
--- branches/robast-0.7/pkg/RobAStBase/chm/comparePlot.html 2009-01-12 21:41:36 UTC (rev 243)
+++ branches/robast-0.7/pkg/RobAStBase/chm/comparePlot.html 2009-01-28 04:39:13 UTC (rev 244)
@@ -32,7 +32,7 @@
main = FALSE, inner = TRUE, sub = FALSE,
col.inner = par("col.main"), cex.inner = 0.8,
bmar = par("mar")[1], tmar = par("mar")[3],
- mfColRow = TRUE)
+ mfColRow = TRUE, to.draw.arg = NULL)
</pre>
@@ -61,9 +61,13 @@
just as argument <code>main</code> in <code><a onclick="findlink('graphics', 'plotdefault.html')" style="text-decoration: underline; color: blue; cursor: hand">plot.default</a></code>.</td></tr>
<tr valign="top"><td><code>inner</code></td>
<td>
-logical: panels have their own titles? or <br>
-character vector of / cast to length number of comparands:
-<code>main</code> in <code><a onclick="findlink('graphics', 'plotdefault.html')" style="text-decoration: underline; color: blue; cursor: hand">plot.default</a></code>)</td></tr>
+logical: do panels have their own titles? or <br>
+character vector of / cast to length 'number of plotted
+dimensions';
+if argument <code>to.draw.arg</code> is used, this refers to
+a vector of length <code>length(to.draw.arg)</code>, the
+actually plotted dimensions. For further information, see also
+description of argument <code>main</code> in <code><a onclick="findlink('graphics', 'plotdefault.html')" style="text-decoration: underline; color: blue; cursor: hand">plot.default</a></code>.</td></tr>
<tr valign="top"><td><code>sub</code></td>
<td>
logical: is a sub-title to be used? or <br>
@@ -85,6 +89,19 @@
<tr valign="top"><td><code>mfColRow</code></td>
<td>
shall default partition in panels be used — defaults to <code>TRUE</code></td></tr>
+<tr valign="top"><td><code>to.draw.arg</code></td>
+<td>
+if <code>mfColRow==FALSE</code>, either <code>NULL</code> (default;
+everything is plotted) or a vector of either integers
+(the indices of the subplots to be drawn) or characters
+— the names of the subplots to be drawn: these
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 244
More information about the Robast-commits
mailing list