[Distr-commits] r1362 - in branches/distr-2.9/pkg/distr: R inst
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Nov 25 14:29:34 CET 2021
Author: ruckdeschel
Date: 2021-11-25 14:29:34 +0100 (Thu, 25 Nov 2021)
New Revision: 1362
Modified:
branches/distr-2.9/pkg/distr/R/bAcDcLcDistribution.R
branches/distr-2.9/pkg/distr/inst/NEWS
Log:
[distr] devel branch 2.9:
+ fixed some error in distributional arithmetics brought up by Andrew Robinson
<apro at unimelb.edu.au>
to produce meaningful error messages we had code that tried to deparse operands in
operationswith restricted definition domains like "/", "^"; it turned our that our
idea to catch errors in this deparsing within a try()-catch did not work any longer
when called from within a function; as way out, we now have code which no longer
needs the try()-catch and instead climbs up the parsing tree and searches for the
first occurrence of "/" resp. "^" and deparses this
Modified: branches/distr-2.9/pkg/distr/R/bAcDcLcDistribution.R
===================================================================
--- branches/distr-2.9/pkg/distr/R/bAcDcLcDistribution.R 2021-11-23 21:25:12 UTC (rev 1361)
+++ branches/distr-2.9/pkg/distr/R/bAcDcLcDistribution.R 2021-11-25 13:29:34 UTC (rev 1362)
@@ -104,10 +104,17 @@
setMethod("/", c("numeric",
"AcDcLcDistribution"),
function(e1,e2){
- if (is(try(e2s <- as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))$e2)),silent =TRUE), "try-error"))
- e2s <- "e2"
-
+ i <- 1; stopit <- FALSE; sL <- length(sys.calls())
+ e2s <- "e2"
+ while(!stopit && i <= sL){
+ i <- i + 1
+ trcall <- sys.call(sys.parent(i))
+ myc <- paste(as.list(trcall)[[1]])
+ if(myc=="/"){
+ e2s <- as.character(deparse(match.call(call=trcall)$e2))
+ stopit <- TRUE
+ }
+ }
e2 <- .ULC.cast(e2)
# if( is(e2,"AffLinUnivarLebDecDistribution"))
@@ -168,9 +175,17 @@
setMethod("/", c("AcDcLcDistribution",
"AcDcLcDistribution"),
function(e1,e2){
- if (is(try(e2s <- as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))$e2)),silent =TRUE), "try-error"))
- e2s <- "e2"
+ i <- 1; stopit <- FALSE; sL <- length(sys.calls())
+ e2s <- "e2"
+ while(!stopit && i <= sL){
+ i <- i + 1
+ trcall <- sys.call(sys.parent(i))
+ myc <- paste(as.list(trcall)[[1]])
+ if(myc=="/"){
+ e2s <- as.character(deparse(match.call(call=trcall)$e2))
+ stopit <- TRUE
+ }
+ }
# if( is(e2,"AbscontDistribution"))
# e2 <- as(as(e2,"AbscontDistribution"), "UnivarLebDecDistribution")
@@ -279,11 +294,19 @@
setMethod("^", c("AcDcLcDistribution","numeric"),
function(e1,e2){
- if (is(try(mc <- match.call(call = sys.call(sys.parent(1))),
- silent=TRUE), "try-error"))
- {e1s <- "e1"; e2s <- "e2"}
- else {e1s <- as.character(deparse(mc$e1))
- e2s <- as.character(deparse(mc$e2))}
+ i <- 1; stopit <- FALSE; sL <- length(sys.calls())
+ e1s <- "e1"; e2s <- "e2"
+ while(!stopit && i <= sL){
+ i <- i + 1
+ trcall <- sys.call(sys.parent(i))
+ myc <- paste(as.list(trcall)[[1]])
+ if(myc=="^"){
+ mc <- match.call(call=trcall)
+ e1s <- as.character(deparse(mc$e1))
+ e2s <- as.character(deparse(mc$e2))
+ stopit <- TRUE
+ }
+ }
if (length(e2)>1) stop("length of operator must be 1")
if (isTRUE(all.equal(e2,1))) return(e1)
@@ -369,13 +392,19 @@
setMethod("^", c("AcDcLcDistribution","AcDcLcDistribution"),
function(e1,e2){
### check if there are problems
- if (is(try(e1s <- as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))$e1)),silent =TRUE), "try-error"))
- e1s <- "e1"
- if (is(try(e2s <- as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))$e2)),silent =TRUE), "try-error"))
- e2s <- "e2"
-
+ i <- 1; stopit <- FALSE; sL <- length(sys.calls())
+ e1s <- "e1"; e2s <- "e2"
+ while(!stopit && i <= sL){
+ i <- i + 1
+ trcall <- sys.call(sys.parent(i))
+ myc <- paste(as.list(trcall)[[1]])
+ if(myc=="/"){
+ mc <- match.call(call=trcall)
+ e1s <- as.character(deparse(mc$e1))
+ e2s <- as.character(deparse(mc$e2))
+ stopit <- TRUE
+ }
+ }
# if( is(e1,"AffLinUnivarLebDecDistribution"))
# e1 <- as(e1, "UnivarLebDecDistribution")
# if( is(e2,"AffLinUnivarLebDecDistribution"))
@@ -456,12 +485,19 @@
setMethod("^", c("numeric","AcDcLcDistribution"),
function(e1,e2){
### check if there are problems
- if (is(try(e1s <- as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))$e1)),silent =TRUE), "try-error"))
- e1s <- "e1"
- if (is(try(e2s <- as.character(deparse(match.call(
- call = sys.call(sys.parent(1)))$e2)),silent =TRUE), "try-error"))
- e2s <- "e2"
+ i <- 1; stopit <- FALSE; sL <- length(sys.calls())
+ e1s <- "e1"; e2s <- "e2"
+ while(!stopit && i <= sL){
+ i <- i + 1
+ trcall <- sys.call(sys.parent(i))
+ myc <- paste(as.list(trcall)[[1]])
+ if(myc=="^"){
+ mc <- match.call(call=trcall)
+ e1s <- as.character(deparse(mc$e1))
+ e2s <- as.character(deparse(mc$e2))
+ stopit <- TRUE
+ }
+ }
e2 <- .ULC.cast(e2)
#e2 <- .if( is(e2,"AffLinUnivarLebDecDistribution"))
Modified: branches/distr-2.9/pkg/distr/inst/NEWS
===================================================================
--- branches/distr-2.9/pkg/distr/inst/NEWS 2021-11-23 21:25:12 UTC (rev 1361)
+++ branches/distr-2.9/pkg/distr/inst/NEWS 2021-11-25 13:29:34 UTC (rev 1362)
@@ -17,6 +17,12 @@
bug fixes
+ fixed a glitch in catching argument names in bAcDcLcDistribution.R
detected by Elio Campitelli <elio.campitelli at cima.fcen.uba.ar>
++ fixed some error in distributional arithmetics brought up by Andrew Robinson <apro at unimelb.edu.au>
+ to produce meaningful error messages we had code that tried to deparse operands in operations
+ with restricted definition domains like "/", "^"; it turned our that our idea to catch errors
+ in this deparsing within a try()-catch did not work any longer when called from within a function;
+ as way out, we now have code which no longer needs the try()-catch and instead climbs up the
+ parsing tree and searches for the first occurrence of "/" resp. "^" and deparses this
under the hood:
+ triggered by an email by Santhosh V <Santhosh.V at se.com>, we added a patch to be more careful when producing
More information about the Distr-commits
mailing list