[Distr-commits] r1227 - branches/distr-2.8/pkg/distrMod/R pkg/distrMod/R

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Sun Jul 29 19:56:25 CEST 2018


Author: ruckdeschel
Date: 2018-07-29 19:56:25 +0200 (Sun, 29 Jul 2018)
New Revision: 1227

Modified:
   branches/distr-2.8/pkg/distrMod/R/qqplot.R
   branches/distr-2.8/pkg/distrMod/R/returnlevelplot.R
   pkg/distrMod/R/qqplot.R
   pkg/distrMod/R/returnlevelplot.R
Log:
[distrMod] bugfix in branch 2.8 and trunk:
- defaults for xlab ylab were not correctly set 

Modified: branches/distr-2.8/pkg/distrMod/R/qqplot.R
===================================================================
--- branches/distr-2.8/pkg/distrMod/R/qqplot.R	2018-07-28 22:56:28 UTC (rev 1226)
+++ branches/distr-2.8/pkg/distrMod/R/qqplot.R	2018-07-29 17:56:25 UTC (rev 1227)
@@ -120,6 +120,15 @@
              withSubst = TRUE
     ){ ## return value as in stats::qqplot
 
+    mc <- match.call(call = sys.call(sys.parent(1)))
+    xcc <- as.character(deparse(mc$x))
+    ycc <- as.character(deparse(mc$y))
+
+    if(missing(xlab)){ xlab <- mc$xlab <- xcc}
+    if(missing(ylab)){ ylab <- mc$ylab <- ycc}
+
+    dots <- match.call(call = sys.call(sys.parent(1)),
+                       expand.dots = FALSE)$"..."
     args0 <- list(x = x, y = y, n = n, withIdLine = withIdLine,
              withConf = withConf, withConf.pw  = withConf.pw,
              withConf.sim = withConf.sim, plot.it = plot.it, datax = datax,
@@ -142,14 +151,8 @@
              legend.cex = legend.cex, legend.pref = legend.pref,
              legend.postf = legend.postf, legend.alpha = legend.alpha,
              debug = debug, withSubst = withSubst)
-    mc <- match.call(call = sys.call(sys.parent(1)))
-    dots <- match.call(call = sys.call(sys.parent(1)),
-                       expand.dots = FALSE)$"..."
     plotInfo <- list(call = mc, dots=dots, args=args0)
-    xcc <- as.character(deparse(mc$x))
-    ycc <- as.character(deparse(mc$y))
-    if(missing(xlab)){ xlab <- mc$xlab <- xcc}
-    if(missing(ylab)){ ylab <- mc$ylab <- ycc}
+
     mcl <- as.list(mc)[-1]
     force(x)
     if(is.null(mcl$datax)) datax <- FALSE
@@ -414,8 +417,10 @@
     ylab = deparse(substitute(y)), ...){
 
     mc <- match.call(call = sys.call(sys.parent(1)))
-    dots <- match.call(call = sys.call(sys.parent(1)),
-                       expand.dots = FALSE)$"..."
+    mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
+    mcx <- as.character(deparse(mc$x))
+    mcy <- as.character(deparse(mc$y))
+    dots <- mc1$"..."
     args0 <- list(x = x, y = y,
                   n = if(!missing(n)) n else length(x),
                   withIdLine = withIdLine, withConf = withConf,
@@ -424,8 +429,8 @@
                   plot.it = plot.it, xlab = xlab, ylab = ylab)
     plotInfo <- list(call=mc, dots=dots, args=args0)
 
-    if(missing(xlab)) mc$xlab <- as.character(deparse(mc$x))
-    if(missing(ylab)) mc$ylab <- as.character(deparse(mc$y))
+    if(missing(xlab)) mc$xlab <- mcx
+    if(missing(ylab)) mc$ylab <- mcy
     mcl <- as.list(mc)[-1]
 
     mcl$y <- yD <- y at distribution
@@ -447,18 +452,20 @@
     plot.it = TRUE, xlab = deparse(substitute(x)),
     ylab = deparse(substitute(y)), ...){
 
+    mc <- match.call(call = sys.call(sys.parent(1)))
+    mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
+    mcx <- as.character(deparse(mc$x))
+    mcy <- as.character(deparse(mc$y))
+
     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)
 
-    mc <- match.call(call = sys.call(sys.parent(1)))
-    mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
     dots <- mc1$"..."
     plotInfo <- list(call=mc, dots=dots, args=args0)
 
-    if(missing(xlab)) mc$xlab <- as.character(deparse(mc$x))
-    if(missing(ylab)) mc$ylab <- as.character(deparse(mc$y))
+    if(missing(xlab)) mc$xlab <- mcx
     mcl <- as.list(mc)[-1]
 
     param <- ParamFamParameter(main=untransformed.estimate(y), nuisance=nuisance(y),
@@ -474,6 +481,7 @@
 
     PFam0 <- modifyModel(PFam, param)
     mcl$y <- PFam0
+    if(missing(ylab)) mcl$ylab <- paste(name(PFam0),gettext("fitted by"), mcy)
     retv <- do.call(getMethod("qqplot", signature(x="ANY", y="ProbFamily")),
             args=mcl)
     retv$call <- retv$dots <- retv$args <- NULL

Modified: branches/distr-2.8/pkg/distrMod/R/returnlevelplot.R
===================================================================
--- branches/distr-2.8/pkg/distrMod/R/returnlevelplot.R	2018-07-28 22:56:28 UTC (rev 1226)
+++ branches/distr-2.8/pkg/distrMod/R/returnlevelplot.R	2018-07-29 17:56:25 UTC (rev 1227)
@@ -79,6 +79,9 @@
              debug = FALSE, ## shall additional debug output be printed out?
              withSubst = TRUE
     ){ ## return value as in stats::qqplot
+    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, y = y, n = n, withIdLine = withIdLine,
              withConf = withConf, withConf.pw  = withConf.pw,
              withConf.sim = withConf.sim, plot.it = plot.it, datax = datax,
@@ -101,9 +104,6 @@
              legend.cex = legend.cex, legend.pref = legend.pref,
              legend.postf = legend.postf, legend.alpha = legend.alpha,
              debug = debug, withSubst = withSubst)
-    mc <- match.call(call = sys.call(sys.parent(1)))
-    dots <- match.call(call = sys.call(sys.parent(1)),
-                       expand.dots = FALSE)$"..."
     plotInfo <- list(call = mc, dots=dots, args=args0)
 
     MaxOrPOT <- match.arg(MaxOrPOT)
@@ -118,9 +118,8 @@
                             xcc))
                }else function(inx)inx
 
-    if(missing(xlab)) mc$xlab <- paste(gettext("Return level of"),
-                                       as.character(deparse(mc$x)))
-    if(missing(ylab)) mc$ylab <- gettext("Return period (years)")
+    if(missing(xlab)){mc$xlab <- paste(gettext("Return level of"), xcc)}
+    if(missing(ylab)){mc$ylab <- gettext("Return period (years)")}
     if(missing(main)) mc$main <- gettext("Return level plot")
     mcl <- as.list(mc)[-1]
     mcl$datax <- NULL
@@ -302,8 +301,8 @@
     mcl$cex <- cex.pts
     mcl$col <- col.pts
 
-    mcl$xlab <- .mpresubs(mcl$xlab)
-    mcl$ylab <- .mpresubs(mcl$ylab)
+    mc$xlab <- .mpresubs(mcl$xlab)
+    mc$ylab <- .mpresubs(mcl$ylab)
 
     if (!withSweave){
            devNew(width = width, height = height)
@@ -327,13 +326,13 @@
            mcl$log <- NULL
        }
        if(datax){
-          mcl$xlab <- xlab
-          mcl$ylab <- ylab
+          mcl$xlab <- mc$xlab
+          mcl$ylab <- mc$ylab
           plotInfo$plotArgs <- c(list(x=xallc1, y=yallc1, log=logs, type="n"),mcl)
           plotInfo$pointArgs <- c(list(x=xso, y=ycso), mcl)
        }else{
-          mcl$ylab <- xlab
-          mcl$xlab <- ylab
+          mcl$ylab <- mc$xlab
+          mcl$xlab <- mc$ylab
           plotInfo$plotArgs <- c(list(x=yallc1, y=xallc1, log=logs,type="n"),mcl)
           plotInfo$pointArgs <- c(list(x=ycso, y=xso), mcl)
        }
@@ -420,8 +419,10 @@
     ylab = deparse(substitute(y)), ...){
 
     mc <- match.call(call = sys.call(sys.parent(1)))
-    dots <- match.call(call = sys.call(sys.parent(1)),
-                       expand.dots = FALSE)$"..."
+    mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
+    mcx <- as.character(deparse(mc$x))
+    mcy <- as.character(deparse(mc$y))
+    dots <- mc1$"..."
     args0 <- list(x = x, y = y,
                   n = if(!missing(n)) n else length(x),
                   withIdLine = withIdLine, withConf = withConf,
@@ -431,8 +432,8 @@
 
     plotInfo <- list(call=mc, dots=dots, args=args0)
 
-    if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), as.character(deparse(mc$x)))
-    if(missing(ylab)) mc$ylab <- paste(gettext("Return Period at"), as.character(deparse(mc$y)))
+    if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), mcx)
+    if(missing(ylab)) mc$ylab <- paste(gettext("Return Period at"), mcy)
     mcl <- as.list(mc)[-1]
 
     mcl$y <- yD <- y at distribution
@@ -455,8 +456,10 @@
     ylab = deparse(substitute(y)), ...){
 
     mc <- match.call(call = sys.call(sys.parent(1)))
-    dots <- match.call(call = sys.call(sys.parent(1)),
-                       expand.dots = FALSE)$"..."
+    mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
+    mcx <- as.character(deparse(mc$x))
+    mcy <- as.character(deparse(mc$y))
+    dots <- mc1$"..."
     args0 <- list(x = x, y = y,
                   n = if(!missing(n)) n else length(x),
                   withIdLine = withIdLine, withConf = withConf,
@@ -466,7 +469,7 @@
 
     plotInfo <- list(call=mc, dots=dots, args=args0)
 
-    if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), as.character(deparse(mc$x)))
+    if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), mcx)
     mcl <- as.list(mc)[-1]
 
     param <- ParamFamParameter(main=untransformed.estimate(y), nuisance=nuisance(y),
@@ -482,7 +485,7 @@
 
     PFam0 <- modifyModel(PFam, param)
     mcl$y <- PFam0
-    if(missing(ylab)) mcl$ylab <- paste(gettext("Return Period at fitted"), name(PFam0))
+    if(missing(ylab)) mcl$ylab <- paste(gettext("Return Period at fitted"), name(PFam0), "\n -- fit by ", mcy)
 
     retv <- do.call(getMethod("returnlevelplot", signature(x="ANY", y="ProbFamily")),
             args=mcl)

Modified: pkg/distrMod/R/qqplot.R
===================================================================
--- pkg/distrMod/R/qqplot.R	2018-07-28 22:56:28 UTC (rev 1226)
+++ pkg/distrMod/R/qqplot.R	2018-07-29 17:56:25 UTC (rev 1227)
@@ -388,8 +388,10 @@
     ylab = deparse(substitute(y)), ...){
 
     mc <- match.call(call = sys.call(sys.parent(1)))
-    if(missing(xlab)) mc$xlab <- as.character(deparse(mc$x))
-    if(missing(ylab)) mc$ylab <- as.character(deparse(mc$y))
+    mcx <- as.character(deparse(mc$x))
+    mcy <- as.character(deparse(mc$y))
+    if(missing(xlab)) mc$xlab <- mcx
+    if(missing(ylab)) mc$ylab <- mcy
     mcl <- as.list(mc)[-1]
 
     mcl$y <- yD <- y at distribution
@@ -410,8 +412,10 @@
     ylab = deparse(substitute(y)), ...){
 
     mc <- match.call(call = sys.call(sys.parent(1)))
-    if(missing(xlab)) mc$xlab <- as.character(deparse(mc$x))
-    if(missing(ylab)) mc$ylab <- as.character(deparse(mc$y))
+    mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
+    mcx <- as.character(deparse(mc$x))
+    mcy <- as.character(deparse(mc$y))
+    if(missing(xlab)) mc$xlab <- mcx
     mcl <- as.list(mc)[-1]
 
     param <- ParamFamParameter(main=untransformed.estimate(y), nuisance=nuisance(y),
@@ -427,6 +431,7 @@
 
     PFam0 <- modifyModel(PFam, param)
     mcl$y <- PFam0
+    if(missing(ylab)) mcl$ylab <- paste(name(PFam0),gettext("fitted by"), mcy)
     retv <- do.call(getMethod("qqplot", signature(x="ANY", y="ProbFamily")),
             args=mcl)
     retv$call <- mc        

Modified: pkg/distrMod/R/returnlevelplot.R
===================================================================
--- pkg/distrMod/R/returnlevelplot.R	2018-07-28 22:56:28 UTC (rev 1226)
+++ pkg/distrMod/R/returnlevelplot.R	2018-07-29 17:56:25 UTC (rev 1227)
@@ -92,9 +92,8 @@
                             xcc))
                }else function(inx)inx
 
-    if(missing(xlab)) mc$xlab <- paste(gettext("Return level of"),
-                                       as.character(deparse(mc$x)))
-    if(missing(ylab)) mc$ylab <- gettext("Return period (years)")
+    if(missing(xlab)){mc$xlab <-  paste(gettext("Return level of"), xcc)}
+    if(missing(ylab)){mc$ylab <-  gettext("Return period (years)")}
     if(missing(main)) mc$main <- gettext("Return level plot")
     mcl <- as.list(mc)[-1]
     mcl$datax <- NULL
@@ -276,8 +275,8 @@
     mcl$cex <- cex.pts
     mcl$col <- col.pts
 
-    mcl$xlab <- .mpresubs(mcl$xlab)
-    mcl$ylab <- .mpresubs(mcl$ylab)
+    mc$xlab <- .mpresubs(mcl$xlab)
+    mc$ylab <- .mpresubs(mcl$ylab)
 
     if (!withSweave){
            devNew(width = width, height = height)
@@ -301,13 +300,13 @@
            mcl$log <- NULL
        }
        if(datax){
-          mcl$xlab <- xlab
-          mcl$ylab <- ylab
+          mcl$xlab <- mc$xlab
+          mcl$ylab <- mc$ylab
           do.call(plot, c(list(x=xallc1, y=yallc1, log=logs,type="n"),mcl))
           do.call(points, c(list(x=xso, y=ycso), mcl))
        }else{
-          mcl$ylab <- xlab
-          mcl$xlab <- ylab
+          mcl$ylab <- mc$xlab
+          mcl$xlab <- mc$ylab
           do.call(plot,  c(list(x=yallc1, y=xallc1, log=logs,type="n"),mcl))
           do.call(points, c(list(x=ycso, y=xso), mcl))
        }
@@ -384,8 +383,10 @@
     ylab = deparse(substitute(y)), ...){
 
     mc <- match.call(call = sys.call(sys.parent(1)))
-    if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), as.character(deparse(mc$x)))
-    if(missing(ylab)) mc$ylab <- paste(gettext("Return Period at"), as.character(deparse(mc$y)))
+    mcx <- as.character(deparse(mc$x))
+    mcy <- as.character(deparse(mc$y))
+    if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), mcx)
+    if(missing(ylab)) mc$ylab <- paste(gettext("Return Period at"), mcy)
     mcl <- as.list(mc)[-1]
 
     mcl$y <- yD <- y at distribution
@@ -404,6 +405,9 @@
     ylab = deparse(substitute(y)), ...){
 
     mc <- match.call(call = sys.call(sys.parent(1)))
+    mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
+    mcx <- as.character(deparse(mc$x))
+    mcy <- as.character(deparse(mc$y))
     if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), as.character(deparse(mc$x)))
     mcl <- as.list(mc)[-1]
 
@@ -420,7 +424,7 @@
 
     PFam0 <- modifyModel(PFam, param)
     mcl$y <- PFam0
-    if(missing(ylab)) mcl$ylab <- paste(gettext("Return Period at fitted"), name(PFam0))
+    if(missing(ylab)) mcl$ylab <- paste(gettext("Return Period at fitted"), name(PFam0), "\n -- fit by ", mcy)
 
     return(invisible(do.call(getMethod("returnlevelplot", signature(x="ANY", y="ProbFamily")),
             args=mcl)))



More information about the Distr-commits mailing list