Nothing
### from Matthias' thesis / ROptEst
setMethod("plot", signature(x = "ParamFamily", y = "missing"),
function(x, ...){
e1 <- x@distribution
if(!is(e1, "UnivariateDistribution")) stop("not yet implemented")
mc <- match.call(call = sys.call(sys.parent(1)))
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
args0 <- list(x=x)
plotInfo <- list(call = mc, dots=dots, args=args0)
plotInfo$distribution <- plot(e1,...)
class(plotInfo) <- c("plotInfo","DiagnInfo")
return(invisible(plotInfo))
})
setMethod("plot", signature(x = "L2ParamFamily", y = "missing"),
function(x, withSweave = getdistrOption("withSweave"),
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, to.draw.arg = NULL, withSubst= TRUE){
mc <- match.call(call = sys.call(sys.parent(1)))
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
args0 <- list(x=x, withSweave = withSweave,
main = main, inner = inner, sub = sub,
col.inner = col.inner, cex.inner = cex.inner,
bmar = bmar, tmar = tmar, mfColRow = mfColRow,
to.draw.arg = to.draw.arg, withSubst= withSubst)
plotInfo <- list(call = mc, dots=dots, args=args0)
xc <- mc$x
xcc <- as.character(deparse(xc))
.mpresubs <- if(withSubst){
function(inx)
.presubs(inx, c("%C", "%A", "%D" ),
c(as.character(class(x)[1]),
as.character(date()),
xcc))
}else function(inx)inx
dots$to.draw.arg <- NULL
trafO <- trafo(x@param)
# dims <- nrow(trafO)
dimm <- dims <- length(x@param)
to.draw <- 1:(3+dims)
dimnms <- names(main(x@param)) #c(rownames(trafO))
if(is.null(dimnms))
dimnms <- paste("dim",1:dims,sep="")
names(to.draw) <- c("d","p","q", dimnms)
if(! is.null(to.draw.arg)){
if(is.character(to.draw.arg))
to.draw <- pmatch(to.draw.arg, names(to.draw))
else if(is.numeric(to.draw.arg))
to.draw <- to.draw.arg
}
l.draw <- length(to.draw)
pF <- expression({})
if(!is.null(dots[["panel.first"]])){
pF <- .panel.mingle(dots,"panel.first")
}
pF <- .fillList(pF, l.draw)
pL <- expression({})
if(!is.null(dots[["panel.last"]])){
pl <- .panel.mingle(dots,"panel.last")
}
pL <- .fillList(pL, length(to.draw))
plotInfo$to.draw <- to.draw
plotInfo$panelFirst <- pF
plotInfo$panelLast <- pL
plotCount <- 1
l2dpl <- to.draw[to.draw > 3]
dims0 <- length(l2dpl)
nrows <- trunc(sqrt(dims0))
ncols <- ceiling(dims0/nrows)
if(!is.logical(inner)){
if(!is.list(inner))
inner <- as.list(inner)
#stop("Argument 'inner' must either be 'logical' or a 'list'")
innerLog <- TRUE
iL <- length(to.draw[to.draw <= 3])+length(l2dpl)
iLD <- (1:iL)[to.draw <= 3]
iLL <- (1:iL)[to.draw > 3]
inner <- .fillList(inner,iL)
innerD <- if(length(iLD)) inner[iLD] else NULL
innerL <- if(length(iLL)) inner[iLL] else NULL
}else{innerLog <- innerD <- innerL <- inner}
if(!is.null(dots[["lty"]])) dots["lty"] <- NULL
if(!is.null(dots[["type"]])) dots["type"] <- NULL
if(!is.null(dots[["xlab"]])) dots["xlab"] <- NULL
if(!is.null(dots[["ylab"]])) dots["ylab"] <- NULL
e1 <- x@distribution
if(!is(e1, "UnivariateDistribution")) stop("not yet implemented")
if(is(e1, "UnivariateDistribution")){
xlim <- eval(dots$xlim)
if(!is.null(xlim)){
xm <- min(xlim)
xM <- max(xlim)
}
if(is(e1, "AbscontDistribution")){
lower0 <- getLow(e1, eps = getdistrOption("TruncQuantile")*2)
upper0 <- getUp(e1, eps = getdistrOption("TruncQuantile")*2)
me <- median(e1); s <- IQR(e1)
lower1 <- me - 6 * s
upper1 <- me + 6 * s
lower <- max(lower0, lower1)
upper <- min(upper0, upper1)
if(!is.null(xlim)){
lower <- min(lower,xm)
upper <- max(upper,xM)
}
h <- upper - lower
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)
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)]
}
}
dxg <- d(e1)(x.vec)
pxg <- p(e1)(x.vec)
ylim <- eval(dots$ylim)
if(!is.null(ylim)){
d.0 <- 1 %in% to.draw
d.1 <- 2 %in% to.draw | 3 %in% to.draw
if(! length(ylim) %in% c(2,2*(d.0+d.1+dims0)))
stop("Wrong length of Argument ylim");
ylim <- matrix(ylim, 2,d.0+d.1+dims0)
iy <- if(d.0+d.1==2) 1:2 else 1
dots$ylim <- ylim[,iy]
}
L2deriv <- as(diag(dimm) %*% x@L2deriv, "EuclRandVariable")
mainL <- FALSE
subL <- FALSE
lineT <- NA
if (hasArg(main)){
mainL <- TRUE
if (is.logical(main)){
if (!main) mainL <- FALSE
else
main <- gettextf("Distribution Plot for model %%A") ###
### double %% as % is special for gettextf
}
main <- .mpresubs(main)
if (mainL) {
if(missing(tmar))
tmar <- 5
lineT <- 0.6
}
}
if(missing(cex.inner)){
cex.inner <- .65
cex.innerD <- 1
}else{
cex.inner <- rep(cex.inner, length.out=2)
cex.innerD <- cex.inner[1]
cex.inner <- cex.inner[2]
}
if (hasArg(sub)){
subL <- TRUE
if (is.logical(sub)){
if (!sub) subL <- FALSE
else sub <- gettextf("generated %%D")
### double %% as % is special for gettextf
}
sub <- .mpresubs(sub)
if (subL)
if (missing(bmar)) bmar <- 6
}
if(is.logical(innerL)){
# tnm <- c(rownames(trafO))
tnms <- 1:dims #if(is.null(tnm)) paste(1:dims) else paste("'", tnm, "'", sep = "")
mnm <- names(x@param@main)
mnms <- if(is.null(mnm)) NULL else paste("'", mnm, "' = ", sep = "")
mss <- paste(mnms, round(x@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(x@param@nuisance)){
nnm <- names(x@param@nuisance)
nnms <- if(is.null(nnm)) NULL else paste("'", nnm, "' = ", sep = "")
innerT <- paste(innerT,
gettextf("\nand nuisance parameter ("),
paste(nnms,round(x@param@nuisance, 3), collapse = ", "),
")",
sep="" )
}
if(!is.null(x@param@fixed)){
fnm <- names(x@param@fixed)
fnms <- if(is.null(fnm)) NULL else paste("'", fnm, "' = ", sep = "")
innerT <- paste(innerT,
gettextf("\nand fixed known parameter ("),
paste(fnms, round(x@param@fixed, 3), collapse = ", "),
")",
sep="" )
}
innerT <- if(length(l2dpl)) innerT[l2dpl-3] else NULL
}else{
innerT <- lapply(innerL, .mpresubs)
innerD <- lapply(innerD, .mpresubs)
}
dotsT <- dots
dotsT["main"] <- NULL
dotsT["cex.main"] <- NULL
dotsT["col.main"] <- NULL
dotsT["line"] <- NULL
distrpl <- (1:3) %in% to.draw
todrw <- as.numeric((1:3)[distrpl])
if(any(distrpl)){
lis0 <- c(list(e1, withSweave = withSweave,
main = main, inner = innerD, sub = sub,
col.inner = col.inner, cex.inner = cex.innerD),
dots, mfColRow = mfColRow)
lis0$to.draw.arg <- todrw
lis0[["panel.first"]] <- pF[plotCount+(0:2)]
lis0[["panel.last"]] <- pL[plotCount+(0:2)]
plotInfo$distr <- do.call(plot, args = lis0)
plotInfo$distr$List <- lis0
plotCount <- plotCount + 1
}
o.warn <- options("warn")
options(warn = -1)
on.exit(options(warn=o.warn))
opar <- par(no.readonly = TRUE)
# opar$cin <- opar$cra <- opar$csi <- opar$cxy <- opar$din <- NULL
on.exit(par(opar, no.readonly = TRUE))
if (!withSweave){
devNewArgs <- list()
if(!is.null(dots$width)) devNewArgs[["width"]] <- dots[["width"]]
if(!is.null(dots$height)) devNewArgs[["height"]] <- dots[["height"]]
do.call(devNew, devNewArgs)
}
parArgs <- NULL
if(mfColRow)
parArgs <- list(mfrow = c(nrows, ncols))
omar <- par("mar", no.readonly = TRUE)
parArgs <- c(parArgs,list(mar = c(bmar,omar[2],tmar,omar[4]), no.readonly = TRUE))
dots$ylim <- NULL
plotInfo$parArgs <- parArgs
do.call(par,args=parArgs)
plotInfo$L2derivPlotUsr <- plotInfo$L2derivPlotArgs <- vector("list",dims0)
plotInfo$L2derivPlotLines <- plotInfo$L2derivPlotTitle <- vector("list",dims0)
for(i in 1:dims0){
indi <- l2dpl[i]-3
if(!is.null(ylim)) dots$ylim <- ylim[,d.0+d.1+i]
dots$panel.first <- pF[[plotCount]]
dots$panel.last <- pL[[plotCount]]
plotInfo$L2derivPlotArgs[[i]] <- c(list(x=x.vec,
y=sapply(x.vec, L2deriv@Map[[indi]]),
type = plty, lty = lty, xlab = "x",
ylab = expression(paste(L[2], " derivative"))),
dots)
do.call(plot, args=c(list(x=x.vec,
y=sapply(x.vec, L2deriv@Map[[indi]]),
type = plty, lty = lty, xlab = "x",
ylab = expression(paste(L[2], " derivative"))),
dots))
plotInfo$L2derivPlotUsr[[i]] <- par("usr")
plotCount <- plotCount + 1
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, L2deriv@Map[[indi]]),
lty = "dotted"),dots))
plotInfo$L2derivPlotLines[[i]] <- c(list(x.vec1, sapply(x.vec1,
L2deriv@Map[[indi]]), lty = "dotted"),dots)
}
if(innerLog){
do.call(title, args = c(list(main = innerT[i]), dotsT,
line = lineT, cex.main = cex.inner,
col.main = col.inner))
plotInfo$L2derivPlotTitle[[i]] <- c(list(main = innerT[i]), 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"
if(!hasArg(col.main)) col.main <- par("col.main") else col.main <- dots$"col.main"
if (mainL){
mtext(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
plotInfo$mainL <- list(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
}
if(!hasArg(cex.sub)) cex.sub <- par("cex.sub") else cex.sub <- dots$"cex.sub"
if(!hasArg(col.sub)) col.sub <- par("col.sub") else col.sub <- dots$"col.sub"
if (subL){
mtext(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
plotInfo$subL <- list(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
}
class(plotInfo) <- c("plotInfo","DiagnInfo")
return(invisible(plotInfo))
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.