[Distr-commits] r964 - in branches/distr-2.6/pkg/distr: R inst man

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Tue Aug 19 02:11:33 CEST 2014


Author: ruckdeschel
Date: 2014-08-19 02:11:33 +0200 (Tue, 19 Aug 2014)
New Revision: 964

Modified:
   branches/distr-2.6/pkg/distr/R/internalUtils.R
   branches/distr-2.6/pkg/distr/R/plot-methods.R
   branches/distr-2.6/pkg/distr/R/plot-methods_LebDec.R
   branches/distr-2.6/pkg/distr/inst/NEWS
   branches/distr-2.6/pkg/distr/man/internals.Rd
   branches/distr-2.6/pkg/distr/man/plot-methods.Rd
Log:
[distr] arguments panel.first, panel.last for plot-methods can now be lists; still does not work quite as desired (see example (plot)) 

Modified: branches/distr-2.6/pkg/distr/R/internalUtils.R
===================================================================
--- branches/distr-2.6/pkg/distr/R/internalUtils.R	2014-08-18 21:13:32 UTC (rev 963)
+++ branches/distr-2.6/pkg/distr/R/internalUtils.R	2014-08-19 00:11:33 UTC (rev 964)
@@ -1272,4 +1272,18 @@
 }
 
 
-           
\ No newline at end of file
+.panel.mingle <- function(dots, element){
+  pF <- dots[[element]]
+  if(is.list(pF)) return(pF)
+  pFr <- if(typeof(pF)=="symbol") eval(pF) else{
+     pFc <- as.call(pF)
+     if(as.list(pFc)[[1]] == "list"){
+        lis <- vector("list",length(as.list(pFc))-1)
+        for(i in 1:length(lis)){
+            lis[[i]] <- pFc[[i+1]]
+        }
+        lis
+     }else pF
+  }
+  return(pFr)
+}

Modified: branches/distr-2.6/pkg/distr/R/plot-methods.R
===================================================================
--- branches/distr-2.6/pkg/distr/R/plot-methods.R	2014-08-18 21:13:32 UTC (rev 963)
+++ branches/distr-2.6/pkg/distr/R/plot-methods.R	2014-08-19 00:11:33 UTC (rev 964)
@@ -28,6 +28,18 @@
       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, l.draw)
+
+     dots$panel.first <- dots$panel.last <- NULL
      dots$col.hor <- NULL
 
      dots.for.points <- .makedotsPt(dots)
@@ -231,12 +243,17 @@
              }
           }
 
+     plotCount <- 1
      o.warn <- getOption("warn"); options(warn = -1)
      if(1%in%to.draw){
          on.exit(options(warn=o.warn))
-         do.call(plot, c(list(x = grid, dxg, type = "l", 
+         dots.without.pch$panel.first <- pF[[plotCount]]
+         dots.without.pch$panel.last  <- pL[[plotCount]]
+         do.call(plot, c(list(x = grid, dxg, type = "l",
              ylim = ylim1,  ylab = ylab0[["d"]], xlab = xlab0[["d"]], log = logpd),
              dots.without.pch))
+         dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
+         plotCount <- plotCount + 1
          options(warn = o.warn)
      
          title(main = inner.d, line = lineT, cex.main = cex.inner,
@@ -249,9 +266,13 @@
      if(is.finite(q(x)(1))) {grid <- c(grid,q(x)(1)); pxg <- c(pxg,1)}
 
      if(2%in%to.draw){
-        do.call(plot, c(list(x = grid, pxg, type = "l", 
+        dots.without.pch$panel.first <- pF[[plotCount]]
+        dots.without.pch$panel.last  <- pL[[plotCount]]
+        do.call(plot, c(list(x = grid, pxg, type = "l",
              ylim = ylim2, ylab = ylab0[["p"]], xlab = xlab0[["p"]], log = logpd),
              dots.without.pch))
+        dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
+        plotCount <- plotCount + 1
         options(warn = o.warn)
       
         title(main = inner.p, line = lineT, cex.main = cex.inner,
@@ -289,9 +310,13 @@
      
      if(3%in%to.draw){
         options(warn = -1)
-        do.call(plot, c(list(x = po, xo, type = "n", 
+        dots.without.pch$panel.first <- pF[[plotCount]]
+        dots.without.pch$panel.last  <- pL[[plotCount]]
+        do.call(plot, c(list(x = po, xo, type = "n",
              xlim = ylim2, ylim = xlim, ylab = ylab0[["q"]], xlab = xlab0[["q"]],
              log = logq), dots.without.pch))
+        dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
+        plotCount <- plotCount + 1
         options(warn = o.warn)
     
         
@@ -358,10 +383,21 @@
       }
       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, l.draw)
+      dots$panel.first <- dots$panel.last <- NULL
+
       dots$ngrid <- NULL
 
       dots.for.points <- .makedotsPt(dots)
-      print(dots.for.points)
       dots.lowlevel <- .makedotsLowLevel(dots)
       dots.without.pch <- dots.lowlevel[! (names(dots.lowlevel) %in% c("col", "pch"))]
       ###
@@ -566,10 +602,17 @@
        o.warn <- getOption("warn")
        options(warn = -1)
        on.exit(options(warn=o.warn))
+
+     plotCount <- 1
+
      if(1%in%to.draw){
+       dots.without.pch$panel.first <- pF[[plotCount]]
+       dots.without.pch$panel.last  <- pL[[plotCount]]
        do.call(plot, c(list(x = supp, dx, type = "h", pch = pch.a,
             ylim = ylim1, xlim=xlim, ylab = ylab0[["d"]], xlab = xlab0[["d"]],
             log = logpd), dots.without.pch))
+       dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
+       plotCount <- plotCount + 1
        options(warn = o.warn)
 
 
@@ -588,12 +631,16 @@
      psupp1 <- c(0,p(x)(supp1))
 
      if(2%in%to.draw){
-       do.call(plot, c(list(x = stepfun(x = supp1, y = psupp1), 
+       dots.without.pch$panel.first <- pF[[plotCount]]
+       dots.without.pch$panel.last  <- pL[[plotCount]]
+       do.call(plot, c(list(x = stepfun(x = supp1, y = psupp1),
                      main = "", verticals = verticals, 
                      do.points = FALSE, 
                      ylim = ylim2, ylab = ylab0[["p"]], xlab = xlab0[["p"]],
                      col.hor = col.hor, col.vert = col.vert, 
                      log = logpd), dots.without.pch))
+       dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
+       plotCount <- plotCount + 1
        if(do.points)
           {if(ngrid>1){
               do.call(points, c(list(x = supp, y = psupp1[1:ngrid], pch = pch.u, 
@@ -621,7 +668,9 @@
 
      if(3%in%to.draw){
        options(warn = -1)
-       do.call(plot, c(list(x = stepfun(c(0,p(x)(supp)), 
+       dots.without.pch$panel.first <- pF[[plotCount]]
+       dots.without.pch$panel.last  <- pL[[plotCount]]
+       do.call(plot, c(list(x = stepfun(c(0,p(x)(supp)),
                             c(NA,supp,NA), right = TRUE), 
             main = "", xlim = ylim2, ylim = c(min(supp),max(supp)),
             ylab = ylab0[["q"]], xlab = xlab0[["q"]],
@@ -630,6 +679,8 @@
             col.points = col.points,
             col.hor = col.hor, col.vert = col.vert, 
             log = logq), dots.without.pch))
+       dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
+       plotCount <- plotCount + 1
        options(warn = o.warn)
 
       

Modified: branches/distr-2.6/pkg/distr/R/plot-methods_LebDec.R
===================================================================
--- branches/distr-2.6/pkg/distr/R/plot-methods_LebDec.R	2014-08-18 21:13:32 UTC (rev 963)
+++ branches/distr-2.6/pkg/distr/R/plot-methods_LebDec.R	2014-08-19 00:11:33 UTC (rev 964)
@@ -57,6 +57,19 @@
       xlab0.d <- xlab0.c <- list("d"="x", "p"="q", "q"="p")
       ylab0.d <- ylab0.c <- list("d"="d(x)", "p"="p(q)", "q"="q(p)")
 
+      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, l.draw)
+      dots$panel.first <- dots$panel.last <- NULL
+
+      plotCount <- 1
       if(!is(x, "UnivarLebDecDistribution"))
           x <- .ULC.cast(x)
 
@@ -64,6 +77,8 @@
          mcl <- as.list(mc)
          mcl$to.draw.arg <- (1:3)[( (6:8) %in%to.draw )] 
          mcl$ngrid <- NULL
+         mcl$panel.first <- pF[plotCount+(0:2)]
+         mcl$panel.last  <- pL[plotCount+(0:2)]
          if(is.null(mcl$xlab)) mcl$xlab <- xlab0.d
          if(is.null(mcl$ylab)) mcl$ylab <- ylab0.d
          if(!is.logical(inner)){
@@ -80,6 +95,8 @@
          mcl$col.hor <- NULL
          if(is.null(mcl$xlab)) mcl$xlab <- xlab0.c
          if(is.null(mcl$ylab)) mcl$ylab <- ylab0.c
+         mcl$panel.first <- pF[plotCount+(0:2)]
+         mcl$panel.last  <- pL[plotCount+(0:2)]
          mcl$to.draw.arg <- (1:3)[( (3:5) %in%to.draw )]
             if(!is.logical(inner)){
                 if(length(inner)!=3)
@@ -99,6 +116,8 @@
          mcl$x <- x
          mcl$to.draw.arg <- (1:3)[( (6:8) %in%to.draw )] 
          mcl$ngrid <- NULL
+         mcl$panel.first <- pF[5+mcl$to.draw.arg]
+         mcl$panel.last  <- pL[5+mcl$to.draw.arg]
             if(!is.logical(inner)){
                 if(length(inner)!=3)
                    {inner <- .fillList(inner, 8)
@@ -116,6 +135,8 @@
          mcl$x <- x
          mcl$to.draw.arg <- (1:3)[( (3:5) %in%to.draw )] 
          mcl$col.hor <- NULL
+         mcl$panel.first <- pF[2+mcl$to.draw.arg]
+         mcl$panel.last  <- pL[2+mcl$to.draw.arg]
             if(!is.logical(inner)){
                 if(length(inner)!=3)
                    {inner <- .fillList(inner, 8)
@@ -393,9 +414,13 @@
      o.warn <- getOption("warn"); options(warn = -1)
      if(1 %in% to.draw){
         on.exit(options(warn=o.warn))
+        dots.without.pch$panel.first <- pF[[plotCount]]
+        dots.without.pch$panel.last  <- pL[[plotCount]]
         do.call(plot, c(list(x = grid, pxg, type = "l",
              ylim = ylim2, ylab = ylab0[[1]][["p"]], xlab = xlab0[[1]][["p"]], log = logpd),
              dots.without.pch))
+        dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
+        plotCount <- plotCount + 1
         options(warn = o.warn)
    
         pxg.d <- p(x)(supp)
@@ -451,9 +476,13 @@
 
      if(2 %in% to.draw){
         options(warn = -1)
+        dots.without.pch$panel.first <- pF[[plotCount]]
+        dots.without.pch$panel.last  <- pL[[plotCount]]
         do.call(plot, c(list(x = po, xo, type = "n",
              xlim = ylim2, ylim = xlim, ylab = ylab0[[1]][["q"]], xlab = xlab0[[1]][["q"]],
              log = logq), dots.without.pch), envir = parent.frame(2))
+        plotCount <- plotCount + 1
+        dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
         options(warn = o.warn)
    
    
@@ -516,7 +545,10 @@
      mc.ac$withSweave <- TRUE 
      mc.ac$to.draw.arg <- (1:3)[( (3:5) %in%to.draw )] 
      if(is.null(mc.ac$cex.inner))  mc.ac$cex.inner <- 0.9
+     mc.ac[["panel.first"]] <- pF[plotCount+(0:2)]
+     mc.ac[["panel.last"]]  <- pL[plotCount+(0:2)]
      do.call(plotC, c(list(acPart(x)),mc.ac), envir = parent.frame(2))
+     plotCount <- plotCount + 3
 
      mc.di <- mc
      if(!is.logical(inner)) 
@@ -534,7 +566,10 @@
      mc.di$withSweave <- TRUE 
      mc.di$to.draw.arg <- (1:3)[( (6:8) %in%to.draw )]
      if(is.null(mc.di$cex.inner))  mc.di$cex.inner <- 0.9
+     mc.di[["panel.first"]] <- pF[plotCount+(0:2)]
+     mc.di[["panel.last"]]  <- pL[plotCount+(0:2)]
      do.call(plotD, c(list(discretePart(x)),mc.di), envir = parent.frame(2))
+     plotCount <- plotCount + 3
      return(invisible())
      
    }

Modified: branches/distr-2.6/pkg/distr/inst/NEWS
===================================================================
--- branches/distr-2.6/pkg/distr/inst/NEWS	2014-08-18 21:13:32 UTC (rev 963)
+++ branches/distr-2.6/pkg/distr/inst/NEWS	2014-08-19 00:11:33 UTC (rev 964)
@@ -16,7 +16,8 @@
 + updated references in vignette 'newDistributions'
 + added generating function "EmpiricalDistribution" which is a simple
   wrapper to function "DiscreteDistribution"
-
++ arguments panel.first, panel.last for plot-methods can now be lists
+  
 under the hood:
 
 -qqplot: 

Modified: branches/distr-2.6/pkg/distr/man/internals.Rd
===================================================================
--- branches/distr-2.6/pkg/distr/man/internals.Rd	2014-08-18 21:13:32 UTC (rev 963)
+++ branches/distr-2.6/pkg/distr/man/internals.Rd	2014-08-19 00:11:33 UTC (rev 964)
@@ -59,6 +59,7 @@
 \alias{.DistrCollapse}
 \alias{.convDiscrDiscr}
 \alias{.inWithTol}
+\alias{.panel.mingle}
 \alias{devNew}
 
 \title{Internal functions of package distr}
@@ -134,6 +135,7 @@
 .getCommonWidth(x1,x2, tol=.Machine$double.eps)
 .convDiscrDiscr(e1,e2)
 .inWithTol(x,y,tol=.Machine$double.eps)
+.panel.mingle(dots,element)
 devNew(...)
 }
 
@@ -241,6 +243,8 @@
  \item{n2}{integer argument for \code{.EuclidAlgo}}
  \item{x1}{width argument for \code{.getCommonWidth}}
  \item{x2}{width argument for \code{.getCommonWidth}}
+ \item{dots}{the unevaluated \code{\dots} argument}
+ \item{element}{the name of the item in the unevaluated \code{\dots} argument}
  \item{...}{arguments passed through to other functions}
 }
 
@@ -392,6 +396,13 @@
 \code{.convDiscrDiscr} computes the convolution of two discrete distributions by
     brute force.
 \code{.inWithTol} works like \code{\%in\%} but with a given tolerance.
+
+\code{.panel.mingle} is used for mingling arguments \code{panel.first},
+\code{panel.last} in a plot; it returns the evaluated argument \code{element}
+within dots, if it is a symbol; else if it can be interpreted as a call, and if
+the top call is \code{list}, it returns a list of the items of the call to \code{list},
+unevaluated, and otherwise the unchanged argument.
+
 \code{devNew} opens a new device. This function is for back compatibility
 with R versions < 2.8.0.
 }
@@ -464,7 +475,12 @@
 \item{.convDiscrDiscr}{returns the convolution of two discrete distributions.}
 \item{.inWithTol}{returns a logical vector of same lenght as \code{x} for the
     matches (up to tolerance) with vector \code{y}.}
-\item{devNew}{returns the return value of the device opened, 
+\item{.panel.mingle}{used for mingling arguments \code{panel.first},
+\code{panel.last}; returns the evaluated argument \code{element} within dots,
+if it is a symbol; else if it can be interpreted as a call, and if the top
+call is \code{list}, it returns a list of the items of the call to \code{list},
+unevaluated, and otherwise the unchanged argument.}
+\item{devNew}{returns the return value of the device opened,
 usually invisible \code{NULL}.}
 }
 

Modified: branches/distr-2.6/pkg/distr/man/plot-methods.Rd
===================================================================
--- branches/distr-2.6/pkg/distr/man/plot-methods.Rd	2014-08-18 21:13:32 UTC (rev 963)
+++ branches/distr-2.6/pkg/distr/man/plot-methods.Rd	2014-08-19 00:11:33 UTC (rev 964)
@@ -204,6 +204,13 @@
 for titles. If no character substitutions and mathematical expressions
 are needed, character vectors of respective length instead of lists are
 also allowed for arguments \code{xlab}, \code{ylab}.
+
+In addition, argument \code{\dots} may contain arguments \code{panel.first},
+\code{panel.last}, i.e., hook expressions to be evaluated at the very beginning
+and at the very end of each panel (within the then valid coordinates).
+To be able to use these hooks for each panel individually, they may also be
+lists of expressions (of the same length as the number of panels and
+run through in the same order as the panels).
 }
 
 \examples{
@@ -229,6 +236,13 @@
                   "Pseudo-inverse with param's \%N"), 
      sub = "this plot was correctly generated on \%D", 
      cex.inner = 0.9, cex.sub = 0.8)
+
+plot(Norm(),panel.first=grid(4,4))
+## does not (yet) work as desired:
+plot(Norm(),panel.first=list(grid(5,5),grid(3,3),grid(4,4)))
+li <- list(substitute(grid(5,5)),substitute(grid(3,3)),substitute(grid(4,4)))
+plot(Norm(),panel.first=li)
+
 plot(Cauchy())
 plot(Cauchy(), xlim = c(-4,4))
 plot(Chisq())



More information about the Distr-commits mailing list