[Distr-commits] r1283 - in branches/distr-2.8/pkg/distrEx: . R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Aug 18 22:02:47 CEST 2018
Author: ruckdeschel
Date: 2018-08-18 22:02:42 +0200 (Sat, 18 Aug 2018)
New Revision: 1283
Added:
branches/distr-2.8/pkg/distrEx/R/DiagnUtils.R
Modified:
branches/distr-2.8/pkg/distrEx/NAMESPACE
branches/distr-2.8/pkg/distrEx/R/AsymTotalVarDist.R
branches/distr-2.8/pkg/distrEx/R/CvMDist.R
branches/distr-2.8/pkg/distrEx/R/Expectation.R
branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R
branches/distr-2.8/pkg/distrEx/R/HellingerDist.R
branches/distr-2.8/pkg/distrEx/R/OAsymTotalVarDist.R
branches/distr-2.8/pkg/distrEx/R/TotalVarDist.R
branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R
branches/distr-2.8/pkg/distrEx/inst/NEWS
branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd
branches/distr-2.8/pkg/distrEx/man/CvMDist.Rd
branches/distr-2.8/pkg/distrEx/man/E.Rd
branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd
branches/distr-2.8/pkg/distrEx/man/OAsymTotalVarDist.Rd
branches/distr-2.8/pkg/distrEx/man/TotalVarDist.Rd
branches/distr-2.8/pkg/distrEx/man/distrExIntegrate.Rd
branches/distr-2.8/pkg/distrEx/man/internals.Rd
Log:
[distrEx] branch 2.8
+ particular functionality to inspect/access this diagnostic
information through showDiagnostic, getDiagnostic and the S3method
for print for class DiagnosticClass
+ new S3 class DiagnosticClass and helper functions .showallNamesDiagnosticList,
.reorganizeDiagnosticList to ease inspection of the diagnostic information;
exported constant .nmsToGather captures the names of items in diagnostic attributes
which are "easily" shown (numeric, logical, character)
+ Expectations, .qtlIntegrate and distances based on integration (i.e., TotalVarDist,
OAsymTotalVarDist, AsymTotalVarDist, HellingerDist, CvMDist) if (diagnostic==TRUE)
return diagnostic attributes of S3 class "DiagnosticClass"
Modified: branches/distr-2.8/pkg/distrEx/NAMESPACE
===================================================================
--- branches/distr-2.8/pkg/distrEx/NAMESPACE 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/NAMESPACE 2018-08-18 20:02:42 UTC (rev 1283)
@@ -2,7 +2,7 @@
importFrom("stats", "dnorm", "integrate", "optimize", "pbinom",
"pchisq", "pexp", "pnorm", "ppois", "qcauchy", "qnorm",
"uniroot", "dunif")
-importFrom("utils", "getFromNamespace")
+importFrom("utils", "getFromNamespace", "object.size")
import("methods")
import("distr")
importFrom("startupmsg", "buildStartupMessage")
@@ -54,3 +54,6 @@
export("make01","PrognCondDistribution",
"PrognCondition")
export(".getIntbounds", ".qtlIntegrate", ".filterEargs", ".filterFunargs")
+export("print.DiagnosticClass", "showDiagnostic", "getDiagnostic",
+ ".nmsToGather", ".showallNamesDiagnosticList", ".reorganizeDiagnosticList")
+S3method(print,"DiagnosticClass")
\ No newline at end of file
Modified: branches/distr-2.8/pkg/distrEx/R/AsymTotalVarDist.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/AsymTotalVarDist.R 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/R/AsymTotalVarDist.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -84,6 +84,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
}
@@ -108,6 +109,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
names(res) <- "asym. total variation distance"
return(res)
@@ -212,6 +214,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -232,6 +235,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -353,7 +357,10 @@
}
res <- res +sum(integ.p.d(1))
names(res) <- "asym. total variation distance"
- if(diagnostic) attr(res, "diagnostic") <- diagn
+ if(diagnostic){
+ attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
+ }
return(res)
}
# else: only have to search in c in [low1;1] resp [1;up1]
@@ -380,9 +387,8 @@
res <- res +sum(integ.p.d(c.rho))
names(res) <- "asym. total variation distance"
if(diagnostic){
- diagn <- attr(res,"diagnostic")
- diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
Modified: branches/distr-2.8/pkg/distrEx/R/CvMDist.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/CvMDist.R 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/R/CvMDist.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -21,6 +21,7 @@
if(diagnostic){
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
+ class(diagn)<- "DiagnosticClass"
attr(res,"diagnostic") <- diagn
}
names(res) <- "CvM distance"
@@ -42,6 +43,7 @@
if(diagnostic){
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
+ class(diagn)<- "DiagnosticClass"
attr(res,"diagnostic") <- diagn
}
return(res)
Added: branches/distr-2.8/pkg/distrEx/R/DiagnUtils.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/DiagnUtils.R (rev 0)
+++ branches/distr-2.8/pkg/distrEx/R/DiagnUtils.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -0,0 +1,214 @@
+############# print and other methods for DiagnosticClass
+
+############################################################################
+########## internal helper functions and constants
+############################################################################
+
+.nmsToGather <- c("method", "time", "lower",
+ "upper", "rel.tol", "abs.tol", "stop.on.error",
+ "value", "abs.error", "subdivisions" ,"message")
+
+.reorganizeDiagnosticList <- function(liste, .depth=1, names0, prenames = "",
+ nmstoGather="", nmstoGatherNS="", withprint=TRUE,
+ .GatherList = NULL, .GatherListNS = NULL){
+ if(missing(names0)||(all(names0=="")&&length(names0)==1))
+ names0 <- .showallNamesDiagnosticList(liste)
+ nms <- names(liste)
+ if(is.null(.GatherList)&&is.null(.GatherListNS)){
+ if(missing(nmstoGather)){
+ # if(is.null(match.call()$names0)||all(match.call()$names0==""))
+ nmstoGather <- .nmsToGather # else nmstoGather <- names0
+ }
+ # if(all(nmstoGather=="")&&length(nmstoGather)==1)
+ nmstoGather <- names0[names0%in%nmstoGather]
+ if(length(nmstoGather)){
+ .GatherList <- vector("list", length(nmstoGather))
+ names(.GatherList) <- nmstoGather
+ }
+ if(!((missing(nmstoGatherNS)||nmstoGatherNS==""))){
+ nmstoGatherNS0 <- nmstoGatherNS
+ }else nmstoGatherNS0 <- NULL
+ nmstoGatherNS <- names0[!names0%in%nmstoGather]
+ if(!is.null(nmstoGatherNS0))
+ nmstoGatherNS <- nmstoGatherNS[nmstoGatherNS %in% nmstoGatherNS0]
+ if(length(nmstoGatherNS)){
+ .GatherListNS <- vector("list", length(nmstoGatherNS))
+ names(.GatherListNS) <- nmstoGatherNS
+ }
+
+ }
+ if(is.null(nms)) nms <- paste("[",seq(liste),"]",sep="")
+ for(i in seq(liste)){
+ if(nms[i]=="") nms[i] <- paste("[",i,"]",sep="")
+ longname <- paste(prenames,nms[i],sep="$")
+ if(is(liste[[i]], "try-error")) liste[[i]] <- list("message"=as.list(liste[[i]])[[1]])
+ if(nms[i]%in% names0){
+ if(withprint) cat(rep(">", .depth)," ", nms[i],"\n",sep="")
+ }
+ if(is.list(liste[[i]])){
+ res <- .reorganizeDiagnosticList(liste[[i]], .depth=.depth+1, names0=names0,
+ prenames=longname, nmstoGather=nmstoGather, nmstoGatherNS=nmstoGatherNS,
+ withprint= withprint, .GatherList = .GatherList, .GatherListNS = .GatherListNS)
+ .GatherList <- res$show
+ .GatherListNS <- res$noshow
+ }
+ if(!is.null(nms)){
+ if(nms[i] %in% names0){
+ if(withprint) cat(longname,":\n")
+ if(withprint) print(liste[[i]])
+ if(nms[i] %in% nmstoGather){
+ vec0 <- NULL
+ nvec0 <- NULL
+ if(length(.GatherList[[nms[i]]])) {
+ vec0 <- .GatherList[[nms[i]]]
+ nvec0 <- names(vec0)
+ }
+ vecneu <- liste[[i]]
+ lvecneu <- length(vecneu)
+ vec0 <- c(vec0, vecneu)
+ nmsC <- if(!is.call(liste[[i]]))
+ paste(longname,names(vecneu),sep=".") else longname
+ nvec0 <- c(nvec0, nmsC)
+ names(vec0) <- nvec0
+ .GatherList[[nms[i]]] <- vec0
+ }
+ if(nms[i] %in% nmstoGatherNS){
+ vec0 <- NULL
+ nvec0 <- NULL
+ if(length(.GatherListNS[[nms[i]]])) {
+ vec0 <- .GatherListNS[[nms[i]]]
+ nvec0 <- names(vec0)
+ }
+ vecneu <- liste[[i]]
+ vec0 <- c(vec0, vecneu)
+ nmsC <- if(!is.call(liste[[i]]))
+ paste(longname,names(vecneu),sep=".") else longname
+ nvec0 <- c(nvec0, nmsC)
+ names(vec0) <- nvec0
+ .GatherListNS[[nms[i]]] <- vec0
+ }
+ }
+ }
+ }
+ if(.depth==1 && "time" %in% c(names(.GatherList),names(.GatherListNS))){
+ li <- if("time" %in% names(.GatherList)) .GatherList[["time"]] else .GatherListNS[["time"]]
+ if(length(li)){
+ linms <- names(li)
+ mat <- t(matrix(li,5))
+ colmat <- unique(gsub(".+\\$time\\.","",linms))
+ rowmat <- unique(gsub("(.+)\\$time\\..+","\\1",linms))
+ colnames(mat) <- colmat
+ rownames(mat) <- rowmat
+ if("time" %in% names(.GatherList))
+ .GatherList[["time"]] <- mat
+ if("time" %in% names(.GatherListNS))
+ .GatherListNS[["time"]] <- mat
+ }
+ }
+ return(invisible(list(show=.GatherList, noshow=.GatherListNS)))
+}
+
+.showallNamesDiagnosticList <- function(liste,.depth=1){
+ nms <- names(liste)
+ for(item in seq(liste)){
+ nms.depthr <- NULL
+ if(is.list(liste[[item]]))
+ nms.depthr <- .showallNamesDiagnosticList(liste[[item]],.depth=.depth+1)
+ nms<- unique(c(nms,nms.depthr))
+ }
+ return(nms)
+}
+
+############################################################################
+########## functions to operate on diagnostic information
+############################################################################
+
+
+print.DiagnosticClass <- function(x, what, withNonShows = FALSE, ...){
+ if(missing(what)) what <- .showallNamesDiagnosticList(x)
+ xn <- paste(deparse(substitute(x)))
+ Diagtitle <- gettext("Diagnostic Information to Integrations in Object ")
+ underl <- paste(rep("=",nchar(Diagtitle)+3+nchar(xn)),collapse="")
+ cat("\n", underl,"\n", Diagtitle, "\"", xn,"\"\n", underl, "\n\n", sep="")
+ cat(gettext("The diagnostic has information to the following names:\n\n"))
+ nms <- .showallNamesDiagnosticList(x)
+ print(nms, ...)
+ cat("\n")
+ res <- .reorganizeDiagnosticList(x, names0=what, withprint=FALSE)
+ diaglistsShow <- res$show
+ sel <- names(diaglistsShow) %in% what
+ diaglistsShow <- diaglistsShow[sel]
+ for(item in seq(diaglistsShow)){
+ cat(gettext("Diagnostic information on item \""),
+ names(diaglistsShow)[item],"\":\n\n", sep="")
+ if(names(diaglistsShow)[item]=="call"){
+ cat("Calls: \n")
+ print(names(diaglistsShow[[item]]),...)
+ }else print(diaglistsShow[[item]], ...)
+ cat("\n")
+ }
+ if(withNonShows){
+ diaglistsNoShow <- res$noshow
+ sel <- names(diaglistsNoShow) %in% what
+ diaglistsNoShow <- diaglistsNoShow[sel]
+ for(item in seq(diaglistsNoShow)){
+ cat(gettext("Diagnostic information on item \""),
+ names(diaglistsNoShow)[item],"\":", sep="")
+ if(names(diaglistsNoShow)[item]=="call"){
+ cat("\n\n", gettext("Calls"), ": \n", sep="")
+ print(names(diaglistsNoShow[[item]]), ...)
+ }else{
+ if(names(diaglistsNoShow)[item]=="args"){
+ cat("\n\n", gettext("args"), ": \n", sep="")
+ print(names(diaglistsNoShow[[item]]), ...)
+ }else cat(" ",gettext("skipped"), "\n", sep="")
+ }
+ cat("\n")
+ }
+ }
+ cat(underl,"\n", gettext("-- end of diagnostic --\n"), underl,"\n\n",sep="")
+ res <- c(res$show,res$noshow)
+ res <- res[what]
+ return(invisible(res))
+}
+
+showDiagnostic <- function(x, what, withNonShows = FALSE, ...){
+ diagn <- attr(x,"diagnostic")
+ diagnKStep <- attr(x,"kStepDiagnostic")
+ if(!is.null(diagnKStep)){
+ if(is.null(diagn)){
+ diagn <- list(kStep=diagnKStep)
+ class(diagn) <- "DiagnosticClass"
+ }else{
+ diagn <- c(diagn, kStep=diagnKStep)
+ class(diagn) <- "DiagnosticClass"
+ }
+ }
+ if(is.null(diagn)) return(invisible(NULL))
+ if(missing(what)) what <- .showallNamesDiagnosticList(diagn)
+ res <- print(diagn, what = what, withNonShows=withNonShows, ...)
+ return(invisible(res))
+}
+
+getDiagnostic<- function(x, what, reorganized=TRUE){
+ diagn <- attr(x,"diagnostic")
+ diagnKStep <- attr(x,"kStepDiagnostic")
+ if(!is.null(diagnKStep)){
+ if(is.null(diagn)){
+ diagn <- list(kStep=diagnKStep)
+ class(diagn) <- "DiagnosticClass"
+ }else{
+ diagn <- c(diagn, kStep=diagnKStep)
+ class(diagn) <- "DiagnosticClass"
+ }
+ }
+ if(!reorganized) return(invisible(diagn))
+ if(missing(what)){ what <- ""; toSel <- .nmsToGather
+ }else{ toSel <- what }
+ diagns <- .reorganizeDiagnosticList(diagn, names0=what, withprint=FALSE)
+ diagns.s <- diagns$show[names(diagns$show) %in% toSel]
+ diagns.ns <- diagns$noshow[names(diagns$noshow) %in% toSel]
+ res <- c(diagns.s,diagns.ns)
+ res <- res[what]
+ return(invisible(res))
+}
Modified: branches/distr-2.8/pkg/distrEx/R/Expectation.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -88,6 +88,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -137,6 +138,7 @@
diagn <- attr(res0, "diagnostic")
diagn[["call"]] <- mc
attr(res1, "diagnostic") <- diagn
+ class(attr(res1, "diagnostic"))<- "DiagnosticClass"
}
return(res1)
})
@@ -245,6 +247,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -364,6 +367,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -446,6 +450,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -513,6 +518,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -567,6 +573,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -626,6 +633,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -677,6 +685,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -699,6 +708,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -792,6 +802,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -816,6 +827,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -867,6 +879,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic")) <- "DiagnosticClass"
}
return(res)
@@ -889,6 +902,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -911,6 +925,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -931,6 +946,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res, "diagnostic"))<- "DiagnosticClass"
}
return(res)
@@ -956,9 +972,12 @@
IQR.fac = IQR.fac, ..., diagnostic = diagnostic )
I.dc <- E(discretePart(object), low = low, upp = upp )
res <- as.vector(object at mixCoeff %*% c(I.ac, I.dc))
- diagn <- attr(I.ac, "diagnostic")
- diagn[["call"]] <- mc
- if(diagnostic) attr(res,"diagnostic") <- diagn
+ if(diagnostic){
+ diagn <- attr(I.ac, "diagnostic")
+ diagn[["call"]] <- mc
+ attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
+ }
return(res)
})
setMethod("E", signature(object = "UnivarLebDecDistribution",
@@ -978,9 +997,12 @@
I.dc <- E(discretePart(object), fun = fun, useApply = useApply,
low = low, upp = upp, ... )
res <- as.vector(object at mixCoeff %*% c(I.ac, I.dc))
- diagn <- attr(I.ac, "diagnostic")
- diagn[["call"]] <- mc
- if(diagnostic) attr(res,"diagnostic") <- diagn
+ if(diagnostic){
+ diagn <- attr(I.ac, "diagnostic")
+ diagn[["call"]] <- mc
+ attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
+ }
return(res)
})
setMethod("E", signature(object = "UnivarLebDecDistribution",
@@ -999,9 +1021,12 @@
IQR.fac = IQR.fac, ... , diagnostic = diagnostic)
I.dc <- E(discretePart(object), cond = cond, low = low, upp = upp, ... )
res <- as.vector(object at mixCoeff %*% c(I.ac, I.dc))
- diagn <- attr(I.ac, "diagnostic")
- diagn[["call"]] <- mc
- if(diagnostic) attr(res,"diagnostic") <- diagn
+ if(diagnostic){
+ diagn <- attr(I.ac, "diagnostic")
+ diagn[["call"]] <- mc
+ attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
+ }
return(res)
})
@@ -1022,9 +1047,12 @@
I.dc <- E(discretePart(object), fun = fun, cond = cond,
useApply = useApply, low = low, upp = upp, ... )
res <- as.vector(object at mixCoeff %*% c(I.ac, I.dc))
- diagn <- attr(I.ac, "diagnostic")
- diagn[["call"]] <- mc
- if(diagnostic) attr(res,"diagnostic") <- diagn
+ if(diagnostic){
+ diagn <- attr(I.ac, "diagnostic")
+ diagn[["call"]] <- mc
+ attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
+ }
return(res)
})
@@ -1053,9 +1081,12 @@
I.dc <- E(discretePart(object), fun = fun, cond = cond, low = low,
upp = upp, ... )
res <- as.vector(object at mixCoeff %*% c(I.ac, I.dc))
- diagn <- attr(I.ac, "diagnostic")
- diagn[["call"]] <- mc
- if(diagnostic) attr(res,"diagnostic") <- diagn
+ if(diagnostic){
+ diagn <- attr(I.ac, "diagnostic")
+ diagn[["call"]] <- mc
+ attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
+ }
return(res)
})
@@ -1073,9 +1104,12 @@
resS <- E(S, ..., diagnostic = diagnostic)
resN <- E(N)
res <- resS*resN
- diagn <- attr(resS, "diagnostic")
- diagn[["call"]] <- mc
- if(diagnostic) attr(res,"diagnostic") <- diagn
+ if(diagnostic){
+ diagn <- attr(resS, "diagnostic")
+ diagn[["call"]] <- mc
+ attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
+ }
return(res)
}else{
res <- E(simplifyD(object), low = low, upp = upp, ..., diagnostic = diagnostic)
@@ -1083,6 +1117,7 @@
diagn <- attr(res, "diagnostic")
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
}
@@ -1111,6 +1146,7 @@
if(diagnostic){
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -1139,6 +1175,7 @@
if(diagnostic){
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -1167,6 +1204,7 @@
if(diagnostic){
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -1196,6 +1234,7 @@
if(diagnostic){
diagn[["call"]] <- mc
attr(res, "diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -87,6 +87,7 @@
if(diagnostic){
diagn[["call"]] <- mc
attr(int,"diagnostic") <- diagn
+ class(attr(int,"diagnostic"))<- "DiagnosticClass"
}
return(int)
@@ -108,6 +109,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -129,6 +131,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -150,6 +153,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
Modified: branches/distr-2.8/pkg/distrEx/R/HellingerDist.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/HellingerDist.R 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/R/HellingerDist.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -115,6 +115,7 @@
if(diagnostic){
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
+ class(diagn)<- "DiagnosticClass"
attr(res,"diagnostic") <- diagn
}
return(res)
@@ -134,6 +135,7 @@
if(diagnostic){
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
+ class(diagn)<- "DiagnosticClass"
attr(res,"diagnostic") <- diagn
}
return(res)
@@ -169,6 +171,7 @@
if(diagnostic){
diagn <- attr(da2,"diagnostic")
diagn[["call"]] <- match.call()
+ class(diagn)<- "DiagnosticClass"
attr(res,"diagnostic") <- diagn
}
return(res)
Modified: branches/distr-2.8/pkg/distrEx/R/OAsymTotalVarDist.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/OAsymTotalVarDist.R 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/R/OAsymTotalVarDist.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -82,6 +82,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -169,6 +170,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -190,6 +192,7 @@
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
@@ -313,9 +316,8 @@
res <- res +sum(integ.d(c.opt))
names(res) <- "minimal asym. total variation distance"
if(diagnostic){
- diagn <- attr(res,"diagnostic")
- diagn[["call"]] <- match.call()
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
})
Modified: branches/distr-2.8/pkg/distrEx/R/TotalVarDist.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/TotalVarDist.R 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/R/TotalVarDist.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -28,6 +28,7 @@
if(diagnostic){
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
+ class(diagn)<- "DiagnosticClass"
attr(res,"diagnostic") <- diagn
}
@@ -112,6 +113,7 @@
if(diagnostic){
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
+ class(diagn)<- "DiagnosticClass"
attr(res,"diagnostic") <- diagn
}
return(res)
@@ -159,6 +161,7 @@
if(diagnostic){
diagn <- attr(res,"diagnostic")
diagn[["call"]] <- match.call()
+ class(diagn)<- "DiagnosticClass"
attr(res,"diagnostic") <- diagn
}
res
Modified: branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R
===================================================================
--- branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R 2018-08-18 20:02:42 UTC (rev 1283)
@@ -162,9 +162,9 @@
stop.on.error = stop.on.error),list(...)),
result = res)
res <- val
- attr(res,"diagnostic") <- diagn
}else res <- val
}else{
+ errmess <- res
Zi <- 1
if(lower >= upper){
lo <- lower
@@ -224,7 +224,7 @@
diagn <- list(call = mc, method = "GLIntegrate",
args = c(list(lower=lower, upper=upper, order=order),
list(...)),
- result = res,
+ result = list(GLIresult = res, errorMessage = errmess),
distrExOptions = .distrExOptions)
}
}
@@ -234,6 +234,7 @@
if(diagnostic){
diagn$time <- structure(new.time - time, class = "proc_time")
attr(res,"diagnostic") <- diagn
+ class(attr(res,"diagnostic"))<- "DiagnosticClass"
}
return(res)
}
Modified: branches/distr-2.8/pkg/distrEx/inst/NEWS
===================================================================
--- branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-18 20:02:42 UTC (rev 1283)
@@ -17,7 +17,10 @@
optional attribute "diagnostic" which is filled if argument
diagnostic is TRUE (the E()-methods whenever they use distrExIntegrate
in (parts of) their computation.
-
++ particular functionality to inspect/access this diagnostic
+ information through showDiagnostic, getDiagnostic and the S3method
+ for print for class DiagnosticClass
+
under the hood:
+ moved quantile integration methods for expectation for Weibull and
Gamma distribution from pkg RobExtremes to distrEx; this is now also used
@@ -76,6 +79,14 @@
.AW.1e5 instead to .AW.100000
+ code to produce the grid values .AW.xxx in sysdata.rda is now contained
in distrExIntegrate.R in an if(FALSE) { <block> }
++ new S3 class DiagnosticClass and helper functions .showallNamesDiagnosticList,
+ .reorganizeDiagnosticList to ease inspection of the diagnostic information;
+ exported constant .nmsToGather captures the names of items in diagnostic attributes
+ which are "easily" shown (numeric, logical, character)
++ Expectations, .qtlIntegrate and distances based on integration (i.e., TotalVarDist,
+ OAsymTotalVarDist, AsymTotalVarDist, HellingerDist, CvMDist) if (diagnostic==TRUE)
+ return diagnostic attributes of S3 class "DiagnosticClass"
+
##############
v 2.7
##############
Modified: branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd
===================================================================
--- branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd 2018-08-18 20:02:42 UTC (rev 1283)
@@ -127,6 +127,11 @@
between the smoothed empirical distribution and the provided abs. cont.
distribution is computed.
+ Diagnostics on the involved integrations are available if argument
+ \code{diagnostic} is \code{TRUE}. Then there is attribute \code{diagnostic}
+ attached to the return value, which may be inspected
+ and assessed through \code{\link[distrEx]{showDiagnostic}} and
+ \code{\link[distrEx]{getDiagnostic}}.
}
\value{ Asymmetric Total variation distance of \code{e1} and \code{e2} }
\section{Methods}{
Modified: branches/distr-2.8/pkg/distrEx/man/CvMDist.Rd
===================================================================
--- branches/distr-2.8/pkg/distrEx/man/CvMDist.Rd 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/man/CvMDist.Rd 2018-08-18 20:02:42 UTC (rev 1283)
@@ -45,6 +45,13 @@
univariate distribution.
}
}}
+\details{
+ Diagnostics on the involved integrations are available if argument
+ \code{diagnostic} is \code{TRUE}. Then there is attribute \code{diagnostic}
+ attached to the return value, which may be inspected
+ and assessed through \code{\link[distrEx]{showDiagnostic}} and
+ \code{\link[distrEx]{getDiagnostic}}.
+}
\references{
Rieder, H. (1994) \emph{Robust Asymptotic Statistics}. New York: Springer.
}
Modified: branches/distr-2.8/pkg/distrEx/man/E.Rd
===================================================================
--- branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-18 20:02:42 UTC (rev 1283)
@@ -289,6 +289,13 @@
function \code{.qtlIntegrate}, where both arguments \code{.withLeftTail}
and \code{.withRightTail} are \code{TRUE} for the Cauchy and Gamma distributions,
and only \code{.withRightTail} ist \code{TRUE} for the Weibull distribution.
+
+ Diagnostics on the involved integrations are available if argument
+ \code{diagnostic} is \code{TRUE}. Then there is attribute \code{diagnostic}
+ attached to the return value, which may be inspected
+ and assessed through \code{\link[distrEx]{showDiagnostic}} and
+ \code{\link[distrEx]{getDiagnostic}}.
+
}
\value{
Modified: branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd
===================================================================
--- branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd 2018-08-18 20:02:42 UTC (rev 1283)
@@ -109,6 +109,12 @@
which leads to an abs. cont. distribution. Afterwards the distance
between the smoothed empirical distribution and the provided abs. cont.
distribution is computed.
+
+ Diagnostics on the involved integrations are available if argument
+ \code{diagnostic} is \code{TRUE}. Then there is attribute \code{diagnostic}
+ attached to the return value, which may be inspected
+ and assessed through \code{\link[distrEx]{showDiagnostic}} and
+ \code{\link[distrEx]{getDiagnostic}}.
}
\value{ Hellinger distance of \code{e1} and \code{e2} }
\section{Methods}{
Modified: branches/distr-2.8/pkg/distrEx/man/OAsymTotalVarDist.Rd
===================================================================
--- branches/distr-2.8/pkg/distrEx/man/OAsymTotalVarDist.Rd 2018-08-16 12:31:54 UTC (rev 1282)
+++ branches/distr-2.8/pkg/distrEx/man/OAsymTotalVarDist.Rd 2018-08-18 20:02:42 UTC (rev 1283)
@@ -83,6 +83,7 @@
or \code{"GLIntegrate"}), \code{call}, \code{result} (the complete return
value of the method), \code{args} (the args with which the
method was called), and \code{time} (the time to compute the integral). }
+
}
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/distr -r 1283
More information about the Distr-commits
mailing list