From noreply at r-forge.r-project.org Thu Aug 2 12:24:12 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 2 Aug 2018 12:24:12 +0200 (CEST) Subject: [Distr-commits] r1238 - branches/distr-2.8/pkg/utils pkg/utils Message-ID: <20180802102412.A6F4618420D@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-02 12:24:12 +0200 (Thu, 02 Aug 2018) New Revision: 1238 Added: branches/distr-2.8/pkg/utils/RCheckOT.bat branches/distr-2.8/pkg/utils/RZipInstall.bat pkg/utils/RZipInstall.bat Modified: branches/distr-2.8/pkg/utils/RCRAN.bat branches/distr-2.8/pkg/utils/RCheck.bat branches/distr-2.8/pkg/utils/README-R-utils branches/distr-2.8/pkg/utils/RZip.bat branches/distr-2.8/pkg/utils/finde.R pkg/utils/RCRAN.bat pkg/utils/RCheck.bat pkg/utils/RCheckOT.bat pkg/utils/README-R-utils pkg/utils/RZip.bat pkg/utils/finde.R Log: branch 2.8 and trunk: + updated batch utils : * in R CMD check utils set (_R_CHECK_LENGTH_1_CONDITION_=true) * in RZip now install to a temporary folder which is subsequently deleted (to avoid installation into the real library... * RZipInstall now does zipping and installing at the same time (as RZip did before) + bugfix in ersetze() + updated documentation of R-Utils Modified: branches/distr-2.8/pkg/utils/RCRAN.bat =================================================================== --- branches/distr-2.8/pkg/utils/RCRAN.bat 2018-07-31 11:31:46 UTC (rev 1237) +++ branches/distr-2.8/pkg/utils/RCRAN.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,7 +1,9 @@ @echo off +set _R_CHECK_LENGTH_1_CONDITION_=true if not "%2"=="" ( call R CMD check --as-cran --output=%2 %1 ) else ( call R CMD check --as-cran %1 ) +set _R_CHECK_LENGTH_1_CONDITION_= echo on Modified: branches/distr-2.8/pkg/utils/RCheck.bat =================================================================== --- branches/distr-2.8/pkg/utils/RCheck.bat 2018-07-31 11:31:46 UTC (rev 1237) +++ branches/distr-2.8/pkg/utils/RCheck.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,7 +1,9 @@ @echo off +set _R_CHECK_LENGTH_1_CONDITION_=true if not "%2"=="" ( -call R CMD check --multiarch --output=%2 --timings --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 +call R CMD check --multiarch --output=%2 --timings --run-donttest --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 ) else ( -call R CMD check --multiarch --timings --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 +call R CMD check --multiarch --timings --run-donttest --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 ) +set _R_CHECK_LENGTH_1_CONDITION_= echo on Added: branches/distr-2.8/pkg/utils/RCheckOT.bat =================================================================== --- branches/distr-2.8/pkg/utils/RCheckOT.bat (rev 0) +++ branches/distr-2.8/pkg/utils/RCheckOT.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -0,0 +1,9 @@ + at echo off +set _R_CHECK_LENGTH_1_CONDITION_=true +if not "%2"=="" ( +call R CMD check --multiarch --output=%2 --run-donttest --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 +) else ( +call R CMD check --run-donttest --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 +) +set _R_CHECK_LENGTH_1_CONDITION_= +echo on Modified: branches/distr-2.8/pkg/utils/README-R-utils =================================================================== --- branches/distr-2.8/pkg/utils/README-R-utils 2018-07-31 11:31:46 UTC (rev 1237) +++ branches/distr-2.8/pkg/utils/README-R-utils 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,5 +1,5 @@ ##################################################### -# Howto to R - utils -- version 2.2 (040909) +# Howto to R - utils -- version 2.8 (020818) ##################################################### ########### R - Utils @@ -9,14 +9,42 @@ # searches for a given pattern (possibly with regular expressions) # in all files with a given file extension in a given folder # similarly replaces patterns -# Syntax +# Syntax (as of branch >= distr-2.8 and trunk from 2018-08-02) -finde(x = "nchar", dir="C:/rtest/distrEx/R", ext = "R", rec = FALSE) -## args: x : pattern; dir: folder; ext: file extension, rec: recursive in subfolders? +finde(x = "nchar", dir = "C:/rtest/distr/pkg/distr/R", + ext = "R", restrictFilepattern = "", excludeFilepattern = "", + excludeext = "", withEmpty = FALSE, rec = FALSE) +## args: x : pattern to be found (may be a regexp; +## dir: folder to be searched; +## ext: file extension[s] to which the search is restricted (can be a vector) +## here: ext = all that comes after the last "." +## restrictFilePattern: pattern[s] in file name to which the search is restricted +## (can be a vector) +## excludeFilePattern: pattern[s] in file name to be excluded from the search +## (can be a vector) +## excludeext: file extension[s] to be excluded from the search (can be a vector) +## withEmpty: logical should empty extensions be included in the search +## rec: recursive in subfolders? +## semantics: if any of the restrictFilePattern, excludeFilepattern, excludeext is +## a vector of length 1 and == "", no restriction is done through this arg +## if length of arg ext is 1 and == "" and withEmpty is TRUE, only empty +## restrictions are searched; if in the same case withEmpty is FALSE +## no restrictions based on ext are done +## otherwise whenever withEmpty is TRUE the empty extensions are included +## in the search -ersetze(x0 = "nchar", x1="nchar", dir="C:/rtest/distr/pkg/distr/R", ext = "R", rec = FALSE) -## args: x0 : pattern to be replaced; x1= replacing text; dir: folder; -## ext: file extension, rec: recursive in subfolders? +ersetze(x0 = "nchar", x1 = "nchar", dir = "C:/rtest/distr/pkg/distr/R", + ext = "R", restrictFilepattern = "", excludeFilepattern = "", + excludeext = "", rec = FALSE, withEmpty = FALSE, + withoverwrite = FALSE) +## args: x0: pattern to be replaced +## x1: replacing text +## withoverwrite: if FALSE only found items are shown (to check this first before +## going "real" ..) from 2.8 on, only files with found items are +## overwritten in case of withoverwrite == TRUE (was a bug before) +## all other args as with finde() +## semantics: as with finde(); in fact, finde now calls ersetze() with args +## x1="" and withoverwrite = FALSE ### ladealles.R # @@ -28,6 +56,40 @@ ## develDir: development folder (absolute path) ## pattern: regexpr. for files to be sourced in +### DESCRIPTIONutils.R : +# +# sources in some utils to update DESCRIPTION files and connected/linked +# other information files + +changeDescription(startDir ,names, values, pkgs = NULL ,withSVNread = TRUE, + withPackageHelpUpdate = TRUE, pathRepo = NULL, + withDate = TRUE, inRforge = TRUE, withlogin = TRUE, + PathToBash = "C:/cygwin64/bin/bash", + PathToreadsvnlog.sh="C:/rtest/distr/branches/distr-2.4/pkg/utils", + tmpfile = "C:/rtest/tmp-svnlog5.txt", verbose = FALSE) +## args: startDir: folder with pkgs to be updated, +## e.g. "C:/rtest/distr/branches/distr-2.6" +## names: names of the DESCRIPTION tags to be updated +## values: values of the DESCRIPTION tags to be updated +## (a matrix, columns = pkgs and row = tags see examples) +## pkgs: pkgs to be updated; if NULL all pkgs in startfolder +## withSVNread: should VCS/SVNRevision be updated +## withPackageHelpUpdate: should file -package.Rd in man be updated +## pathRepo: path to svn repo; if NULL deduced from startDir assuming r-forge +## withDate: shall date be updated? +## inRforge: shall we use r-forge as repository +## (otherwise need full URL as arg pathRepo +## withlogin: do we need option --login (yes in cygwin, don't know in Linux) +## PathToBash: path to bash +## PathToreadsvnlog.sh: path to shell script readsvnlog.sh +## tmpfile: some tmpfile to which we write the results temporarily; +## is deleted afterwords +## verbose: how verbose should we be? +## +## uses getRevNr() in getRevNr.R in utils +## for examples see DESCRIPTIONutilsExamples.R + + ### compare.R : # # compares (recursively over all slots / list elements) Modified: branches/distr-2.8/pkg/utils/RZip.bat =================================================================== --- branches/distr-2.8/pkg/utils/RZip.bat 2018-07-31 11:31:46 UTC (rev 1237) +++ branches/distr-2.8/pkg/utils/RZip.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,3 +1,5 @@ @echo off -call R CMD INSTALL --build --byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both %1 +mkdir tmpInstall00 +call R CMD INSTALL --build --library=tmpInstall00 --byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both %1 +rmdir /S/Q tmpInstall00 echo on Added: branches/distr-2.8/pkg/utils/RZipInstall.bat =================================================================== --- branches/distr-2.8/pkg/utils/RZipInstall.bat (rev 0) +++ branches/distr-2.8/pkg/utils/RZipInstall.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -0,0 +1,3 @@ + at echo off +call R CMD INSTALL --build --byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both %1 +echo on Modified: branches/distr-2.8/pkg/utils/finde.R =================================================================== --- branches/distr-2.8/pkg/utils/finde.R 2018-07-31 11:31:46 UTC (rev 1237) +++ branches/distr-2.8/pkg/utils/finde.R 2018-08-02 10:24:12 UTC (rev 1238) @@ -72,7 +72,7 @@ invisible() } DIR <- dir(rec=rec) - if(! ((ext=="")&&(withEmpty))){ + if(! (all(ext=="")&&(withEmpty))){ ext0 <- sapply(ext, function(ext1) if(ext=="") "" else paste("\\.", ext, sep="")) extL <- sapply(ext0, function(ers) grepl(ers,DIR)) if(withEmpty){ Modified: pkg/utils/RCRAN.bat =================================================================== --- pkg/utils/RCRAN.bat 2018-07-31 11:31:46 UTC (rev 1237) +++ pkg/utils/RCRAN.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,7 +1,9 @@ @echo off +set _R_CHECK_LENGTH_1_CONDITION_=true if not "%2"=="" ( call R CMD check --as-cran --output=%2 %1 ) else ( call R CMD check --as-cran %1 ) +set _R_CHECK_LENGTH_1_CONDITION_= echo on Modified: pkg/utils/RCheck.bat =================================================================== --- pkg/utils/RCheck.bat 2018-07-31 11:31:46 UTC (rev 1237) +++ pkg/utils/RCheck.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,7 +1,9 @@ @echo off +set _R_CHECK_LENGTH_1_CONDITION_=true if not "%2"=="" ( -call R CMD check --multiarch --output=%2 --timings --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 +call R CMD check --multiarch --output=%2 --timings --run-donttest --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 ) else ( -call R CMD check --multiarch --timings --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 +call R CMD check --multiarch --timings --run-donttest --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 ) +set _R_CHECK_LENGTH_1_CONDITION_= echo on Modified: pkg/utils/RCheckOT.bat =================================================================== --- pkg/utils/RCheckOT.bat 2018-07-31 11:31:46 UTC (rev 1237) +++ pkg/utils/RCheckOT.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,7 +1,9 @@ @echo off +set _R_CHECK_LENGTH_1_CONDITION_=true if not "%2"=="" ( -call R CMD check --multiarch --output=%2 %1 +call R CMD check --multiarch --output=%2 --run-donttest --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 ) else ( -call R CMD check %1 +call R CMD check --run-donttest --install-args="--byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both --force-biarch" %1 ) +set _R_CHECK_LENGTH_1_CONDITION_= echo on Modified: pkg/utils/README-R-utils =================================================================== --- pkg/utils/README-R-utils 2018-07-31 11:31:46 UTC (rev 1237) +++ pkg/utils/README-R-utils 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,5 +1,5 @@ ##################################################### -# Howto to R - utils -- version 2.2 (040909) +# Howto to R - utils -- version 2.8 (020818) ##################################################### ########### R - Utils @@ -9,14 +9,42 @@ # searches for a given pattern (possibly with regular expressions) # in all files with a given file extension in a given folder # similarly replaces patterns -# Syntax +# Syntax (as of branch >= distr-2.8 and trunk from 2018-08-02) -finde(x = "nchar", dir="C:/rtest/distrEx/R", ext = "R", rec = FALSE) -## args: x : pattern; dir: folder; ext: file extension, rec: recursive in subfolders? +finde(x = "nchar", dir = "C:/rtest/distr/pkg/distr/R", + ext = "R", restrictFilepattern = "", excludeFilepattern = "", + excludeext = "", withEmpty = FALSE, rec = FALSE) +## args: x : pattern to be found (may be a regexp; +## dir: folder to be searched; +## ext: file extension[s] to which the search is restricted (can be a vector) +## here: ext = all that comes after the last "." +## restrictFilePattern: pattern[s] in file name to which the search is restricted +## (can be a vector) +## excludeFilePattern: pattern[s] in file name to be excluded from the search +## (can be a vector) +## excludeext: file extension[s] to be excluded from the search (can be a vector) +## withEmpty: logical should empty extensions be included in the search +## rec: recursive in subfolders? +## semantics: if any of the restrictFilePattern, excludeFilepattern, excludeext is +## a vector of length 1 and == "", no restriction is done through this arg +## if length of arg ext is 1 and == "" and withEmpty is TRUE, only empty +## restrictions are searched; if in the same case withEmpty is FALSE +## no restrictions based on ext are done +## otherwise whenever withEmpty is TRUE the empty extensions are included +## in the search -ersetze(x0 = "nchar", x1="nchar", dir="C:/rtest/distr/pkg/distr/R", ext = "R", rec = FALSE) -## args: x0 : pattern to be replaced; x1= replacing text; dir: folder; -## ext: file extension, rec: recursive in subfolders? +ersetze(x0 = "nchar", x1 = "nchar", dir = "C:/rtest/distr/pkg/distr/R", + ext = "R", restrictFilepattern = "", excludeFilepattern = "", + excludeext = "", rec = FALSE, withEmpty = FALSE, + withoverwrite = FALSE) +## args: x0: pattern to be replaced +## x1: replacing text +## withoverwrite: if FALSE only found items are shown (to check this first before +## going "real" ..) from 2.8 on, only files with found items are +## overwritten in case of withoverwrite == TRUE (was a bug before) +## all other args as with finde() +## semantics: as with finde(); in fact, finde now calls ersetze() with args +## x1="" and withoverwrite = FALSE ### ladealles.R # @@ -28,6 +56,40 @@ ## develDir: development folder (absolute path) ## pattern: regexpr. for files to be sourced in +### DESCRIPTIONutils.R : +# +# sources in some utils to update DESCRIPTION files and connected/linked +# other information files + +changeDescription(startDir ,names, values, pkgs = NULL ,withSVNread = TRUE, + withPackageHelpUpdate = TRUE, pathRepo = NULL, + withDate = TRUE, inRforge = TRUE, withlogin = TRUE, + PathToBash = "C:/cygwin64/bin/bash", + PathToreadsvnlog.sh="C:/rtest/distr/branches/distr-2.4/pkg/utils", + tmpfile = "C:/rtest/tmp-svnlog5.txt", verbose = FALSE) +## args: startDir: folder with pkgs to be updated, +## e.g. "C:/rtest/distr/branches/distr-2.6" +## names: names of the DESCRIPTION tags to be updated +## values: values of the DESCRIPTION tags to be updated +## (a matrix, columns = pkgs and row = tags see examples) +## pkgs: pkgs to be updated; if NULL all pkgs in startfolder +## withSVNread: should VCS/SVNRevision be updated +## withPackageHelpUpdate: should file -package.Rd in man be updated +## pathRepo: path to svn repo; if NULL deduced from startDir assuming r-forge +## withDate: shall date be updated? +## inRforge: shall we use r-forge as repository +## (otherwise need full URL as arg pathRepo +## withlogin: do we need option --login (yes in cygwin, don't know in Linux) +## PathToBash: path to bash +## PathToreadsvnlog.sh: path to shell script readsvnlog.sh +## tmpfile: some tmpfile to which we write the results temporarily; +## is deleted afterwords +## verbose: how verbose should we be? +## +## uses getRevNr() in getRevNr.R in utils +## for examples see DESCRIPTIONutilsExamples.R + + ### compare.R : # # compares (recursively over all slots / list elements) Modified: pkg/utils/RZip.bat =================================================================== --- pkg/utils/RZip.bat 2018-07-31 11:31:46 UTC (rev 1237) +++ pkg/utils/RZip.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -1,3 +1,5 @@ @echo off -call R CMD INSTALL --build --byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both %1 +mkdir tmpInstall00 +call R CMD INSTALL --build --library=tmpInstall00 --byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both %1 +rmdir /S/Q tmpInstall00 echo on Added: pkg/utils/RZipInstall.bat =================================================================== --- pkg/utils/RZipInstall.bat (rev 0) +++ pkg/utils/RZipInstall.bat 2018-08-02 10:24:12 UTC (rev 1238) @@ -0,0 +1,3 @@ + at echo off +call R CMD INSTALL --build --byte-compile --with-keep.source --compact-docs --resave-data --install-tests --example --html --latex --clean --preclean --compile-both %1 +echo on Modified: pkg/utils/finde.R =================================================================== --- pkg/utils/finde.R 2018-07-31 11:31:46 UTC (rev 1237) +++ pkg/utils/finde.R 2018-08-02 10:24:12 UTC (rev 1238) @@ -72,7 +72,7 @@ invisible() } DIR <- dir(rec=rec) - if(! ((ext=="")&&(withEmpty))){ + if(! (all(ext=="")&&(withEmpty))){ ext0 <- sapply(ext, function(ext1) if(ext=="") "" else paste("\\.", ext, sep="")) extL <- sapply(ext0, function(ers) grepl(ers,DIR)) if(withEmpty){ From noreply at r-forge.r-project.org Thu Aug 2 12:26:31 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 2 Aug 2018 12:26:31 +0200 (CEST) Subject: [Distr-commits] r1239 - branches/distr-2.8/pkg/utils pkg/utils Message-ID: <20180802102631.1A236189E37@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-02 12:26:30 +0200 (Thu, 02 Aug 2018) New Revision: 1239 Modified: branches/distr-2.8/pkg/utils/finde.R pkg/utils/finde.R Log: [utils] trunk and branch 2.8: yet another bug fix in finde.R Modified: branches/distr-2.8/pkg/utils/finde.R =================================================================== --- branches/distr-2.8/pkg/utils/finde.R 2018-08-02 10:24:12 UTC (rev 1238) +++ branches/distr-2.8/pkg/utils/finde.R 2018-08-02 10:26:30 UTC (rev 1239) @@ -72,7 +72,7 @@ invisible() } DIR <- dir(rec=rec) - if(! (all(ext=="")&&(withEmpty))){ + if(! (all(ext=="")&&(!withEmpty))){ ext0 <- sapply(ext, function(ext1) if(ext=="") "" else paste("\\.", ext, sep="")) extL <- sapply(ext0, function(ers) grepl(ers,DIR)) if(withEmpty){ Modified: pkg/utils/finde.R =================================================================== --- pkg/utils/finde.R 2018-08-02 10:24:12 UTC (rev 1238) +++ pkg/utils/finde.R 2018-08-02 10:26:30 UTC (rev 1239) @@ -72,7 +72,7 @@ invisible() } DIR <- dir(rec=rec) - if(! (all(ext=="")&&(withEmpty))){ + if(! (all(ext=="")&&(!withEmpty))){ ext0 <- sapply(ext, function(ext1) if(ext=="") "" else paste("\\.", ext, sep="")) extL <- sapply(ext0, function(ers) grepl(ers,DIR)) if(withEmpty){ From noreply at r-forge.r-project.org Sat Aug 4 16:01:53 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 4 Aug 2018 16:01:53 +0200 (CEST) Subject: [Distr-commits] r1240 - branches/distr-2.8/pkg/distrMod/R Message-ID: <20180804140153.70E8E18A2FD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-04 16:01:53 +0200 (Sat, 04 Aug 2018) New Revision: 1240 Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R Log: [distrMod] branch 2.8: discovered some issues with local variables in L2Families (global values were used instead...) => in code in SimpleL2ParamFamilies.R: + param.0 denotes the local current parameter of the L2Family + param is used as function argument + .0 is used in .fct - functions as local variant (intern to fct) of the current parameter + in the substituted L2deriv.fct, we use .1 which is substituted for .0 + in case .0 is already used otherwise (as in NbinomMeanSizeFamily) we use .00 instead => now except for shape values < 1 CvMMDEstimator works with variances ... Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-02 10:26:30 UTC (rev 1239) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-04 14:01:53 UTC (rev 1240) @@ -13,7 +13,7 @@ param1 <- size names(param1) <- "size" if(missing(trafo)) trafo <- matrix(1, dimnames = list("prob","prob")) - param <- ParamFamParameter(name = "probability of success", + param.0 <- ParamFamParameter(name = "probability of success", main = param0, fixed = param1, trafo = trafo) @@ -27,23 +27,23 @@ if(param>=1) return(1-.Machine$double.eps) return(param)} L2deriv.fct <- function(param){ - prob <- main(param) + prob.0 <- main(param) fct <- function(x){} - body(fct) <- substitute({ (x-size*prob)/(prob*(1-prob)) }, - list(size = size, prob = prob)) + body(fct) <- substitute({ (x-size*prob.1)/(prob.1*(1-prob.1)) }, + list(size = size, prob.0 = prob.1)) return(fct)} - L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = size*prob)) + L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = size*prob)) L2derivDistr <- UnivarDistrList((distribution - size*prob)/(prob*(1-prob))) if(.isEqual(prob,0.5)) L2derivDistrSymm <- DistrSymmList(SphericalSymmetry(SymmCenter = 0)) else L2derivDistrSymm <- DistrSymmList(NoSymmetry()) FisherInfo.fct <- function(param){ - prob <- main(param) - PosDefSymmMatrix(matrix(size/(prob*(1-prob)), + prob.0 <- main(param) + PosDefSymmMatrix(matrix(size/(prob.0*(1-prob.0)), dimnames=list("prob","prob")))} - FisherInfo <- FisherInfo.fct(param) + FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, distrSymm = distrSymm, param = param, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, @@ -73,7 +73,7 @@ param0 <- lambda names(param0) <- "lambda" if(missing(trafo)) trafo <- matrix(1, dimnames = list("lambda","lambda")) - param <- ParamFamParameter(name = "positive mean", + param.0 <- ParamFamParameter(name = "positive mean", main = param0, trafo = trafo) modifyParam <- function(theta){ Pois(lambda = theta) } @@ -82,20 +82,20 @@ makeOKPar <- function(param) {if(param<=0) return(.Machine$double.eps) return(param)} L2deriv.fct <- function(param){ - lambda <- main(param) + lambda.0 <- main(param) fct <- function(x){} - body(fct) <- substitute({ x/lambda-1 }, - list(lambda = lambda)) + body(fct) <- substitute({ x/lambda.1-1 }, + list(lambda.1 = lambda.0)) return(fct)} L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = lambda)) L2derivDistr <- UnivarDistrList(distribution/lambda - 1) L2derivDistrSymm <- DistrSymmList(NoSymmetry()) FisherInfo.fct <- function(param){ - lambda <- main(param) - PosDefSymmMatrix(matrix(1/lambda, + lambda.0 <- main(param) + PosDefSymmMatrix(matrix(1/lambda.0, dimnames=list("lambda","lambda")))} - FisherInfo <- FisherInfo.fct(param) + FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, distrSymm = distrSymm, param = param, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, @@ -127,7 +127,7 @@ param1 <- size names(param1) <- "size" if(missing(trafo)) trafo <- matrix(1, dimnames = list("prob","prob")) - param <- ParamFamParameter(name = "probability of success", + param.0 <- ParamFamParameter(name = "probability of success", main = param0, fixed = param1, trafo = trafo) @@ -140,20 +140,20 @@ if(param>=1) return(1-.Machine$double.eps) return(param)} L2deriv.fct <- function(param){ - prob <- main(param) + prob.0 <- main(param) fct <- function(x){} - body(fct) <- substitute({ (size/prob- x/(1-prob)) }, - list(size = size, prob = prob)) + body(fct) <- substitute({ (size/prob.1- x/(1-prob.1)) }, + list(size = size, prob.1 = prob.0)) return(fct)} L2derivSymm <- FunSymmList(NonSymmetric()) L2derivDistr <- UnivarDistrList((size/prob- distribution/(1-prob))) L2derivDistrSymm <- DistrSymmList(NoSymmetry()) FisherInfo.fct <- function(param){ - prob <- main(param) - PosDefSymmMatrix(matrix(size/(prob^2*(1-prob)), + prob.0 <- main(param) + PosDefSymmMatrix(matrix(size/(prob.0^2*(1-prob.0)), dimnames=list("prob","prob")))} - FisherInfo <- FisherInfo.fct(param) + FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, distrSymm = distrSymm, param = param, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, @@ -182,7 +182,7 @@ param0 <- c(size,prob) names(param0) <- nms <- c("size","prob") if(missing(trafo)) trafo <- matrix(c(1,0,0,1),2,2, dimnames = list(c("size","prob"),c("size","prob"))) - param <- ParamFamParameter(name = "NegBinomParameter", + param.0 <- ParamFamParameter(name = "NegBinomParameter", main = param0, trafo = trafo) modifyParam <- function(theta){ Nbinom(size = theta[1], prob = theta[2]) } @@ -197,14 +197,14 @@ param["size"] <- min(1e-8, param["size"]) return(param)} L2deriv.fct <- function(param){ - prob <- main(param)["prob"] - size <- main(param)["size"] + prob.0 <- main(param)["prob"] + size.0 <- main(param)["size"] fct1 <- function(x){} fct2 <- function(x){} - body(fct2) <- substitute({ (size/prob- x/(1-prob)) }, - list(size = size, prob = prob)) - body(fct1) <- substitute({ digamma(x+size)-digamma(size)+log(prob)}, - list(size = size, prob = prob)) + body(fct2) <- substitute({ (size.1/prob.1- x/(1-prob.1)) }, + list(size.1 = size.0, prob.1 = prob.0)) + body(fct1) <- substitute({ digamma(x+size.1)-digamma(size.1)+log(prob.1)}, + list(size.1 = size.0, prob.1 = prob.0)) return(list(fct1, fct2))} L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric()) @@ -216,18 +216,18 @@ L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry()) FisherInfo.fct <- function(param){ - prob <- main(param)["prob"] - size <- main(param)["size"] - xn <- 0:min(max(support(distribution)), - qnbinom(1e-6,size=size,prob=prob,lower.tail=FALSE), + prob.0 <- main(param)["prob"] + size.0 <- main(param)["size"] + xn <- 0:min(max(support(Nbinom(size = size.0, prob = prob.0))), + qnbinom(1e-6,size=size.0,prob=prob.0,lower.tail=FALSE), 1e5) - I11 <- -sum((trigamma(xn+size)-trigamma(size))*dnbinom(xn,size=size,prob=prob)) - I12 <- -1/prob - I22 <- size/prob^2/(1-prob) + I11 <- -sum((trigamma(xn+size.0)-trigamma(size.0))*dnbinom(xn,size=size.0,prob=prob.0)) + I12 <- -1/prob.0 + I22 <- size.0/prob.0^2/(1-prob.0) PosDefSymmMatrix(matrix(c(I11,I12,I12,I22),2,2, dimnames=list(nms,nms)))} - FisherInfo <- FisherInfo.fct(param) + FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, distrSymm = distrSymm, param = param, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, @@ -257,7 +257,7 @@ param0 <- c(size,mean) names(param0) <- nms <- c("size","mean") if(missing(trafo)) trafo <- matrix(c(1,0,0,1),2,2, dimnames = list(nms,nms)) - param <- ParamFamParameter(name = "probability of success", + param.0 <- ParamFamParameter(name = "probability of success", main = param0, trafo = trafo) modifyParam <- function(theta){ Nbinom(size = theta[1], prob = theta[1]/(theta[1]+theta[2])) } @@ -272,19 +272,19 @@ param["size"] <- min(1e-8, param["size"]) return(param)} L2deriv.fct <- function(param){ - size.0 <- main(param)["size"] - mean.0 <- main(param)["mean"] - prob.0 <- size.0/(size.0+mean.0) + size.00 <- main(param)["size"] + mean.00 <- main(param)["mean"] + prob.00 <- size.00/(size.00+mean.00) fct1 <- function(x){} fct1.2 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({ digamma(x+size)-digamma(size)+log(prob.2)}, - list(size = size.0, prob.2 = prob.0)) - body(fct1.2)<- substitute({ (size/prob.2- x/(1-prob.2)) }, - list(size = size.0, prob.2 = prob.0)) - body(fct2) <- substitute({ (1/prob.2-1)* fct1(x) - size/prob.2^2 * fct1.2(x)}, - list(size = size.0, prob.2 = prob.0)) + body(fct1) <- substitute({ digamma(x+size.1)-digamma(size.1)+log(prob.1)}, + list(size.1 = size.00, prob.1 = prob.00)) + body(fct1.2)<- substitute({ (size.1/prob.1- x/(1-prob.1)) }, + list(size.1 = size.00, prob.1 = prob.00)) + body(fct2) <- substitute({ (1/prob.1-1)* fct1(x) - size.1/prob.1^2 * fct1.2(x)}, + list(size.1 = size.00, prob.1 = prob.00)) return(list(fct1, fct2))} L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric()) @@ -302,21 +302,21 @@ L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry()) FisherInfo.fct <- function(param){ - mean <- main(param)["mean"] - size <- main(param)["size"] - prob.0 <- size/(size+mean) - xn <- 0:min(max(support(distribution)), - qnbinom(1e-6,size=size,prob=prob.0,lower.tail=FALSE), + mean.0 <- main(param)["mean"] + size.0 <- main(param)["size"] + prob.00 <- size.0/(size.0+mean.0) + xn <- 0:min(max(support(Nbinom(size = size.0, prob = prob.00))), + qnbinom(1e-6,size=size.0,prob=prob.00,lower.tail=FALSE), 1e5) - I11 <- -sum((trigamma(xn+size)-trigamma(size))*dnbinom(xn,size=size,prob=prob.0)) - I12 <- -1/prob.0 - I22 <- size/prob.0^2/(1-prob.0) - D.m <- matrix(c(1,1/prob.0-1,0,-size/prob.0^2),2,2) + I11 <- -sum((trigamma(xn+size.0)-trigamma(size.0))*dnbinom(xn,size=size.0,prob=prob.00)) + I12 <- -1/prob.00 + I22 <- size.0/prob.00^2/(1-prob.00) + D.m <- matrix(c(1,1/prob.00-1,0,-size.0/prob.00^2),2,2) ma <- D.m%*%matrix(c(I11,I12,I12,I22),2,2)%*%t(D.m) dimnames(ma) <- list(nms,nms) PosDefSymmMatrix(ma)} - FisherInfo <- FisherInfo.fct(param) + FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, distrSymm = distrSymm, param = param, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, @@ -347,7 +347,7 @@ param0 <- c(scale, shape) names(param0) <- nms <- c("scale", "shape") if(missing(trafo)) {trafo <- diag(2); dimnames(trafo) <-list(nms,nms)} - param <- ParamFamParameter(name = "scale and shape", + param.0 <- ParamFamParameter(name = "scale and shape", main = param0, trafo = trafo, withPosRestr = TRUE, .returnClsName ="ParamWithScaleAndShapeFamParameter") @@ -364,14 +364,14 @@ makeOKPar <- function(param) {param <- abs(param) return(param)} L2deriv.fct <- function(param){ - scale <- main(param)[1] - shape <- main(param)[2] + scale.0 <- main(param)[1] + shape.0 <- main(param)[2] fct1 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({ (x/scale - shape)/scale }, - list(scale = scale, shape = shape)) - body(fct2) <- substitute({ log(x/scale) - digamma(shape) }, - list(scale = scale, shape = shape)) + body(fct1) <- substitute({ (x/scale.1 - shape.1)/scale.1 }, + list(scale.1 = scale.0, shape.1 = shape.0)) + body(fct2) <- substitute({ log(x/scale.1) - digamma(shape.1) }, + list(scale.1 = scale.0, shape.1 = shape.0)) return(list(fct1, fct2))} L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = scale*shape), NonSymmetric()) @@ -383,13 +383,13 @@ digamma(shape))) L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry()) FisherInfo.fct <- function(param){ - scale <- main(param)[1] - shape <- main(param)[2] - PosDefSymmMatrix(matrix(c(shape/scale^2, 1/scale, - 1/scale, trigamma(shape)), ncol=2, + scale.0 <- main(param)[1] + shape.0 <- main(param)[2] + PosDefSymmMatrix(matrix(c(shape.0/scale.0^2, 1/scale.0, + 1/scale.0, trigamma(shape.0)), ncol=2, dimnames=list(nms,nms)))} - FisherInfo <- FisherInfo.fct(param) + FisherInfo <- FisherInfo.fct(param.0) L2Fam <- new("GammaFamily") L2Fam at name <- name L2Fam at distribution <- distribution @@ -407,7 +407,7 @@ L2Fam at makeOKPar <- makeOKPar L2Fam at scaleshapename <- c("scale"="scale","shape"="shape") - L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param), + L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param.0), Domain = Reals())) if(!is.function(trafo)) @@ -427,6 +427,7 @@ return(L2Fam) } +(G1 <- GammaFamily()) ################################################################## ## Beta family :: new 08/08 P.R. @@ -438,7 +439,7 @@ param0 <- c(shape1, shape2) names(param0) <- nms <- c("shape1", "shape2") if(missing(trafo)) {trafo <- diag(2); dimnames(trafo) <-list(nms,nms)} - param <- ParamFamParameter(name = "shape1 and shape2", + param.0 <- ParamFamParameter(name = "shape1 and shape2", main = param0, trafo = trafo) modifyParam <- function(theta){ Beta(shape1 = theta[1], shape2 = theta[2]) } makeOKPar <- function(param) {param <- pmax(.Machine$double.eps,param) @@ -454,16 +455,16 @@ return(st) } L2deriv.fct <- function(param){ - shape1 <- main(param)[1] - shape2 <- main(param)[2] + shape1.0 <- main(param)[1] + shape2.0 <- main(param)[2] fct1 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({log(x)-digamma(shape1)+ - digamma(shape1+shape2)}, - list(shape1 = shape1, shape2 = shape2)) - body(fct2) <- substitute({log(1-x)-digamma(shape2)+ - digamma(shape1+shape2)}, - list(shape1 = shape1, shape2 = shape2)) + body(fct1) <- substitute({log(x)-digamma(shape1.1)+ + digamma(shape1.1+shape2.1)}, + list(shape1.1 = shape1.0, shape2.1 = shape2.0)) + body(fct2) <- substitute({log(1-x)-digamma(shape2.1)+ + digamma(shape1.1+shape2.1)}, + list(shape1.1 = shape1.0, shape2.1 = shape2.0)) return(list(fct1, fct2))} L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric()) L2derivDistr <- NULL @@ -474,13 +475,13 @@ digamma(shape2)+digamma(shape1+shape2)) L2derivDistrSymm <- DistrSymmList(NoSymmetry(), NoSymmetry()) FisherInfo.fct <- function(param){ - shape1 <- main(param)[1] - shape2 <- main(param)[2] +# shape1.0 <- main(param)[1] +# shape2.0 <- main(param)[2] FI <- diag(trigamma(main(param)))-trigamma(sum(main(param))) dimnames(FI) <- list(nms,nms) PosDefSymmMatrix(FI)} - FisherInfo <- FisherInfo.fct(param) + FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, distrSymm = distrSymm, param = param, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, From noreply at r-forge.r-project.org Sun Aug 5 17:46:35 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 5 Aug 2018 17:46:35 +0200 (CEST) Subject: [Distr-commits] r1241 - in branches/distr-2.8/pkg/distrEx: . R inst man Message-ID: <20180805154635.BAE941880FB@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-05 17:46:35 +0200 (Sun, 05 Aug 2018) New Revision: 1241 Added: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R Modified: branches/distr-2.8/pkg/distrEx/NAMESPACE branches/distr-2.8/pkg/distrEx/R/Expectation.R branches/distr-2.8/pkg/distrEx/inst/NEWS branches/distr-2.8/pkg/distrEx/man/E.Rd Log: [distrEx] branch 2.8: + introduce exported helper function .qtlIntegrate to achieve this (is reused in RobExtremes for the GEV methods there) + cleaned .Rd file E.Rd: It contained still some references to methods for extreme value distributions which are now in RobExtremes and some old mail reference peter.ruckdeschel at uni-bayreuth.de Modified: branches/distr-2.8/pkg/distrEx/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distrEx/NAMESPACE 2018-08-04 14:01:53 UTC (rev 1240) +++ branches/distr-2.8/pkg/distrEx/NAMESPACE 2018-08-05 15:46:35 UTC (rev 1241) @@ -1,7 +1,7 @@ useDynLib("distrEx", .registration = TRUE, .fixes = "C_") importFrom("stats", "dnorm", "integrate", "optimize", "pbinom", "pchisq", "pexp", "pnorm", "ppois", "qcauchy", "qnorm", - "uniroot") + "uniroot", "dunif") importFrom("utils", "getFromNamespace") import("methods") import("distr") @@ -53,4 +53,4 @@ "distrExMASK", "distrExoptions", "distrExMOVED") export("make01","PrognCondDistribution", "PrognCondition") -export(".getIntbounds") +export(".getIntbounds", ".qtlIntegrate") Modified: branches/distr-2.8/pkg/distrEx/R/Expectation.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-04 14:01:53 UTC (rev 1240) +++ branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-05 15:46:35 UTC (rev 1241) @@ -591,49 +591,52 @@ ### source https://mathworld.wolfram.com/GammaDistribution.html -setMethod("E", signature(object = "Gammad", - fun = "function", - cond = "missing"), - function(object, fun, low = NULL, upp = NULL, - rel.tol= getdistrExOption("ErelativeTolerance"), - lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), - upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = getdistrExOption("IQR.fac"), ... - ){ +## replaced by quantile method in file GammaWeibullExpectation.R from distrEx 2.8.0 +# on +# +#setMethod("E", signature(object = "Gammad", +# fun = "function", +# cond = "missing"), +# function(object, fun, low = NULL, upp = NULL, +# rel.tol= getdistrExOption("ErelativeTolerance"), +# lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), +# upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), +# IQR.fac = getdistrExOption("IQR.fac"), ... +# ){ +# +# dots <- list(...) +# dots.withoutUseApply <- dots +# useApply <- TRUE +# if(!is.null(dots$useApply)) useApply <- dots$useApply +# dots.withoutUseApply$useApply <- NULL +# integrand <- function(x, dfun, ...){ di <- dim(x) +# y <- exp(x) +# if(useApply){ +# funy <- sapply(y,fun, ...) +# dim(y) <- di +# dim(funy) <- di +# }else funy <- fun(y,...) +# return(funy * y * dfun(y)) } +# +# if(is.null(low)) low <- -Inf +# if(is.null(upp)) upp <- Inf +# +# Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile, +# upperTruncQuantile, IQR.fac) +# low <- if(Ib["low"]<=0) -Inf else log(Ib["low"]) +# upp <- log(Ib["upp"]) +# +# return(do.call(distrExIntegrate, c(list(f = integrand, +# lower = low, +# upper = upp, +# rel.tol = rel.tol, +# distr = object, dfun = d(object)), dots.withoutUseApply))) +# +# }) - dots <- list(...) - dots.withoutUseApply <- dots - useApply <- TRUE - if(!is.null(dots$useApply)) useApply <- dots$useApply - dots.withoutUseApply$useApply <- NULL - integrand <- function(x, dfun, ...){ di <- dim(x) - y <- exp(x) - if(useApply){ - funy <- sapply(y,fun, ...) - dim(y) <- di - dim(funy) <- di - }else funy <- fun(y,...) - return(funy * y * dfun(y)) } - if(is.null(low)) low <- -Inf - if(is.null(upp)) upp <- Inf - - Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile, - upperTruncQuantile, IQR.fac) - low <- if(Ib["low"]<=0) -Inf else log(Ib["low"]) - upp <- log(Ib["upp"]) - - return(do.call(distrExIntegrate, c(list(f = integrand, - lower = low, - upper = upp, - rel.tol = rel.tol, - distr = object, dfun = d(object)), dots.withoutUseApply))) - - }) - - -setMethod("E", signature(object = "Geom", - fun = "missing", +setMethod("E", signature(object = "Geom", + fun = "missing", cond = "missing"), function(object, low = NULL, upp = NULL, ...){ if(!is.null(low)) if(low <= min(support(object))) low <- NULL Added: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R (rev 0) +++ branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-05 15:46:35 UTC (rev 1241) @@ -0,0 +1,100 @@ +## taken from RobExtremes (slightly modified) as of version 2.8.0 + +.qtlIntegrate <- function(object, fun, low = NULL, upp = NULL, + rel.tol= getdistrExOption("ErelativeTolerance"), + lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), + upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ..., + .withLeftTail = FALSE, .withRightTail = FALSE + ){ + + dots <- list(...) + dots.withoutUseApply <- dots + useApply <- TRUE + if(!is.null(dots$useApply)) useApply <- dots$useApply + + dots.withoutUseApply$useApply <- NULL + dots.withoutUseApply$stop.on.error <- NULL + + integrand <- function(x, dfun, ...){ di <- dim(x) + y <- q.l(object)(x)##quantile transformation + if(useApply){ + funy <- sapply(y,fun, ...) + dim(y) <- di + dim(funy) <- di + }else funy <- fun(y,...) + return(funy) } + + if(is.null(low)) low <- -Inf + if(is.null(upp)) upp <- Inf + + Ib <- .getIntbounds(object, low, upp, lowerTruncQuantile, + upperTruncQuantile, IQR.fac) + low <- p(object)(Ib["low"]) + upp <- p(object)(Ib["upp"]) + if(is.nan(low)) low <- 0 + if(is.nan(upp)) upp <- 1 + + intV.l <- intV.u <- 0 + low.m <- low + upp.m <- upp + + if(.withRightTail){ + upp.m <- min(upp,0.98) + if(upp>0.98){ + intV.u <- do.call(distrExIntegrate, c(list(f = integrand, + lower = 0.98, + upper = upp, + rel.tol = rel.tol, stop.on.error = FALSE, + distr = object, dfun = dunif), dots.withoutUseApply)) + } + } + if(.withLeftTail){ + low.m <- max(low,0.02) + if(low<0.02){ + intV.l <- do.call(distrExIntegrate, c(list(f = integrand, + lower = low, + upper = 0.02, + rel.tol = rel.tol, stop.on.error = FALSE, + distr = object, dfun = dunif), dots.withoutUseApply)) + } + } + intV.m <- do.call(distrExIntegrate, c(list(f = integrand, + lower = low.m, + upper = upp.m, + rel.tol = rel.tol, stop.on.error = FALSE, + distr = object, dfun = dunif), dots.withoutUseApply)) + + int <- intV.l+intV.m+intV.u + + return(int) + + } + +setMethod("E", signature(object = "Weibull", fun = "function", cond = "missing"), + function(object, fun, low = NULL, upp = NULL, + rel.tol= getdistrExOption("ErelativeTolerance"), + lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), + upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ... + ){ + .qtlIntegrate(object = object, fun = fun, low = low, upp = upp, + rel.tol= rel.tol, lowerTruncQuantile = lowerTruncQuantile, + upperTruncQuantile = upperTruncQuantile, + IQR.fac = IQR.fac, ..., + .withLeftTail = FALSE, .withRightTail = TRUE) + }) + +setMethod("E", signature(object = "Gammad", fun = "function", cond = "missing"), + function(object, fun, low = NULL, upp = NULL, + rel.tol= getdistrExOption("ErelativeTolerance"), + lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), + upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ... + ){ + .qtlIntegrate(object = object, fun = fun, low = low, upp = upp, + rel.tol= rel.tol, lowerTruncQuantile = lowerTruncQuantile, + upperTruncQuantile = upperTruncQuantile, + IQR.fac = IQR.fac, ..., + .withLeftTail = TRUE, .withRightTail = TRUE) + }) Modified: branches/distr-2.8/pkg/distrEx/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-04 14:01:53 UTC (rev 1240) +++ branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-05 15:46:35 UTC (rev 1241) @@ -14,6 +14,15 @@ user-visible CHANGES: + DESCRIPTION tag SVNRevision changed to VCS/SVNRevision +under the hood: ++ moved quantile integration methods for expectation for Weibull and + Gamma distribution from pkg RobExtremes to distrEx ++ introduce exported helper function .qtlIntegrate to achieve this + (is reused in RobExtremes for the GEV methods there) ++ cleaned .Rd file E.Rd: It contained still some references to methods + for extreme value distributions which are now in RobExtremes + and some old mail reference peter.ruckdeschel at uni-bayreuth.de + ############## v 2.7 ############## Modified: branches/distr-2.8/pkg/distrEx/man/E.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-04 14:01:53 UTC (rev 1240) +++ branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-05 15:46:35 UTC (rev 1241) @@ -44,23 +44,25 @@ \alias{E,Exp,missing,missing-method} \alias{E,Fd,missing,missing-method} \alias{E,Gammad,missing,missing-method} -\alias{E,Gammad,function,missing-method} \alias{E,Geom,missing,missing-method} \alias{E,Gumbel,missing,missing-method} -\alias{E,GPareto,missing,missing-method} -\alias{E,GPareto,function,missing-method} -\alias{E,GEV,missing,missing-method} -\alias{E,GEV,function,missing-method} +%\alias{E,GPareto,missing,missing-method} +%\alias{E,GPareto,function,missing-method} +%\alias{E,GEV,missing,missing-method} +%\alias{E,GEV,function,missing-method} \alias{E,Hyper,missing,missing-method} \alias{E,Logis,missing,missing-method} \alias{E,Lnorm,missing,missing-method} \alias{E,Nbinom,missing,missing-method} \alias{E,Norm,missing,missing-method} -\alias{E,Pareto,missing,missing-method} +%\alias{E,Pareto,missing,missing-method} \alias{E,Pois,missing,missing-method} \alias{E,Td,missing,missing-method} \alias{E,Unif,missing,missing-method} \alias{E,Weibull,missing,missing-method} +\alias{E,Gammad,function,missing-method} +\alias{E,Weibull,function,missing-method} +\alias{.qtlIntegrate} \title{Generic Function for the Computation of (Conditional) Expectations} \description{ @@ -202,26 +204,36 @@ rel.tol = getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = getdistrExOption("IQR.fac"), ...) + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...) \S4method{E}{Geom,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Gumbel,missing,missing}(object, low = NULL, upp = NULL, ...) -\S4method{E}{GPareto,missing,missing}(object, low = NULL, upp = NULL, ...) -\S4method{E}{GPareto,function,missing}(object, fun, low = NULL, upp = NULL, - rel.tol = getdistrExOption("ErelativeTolerance"), - lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), - upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = max(10000, getdistrExOption("IQR.fac")), ...) +%\S4method{E}{GPareto,missing,missing}(object, low = NULL, upp = NULL, ...) +%\S4method{E}{GPareto,function,missing}(object, fun, low = NULL, upp = NULL, +% rel.tol = getdistrExOption("ErelativeTolerance"), +% lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), +% upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), +% IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...) \S4method{E}{Hyper,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Logis,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Lnorm,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Nbinom,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Norm,missing,missing}(object, low = NULL, upp = NULL, ...) -\S4method{E}{Pareto,missing,missing}(object, low = NULL, upp = NULL, ...) +%\S4method{E}{Pareto,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Pois,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Unif,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Td,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Weibull,missing,missing}(object, low = NULL, upp = NULL, ...) - +\S4method{E}{Weibull,function,missing}(object, fun, low = NULL, upp = NULL, + rel.tol = getdistrExOption("ErelativeTolerance"), + lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), + upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...) +.qtlIntegrate(object, fun, low = NULL, upp = NULL, + rel.tol= getdistrExOption("ErelativeTolerance"), + lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), + upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ..., + .withLeftTail = FALSE, .withRightTail = FALSE) } \arguments{ \item{object}{ object of class \code{"Distribution"}} @@ -241,6 +253,10 @@ \item{useApply}{ logical: should \code{sapply}, respectively \code{apply} be used to evaluate \code{fun}. } \item{withCond}{ logical: is \code{cond} in the argument list of \code{fun}. } + \item{.withLeftTail}{ logical: should left tail (falling into quantile range [0,0.02]) + be computed separately to enhance accuracy? } + \item{.withRightTail}{ logical: should right tail (falling into quantile range [0.98,1]) + be computed separately to enhance accuracy? } } \details{The precision of the computations can be controlled via certain global options; cf. \code{\link{distrExOptions}}. @@ -249,8 +265,16 @@ \code{fun} or \code{cond}. Also the result, when arguments \code{low} or \code{upp} is given, is the \emph{unconditional value} of the expectation; no conditioning with respect to \code{low <= object <= upp} - is done.} + is done. + For the Gamma and Weibull distribution for integration with missing argument + \code{cond} but given argument \code{fun}, we use integration on [0,1] + (i.e, via the respective probability transformation). This done via helper + function \code{.qtlIntegrate}, where both arguments \code{.withLeftTail} + and \code{.withRightTail} are \code{TRUE} for the Gamma distribution, + and only \code{.withRightTail} ist \code{TRUE} for the Weibull distribution. + } + \value{ The (conditional) expectation is computed. } @@ -401,15 +425,16 @@ \item{object = "Gammad", fun = "missing", cond = "missing":}{ exact evaluation using explicit expressions.} \item{object = "Gammad", fun = "function", cond = "missing":}{ - use substitution method (y := log(x)) for numerical integration.} + use integration over the quantile range for numerical integration + via helper function \code{.qtlIntegrate}.} \item{object = "Geom", fun = "missing", cond = "missing":}{ exact evaluation using explicit expressions.} \item{object = "Gumbel", fun = "missing", cond = "missing":}{ exact evaluation using explicit expressions.} - \item{object = "GPareto", fun = "missing", cond = "missing":}{ - exact evaluation using explicit expressions.} - \item{object = "GPareto", fun = "function", cond = "missing":}{ - use substitution method (y := log(x)) for numerical integration.} +% \item{object = "GPareto", fun = "missing", cond = "missing":}{ +% exact evaluation using explicit expressions.} +% \item{object = "GPareto", fun = "function", cond = "missing":}{ +% use substitution method (y := log(x)) for numerical integration.} \item{object = "Hyper", fun = "missing", cond = "missing":}{ exact evaluation using explicit expressions.} \item{object = "Logis", fun = "missing", cond = "missing":}{ @@ -420,8 +445,8 @@ exact evaluation using explicit expressions.} \item{object = "Norm", fun = "missing", cond = "missing":}{ exact evaluation using explicit expressions.} - \item{object = "Pareto", fun = "missing", cond = "missing":}{ - exact evaluation using explicit expressions.} +% \item{object = "Pareto", fun = "missing", cond = "missing":}{ +% exact evaluation using explicit expressions.} \item{object = "Pois", fun = "missing", cond = "missing":}{ exact evaluation using explicit expressions.} \item{object = "Unif", fun = "missing", cond = "missing":}{ @@ -430,9 +455,12 @@ exact evaluation using explicit expressions.} \item{object = "Weibull", fun = "missing", cond = "missing":}{ exact evaluation using explicit expressions.} + \item{object = "Weibull", fun = "function", cond = "missing":}{ + use integration over the quantile range for numerical integration + via helper function \code{.qtlIntegrate}.} }} %\references{ ~put references to the literature/web site here ~ } -\author{Matthias Kohl \email{Matthias.Kohl at stamats.de} and Peter Ruckdeschel \email{peter.ruckdeschel at uni-bayreuth.de}} +\author{Matthias Kohl \email{Matthias.Kohl at stamats.de} and Peter Ruckdeschel \email{peter.ruckdeschel at uni-oldenburg.de}} %\note{ ~~further notes~~ } \seealso{\code{\link{distrExIntegrate}}, \code{\link{m1df}}, \code{\link{m2df}}, \code{\link[distr]{Distribution-class}}} From noreply at r-forge.r-project.org Sun Aug 5 17:52:19 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 5 Aug 2018 17:52:19 +0200 (CEST) Subject: [Distr-commits] r1242 - branches/distr-2.8/pkg/distrEx/R Message-ID: <20180805155219.3E65418A313@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-05 17:52:18 +0200 (Sun, 05 Aug 2018) New Revision: 1242 Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R Log: [distrEx] branch 2.8: yet another minor clitch in .qtlIntegrate Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-05 15:46:35 UTC (rev 1241) +++ branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-05 15:52:18 UTC (rev 1242) @@ -43,7 +43,7 @@ upp.m <- min(upp,0.98) if(upp>0.98){ intV.u <- do.call(distrExIntegrate, c(list(f = integrand, - lower = 0.98, + lower = max(0.98,low), upper = upp, rel.tol = rel.tol, stop.on.error = FALSE, distr = object, dfun = dunif), dots.withoutUseApply)) @@ -54,7 +54,7 @@ if(low<0.02){ intV.l <- do.call(distrExIntegrate, c(list(f = integrand, lower = low, - upper = 0.02, + upper = min(0.02, upp), rel.tol = rel.tol, stop.on.error = FALSE, distr = object, dfun = dunif), dots.withoutUseApply)) } From noreply at r-forge.r-project.org Sun Aug 5 17:55:36 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 5 Aug 2018 17:55:36 +0200 (CEST) Subject: [Distr-commits] r1243 - in branches/distr-2.8/pkg/distrMod: . R inst man Message-ID: <20180805155536.8AA5318A2B7@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-05 17:55:36 +0200 (Sun, 05 Aug 2018) New Revision: 1243 Added: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE branches/distr-2.8/pkg/distrMod/R/0distrModUtils.R branches/distr-2.8/pkg/distrMod/R/MCEstimator.R branches/distr-2.8/pkg/distrMod/R/MDEstimator.R branches/distr-2.8/pkg/distrMod/R/MLEstimator.R branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd branches/distr-2.8/pkg/distrMod/man/internals.Rd Log: [distrMod] branch 2.8: + distinguish two cases for CvMMDEstimator: mu = emp. cdf (default) and mu = current best fit model distribution (controlled by argument muDatOrMod = c("Dat","Mod")) => consistency between estimate and asyCov + added some theory/references to help file to MD estimators bug fixes + discovered some issues with local variables in L2Families (global values were used instead...) + default for asCov of CvMMDEstimator was inconsistent: the estimator was using emp.cdf, but the asyCov was using mu the current best fit model distribution + in the wrappers to MDEstimator: CvMMDEstimator, KolmogorovMDEstimator, TotalVarMDEstimator, HellingerMDEstimator, we had the "wrong" call in slot estimate.call + in the last commit, forgot to change param to param.0 when calling L2ParamFamily in SimpleL2ParamFamilies.R (when res <- L2ParamFamily(....)) + in the last commit, mixed prob.0 and prob.1 in line 33 under the hood + replaced integration for AbscontDistribution(s) in .CvMMDCovariance by integration on quantile scale => CvMMDEstimator now works with variances even for Gamma distributions for shape < 1 ... + .process.meCalcRes gains arg "x" to be able to pass on emp.CDF for mu in CvMMDEstimator if arg asvar.fct of MCEstimator has "x" in formals the observations x are passed on to asvar.fct, otherwise they are not; correspondingly "x" is passed on to .process.meCalcRes in MCEstimator(), MDEstimator(), MLEstimator(). + old .CvMMDCovariance() becomes .oldCvMMDCovariance + new wrapper .CvMMDCovarianceWithMux which uses emp cdf as mu + new wrappe CvMDist2 which by default uses model distribution as mu + CvMMDEstimator gains argument muDatOrMod = c("Dat","Mod") to distinguish two cases + moved code to .[old]CvMMDCovariance from 0distrModUtils.R to new file asCvMVarianceQtl.R Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-05 15:52:18 UTC (rev 1242) +++ branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-05 15:55:36 UTC (rev 1243) @@ -94,4 +94,5 @@ export("L2LocationUnknownScaleFamily", "L2ScaleUnknownLocationFamily") export("meRes", "get.criterion.fct") export("addAlphTrsp2col") -export(".deleteDim",".isUnitMatrix",".CvMMDCovariance") +export(".deleteDim",".isUnitMatrix", + ".CvMMDCovariance", ".oldCvMMDCovariance", ".CvMMDCovarianceWithMux") Modified: branches/distr-2.8/pkg/distrMod/R/0distrModUtils.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/0distrModUtils.R 2018-08-05 15:52:18 UTC (rev 1242) +++ branches/distr-2.8/pkg/distrMod/R/0distrModUtils.R 2018-08-05 15:55:36 UTC (rev 1243) @@ -90,318 +90,6 @@ } -.CvMMDCovariance<- function(L2Fam, param, mu = distribution(L2Fam), - withplot = FALSE, withpreIC = FALSE, - N = getdistrOption("DefaultNrGridPoints")+1, - rel.tol=.Machine$double.eps^0.3, - TruncQuantile = getdistrOption("TruncQuantile"), - IQR.fac = 15, - ...){ - - # preparations: - - N1 <- 2*N+1 - odd <- (1:N1)%%2==1 - - param0 <- L2Fam at param - dim0 <- dimension(param0) -# print(param0) - paramP <- param0 - paramP at main <- main(param) - paramP at trafo <- diag(dim0) -# print(paramP) - L2Fam <- modifyModel(L2Fam, paramP) - -# print(L2deriv(L2Fam)[[1]]@Map) - distr <- L2Fam at distribution - - ### get a sensible integration range: - low0 <- q.l(distr)(TruncQuantile) - up0 <- q.l(distr)(TruncQuantile, lower.tail = FALSE) - m0 <- median(distr); s0 <- IQR(distr) - low1 <- m0 - IQR.fac * s0 - up1 <- m0 + IQR.fac * s0 - low <- max(low0,low1); up <- min(up0,up1) - - ### get a sensible integration range: - if(missing(mu)) mu <- distr - low0.mu <- q.l(mu)(TruncQuantile) - up0.mu <- q.l(mu)(TruncQuantile, lower.tail = FALSE) - m0.mu <- median(mu); s0.mu <- IQR(mu) - low1.mu <- m0.mu - IQR.fac * s0.mu - up1.mu <- m0.mu + IQR.fac * s0.mu - low.mu <- max(low0.mu,low1.mu); up.mu <- min(up0.mu,up1.mu) - - - if(is(distr,"DiscreteDistribution")) - x.seq <-support(distr) - else - {if(is(distr,"AbscontDistribution")){ - x.seq0 <- seq(low, up, length = N1) - h0 <- diff(x.seq0[2:1]) - x.seq <- x.seq0[odd] - }else{ - x.seq <- seq(low,up, length = N) - } - } - if(is(mu,"DiscreteDistribution")) - x.mu.seq <- support(mu) - else - {if(is(mu,"AbscontDistribution")){ - x.mu.seq0 <- seq(low.mu, up.mu, length = N1) - h0.mu <- diff(x.mu.seq0[2:1]) - x.mu.seq <- x.mu.seq0[odd] - }else{ - x.mu.seq <- seq(low.mu, up.mu, length = N) - } - } - - L2deriv <- L2deriv(L2Fam)[[1]] -# y.seq <- sapply(x.seq, function(x) evalRandVar(L2deriv, x)) -# plot(x.seq[!is.na(y.seq)],y.seq ,type="l") - - ## are we working with a one-dim L2deriv or not? - - onedim <- (length(L2deriv at Map)==1) - - - if(onedim){ - ## one-dim case - - ## Delta, formula (56), p. 133 [Ri:94] - ## Ptheta- primitive function for Lambda - - if(is(distr,"AbscontDistribution")){ - Delta0x <- sapply(x.seq0, function(x) - evalRandVar(L2deriv, x)) * - d(distr)(x.seq0) - Delta0 <- h0*.csimpsum(Delta0x) - }else{ - L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv, x) - Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) L2x(x,y=Y) - return(E(object=distr, fun = fct))}) - } - # print(Delta0) - Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) - if(is(distr,"DiscreteDistribution")) - Delta <- function(x) Delta1(x) * (x %in% support(distr)) - else Delta <- function(x) Delta1(x) - # print(Delta(x.seq)) - # print(Delta(rnorm(100))) - - ## J = Var_Ptheta Delta - J1 <- E(object=distr, fun = Delta) -# print(J1) - Delta.0 <- function(x) Delta(x) - J1 - # print(Delta.0(x.seq)) - # print(Delta.0(r(distr)(100))^2) - #J <- distrExIntegrate(function(x) d(distr)(x)*Delta.0(x)^2, lower=low, upper=up) - J <- E(object=distr, fun = function(x) Delta.0(x)^2 ) -# print(J) - - ### CvM-IC phi - phi <- function(x) Delta.0(x)/J - - ## integrand phi x Ptheta in formula (51) [ibid] - phi1 <- function(x) phi(x) * p(distr)(x) - psi1 <- E(object = mu, fun = phi1) - - - ## obtaining IC psi (formula (51)) - - if(is(mu,"AbscontDistribution")){ - phix <- function(x) phi(x)*d(mu)(x) - psi0x <- sapply(rev(x.mu.seq0), phix) - psi0 <- h0.mu*rev(.csimpsum(psi0x)) - }else{ - phixy <- function(x,y) (x<=y)*phi(y) - psi0 <- sapply(x.mu.seq, function(X){ fct <- function(y) phixy(x=X,y=y) - return(E(object=mu, fun = fct))}) - } - # print(psi0) - psi.1 <- approxfun(x.mu.seq, psi0, yleft = 0, yright = rev(psi0)[1]) - if(is(distr,"DiscreteDistribution")) - psi <- function(x) (psi.1(x)-psi1) * (x %in% support(mu)) - else psi <- function(x) psi.1(x)-psi1 - - E2 <- E(object=distr, fun = function(x) psi(x)^2) - L2deriv <- L2Fam at L2deriv[[1]] - ## E2 = Cov_mu (psi) - -# ### control: centering & standardization - E1 <- E(object=distr, fun = psi ) - E3 <- E(object=distr, fun = function(x) psi(x)*evalRandVar(L2deriv, x)) - psi.0 <- function(x) psi(x) - E1 - psi.01 <- function(x) psi.0(x)/E3 - if(withplot) - { dev.new() #windows() - plot(x.seq, psi.01(x.seq), - type = if(is(distr,"DiscreteDistribution")) "p" else "l") - } - E4 <- E(object=distr, fun = function(x) psi.01(x)^2) - psi.01 <- EuclRandVariable(Map = list(psi.01), Domain = Reals()) - -# print(list(E2,E4,E2-E4)) - - }else{ - - ## multivariate case - - Dim <- length(evalRandVar(L2deriv, 1)) - - ## Delta, formula (56), p. 133 [Ri:94] - ## Ptheta- primitive function for Lambda - - Map.Delta <- vector("list",Dim) - # print("HLL") - # print(x.seq0) - for(i in 1:Dim) - { if(is(distr,"AbscontDistribution")){ - #print(L2deriv at Map[[i]]) - fct0 <- sapply(x.seq0, L2deriv at Map[[i]]) * - d(distr)(x.seq0) - #print(fct0) - Delta0 <- h0*.csimpsum(fct0) - }else{ - fct0 <- function(x,y) L2deriv at Map[[i]](x)*(x<=y) - Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) fct0(x,y=Y) - return(E(object=distr, fun = fct))}) - } - #print(Delta0) - Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) - if(is(distr,"DiscreteDistribution")) - Delta <- function(x) Delta1(x) * (x %in% support(distr)) - else Delta <- function(x) Delta1(x) - Map.Delta[[i]] <- Delta - env.i <- environment(Map.Delta[[i]]) <- new.env() - assign("i", i, envir=env.i) - assign("fct", fct, envir=env.i) - assign("fct0", fct0, envir=env.i) - assign("Delta", Delta, envir=env.i) - assign("Delta0", Delta0, envir=env.i) - assign("Delta1", Delta1, envir=env.i) - if(withplot){ - dev.new() - #windows() - plot(x.seq, sapply(x.seq,Map.Delta[[i]]), - type = if(is(distr,"DiscreteDistribution")) "p" else "l") - } - - } - Delta <- EuclRandVariable(Map = Map.Delta, Domain = Reals()) - - - - ## J = Var_Ptheta Delta - J1 <- E(object=distr, fun = Delta) - Delta.0 <- Delta - J1 - J <- E(object=distr, fun = Delta.0 %*%t(Delta.0)) - ### CvM-IC phi - phi <- as(solve(J)%*%Delta.0,"EuclRandVariable") - - ## integrand phi x Ptheta in formula (51) [ibid] - - Map.phi1 <- vector("list",Dim) - for(i in 1:Dim) - { Map.phi1[[i]] <- function(x) evalRandVar(phi,x)[i] * p(distr)(x) - env.i <- environment(Map.phi1[[i]]) <- new.env() - assign("i", i, envir=env.i) - } - - phi1 <- EuclRandVariable(Map = Map.phi1, Domain = Reals()) - psi1 <- E(object=mu, fun = phi1) - - - ## obtaining IC psi (formula (51)) - Map.psi <- vector("list",Dim) - for(i in 1:Dim) - { if(is(mu,"AbscontDistribution")){ - fct01 <- function(x) phi at Map[[i]](x)*d(mu)(x) - fct0 <- sapply(rev(x.mu.seq0),fct01) - phi0 <- h0.mu*rev(.csimpsum(fct0)) - }else{ - fct01 <- NULL - fct0 <- function(x,y) evalRandVar(phi, y)[i]*(x<=y) - phi0 <- sapply(x.mu.seq, - function(X){ - fct <- function(y) fct0(x = X, y) - return(E(object = mu, fun = fct)) - }) - } - - phi0a <- approxfun(x.mu.seq, phi0, yleft = 0, yright = rev(phi0)[1]) - env.i <- environment(phi1) <- new.env() - assign("i", i, envir=env.i) - if(is(distr,"DiscreteDistribution")) - psi0 <- function(x) phi0a(x) * (x %in% support(mu)) - else psi0 <- function(x) phi0a(x) - - Map.psi[[i]] <- psi0 - env.i <- environment(Map.psi[[i]]) <- new.env() - assign("i", i, envir=env.i) - assign("fct", fct, envir=env.i) - assign("fct0", fct0, envir=env.i) - assign("psi0", psi0, envir=env.i) - assign("phi0a", phi0a, envir=env.i) - assign("phi0", phi0, envir=env.i) - } - psi <- EuclRandVariable(Map = Map.psi, Domain = Reals()) - - E2 <- E(object=distr, fun = psi %*%t(psi)) - ## E2 = Cov_mu (psi) - - ### control: centering & standardization - L2deriv <- L2Fam at L2deriv[[1]] - E1 <- E(object=distr, fun = psi ) - E3 <- E(object=distr, fun = psi %*%t(L2deriv)) - psi.0 <- psi - E1 - psi.01 <- as(solve(E3)%*%psi.0,"EuclRandVariable") - if(withplot) - { for(i in 1:Dim) - { dev.new() - plot(x.mu.seq, sapply(x.mu.seq,psi.01 at Map[[i]]), - type = if(is(distr,"DiscreteDistribution")) "p" else "l") - }} - E4 <- E(object=distr, fun = psi.01 %*%t(psi.01)) - } - E4 <- PosSemDefSymmMatrix(E4) - - psi <- EuclRandVarList(psi.01) - nms <- names(c(main(param(L2Fam)),nuisance(param(L2Fam)))) - dimnames(E4) = list(nms,nms) - if(withpreIC) return(list(preIC=psi, Var=E4)) - else return(E4) -} - -### examples: -if(FALSE){ -P0 <- PoisFamily();.CvMMDCovariance(P0,par=ParamFamParameter("lambda",1), withplot=TRUE) -B0 <- BinomFamily(size=8, prob=0.3);.CvMMDCovariance(B0,par=ParamFamParameter("",.3), withplot=TRUE) -N0 <- NormLocationFamily();.CvMMDCovariance(N0,par=ParamFamParameter("",0), withplot=TRUE, N = 200) -C0 <- L2LocationFamily(central=Cauchy());.CvMMDCovariance(C0,par=ParamFamParameter("",0), withplot=TRUE, N = 200) -N1 <- NormScaleFamily(); re=.CvMMDCovariance(N1,par=ParamFamParameter("",1), withICwithplot=TRUE, N = 200) -NS <- NormLocationScaleFamily();paramP <- ParamFamParameter(name = "locscale", main = c("loc"=0,"scale"=1),trafo = diag(2)); - .CvMMDCovariance(NS,par=paramP, withplot=TRUE, N = 100) -cls <- CauchyLocationScaleFamily();.CvMMDCovariance(cls,par=ParamFamParameter("",0:1), withplot=TRUE, N = 200) -Els <- L2LocationScaleFamily(loc = 0, scale = 1, - name = "Laplace Location and scale family", - centraldistribution = DExp(), - LogDeriv = function(x) sign(x), - FisherInfo = diag(2), - trafo = diag(2)) -.CvMMDCovariance(Els,par=ParamFamParameter("",0:1), withplot=TRUE, N = 100) - -system.time(print(.CvMMDCovariance(P0,par=ParamFamParameter("lambda",1)))) -system.time(print(.CvMMDCovariance(B0,par=ParamFamParameter("",.3)))) -system.time(print(.CvMMDCovariance(N0,par=ParamFamParameter("",0), N = 100))) -system.time(print(.CvMMDCovariance(C0,par=ParamFamParameter("",0), N = 100))) -system.time(print(.CvMMDCovariance(N1,par=ParamFamParameter("",1), N = 100))) -system.time(print(.CvMMDCovariance(NS,par=paramP, N = 100))) -system.time(print(.CvMMDCovariance(cls,par=ParamFamParameter("",0:1), N = 100))) -system.time(print(.CvMMDCovariance(Els,par=ParamFamParameter("",0:1), N = 100))) - -} - #------------------------------------ #### utilities copied from package distr v.2.6 svn-rev 943 #------------------------------------ Modified: branches/distr-2.8/pkg/distrMod/R/MCEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MCEstimator.R 2018-08-05 15:52:18 UTC (rev 1242) +++ branches/distr-2.8/pkg/distrMod/R/MCEstimator.R 2018-08-05 15:55:36 UTC (rev 1243) @@ -53,6 +53,7 @@ if(!is.null(asv)) argList <- c(argList, asvar.fct = asv) if(!is.null(dots)) argList <- c(argList, dots) + argList <- c(argList, x = x) ## digesting the results of mceCalc res <- do.call(.process.meCalcRes, argList) Modified: branches/distr-2.8/pkg/distrMod/R/MDEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-05 15:52:18 UTC (rev 1242) +++ branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-05 15:55:36 UTC (rev 1243) @@ -52,6 +52,7 @@ if(!is.null(dots)) argList <- c(argList, dots) if(!validity.check %in% names(argList)) argList$validity.check <- TRUE + argList <- c(argList, x = x) ## digesting the results of mceCalc res <- do.call(.process.meCalcRes, argList) @@ -60,16 +61,32 @@ return(.checkEstClassForParamFamily(ParamFamily,res)) } -CvMMDEstimator <- function(x, ParamFamily, paramDepDist = FALSE, +CvMMDEstimator <- function(x, ParamFamily, muDatOrMod = c("Dat","Mod"), + paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct = .CvMMDCovariance, na.rm = TRUE, ..., .withEvalAsVar = TRUE){ - MDEstimator(x = x, ParamFamily = ParamFamily, distance = CvMDist, + + muDatOrMod <- match.arg(muDatOrMod) + if(muDatOrMod=="Dat") { + distance0 <- CvMDist + estnsffx <- "(mu = emp. cdf)" + if(missing(asvar.fct)) asvar.fct <- .CvMMDCovarianceWithMux + }else{ + distance0 <- CvMDist2 + estnsffx <- "(mu = model distr.)" + if(missing(asvar.fct)) asvar.fct <- .CvMMDCovariance + } + + res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = distance0, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, ..., .withEvalAsVar = .withEvalAsVar) + res at name <- paste("Minimum CvM distance estimate", estnsffx) + res at estimate.call <- match.call() + return(res) } KolmogorovMDEstimator <- function(x, ParamFamily, paramDepDist = FALSE, @@ -77,11 +94,13 @@ trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., .withEvalAsVar = TRUE){ - MDEstimator(x = x, ParamFamily = ParamFamily, distance = KolmogorovDist, + res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = KolmogorovDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, ..., .withEvalAsVar = .withEvalAsVar) + res at estimate.call <- match.call() + return(res) } TotalVarMDEstimator <- function(x, ParamFamily, paramDepDist = FALSE, @@ -89,11 +108,13 @@ trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., .withEvalAsVar = TRUE){ - MDEstimator(x = x, ParamFamily = ParamFamily, distance = TotalVarDist, + res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = TotalVarDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, ..., .withEvalAsVar = .withEvalAsVar) + res at estimate.call <- match.call() + return(res) } HellingerMDEstimator <- function(x, ParamFamily, paramDepDist = FALSE, @@ -101,10 +122,12 @@ trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., .withEvalAsVar = TRUE){ - MDEstimator(x = x, ParamFamily = ParamFamily, distance = HellingerDist, + res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = HellingerDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, ..., .withEvalAsVar = .withEvalAsVar) + res at estimate.call <- match.call() + return(res) } Modified: branches/distr-2.8/pkg/distrMod/R/MLEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-05 15:52:18 UTC (rev 1242) +++ branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-05 15:55:36 UTC (rev 1243) @@ -48,6 +48,7 @@ if(!is.null(asv)) argList <- c(argList, asvar.fct = asv) if(!is.null(dots)) argList <- c(argList, dots) + argList <- c(argList, x = x) ## digesting the results of mceCalc res <- do.call(what = ".process.meCalcRes", args = argList) Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-05 15:52:18 UTC (rev 1242) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-05 15:55:36 UTC (rev 1243) @@ -30,7 +30,7 @@ prob.0 <- main(param) fct <- function(x){} body(fct) <- substitute({ (x-size*prob.1)/(prob.1*(1-prob.1)) }, - list(size = size, prob.0 = prob.1)) + list(size = size, prob.1 = prob.0)) return(fct)} L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = size*prob)) L2derivDistr <- UnivarDistrList((distribution - size*prob)/(prob*(1-prob))) @@ -45,7 +45,7 @@ FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, - distrSymm = distrSymm, param = param, modifyParam = modifyParam, + distrSymm = distrSymm, param = param.0, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, L2derivDistr = L2derivDistr, L2derivDistrSymm = L2derivDistrSymm, FisherInfo.fct = FisherInfo.fct, FisherInfo = FisherInfo, @@ -97,7 +97,7 @@ FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, - distrSymm = distrSymm, param = param, modifyParam = modifyParam, + distrSymm = distrSymm, param = param.0, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, L2derivDistr = L2derivDistr, L2derivDistrSymm = L2derivDistrSymm, FisherInfo.fct = FisherInfo.fct, FisherInfo = FisherInfo, @@ -155,7 +155,7 @@ FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, - distrSymm = distrSymm, param = param, modifyParam = modifyParam, + distrSymm = distrSymm, param = param.0, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, L2derivDistr = L2derivDistr, L2derivDistrSymm = L2derivDistrSymm, FisherInfo.fct = FisherInfo.fct, FisherInfo = FisherInfo, @@ -229,7 +229,7 @@ FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, - distrSymm = distrSymm, param = param, modifyParam = modifyParam, + distrSymm = distrSymm, param = param.0, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, L2derivDistr = L2derivDistr, L2derivDistrSymm = L2derivDistrSymm, FisherInfo.fct = FisherInfo.fct, FisherInfo = FisherInfo, @@ -318,7 +318,7 @@ FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, - distrSymm = distrSymm, param = param, modifyParam = modifyParam, + distrSymm = distrSymm, param = param.0, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, L2derivDistr = L2derivDistr, L2derivDistrSymm = L2derivDistrSymm, FisherInfo.fct = FisherInfo.fct, FisherInfo = FisherInfo, @@ -394,7 +394,7 @@ L2Fam at name <- name L2Fam at distribution <- distribution L2Fam at distrSymm <- distrSymm - L2Fam at param <- param + L2Fam at param <- param.0 L2Fam at modifyParam <- modifyParam L2Fam at props <- props L2Fam at L2deriv.fct <- L2deriv.fct @@ -406,7 +406,7 @@ L2Fam at startPar <- startPar L2Fam at makeOKPar <- makeOKPar L2Fam at scaleshapename <- c("scale"="scale","shape"="shape") - + L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param.0), Domain = Reals())) @@ -427,7 +427,6 @@ return(L2Fam) } -(G1 <- GammaFamily()) ################################################################## ## Beta family :: new 08/08 P.R. @@ -483,7 +482,7 @@ FisherInfo <- FisherInfo.fct(param.0) res <- L2ParamFamily(name = name, distribution = distribution, - distrSymm = distrSymm, param = param, modifyParam = modifyParam, + distrSymm = distrSymm, param = param.0, modifyParam = modifyParam, props = props, L2deriv.fct = L2deriv.fct, L2derivSymm = L2derivSymm, L2derivDistr = L2derivDistr, L2derivDistrSymm = L2derivDistrSymm, FisherInfo.fct = FisherInfo.fct, FisherInfo = FisherInfo, Added: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R (rev 0) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-05 15:55:36 UTC (rev 1243) @@ -0,0 +1,780 @@ +.CvMMDCovarianceWithMux <- function(L2Fam, param, withplot = FALSE, withpreIC = FALSE, + N = 400, rel.tol=.Machine$double.eps^0.3, + TruncQuantile = getdistrOption("TruncQuantile"), + IQR.fac = 15, ..., x=NULL){ + mu <- distribution(L2Fam) + if(!is.null(x)) mu <- DiscreteDistribution(x) + .CvMMDCovariance(L2Fam=L2Fam, param=param, mu=mu, + withplot = withplot, withpreIC = withpreIC, + N = N, rel.tol=rel.tol, TruncQuantile = TruncQuantile, + IQR.fac = IQR.fac, ...) +} + +CvMDist2 <- function(e1,e2,... ) CvMDist(e1, e2, mu = e2, ...) + +### 20180805: new function to compute asCov of CvM-MDE +# which for the primitive functions uses integration on [0,1] +# via quantile transformation +.CvMMDCovariance<- function(L2Fam, param, mu = distribution(L2Fam), + withplot = FALSE, withpreIC = FALSE, + N = 400, rel.tol=.Machine$double.eps^0.3, + TruncQuantile = getdistrOption("TruncQuantile"), + IQR.fac = 15, + ...){ + # preparations: + + dotsInt <- list(...) + dotsInt[["f"]] <- NULL + dotsInt[["lower"]] <- NULL + dotsInt[["upper"]] <- NULL + dotsInt[["stop.on.error"]] <- NULL + dotsInt[["distr"]] <- NULL + + N.1 <- round(0.2*N) + N.3 <- N.1 + N.2 <- N-N.1-N.3 + + N1 <- 2*N+1 + N1.1 <- 2*N.1+1 + N1.2 <- 2*N.2+1 + N1.3 <- 2*N.3+1 + odd <- (1:N1)%%2==1 + odd.1 <- (1:N1.1)%%2==1 + odd.2 <- (1:N1.2)%%2==1 + odd.3 <- (1:N1.3)%%2==1 + + param0 <- L2Fam at param + dim0 <- dimension(param0) + + paramP <- param0 + paramP at main <- main(param) + paramP at trafo <- diag(dim0) + L2Fam <- modifyModel(L2Fam, paramP) + + distr <- L2Fam at distribution + + ### get a sensible integration range: + low <- TruncQuantile + up <- 1-TruncQuantile + + + if(is(distr,"DiscreteDistribution")) + x.seq <-support(distr) + else + {if(is(distr,"AbscontDistribution")){ + + ## split up the integration range into + # .1 = lower tail, .2 mid range, .3 upper tail + + x.seq0 <- seq(0, 1, length = N1) + h0 <- diff(x.seq0[1:2]) + x.seq0.1 <- seq(0, 1, length = N1.1) + h0.1 <- diff(x.seq0.1[1:2]) + x.seq0.2 <- seq(0, 1, length = N1.2) + h0.2 <- diff(x.seq0.2[1:2]) + x.seq <- x.seq0[odd] + x.seq.1 <- low+(1-low)*x.seq0.1/100 + x.seq.3 <- 1-rev(x.seq.1) + x.seq.la <- rev(x.seq.1)[1] + del <- 1-2*(x.seq.la+(h0.1/100+h0.2)/2) + x.seq.2l <- x.seq.la+(h0.1/100+h0.2)/2+del*x.seq0.2 + x.seq.2r <- 1-rev(x.seq.2l) + x.seq.2 <- (x.seq.2l+x.seq.2r)/2 + x.seq.a <- c(x.seq.1[odd.1],x.seq.2[odd.2],x.seq.3[odd.3]) +# x.seq.b <- c(x.seq.1,x.seq.2,x.seq.3) +# iN.1 <- 1:N1.1 +# iN.2 <- N1.1+(1:N1.2) +# iN.3 <- N1.1+N1.2+(1:N1.3) +# riN.3 <- 1:N1.3 +# riN.2 <- N1.3+1:N1.2 +# riN.1 <- N1.3+N1.2+1:N1.1 + }else{ + x.seq <- seq(low,up, length = N) + } + } + if(is(mu,"DiscreteDistribution")) + x.mu.seq <- support(mu) + else + {if(is(mu,"AbscontDistribution")){ + x.mu.seq0 <- x.seq0 + h0.mu <- h0 + x.mu.seq <- x.seq + x.mu.seq.1 <- x.seq.1 + x.mu.seq.2 <- x.seq.2 + x.mu.seq.3 <- x.seq.3 + x.mu.seq.a <- x.seq.a +# x.mu.seq.b <- x.seq.b +# iN.mu.1 <- iN.1 +# iN.mu.2 <- iN.2 +# iN.mu.3 <- iN.3 +# riN.mu.1 <- riN.1 +# riN.mu.2 <- riN.2 +# riN.mu.3 <- riN.3 + }else{ + x.mu.seq <- seq(low, up, length = N) + } + } + + L2deriv.0 <- L2deriv(L2Fam)[[1]] +# y.seq <- sapply(x.seq, function(x) evalRandVar(L2deriv, x)) +# plot(x.seq[!is.na(y.seq)],y.seq ,type="l") + + ## are we working with a one-dim L2deriv or not? + + onedim <- (length(L2deriv.0 at Map)==1) + + + myint <- function(f,...){ + distrExIntegrate(f=f, lower=0, upper=1, + stop.on.error=FALSE, distr=Unif(), ...) + } + + if(onedim){ + ## one-dim case + + ## Delta, formula (56), p. 133 [Ri:94] + ## Ptheta- primitive function for Lambda + + if(is(distr,"AbscontDistribution")){ + fqx <- function(x){qx <- q.l(distr)(x) + return(sapply(qx,function(y)evalRandVar(L2deriv.0, y))) + } + #Delta0x <- sapply(x.seq.b,fqx) + #Delta0x.1 <- Delta0x[iN.1] + #Delta0x.2 <- Delta0x[iN.2] + #Delta0x.3 <- Delta0x[iN.3] + Delta0x.1 <- sapply(x.seq.1,fqx) + Delta0x.2 <- sapply(x.seq.2,fqx) + Delta0x.3 <- sapply(x.seq.3,fqx) + Delta0.1 <- h0/100*.csimpsum(Delta0x.1) + Delta0.2 <- rev(Delta0.1)[1]+h0*.csimpsum(Delta0x.2) + Delta0.3 <- rev(Delta0.2)[1]+h0/100*.csimpsum(Delta0x.3) + Delta0 <- c(Delta0.1,Delta0.2,Delta0.3) + Delta1.q <- approxfun(x.seq.a, Delta0, yleft = 0, yright = 0) + J1 <- do.call(myint, c(list(f=Delta1.q), dotsInt)) + Delta.0 <- function(x) Delta1.q(p(distr)(x))-J1 + J <- do.call(myint, c(list(f=function(x) (Delta1.q(x)-J1)^2),dotsInt)) + }else{ + L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) + Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) L2x(x,y=Y) + return(E(object=distr, fun = fct))}) + Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) + Delta <- Delta1 + if(is(distr,"DiscreteDistribution")) + Delta <- function(x) Delta1(x) * (x %in% support(distr)) + J1 <- E(object=distr, fun = Delta) + Delta.0 <- function(x) Delta(x) - J1 + J <- E(object=distr, fun = function(x) Delta.0(x)^2 ) + } + + ### CvM-IC phi + phi <- function(x) Delta.0(x)/J + + ## obtaining IC psi (formula (51)) + + if(is(mu,"AbscontDistribution")){ + ## integrand phi x Ptheta in formula (51) [ibid] + phi1.q <- function(s){qs <- q.l(mu)(s) + return(phi(qs)*p(distr)(qs)) } + psi1 <- do.call(myint, c(list(f=phi1.q),dotsInt)) + + phiqx <- function(x){qx <- q.l(mu)(x) + return(phi(qx))} + #psi0qx <- sapply(rev(x.mu.seq.b), phiqx) + #psi0qx.1 <- psi0qx[riN.mu.1] + #psi0qx.2 <- psi0qx[riN.mu.2] + #psi0qx.3 <- psi0qx[riN.mu.3] + psi0qx.1 <- sapply(rev(x.mu.seq.1), phiqx) + psi0qx.2 <- sapply(rev(x.mu.seq.2), phiqx) + psi0qx.3 <- sapply(rev(x.mu.seq.3), phiqx) + psi0q.3 <- h0.mu/100*rev(.csimpsum(psi0qx.3)) + psi0q.2 <- psi0q.3[1]+h0.mu*rev(.csimpsum(psi0qx.2)) + psi0q.1 <- psi0q.2[1]+h0.mu/100*rev(.csimpsum(psi0qx.1)) + + psi0q <- c(psi0q.1,psi0q.2,psi0q.3) + psi.q1 <- approxfun(x.mu.seq.a, psi0q, yleft = 0, yright = rev(psi0q)[1]) + psi <- function(x) psi.q1(p(mu)(x))-psi1 + }else{ + ## integrand phi x Ptheta in formula (51) [ibid] + phi1 <- function(x) phi(x) * p(distr)(x) + psi1 <- E(object = mu, fun = phi1) + + phixy <- function(x,y) (x<=y)*phi(y) + psi0 <- sapply(x.mu.seq, function(X){ fct <- function(y) phixy(x=X,y=y) + return(E(object=mu, fun = fct))}) + psi.1 <- approxfun(x.mu.seq, psi0, yleft = 0, yright = rev(psi0)[1]) + psi <- function(x) psi.1(x)-psi1 + if(is(distr,"DiscreteDistribution")) + psi <- function(x) (psi.1(x)-psi1) * (x %in% support(mu)) + } + # print(psi0) + if(is(distr,"AbscontDistribution")){ + psi.q <- function(x){qx <- q.l(distr)(x); return(psi(qx))} + E2 <- do.call(myint, c(list(f=function(x)psi.q(x)^2),dotsInt)) + E1 <- do.call(myint, c(list(f=psi.q),dotsInt)) + E3 <- do.call(myint, c(list(f=function(x){ + qx <- q.l(distr)(x) + L2qx <- sapply(qx,function(y) + evalRandVar(L2deriv.0, y)) + return(psi(qx)*L2qx) + }), dotsInt)) + psi.01 <- function(x) (psi(x)-E1)/E3 + E4 <- do.call(myint, c(list(f=function(x) (psi.q(x)-E1)^2/E3^2),dotsInt)) + }else{ + E2 <- E(object=distr, fun = function(x) psi(x)^2) + L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) + E1 <- E(object=distr, fun = psi ) + E3 <- E(object=distr, fun = function(x) psi(x)*evalRandVar(L2deriv.0, x)) + psi.0 <- function(x) psi(x) - E1 + psi.01 <- function(x) psi.0(x)/E3 + E4 <- E(object=distr, fun = function(x) psi.01(x)^2) + } + ## E2 = Cov_mu (psi) + +# ### control: centering & standardization + if(withplot) + { dev.new() #windows() + x0.seq <- x.seq + if(is(distr,"AbscontDistribution")) x0.seq <- q.l(distr)(x.seq) + plot(x0.seq, psi.01(x0.seq), + type = if(is(distr,"DiscreteDistribution")) "p" else "l") + } + psi.01 <- EuclRandVariable(Map = list(psi.01), Domain = Reals()) + + + }else{ + + ## multivariate case + + Dim <- length(evalRandVar(L2deriv.0, 1)) + + ## Delta, formula (56), p. 133 [Ri:94] + ## Ptheta- primitive function for Lambda + + Map.Delta <- vector("list",Dim) + + for(i in 1:Dim) + { if(is(distr,"AbscontDistribution")){ + #fct0.q <- sapply(x.seq.b, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) + #fct0.q1 <- fct0.q[iN.1] + #fct0.q2 <- fct0.q[iN.2] + #fct0.q3 <- fct0.q[iN.3] + fct0.q1 <- sapply(x.seq.1, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) + fct0.q2 <- sapply(x.seq.2, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) + fct0.q3 <- sapply(x.seq.3, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) + #print(fct0) + Delta0.q1 <- h0/100*.csimpsum(fct0.q1) + Delta0.q2 <- rev(Delta0.q1)[1]+h0*.csimpsum(fct0.q2) + Delta0.q3 <- rev(Delta0.q2)[1]+h0/100*.csimpsum(fct0.q3) + Delta0.q <- c(Delta0.q1,Delta0.q2,Delta0.q3) + Delta1.q <- approxfun(x.seq.a, Delta0.q, yleft = 0, yright = 0) + Delta <- function(x) Delta1.q(p(distr)(x)) + Map.Delta[[i]] <- Delta + env.i <- environment(Map.Delta[[i]]) <- new.env() [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/distr -r 1243 From noreply at r-forge.r-project.org Sun Aug 5 18:04:51 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 5 Aug 2018 18:04:51 +0200 (CEST) Subject: [Distr-commits] r1244 - branches/distr-2.8/pkg/distrMod/R Message-ID: <20180805160451.71D4F1880FB@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-05 18:04:51 +0200 (Sun, 05 Aug 2018) New Revision: 1244 Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R Log: [distrMod] branch 2.8 removed obsolote remark Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-05 15:55:36 UTC (rev 1243) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-05 16:04:51 UTC (rev 1244) @@ -743,14 +743,12 @@ .oldCvMMDCovariance(Nb,par=ParamFamParameter(main=c(size=2.3,prob=0.3)), withplot=TRUE, N = 100) .CvMMDCovariance(Nb,par=ParamFamParameter(main=c(size=2.3,prob=0.3)), withplot=TRUE, N = 100) -## even better results with special E() method for Gamma in pkg RobExtremes GF <- GammaFamily() .oldCvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=4.3)), withplot=TRUE, N = 100) .CvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=4.3)), withplot=TRUE, N = 100) .oldCvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=0.3)), withplot=TRUE, N = 100) .CvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=0.3)), withplot=TRUE, N = 100) - system.time(print(.oldCvMMDCovariance(P0,par=ParamFamParameter("lambda",1)))) system.time(print(.CvMMDCovariance(P0,par=ParamFamParameter("lambda",1)))) system.time(print(.oldCvMMDCovariance(B0,par=ParamFamParameter("",.3)))) From noreply at r-forge.r-project.org Sun Aug 5 22:56:37 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 5 Aug 2018 22:56:37 +0200 (CEST) Subject: [Distr-commits] r1245 - in branches/distr-2.8/pkg/distrMod: R inst man Message-ID: <20180805205637.CA4C418A324@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-05 22:56:37 +0200 (Sun, 05 Aug 2018) New Revision: 1245 Modified: branches/distr-2.8/pkg/distrMod/R/MCEstimator.R branches/distr-2.8/pkg/distrMod/R/MDEstimator.R branches/distr-2.8/pkg/distrMod/R/MLEstimator.R branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R branches/distr-2.8/pkg/distrMod/R/mleCalc-methods.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/MCEstimator.Rd branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd branches/distr-2.8/pkg/distrMod/man/MLEstimator.Rd branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd Log: [distrMod] branch 2.8 + some fiddeling with the names of MCEstimators: all functions MDEstimator, CvMMDEstimator, KolmogorovMDEstimator, TotalVarMDEstimator, HellingerMDEstimator, MLEstimator, MCEstimator gain an extra argument nmsffx for potential suffices to be appended to the estimator name. + in MDEstimator with Cramer von Mises distance in case * distance == CvMDist && !is.null(mu) -> "( mu = )" * distance == CvMDist && is.null(mu) -> "( mu = emp. cdf )" * distance == CvMDist2 -> "( mu = model distr. )" is appended to the default estimator name + similarly in wrapper CvMMDEstimator in case argument 'muDatOrMod' is matched to * muDatOrMod=="Dat" -> "( mu = emp. cdf )" * muDatOrMod=="Mod" -> "( mu = model distr. )" * muDatOrMod=="Other" -> "( mu = )" is appended to the default estimator name + based on this tag "( mu = ... )" later on, in pkg RobAStBase, a (conditional) coerce method produces the pIC of the MDE by means of .CvMMDCovariance[WithMux] Modified: branches/distr-2.8/pkg/distrMod/R/MCEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MCEstimator.R 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/R/MCEstimator.R 2018-08-05 20:56:37 UTC (rev 1245) @@ -4,7 +4,8 @@ MCEstimator <- function(x, ParamFamily, criterion, crit.name, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, - asvar.fct, na.rm = TRUE, ..., .withEvalAsVar = TRUE){ + asvar.fct, na.rm = TRUE, ..., .withEvalAsVar = TRUE, + nmsffx = ""){ ## preparation: getting the matched call es.call <- match.call() @@ -33,8 +34,8 @@ if(missing(crit.name)) crit.name <- "" argList <- c(argList, crit.name = crit.name) if(!is.null(dots)) argList <- c(argList, dots) +# print(argList) - ## call to mceCalc res0 <- do.call(mceCalc, argList) @@ -54,6 +55,7 @@ if(!is.null(asv)) argList <- c(argList, asvar.fct = asv) if(!is.null(dots)) argList <- c(argList, dots) argList <- c(argList, x = x) + if(any(nmsffx!="")) argList <- c(argList, nmsffx = nmsffx) ## digesting the results of mceCalc res <- do.call(.process.meCalcRes, argList) Modified: branches/distr-2.8/pkg/distrMod/R/MDEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-05 20:56:37 UTC (rev 1245) @@ -6,12 +6,14 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, - ..., .withEvalAsVar = TRUE){ + ..., .withEvalAsVar = TRUE, nmsffx = ""){ ## preparation: getting the matched call es.call <- match.call() dots <- match.call(expand.dots = FALSE)$"..." + distfc <- paste(substitute(distance)) + completecases <- complete.cases(x) if(na.rm) x <- na.omit(x) @@ -19,12 +21,35 @@ if(!is.numeric(x)) stop(gettext("'x' has to be a numeric vector")) if(is.null(startPar)) startPar <- startPar(ParamFamily)(x,...) - if(missing(dist.name)) - dist.name <- names(distance(x, ParamFamily at distribution)) + if(missing(dist.name)){ + dist.name0 <- names(distance(x, ParamFamily at distribution)) +# print(dist.name0) +# print(str(dist.name0)) + dist.name <- gsub("(.+distance).+","\\1", dist.name0) + nmsffx <- paste( + gsub(".+distance","",gsub("(.+distance) (.+)","\\2", dist.name0)), + nmsffx, collapse=" ") + if(distfc=="CvMDist2"){ + dist.name <- "CvM distance" + nmsffx <- paste("( mu = model distr. )",nmsffx, collapse=" ") + } + if(distfc=="CvMDist"&&is.null(dots$mu)){ + dist.name <- "CvM distance" + nmsffx <- paste("( mu = emp. cdf )",nmsffx, collapse=" ") + } + if(distfc=="CvMDist"&&!is.null(dots$mu)){ + muc <- paste(deparse((dots$mu))) + dots$mu <- eval(dots$mu) + dist.name <- "CvM distance" + nmsffx <- paste("( mu = ", muc, ")", nmsffx, collapse=" ") + } + } + if(paramDepDist) dots$thetaPar <-NULL - distanceFctWithoutVal <- function(e1,e2,check.validity=NULL,...) distance(e1,e2,...) + distanceFctWithoutVal <- function(e1,e2,check.validity=NULL,...) + distance(e1,e2,...) ## manipulation of the arg list to method mceCalc argList <- c(list(x = x, PFam = ParamFamily, criterion = distanceFctWithoutVal, startPar = startPar, penalty = penalty, @@ -53,6 +78,7 @@ if(!validity.check %in% names(argList)) argList$validity.check <- TRUE argList <- c(argList, x = x) + if(any(nmsffx!="")) argList <- c(argList, nmsffx = nmsffx) ## digesting the results of mceCalc res <- do.call(.process.meCalcRes, argList) @@ -61,22 +87,40 @@ return(.checkEstClassForParamFamily(ParamFamily,res)) } -CvMMDEstimator <- function(x, ParamFamily, muDatOrMod = c("Dat","Mod"), +CvMMDEstimator <- function(x, ParamFamily, muDatOrMod = c("Dat","Mod", "Other"), + mu = NULL, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct = .CvMMDCovariance, - na.rm = TRUE, ..., .withEvalAsVar = TRUE){ + na.rm = TRUE, ..., .withEvalAsVar = TRUE, + nmsffx = ""){ muDatOrMod <- match.arg(muDatOrMod) if(muDatOrMod=="Dat") { distance0 <- CvMDist - estnsffx <- "(mu = emp. cdf)" + estnsffx <- "( mu = emp. cdf )" if(missing(asvar.fct)) asvar.fct <- .CvMMDCovarianceWithMux }else{ - distance0 <- CvMDist2 - estnsffx <- "(mu = model distr.)" - if(missing(asvar.fct)) asvar.fct <- .CvMMDCovariance + if(muDatOrMod=="Mod") { + distance0 <- CvMDist2 + estnsffx <- "( mu = model distr. )" + if(missing(asvar.fct)) asvar.fct <- .CvMMDCovariance + }else{ + if(missing(mu)||is.null(mu)) + stop(gettextf("This choice of 'muDatOrMod' requires a non-null 'mu'")) + muc <- paste(deparse(substitute(mu))) + distance0 <- function(e1,e2,... ) CvMDist(e1, e2, mu = mu, ...) + estnsffx <- paste("( mu = ", muc, ")") + if(missing(asvar.fct)) + asvar.fct <- function(L2Fam, param, N = 400, rel.tol=.Machine$double.eps^0.3, + TruncQuantile = getdistrOption("TruncQuantile"), + IQR.fac = 15, ...){ + .CvMMDCovariance(L2Fam=L2Fam, param=param, mu=eval(mu), + withplot = FALSE, withpreIC = FALSE, + N = N, rel.tol=rel.tol, TruncQuantile = TruncQuantile, + IQR.fac = IQR.fac, ...)} + } } res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = distance0, @@ -84,7 +128,8 @@ trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, ..., .withEvalAsVar = .withEvalAsVar) - res at name <- paste("Minimum CvM distance estimate", estnsffx) +# print(list(estnsffx, nmsffx)) + res at name <- paste("Minimum CvM distance estimate", estnsffx, nmsffx, collapse="") res at estimate.call <- match.call() return(res) } @@ -93,12 +138,12 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., - .withEvalAsVar = TRUE){ + .withEvalAsVar = TRUE, nmsffx = ""){ res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = KolmogorovDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, - ..., .withEvalAsVar = .withEvalAsVar) + ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx) res at estimate.call <- match.call() return(res) } @@ -107,12 +152,12 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., - .withEvalAsVar = TRUE){ + .withEvalAsVar = TRUE, nmsffx = ""){ res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = TotalVarDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, - ..., .withEvalAsVar = .withEvalAsVar) + ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx) res at estimate.call <- match.call() return(res) } @@ -121,12 +166,12 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., - .withEvalAsVar = TRUE){ + .withEvalAsVar = TRUE, nmsffx = ""){ res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = HellingerDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, - ..., .withEvalAsVar = .withEvalAsVar) + ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx) res at estimate.call <- match.call() return(res) } Modified: branches/distr-2.8/pkg/distrMod/R/MLEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-05 20:56:37 UTC (rev 1245) @@ -8,7 +8,8 @@ Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, na.rm = TRUE, ..., .withEvalAsVar = TRUE, - dropZeroDensity = TRUE){ + dropZeroDensity = TRUE, + nmsffx = ""){ ## preparation: getting the matched call es.call <- match.call() @@ -49,6 +50,7 @@ if(!is.null(asv)) argList <- c(argList, asvar.fct = asv) if(!is.null(dots)) argList <- c(argList, dots) argList <- c(argList, x = x) + if(any(nmsffx!="")) argList <- c(argList, nmsffx = nmsffx) ## digesting the results of mceCalc res <- do.call(what = ".process.meCalcRes", args = argList) Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-05 20:56:37 UTC (rev 1245) @@ -10,7 +10,11 @@ IQR.fac = IQR.fac, ...) } -CvMDist2 <- function(e1,e2,... ) CvMDist(e1, e2, mu = e2, ...) +CvMDist2 <- function(e1,e2,... ) {res <- CvMDist(e1, e2, mu = e2, ...) + e2c <- paste(deparse(substitute(e2))) + if(length(e2c) == 1) + names(res) <- paste("CvM distance ( mu =", e2c,")") + return(res)} ### 20180805: new function to compute asCov of CvM-MDE # which for the primitive functions uses integration on [0,1] Modified: branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R 2018-08-05 20:56:37 UTC (rev 1245) @@ -24,7 +24,7 @@ ########################################################################## .process.meCalcRes <- function(res, PFam, trafo, res.name, call, asvar.fct, check.validity, ..., - .withEvalAsVar = TRUE, x = NULL){ + .withEvalAsVar = TRUE, x = NULL, nmsffx = ""){ lmx <- length(main(PFam)) lnx <- length(nuisance(PFam)) @@ -51,6 +51,7 @@ est.name <- if(crit.name=="") "Minimum criterion estimate" else paste("Minimum", crit.name, "estimate", sep = " ") + if(any(nmsffx != "")) est.name <- paste(est.name, nmsffx, collapse=" ") if(is.null(res$Infos)) Infos <- matrix(c(character(0),character(0)), ncol=2, dimnames=list(character(0), c("method", "message"))) @@ -99,12 +100,14 @@ if("x" %in% names(formals(asvar.fct))) asvarArgList <- c(asvarArgList, x=x) asvar.try <- try(do.call(asvar.fct, asvarArgList), silent = TRUE) +# print(asvar.try) as0 <- if(is(asvar.try,"try-error")) NULL else asvar.try return(as0) } asvar <- substitute(do.call(asfct, args=c(list(PFam0, param0, ...))), list(asfct=asvar.tfct, PFam0=PFam, param0=param)) } +# print(eval(asvar)) if(.withEvalAsVar) asvar <- eval(asvar) untransformed.estimate <- theta Modified: branches/distr-2.8/pkg/distrMod/R/mleCalc-methods.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/mleCalc-methods.R 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/R/mleCalc-methods.R 2018-08-05 20:56:37 UTC (rev 1245) @@ -114,7 +114,9 @@ # mceCalcDots1 <- match.call(call = sys.call(sys.parent(1)), # expand.dots = FALSE)$"..." - mceCalcDots <- match.call(expand.dots = FALSE)$"..." + mceCalcDots <- list(...) +# cat("------------\n");print(mceCalcDots);cat("------------\n"); + filterDots <- function(dots){ if(length(dots)){ dotsOptIz <- NULL @@ -155,14 +157,25 @@ if(length(dotsForCrit)==0) dotsForCrit <- NULL } dotsForOpt <- c(dotsOptIz,dotsForCrit[!names(dotsForCrit)%in% nOptProh]) - return(list(dotsForOpt=dotsForOpt, dotsCrit=dotsForCrit)) + return(list(dotsForOpt=dotsForOpt, dotsCrit=dotsForCrit, dotsOnlyOpt=dotsOptIz)) }else return(NULL) } dotsToPass <- do.call(filterDots, list(mceCalcDots)) +# print(dotsToPass) +# print(names(dotsToPass$dotsCrit)) allwarns <- character(0) fun <- function(theta, Data, ParamFamily, criterionF, ...){ vP <- TRUE + dotsfun <- list(...) + names(dotsfun) <- gsub("dotsForC\\.","",names(dotsfun)) +# cat(".....\n");print(dotsfun);cat(".....\n") +# cat("!!!!\n") +# print(names(dotsfun)) +# print(names(dotsToPass$dotsCrit)) +# cat("!!!!\n") + dotsForC0 <- dotsfun[names(dotsfun)%in%names(dotsToPass$dotsCrit)] +# print(dotsForC0) if(validity.check) vP <- validParameter(ParamFamily, theta) if(is.function(penalty)) penalty <- penalty(theta) if(!vP) {crit0 <- penalty; theta <- mO(theta) @@ -172,7 +185,8 @@ names(nuisance(ParamFamily))) else names(theta) <- names(main(ParamFamily)) distr.new <- try(ParamFamily at modifyParam(theta), silent = TRUE) - argList <- c(list(Data, distr.new), ... ) + argList <- list(Data, distr.new) + if(!is.null(dotsForC0)) argList <- c(argList, dotsForC0) if(withthetaPar) argList <- c(argList, list(thetaPar = theta)) if(is(distr.new,"try.error")){ crit0 <- penalty @@ -199,18 +213,26 @@ return(critP)} if(length(param(PFam)) == 1){ - optres <- do.call(optimize, c(list(f = fun, interval = startPar, Data = x, - ParamFamily = PFam, criterionF = criterion), - dotsToPass$dotsForOpt)) + argsOptimize <- list(f = fun, interval = startPar, Data = x, + ParamFamily = PFam, criterionF = criterion) + if(!is.null(dotsToPass$dotsOnlyOpt)) + argsOptimize <- c(argsOptimize, dotsToPass$dotsOnlyOpt) + if(!is.null(dotsToPass$dotsCrit)) + argsOptimize <- c(argsOptimize, dotsForC=dotsToPass$dotsCrit) + optres <- do.call(optimize, argsOptimize) theta <- optres$minimum names(theta) <- names(main(PFam)) crit <- optres$objective method <- "optimize" }else{ if(is(startPar,"Estimate")) startPar <- untransformed.estimate(startPar) - optres <- do.call(optim, c(list(par = startPar, fn = fun, Data = x, - ParamFamily = PFam, criterionF = criterion), - dotsToPass$dotsForOpt)) + argsOptim <- list(par = startPar, fn = fun, Data = x, + ParamFamily = PFam, criterionF = criterion) + if(!is.null(dotsToPass$dotsOnlyOpt)) + argsOptim <- c(argsOptim, dotsToPass$dotsOnlyOpt) + if(!is.null(dotsToPass$dotsCrit)) + argsOptim <- c(argsOptim, dotsForC=dotsToPass$dotsCrit) + optres <- do.call(optim, argsOptim) theta <- as.numeric(optres$par) names(theta) <- c(names(main(PFam)),names(nuisance(PFam))) method <- "optim" @@ -285,6 +307,11 @@ MCEstimator(x = x, ParamFamily = nF, criterion = negLoglikelihood2, fups="fu") +fo <- list(a="fu",c=list(b="e",3)) +refo <- MCEstimator(x = x, ParamFamily = nF, criterion = negLoglikelihood2, + fups=fo) +optimReturn(refo) + re2 <- MCEstimator(x = x, ParamFamily = nF, criterion = negLoglikelihood2, fups="fu", hessian = TRUE, fn="LU") re2 Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-05 20:56:37 UTC (rev 1245) @@ -27,8 +27,10 @@ + For diagnostic purposes, MCEstimate-class gains a slot optimReturn (of class "ANY" and filled by NULL by default) which is filled by the return value of the optimizer in "mceCalc" -- it has a corresponding accessor -+ distinguish two cases for CvMMDEstimator: mu = emp. cdf (default) and mu = current best fit model distribution - (controlled by argument muDatOrMod = c("Dat","Mod")) => consistency between estimate and asyCov ++ distinguish three cases for CvMMDEstimator selected by argument muDatOrMod = c("Dat","Mod", "Other"): + in case "Dat", mu = emp. cdf (default), in case "Mod", mu = current best fit model distribution, + and in case "Other" one has to supply an integration probability mu. + => consistency between estimate and asyCov + added some theory/references to help file to MD estimators bug fixes @@ -59,7 +61,23 @@ + new wrappe CvMDist2 which by default uses model distribution as mu + CvMMDEstimator gains argument muDatOrMod = c("Dat","Mod") to distinguish two cases + moved code to .[old]CvMMDCovariance from 0distrModUtils.R to new file asCvMVarianceQtl.R - ++ some fiddeling with the names of MCEstimators: + all functions MDEstimator, CvMMDEstimator, KolmogorovMDEstimator, TotalVarMDEstimator, + HellingerMDEstimator, MLEstimator, MCEstimator gain an extra argument nmsffx for + potential suffices to be appended to the estimator name. ++ in MDEstimator with Cramer von Mises distance in case + * distance == CvMDist && !is.null(mu) -> "( mu = )" + * distance == CvMDist && is.null(mu) -> "( mu = emp. cdf )" + * distance == CvMDist2 -> "( mu = model distr. )" + is appended to the default estimator name ++ similarly in wrapper CvMMDEstimator in case argument 'muDatOrMod' is matched to + * muDatOrMod=="Dat" -> "( mu = emp. cdf )" + * muDatOrMod=="Mod" -> "( mu = model distr. )" + * muDatOrMod=="Other" -> "( mu = )" + is appended to the default estimator name ++ based on this tag "( mu = ... )" later on, in pkg RobAStBase, a (conditional) + coerce method produces the pIC of the MDE by means of .CvMMDCovariance[WithMux] + ############## v 2.7 ############## Modified: branches/distr-2.8/pkg/distrMod/man/MCEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MCEstimator.Rd 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/man/MCEstimator.Rd 2018-08-05 20:56:37 UTC (rev 1245) @@ -14,7 +14,7 @@ MCEstimator(x, ParamFamily, criterion, crit.name, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, - ..., .withEvalAsVar = TRUE) + ..., .withEvalAsVar = TRUE, nmsffx = "") } \arguments{ \item{x}{ (empirical) data } @@ -45,6 +45,7 @@ \item{.withEvalAsVar}{logical: shall slot \code{asVar} be evaluated (if \code{asvar.fct} is given) or just the call be returned?} + \item{nmsffx}{character: a potential suffix to be appended to the estimator name.} } \details{ The argument \code{criterion} has to be a function with arguments the Modified: branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-05 20:56:37 UTC (rev 1245) @@ -15,20 +15,21 @@ MDEstimator(x, ParamFamily, distance = KolmogorovDist, dist.name, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, - ..., .withEvalAsVar = TRUE) -CvMMDEstimator(x, ParamFamily, muDatOrMod = c("Dat","Mod"), - paramDepDist = FALSE, startPar = NULL, Infos, + ..., .withEvalAsVar = TRUE, nmsffx = "") +CvMMDEstimator(x, ParamFamily, muDatOrMod = c("Dat","Mod", "Other"), + mu = NULL, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, - asvar.fct = .CvMMDCovariance, na.rm = TRUE, ..., .withEvalAsVar = TRUE) + asvar.fct = .CvMMDCovariance, na.rm = TRUE, ..., + .withEvalAsVar = TRUE, nmsffx = "") KolmogorovMDEstimator(x, ParamFamily, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, - na.rm = TRUE, ..., .withEvalAsVar = TRUE) + na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "") TotalVarMDEstimator(x, ParamFamily, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, - na.rm = TRUE, ..., .withEvalAsVar = TRUE) + na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "") HellingerMDEstimator(x, ParamFamily, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, - na.rm = TRUE, ..., .withEvalAsVar = TRUE) + na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "") CvMDist2(e1,e2,... ) } %- maybe also 'usage' for other objects documented here. @@ -42,9 +43,16 @@ as integration measure \eqn{mu} in Cramer-von-Mises distance, the empirical cdf (corresponding to argument value \code{"Dat"}) or the current model distribution - (corresponding to argument value \code{"Mod"}) is to be used; - must be one of "Dat" (default) or "Mod". + (corresponding to argument value \code{"Mod"}) or a given + integration (probability) measure / distribution \code{mu} + (corresponding to argument value \code{"Other"}) is to be used; + must be one of "Dat" (default) or "Mod" or "Other". You can specify just the initial letter.} + \item{mu}{ optional integration (probability) measure for CvM MDE. + defaults to \code{NULL} and is ignored in options + \code{muDatOrMod} in \code{"Dat"} and \code{"Mod"}; + in case \code{"Other"}, it must be of class + \code{UnivariateDistribution}. } \item{paramDepDist}{logical; will computation of distance be parameter dependent (see also note below)? if \code{TRUE}, distance function must be able to digest a parameter \code{thetaPar}; otherwise @@ -74,6 +82,7 @@ \item{.withEvalAsVar}{logical: shall slot \code{asVar} be evaluated (if \code{asvar.fct} is given) or just the call be returned?} + \item{nmsffx}{character: a potential suffix to be appended to the estimator name.} \item{e1}{object of class \code{"Distribution"} or class \code{"numeric"} } \item{e2}{object of class \code{"Distribution"} } } @@ -162,6 +171,7 @@ \code{\link[MASS]{fitdistr}} } \examples{ ## (empirical) Data +set.seed(123) x <- rgamma(50, scale = 0.5, shape = 3) ## parametric family of probability measures @@ -175,15 +185,22 @@ ## von Mises minimum distance estimator with default mu MDEstimator(x = x, ParamFamily = G, distance = CvMDist) -\dontrun{ +\donttest{ ## von Mises minimum distance estimator with default mu MDEstimator(x = x, ParamFamily = G, distance = CvMDist, asvar.fct = .CvMMDCovarianceWithMux) ## or CvMMDEstimator(x = x, ParamFamily = G) +## or +CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Dat") +## or +CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Mod") + ## von Mises minimum distance estimator with mu = N(0,1) MDEstimator(x = x, ParamFamily = G, distance = CvMDist, mu = Norm()) +## or +CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Other", mu = Norm()) ## Total variation minimum distance estimator ## gamma distributions are discretized Modified: branches/distr-2.8/pkg/distrMod/man/MLEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MLEstimator.Rd 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/man/MLEstimator.Rd 2018-08-05 20:56:37 UTC (rev 1245) @@ -12,7 +12,7 @@ MLEstimator(x, ParamFamily, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, na.rm = TRUE, ..., - .withEvalAsVar = TRUE, dropZeroDensity = TRUE) + .withEvalAsVar = TRUE, dropZeroDensity = TRUE, nmsffx = "") } %- maybe also 'usage' for other objects documented here. \arguments{ @@ -39,6 +39,7 @@ \item{dropZeroDensity}{logical of length 1; shall observations with density zero be dropped? Optimizers like \code{optim} require finite values, so get problems when negative loglikelihood is evaluated. } + \item{nmsffx}{character: a potential suffix to be appended to the estimator name.} } \details{ The function uses \code{\link{mleCalc}} Modified: branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd 2018-08-05 16:04:51 UTC (rev 1244) +++ branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd 2018-08-05 20:56:37 UTC (rev 1245) @@ -15,7 +15,7 @@ \usage{ .negLoglikelihood(x, Distribution, ..., dropZeroDensity = TRUE) .process.meCalcRes(res, PFam, trafo, res.name, call, asvar.fct, check.validity, - ..., .withEvalAsVar = TRUE, x = NULL) + ..., .withEvalAsVar = TRUE, x = NULL, nmsffx = "") .callParamFamParameter(PFam, theta, idx, nuis, fixed) } @@ -47,6 +47,7 @@ \item{dropZeroDensity}{logical of length 1; shall observations with density zero be dropped? Optimizers like \code{optim} require finite values, so get problems when negative loglikelihood is evaluated. } + \item{nmsffx}{character: a potential suffix to be appended to the estimator name.} } \details{ From noreply at r-forge.r-project.org Sun Aug 5 22:58:25 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 5 Aug 2018 22:58:25 +0200 (CEST) Subject: [Distr-commits] r1246 - branches/distr-2.8/pkg/distrMod/man Message-ID: <20180805205825.CE76618A280@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-05 22:58:25 +0200 (Sun, 05 Aug 2018) New Revision: 1246 Modified: branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd Log: [distrMod] branch 2.8 some additional examples to CvMMDEstimator Modified: branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-05 20:56:37 UTC (rev 1245) +++ branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-05 20:58:25 UTC (rev 1246) @@ -194,12 +194,17 @@ ## or CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Dat") -## or +## or with model based integration measure: CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Mod") ## von Mises minimum distance estimator with mu = N(0,1) MDEstimator(x = x, ParamFamily = G, distance = CvMDist, mu = Norm()) -## or +## or, with asy Var +MDEstimator(x = x, ParamFamily = G, distance = CvMDist, mu = Norm(), + asvar.fct = function(L2Fam, param, ...){ + .CvMMDCovariance(L2Fam=L2Fam, param=param, mu=Norm(), N = 400) + } ) +## synomymous to CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Other", mu = Norm()) ## Total variation minimum distance estimator From noreply at r-forge.r-project.org Mon Aug 6 00:59:39 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 00:59:39 +0200 (CEST) Subject: [Distr-commits] r1247 - branches/distr-2.8/pkg/distrMod/R Message-ID: <20180805225939.C245E186D34@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 00:59:39 +0200 (Mon, 06 Aug 2018) New Revision: 1247 Modified: branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R Log: [distrMod] branch 2.8: + the L2derivatives of the SimpleL2ParamFamilies and the L2GroupFamilies now respect restrictions in the support of the underlying distribution: the L2derivatives are 0 whenever the argument x has liesInSupport(x,distribution) == FALSE Modified: branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R 2018-08-05 20:58:25 UTC (rev 1246) +++ branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R 2018-08-05 22:59:39 UTC (rev 1247) @@ -40,9 +40,9 @@ "with location parameter 'loc'") if(missing(LogDeriv)) LogDeriv <- .getLogDeriv(centraldistribution) L2deriv.fct <- function(param){ - loc <- main(param) + loc.0 <- main(param) fct <- function(x){} - body(fct) <- substitute({ LogDeriv(x - loc) }, list(loc = loc)) + body(fct) <- substitute({ LogDeriv(x - loc.1) }, list(loc.1 = loc.0)) return(fct)} L2deriv <- EuclRandVarList(RealRandVariable(list(L2deriv.fct(param)), Domain = Reals())) @@ -194,13 +194,26 @@ "the group of transformations 'g(y) = scale*y'", "with scale parameter 'scale'") if(missing(LogDeriv)) LogDeriv <- .getLogDeriv(centraldistribution) - L2deriv.fct <- function(param){ - scale <- main(param) + if(is.finite(q.l(centraldistribution)(0)) || is.finite(q.l(centraldistribution)(1)) ){ + L2deriv.fct <- function(param){ + scale.0 <- main(param) + distr.0 <- scale.0*centraldistribution + loc fct <- function(x){} - body(fct) <- substitute({ ((x - loc)/scale*LogDeriv((x - loc)/scale)-1)/scale }, - list(loc = loc, scale = scale)) + body(fct) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- ((x[inS] - loc.1)/scale*LogDeriv((x[inS] - loc.1)/scale.1)-1)/scale.1 + return(y)}, + list(loc.1 = loc, scale.1 = scale.0)) return(fct)} - L2deriv <- EuclRandVarList(RealRandVariable(list(L2deriv.fct(param)), Domain = Reals())) + }else{ + L2deriv.fct <- function(param){ + scale.0 <- main(param) + fct <- function(x){} + body(fct) <- substitute({ ((x - loc.1)/scale.1*LogDeriv((x - loc.1)/scale.1)-1)/scale.1 }, + list(loc.1 = loc, scale.1 = scale.0)) + return(fct)} + } + L2deriv <- EuclRandVarList(RealRandVariable(list(L2deriv.fct(param)), Domain = Reals())) L2derivDistr <- if(missing(L2derivDistr.0)) @@ -365,15 +378,15 @@ locscalename["loc"] else 1 snm <- if(locscalename["scale"] %in% nmsL) locscalename["scale"] else 2 - mean <- main(param)[lnm] - sd <- main(param)[snm] + mean.0 <- main(param)[lnm] + sd.0 <- main(param)[snm] fct1 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({ LogDeriv((x - loc)/scale)/scale }, - list(loc = mean, scale = sd)) + body(fct1) <- substitute({ LogDeriv((x - loc.1)/scale.1)/scale.1 }, + list(loc.1 = mean.0, scale.1 = sd.0)) body(fct2) <- substitute({ - ((x - loc)/scale * LogDeriv((x - loc)/scale)-1)/scale }, - list(loc = mean, scale = sd)) + ((x - loc.1)/scale.1 * LogDeriv((x - loc.1)/scale.1)-1)/scale.1 }, + list(loc.1 = mean.0, scale.1 = sd.0)) return(list(fct1, fct2))} L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param), @@ -547,15 +560,15 @@ if(missing(LogDeriv)) LogDeriv <- .getLogDeriv(centraldistribution) L2deriv.fct <- function(param){ - mean <- main(param) - sd <- nuisance(param) + mean.0 <- main(param) + sd.0 <- nuisance(param) fct1 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({ LogDeriv((x - loc)/scale)/scale }, - list(loc = mean, scale = sd)) + body(fct1) <- substitute({ LogDeriv((x - loc.1)/scale.1)/scale.1 }, + list(loc.1 = mean.0, scale.1 = sd.0)) body(fct2) <- substitute({ - ((x - loc)/scale * LogDeriv((x - loc)/scale)-1)/scale }, - list(loc = mean, scale = sd)) + ((x - loc.1)/scale.1 * LogDeriv((x - loc.1)/scale.1)-1)/scale.1 }, + list(loc.1 = mean.0, scale.1 = sd.0)) return(list(fct1, fct2))} L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param), @@ -723,18 +736,38 @@ "with location parameter 'loc' and scale parameter 'scale'") if(missing(LogDeriv)) LogDeriv <- .getLogDeriv(centraldistribution) - L2deriv.fct <- function(param){ - mean <- nuisance(param) - sd <- main(param) + if(is.finite(q.l(centraldistribution)(0)) || is.finite(q.l(centraldistribution)(1)) ){ + L2deriv.fct <- function(param){ + mean.0 <- nuisance(param) + sd.0 <- main(param) + distr.0 <- sd.0*centraldistribution+mean.0 fct1 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({ LogDeriv((x - loc)/scale)/scale }, - list(loc = mean, scale = sd)) - body(fct2) <- substitute({ - ((x - loc)/scale * LogDeriv((x - loc)/scale)-1)/scale }, - list(loc = mean, scale = sd)) + body(fct1) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- LogDeriv((x[inS] - loc.1)/scale.1)/scale.1 + return(y)}, + list(loc.1 = mean.0, scale.1 = sd.0)) + body(fct2) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- ((x[inS] - loc.1)/scale.1 * + LogDeriv((x[inS] - loc.1)/scale.1)-1)/scale.1 + return(y)}, + list(loc.1 = mean.0, scale.1 = sd.0)) return(list(fct1, fct2))} - + }else{ + L2deriv.fct <- function(param){ + mean.0 <- nuisance(param) + sd.0 <- main(param) + fct1 <- function(x){} + fct2 <- function(x){} + body(fct1) <- substitute({ LogDeriv((x - loc.1)/scale.1)/scale.1 }, + list(loc.1 = mean.0, scale.1 = sd.0)) + body(fct2) <- substitute({ + ((x - loc.1)/scale.1 * LogDeriv((x - loc.1)/scale.1)-1)/scale.1 }, + list(loc.1 = mean.0, scale.1 = sd.0)) + return(list(fct1, fct2))} + } L2deriv <- EuclRandVarList(RealRandVariable(L2deriv.fct(param), Domain = Reals())) Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-05 20:58:25 UTC (rev 1246) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-05 22:59:39 UTC (rev 1247) @@ -28,8 +28,12 @@ return(param)} L2deriv.fct <- function(param){ prob.0 <- main(param) + distr.0 <- Binom(size = size, prob = prob.0) fct <- function(x){} - body(fct) <- substitute({ (x-size*prob.1)/(prob.1*(1-prob.1)) }, + body(fct) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- (x[inS]-size*prob.1)/(prob.1*(1-prob.1)) + return(y)}, list(size = size, prob.1 = prob.0)) return(fct)} L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = size*prob)) @@ -83,8 +87,12 @@ return(param)} L2deriv.fct <- function(param){ lambda.0 <- main(param) + distr.0 <- Pois(lambda=lambda.0) fct <- function(x){} - body(fct) <- substitute({ x/lambda.1-1 }, + body(fct) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- x[inS]/lambda.1-1 + return(y)}, list(lambda.1 = lambda.0)) return(fct)} L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = lambda)) @@ -141,8 +149,13 @@ return(param)} L2deriv.fct <- function(param){ prob.0 <- main(param) + distr.0 <- Nbinom(size=size, prob=prob.0) fct <- function(x){} - body(fct) <- substitute({ (size/prob.1- x/(1-prob.1)) }, + body(fct) <- substitute({ + y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- (size/prob.1- x[inS]/(1-prob.1)) + return(y)}, list(size = size, prob.1 = prob.0)) return(fct)} L2derivSymm <- FunSymmList(NonSymmetric()) @@ -199,11 +212,20 @@ L2deriv.fct <- function(param){ prob.0 <- main(param)["prob"] size.0 <- main(param)["size"] + distr.0 <- Nbinom(size=size.0, prob=prob.0) fct1 <- function(x){} fct2 <- function(x){} - body(fct2) <- substitute({ (size.1/prob.1- x/(1-prob.1)) }, + body(fct2) <- substitute({ + y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- (size.1/prob.1- x[inS]/(1-prob.1)) + return(y)}, list(size.1 = size.0, prob.1 = prob.0)) - body(fct1) <- substitute({ digamma(x+size.1)-digamma(size.1)+log(prob.1)}, + body(fct1) <- substitute({ + y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- digamma(x[inS]+size.1)-digamma(size.1)+log(prob.1) + return(y)}, list(size.1 = size.0, prob.1 = prob.0)) return(list(fct1, fct2))} @@ -275,15 +297,26 @@ size.00 <- main(param)["size"] mean.00 <- main(param)["mean"] prob.00 <- size.00/(size.00+mean.00) - + distr.0 <- Nbinom(size=size.00, prob=prob.00) + fct1 <- function(x){} fct1.2 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({ digamma(x+size.1)-digamma(size.1)+log(prob.1)}, + body(fct1) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- digamma(x[inS]+size.1)-digamma(size.1)+log(prob.1) + return(y)}, list(size.1 = size.00, prob.1 = prob.00)) - body(fct1.2)<- substitute({ (size.1/prob.1- x/(1-prob.1)) }, + body(fct1.2)<- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- (size.1/prob.1- x[inS]/(1-prob.1)) + return(y)}, list(size.1 = size.00, prob.1 = prob.00)) - body(fct2) <- substitute({ (1/prob.1-1)* fct1(x) - size.1/prob.1^2 * fct1.2(x)}, + body(fct2) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- (1/prob.1-1)* fct1(x[inS]) - + size.1/prob.1^2 * fct1.2(x[inS]) + return(y)}, list(size.1 = size.00, prob.1 = prob.00)) return(list(fct1, fct2))} L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric()) @@ -366,11 +399,18 @@ L2deriv.fct <- function(param){ scale.0 <- main(param)[1] shape.0 <- main(param)[2] + distr.0 <- Gammad(scale = scale.0, shape = shape.0) fct1 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({ (x/scale.1 - shape.1)/scale.1 }, + body(fct1) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- (x[inS]/scale.1 - shape.1)/scale.1 + return(y)}, list(scale.1 = scale.0, shape.1 = shape.0)) - body(fct2) <- substitute({ log(x/scale.1) - digamma(shape.1) }, + body(fct2) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- log(x[inS]/scale.1) - digamma(shape.1) + return(y)}, list(scale.1 = scale.0, shape.1 = shape.0)) return(list(fct1, fct2))} L2derivSymm <- FunSymmList(OddSymmetric(SymmCenter = scale*shape), @@ -456,13 +496,20 @@ L2deriv.fct <- function(param){ shape1.0 <- main(param)[1] shape2.0 <- main(param)[2] + distr.0 <- Beta(shape1=shape1.0, shape2 = shape2.0) fct1 <- function(x){} fct2 <- function(x){} - body(fct1) <- substitute({log(x)-digamma(shape1.1)+ - digamma(shape1.1+shape2.1)}, + body(fct1) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- log(x[inS])-digamma(shape1.1)+ + digamma(shape1.1+shape2.1) + return(y)}, list(shape1.1 = shape1.0, shape2.1 = shape2.0)) - body(fct2) <- substitute({log(1-x)-digamma(shape2.1)+ - digamma(shape1.1+shape2.1)}, + body(fct2) <- substitute({y <- 0*x + inS <- liesInSupport(distr.0, x) + y[inS] <- log(1-x[inS])-digamma(shape2.1)+ + digamma(shape1.1+shape2.1) + return(y)}, list(shape1.1 = shape1.0, shape2.1 = shape2.0)) return(list(fct1, fct2))} L2derivSymm <- FunSymmList(NonSymmetric(), NonSymmetric()) From noreply at r-forge.r-project.org Mon Aug 6 01:00:20 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 01:00:20 +0200 (CEST) Subject: [Distr-commits] r1248 - branches/distr-2.8/pkg/distrMod/inst Message-ID: <20180805230020.511061871C3@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 01:00:17 +0200 (Mon, 06 Aug 2018) New Revision: 1248 Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS Log: [distrMod] branch 2.8: / forgot the news to the last commit: + the L2derivatives of the SimpleL2ParamFamilies and the L2GroupFamilies now respect restrictions in the support of the underlying distribution: the L2derivatives are 0 whenever the argument x has liesInSupport(x,distribution) == FALSE Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-05 22:59:39 UTC (rev 1247) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-05 23:00:17 UTC (rev 1248) @@ -32,6 +32,9 @@ and in case "Other" one has to supply an integration probability mu. => consistency between estimate and asyCov + added some theory/references to help file to MD estimators ++ the L2derivatives of the SimpleL2ParamFamilies and the L2GroupFamilies now respect + restrictions in the support of the underlying distribution: the L2derivatives are 0 + whenever the argument x has liesInSupport(distribution,x) == FALSE bug fixes + discovered some issues with local variables in L2Families (global values were used instead...) From noreply at r-forge.r-project.org Mon Aug 6 02:09:36 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 02:09:36 +0200 (CEST) Subject: [Distr-commits] r1249 - in branches/distr-2.8/pkg/distrMod: . R inst man tests/Examples Message-ID: <20180806000936.72961184B67@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 02:09:35 +0200 (Mon, 06 Aug 2018) New Revision: 1249 Added: branches/distr-2.8/pkg/distrMod/man/LogisticLocationScaleFamily.Rd Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE branches/distr-2.8/pkg/distrMod/R/AllReturnClasses.R branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/0distrMod-package.Rd branches/distr-2.8/pkg/distrMod/man/InternalReturnClasses-class.Rd branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save Log: [distrMod] branch 2.8 + new model class / generator LogisticLocationScaleFamily Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-05 23:00:17 UTC (rev 1248) +++ branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-06 00:09:35 UTC (rev 1249) @@ -37,7 +37,7 @@ exportClasses("BinomFamily","PoisFamily", "NormLocationFamily", "NormScaleFamily", "ExpScaleFamily", "LnormScaleFamily", "GammaFamily", "BetaFamily", "NormLocationScaleFamily", - "CauchyLocationScaleFamily") + "CauchyLocationScaleFamily", "LogisticLocationScaleFamily") exportClasses("NormType", "QFNorm", "InfoNorm", "SelfNorm") exportClasses("Estimate", "MCEstimate") exportClasses("Confint") @@ -81,11 +81,12 @@ "BinomFamily", "PoisFamily", "NbinomFamily", "NormLocationFamily", "NormScaleFamily", "ExpScaleFamily", "LnormScaleFamily", "GammaFamily", "BetaFamily", "NormLocationScaleFamily", - "CauchyLocationScaleFamily", "NbinomwithSizeFamily", "NbinomMeanSizeFamily") + "CauchyLocationScaleFamily", "NbinomwithSizeFamily", "NbinomMeanSizeFamily", + "LogisticLocationScaleFamily") export("asCov", "trAsCov", "asHampel", "asBias", "asMSE", "asUnOvShoot", "fiCov", "trFiCov", "fiHampel", "fiMSE", "fiBias", "fiUnOvShoot") export("positiveBias", "negativeBias", "symmetricBias", - "asymmetricBias", "asSemivar") + "asymmetricBias", "asSemivar", "LOGISTINT2") export("isKerAinKerB") export("L2LocationFamily", "L2ScaleFamily", "L2LocationScaleFamily") export("EuclideanNorm", "QuadFormNorm") Modified: branches/distr-2.8/pkg/distrMod/R/AllReturnClasses.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/AllReturnClasses.R 2018-08-05 23:00:17 UTC (rev 1248) +++ branches/distr-2.8/pkg/distrMod/R/AllReturnClasses.R 2018-08-06 00:09:35 UTC (rev 1249) @@ -60,4 +60,7 @@ setClass("CauchyLocationScaleFamily", contains = "L2LocationScaleFamily") +## Logistic location scale family +setClass("LogisticLocationScaleFamily", + contains = "L2LocationScaleFamily") Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-05 23:00:17 UTC (rev 1248) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-06 00:09:35 UTC (rev 1249) @@ -759,6 +759,42 @@ } + +################################################################## +## Logistic location scale family +################################################################## +LOGISTINT2 <- integrate(function(x){qx <- qlogis(x); (tanh(qx/2)*qx-1)^2}, 0,1, subdivisions=1000,rel.tol=1e-10)$value + +LogisticLocationScaleFamily <- function(location = 0, scale = 1, trafo){ + lsname <- c("loc"="location", "scale"="scale") + if(missing(trafo)) {trafo <- diag(2) + dimnames(trafo) <- list(lsname,lsname)} + res <- L2LocationScaleFamily(loc = location, scale = scale, + name = "normal location and scale family", + locscalename = lsname, + modParam = function(theta) Logis(location = theta[1], scale = theta[2]), + LogDeriv = function(x) (1-exp(x))/(1+exp(x)), + FisherInfo.0 = matrix(c(1/3,0,0,LOGISTINT2),2,2, + dimnames = list(lsname, lsname)), + distrSymm = SphericalSymmetry(SymmCenter = location), + L2derivSymm = FunSymmList(OddSymmetric(SymmCenter = location), + EvenSymmetric(SymmCenter = location)), + L2derivDistrSymm = DistrSymmList(SphericalSymmetry(), + NoSymmetry()), + trafo = trafo, .returnClsName = "LogisticLocationScaleFamily") + if(!is.function(trafo)) + f.call <- substitute(LogisticLocationScaleFamily(location = m, scale = s, + trafo = matrix(Tr, ncol = 2, dimnames = DN)), + list(m = location, s = scale, Tr = trafo, DN = dimnames(trafo))) + else + f.call <- substitute(LogisticLocationScaleFamily(location = m, scale = s, trafo = Tr), + list(m = location, s = scale, Tr = trafo)) + res at fam.call <- f.call + return(res) +} + + + ##################################### ##################################### #### normal models with nuisance @@ -832,3 +868,4 @@ res at fam.call <- f.call return(res) } + Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-05 23:00:17 UTC (rev 1248) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-06 00:09:35 UTC (rev 1249) @@ -35,6 +35,7 @@ + the L2derivatives of the SimpleL2ParamFamilies and the L2GroupFamilies now respect restrictions in the support of the underlying distribution: the L2derivatives are 0 whenever the argument x has liesInSupport(distribution,x) == FALSE ++ new model class / generator LogisticLocationScaleFamily bug fixes + discovered some issues with local variables in L2Families (global values were used instead...) Modified: branches/distr-2.8/pkg/distrMod/man/0distrMod-package.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/0distrMod-package.Rd 2018-08-05 23:00:17 UTC (rev 1248) +++ branches/distr-2.8/pkg/distrMod/man/0distrMod-package.Rd 2018-08-06 00:09:35 UTC (rev 1249) @@ -53,6 +53,9 @@ |>|>|>"BinomFamily" [*] |>|>|>"PoisFamily" [*] |>|>|>"BetaFamily" [*] +|>|>|>"NbinomFamily" [*] +|>|>|>"NbinomwithSizeFamily" [*] +|>|>|>"NbinomMeanSizeFamily" [*] |>|>|>"L2GroupParamFamily" additional slots: LogDeriv(function) @@ -61,15 +64,16 @@ |>|>|>|>"L2LocationScaleUnion" /VIRTUAL/ additional slots: locscalename(character) -|>|>|>|>|>"L2LocationFamily" [*] -|>|>|>|>|>|>"NormLocationFamily" [*] -|>|>|>|>|>"L2ScaleFamily" [*] -|>|>|>|>|>|>"NormScaleFamily" [*] -|>|>|>|>|>|>"ExpScaleFamily" [*] -|>|>|>|>|>|>"LnormScaleFamily" [*] -|>|>|>|>|>"L2LocationScaleFamily" [*] -|>|>|>|>|>|>"NormLocationScaleFamily" [*] -|>|>|>|>|>|>"CauchyLocationScaleFamily" [*] +|>|>|>|>|>"L2LocationFamily" [*] +|>|>|>|>|>|>"NormLocationFamily" [*] +|>|>|>|>|>"L2ScaleFamily" [*] +|>|>|>|>|>|>"NormScaleFamily" [*] +|>|>|>|>|>|>"ExpScaleFamily" [*] +|>|>|>|>|>|>"LnormScaleFamily" [*] +|>|>|>|>|>"L2LocationScaleFamily" [*] +|>|>|>|>|>|>"NormLocationScaleFamily" [*] +|>|>|>|>|>|>"CauchyLocationScaleFamily" [*] +|>|>|>|>|>|>"LogisticLocationScaleFamily" [*] and a (virtual) class union "L2ScaleUnion" between "L2LocationScaleUnion" and "L2ScaleShapeUnion" Modified: branches/distr-2.8/pkg/distrMod/man/InternalReturnClasses-class.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/InternalReturnClasses-class.Rd 2018-08-05 23:00:17 UTC (rev 1248) +++ branches/distr-2.8/pkg/distrMod/man/InternalReturnClasses-class.Rd 2018-08-06 00:09:35 UTC (rev 1249) @@ -13,6 +13,7 @@ \alias{BetaFamily-class} \alias{NormLocationScaleFamily-class} \alias{CauchyLocationScaleFamily-class} +\alias{LogisticLocationScaleFamily-class} \title{Internal return classes for generating functions} \description{internal return classes for generating functions 'L2ParamFamily' and @@ -27,8 +28,9 @@ ``extending'' (no new slots!) class \code{"L2LocationFamily"}, classes \code{NormScaleFamily}, \code{ExpScaleFamily}, and \code{LnormScaleFamily} ``extending'' (no new slots!) class \code{"L2ScaleFamily"}, and classes -\code{CauchyLocationScaleFamily} and \code{NormLocationScaleFamily}, -``extending'' (no new slots!) class \code{"L2LocationScaleFamily"}. +\code{CauchyLocationScaleFamily}, \code{LogisticLocationScaleFamily} and +\code{NormLocationScaleFamily}, ``extending'' (no new slots!) +class \code{"L2LocationScaleFamily"}. } \section{Objects from these classes}{ Objects are only generated internally by the mentioned generating functions. @@ -135,7 +137,8 @@ Class \code{"ParamFamily"}, by class \code{"L2ParamFamily"}.\cr Class \code{"ProbFamily"}, by class \code{"ParamFamily"}. \cr -\code{CauchyLocationScaleFamily} and \code{NormLocationScaleFamily} +\code{CauchyLocationScaleFamily}, \code{LogisticLocationScaleFamily}, +and \code{NormLocationScaleFamily} ``extend'' (no new slots!):\cr Class \code{"L2LocationScaleFamily"}, directly.\cr Class \code{"L2LocationScaleUnion"}, by class \code{"L2LocationScaleFamily"}.\cr Added: branches/distr-2.8/pkg/distrMod/man/LogisticLocationScaleFamily.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/LogisticLocationScaleFamily.Rd (rev 0) +++ branches/distr-2.8/pkg/distrMod/man/LogisticLocationScaleFamily.Rd 2018-08-06 00:09:35 UTC (rev 1249) @@ -0,0 +1,51 @@ +\name{LogisticLocationScaleFamily} +\alias{LogisticLocationScaleFamily} +\alias{LOGISTINT2} + + +\title{Generating function for Logistic location and scale families} +\description{ + Generates an object of class \code{"L2LocationScaleFamily"} which + represents a normal location and scale family. +} +\usage{ +LogisticLocationScaleFamily(location = 0, scale = 1, trafo) +LOGISTINT2 +} +\arguments{ + \item{location}{ location } + \item{scale}{ scale } + \item{trafo}{ function in \code{param} or matrix: transformation of the parameter } +} +\details{ + The slots of the corresponding L2 differentiable + parameteric family are filled. + \code{LOGISTINT2} is a constant used for the scale part of the Fisher information. + More precisely \code{LOGISTINT2} equals to + \eqn{\int_{-\infty}^{\infty} (\tanh(x/2)\,x-1)^2\,{\rm dlogis}(x)\,dx)}{% + integral_{-Inf}^{Inf} (tanh(x/2)x-1)^2 dlogis(x) dx}. +} +\value{Object of class \code{"L2LocationScaleFamily"}} +\references{ + Kohl, M. (2005) \emph{Numerical Contributions to + the Asymptotic Theory of Robustness}. Bayreuth: Dissertation. +} +\author{Peter Ruckdeschel \email{Peter.Ruckdeschel at uni-oldenburg.de}} +%\note{} +\seealso{\code{\link{L2ParamFamily-class}}, \code{\link[distr]{Logis-class}}} +\examples{ +(L1 <- LogisticLocationScaleFamily()) +plot(L1) +FisherInfo(L1) +### need smaller integration range: +distrExoptions("ElowerTruncQuantile"=1e-4,"EupperTruncQuantile"=1e-4) +checkL2deriv(L1) +distrExoptions("ElowerTruncQuantile"=1e-7,"EupperTruncQuantile"=1e-7) +## +set.seed(123) +x <- rlogis(100,location=1,scale=2) +CvMMDEstimator(x, L1) +} +\concept{Logistic location and scale model} +\concept{location and scale model} +\keyword{models} Modified: branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save =================================================================== --- branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save 2018-08-05 23:00:17 UTC (rev 1248) +++ branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save 2018-08-06 00:09:35 UTC (rev 1249) @@ -402,7 +402,7 @@ dimnames = list(nms, nms0)) list(fval = fval0, mat = mat0) } - + Trafo / derivative matrix at which estimate was produced: scale shape shape 0.000 1 @@ -612,23 +612,26 @@ [[1]] function (x) { - ((x - 0)/c(scale = 1) * LogDeriv((x - 0)/c(scale = 1)) - + y <- 0 * x + inS <- liesInSupport(distr.0, x) + y[inS] <- ((x[inS] - 0)/scale * LogDeriv((x[inS] - 0)/c(scale = 1)) - 1)/c(scale = 1) + return(y) } - + > checkL2deriv(E1) -precision of centering: -1.51181e-06 +precision of centering: -2.04266e-06 precision of Fisher information: + scale +scale -3.598621e-05 +precision of Fisher information - relativ error [%]: scale -scale -2.61793e-05 -precision of Fisher information - relativ error [%]: - scale -scale -0.00261793 +scale -0.003598621 condition of Fisher information: [1] 1 $maximum.deviation -[1] 2.61793e-05 +[1] 3.598621e-05 > > @@ -757,19 +760,19 @@ scale 1 1.000000 shape 1 1.644934 > checkL2deriv(G1) -precision of centering: -1.51181e-06 1.312514e-06 +precision of centering: -2.04266e-06 1.791171e-06 precision of Fisher information: scale shape -scale -2.617930e-05 -7.165188e-06 -shape -7.165188e-06 -2.862712e-05 +scale -3.598621e-05 -9.503625e-06 +shape -9.503625e-06 -3.944425e-05 precision of Fisher information - relativ error [%]: scale shape -scale -0.0026179301 -0.0007165188 -shape -0.0007165188 -0.0017403202 +scale -0.0035986209 -0.0009503625 +shape -0.0009503625 -0.0023979229 condition of Fisher information: [1] 10.60328 $maximum.deviation -[1] 2.862712e-05 +[1] 3.944425e-05 > > @@ -803,8 +806,8 @@ Slot "fct": function (x) QuadFormNorm(x, A = A) - - + + > > ## The function is currently defined as @@ -1116,10 +1119,13 @@ [[1]] function (x) { - ((x - 0)/c(meanlog = 1) * LogDeriv((x - 0)/c(meanlog = 1)) - + y <- 0 * x + inS <- liesInSupport(distr.0, x) + y[inS] <- ((x[inS] - 0)/scale * LogDeriv((x[inS] - 0)/c(meanlog = 1)) - 1)/c(meanlog = 1) + return(y) } - + > checkL2deriv(L1) precision of centering: -0.003003394 @@ -1140,6 +1146,94 @@ > base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") > base::cat("LnormScaleFamily", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() +> nameEx("LogisticLocationScaleFamily") +> ### * LogisticLocationScaleFamily +> +> flush(stderr()); flush(stdout()) +> +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") +> ### Name: LogisticLocationScaleFamily +> ### Title: Generating function for Logistic location and scale families +> ### Aliases: LogisticLocationScaleFamily LOGISTINT2 +> ### Keywords: models +> +> ### ** Examples +> +> (L1 <- LogisticLocationScaleFamily()) +An object of class "LogisticLocationScaleFamily" +### name: normal location and scale family + +### distribution: Distribution Object of Class: Norm + mean: 0 + sd: 1 +Warning in show(x) : + arithmetics on distributions are understood as operations on r.v.'s +see 'distrARITH()'; for switching off this warning see '?distroptions' + +### param: An object of class "ParamWithScaleFamParameter" +name: location and scale +location: 0 +scale: 1 +trafo: + location scale +location 1 0 +scale 0 1 + +### props: +[1] "The normal location and scale family is invariant under" +[2] "the group of transformations 'g(x) = scale*x + loc'" +[3] "with location parameter 'loc' and scale parameter 'scale'" +> plot(L1) +> FisherInfo(L1) +An object of class "PosDefSymmMatrix" + location scale +location 0.3333333 0.000000 +scale 0.0000000 1.429956 +> ### need smaller integration range: +> distrExoptions("ElowerTruncQuantile"=1e-4,"EupperTruncQuantile"=1e-4) +> checkL2deriv(L1) +precision of centering: -2.264121e-17 -1.41228 +precision of Fisher information: + location scale +location -1.600022e-01 4.454916e-17 +scale 4.454916e-17 8.149930e-01 +precision of Fisher information - relativ error [%]: + location scale +location -48.00065 Inf +scale Inf 56.99427 +condition of Fisher information: +[1] 3.667949 +$maximum.deviation +[1] 1.41228 + +> distrExoptions("ElowerTruncQuantile"=1e-7,"EupperTruncQuantile"=1e-7) +> ## +> set.seed(123) +> x <- rlogis(100,location=1,scale=2) +> CvMMDEstimator(x, L1) +Evaluations of Minimum CvM distance estimate ( mu = emp. cdf ) : +---------------------------------------------------------------- +An object of class "Estimate" +generated by call + CvMMDEstimator(x = x, ParamFamily = L1) +samplesize: 100 +estimate: + location scale + 0.9199612 1.9512792 + (2.2045470) (0.6064406) +asymptotic (co)variance (multiplied with samplesize): + location scale +location 486.0028 130.60897 +scale 130.6090 36.77702 +Criterion: +CvM distance + 0.01414319 +> +> +> +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("LogisticLocationScaleFamily", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") +> cleanEx() > nameEx("MCEstimate-class") > ### * MCEstimate-class > @@ -1151,7 +1245,8 @@ > ### Aliases: MCEstimate-class criterion criterion,MCEstimate-method > ### criterion.fct criterion.fct,MCEstimate-method > ### startPar,MCEstimate-method method method,MCEstimate-method optimwarn -> ### optimwarn,MCEstimate-method criterion<- criterion<-,MCEstimate-method +> ### optimwarn,MCEstimate-method optimReturn optimReturn,MCEstimate-method +> ### criterion<- criterion<-,MCEstimate-method > ### coerce,MCEstimate,mle-method show,MCEstimate-method > ### profile,MCEstimate-method > ### Keywords: classes @@ -1165,8 +1260,8 @@ > G <- GammaFamily(scale = 1, shape = 2) > > MDEstimator(x, G) -Evaluations of Minimum Kolmogorov distance estimate: ----------------------------------------------------- +Evaluations of Minimum Kolmogorov distance estimate : +------------------------------------------------------ An object of class "Estimate" generated by call MDEstimator(x = x, ParamFamily = G) @@ -1233,18 +1328,6 @@ + return(res) + } > MCEstimator(x = x, ParamFamily = G, criterion = negLoglikelihood) -Warning in fn(par, ...) : - Criterion evaluation at theta = 0.298,4.655 threw an error; -returning starting par; - -Warning in fn(par, ...) : - Criterion evaluation at theta = 0.764,4.655 threw an error; -returning starting par; - -Warning in fn(par, ...) : - Criterion evaluation at theta = 0.298,5.12 threw an error; -returning starting par; - Evaluations of Minimum criterion estimate: ------------------------------------------ An object of class "Estimate" @@ -1252,11 +1335,11 @@ MCEstimator(x = x, ParamFamily = G, criterion = negLoglikelihood) samplesize: 50 estimate: - scale shape -0.2983286 4.6547001 + scale shape +0.342008 4.060286 Criterion: - -1e+20 + +47.9651 > > ## Kolmogorov(-Smirnov) minimum distance estimator > ## Note: you can also use function MDEstimator! @@ -1349,12 +1432,14 @@ > base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: MDEstimator > ### Title: Function to compute minimum distance estimates -> ### Aliases: MDEstimator +> ### Aliases: MDEstimator CvMMDEstimator KolmogorovMDEstimator +> ### TotalVarMDEstimator HellingerMDEstimator CvMDist2 > ### Keywords: univar robust > > ### ** Examples > > ## (empirical) Data +> set.seed(123) > x <- rgamma(50, scale = 0.5, shape = 3) > > ## parametric family of probability measures @@ -1362,33 +1447,47 @@ > > ## Kolmogorov(-Smirnov) minimum distance estimator > MDEstimator(x = x, ParamFamily = G, distance = KolmogorovDist) -Evaluations of Minimum Kolmogorov distance estimate: ----------------------------------------------------- +Evaluations of Minimum Kolmogorov distance estimate : +------------------------------------------------------ An object of class "Estimate" generated by call MDEstimator(x = x, ParamFamily = G, distance = KolmogorovDist) samplesize: 50 estimate: scale shape -0.3398645 4.2654569 +0.5325299 2.4106229 Criterion: Kolmogorov distance - 0.06350364 + 0.07111522 +> ## or +> KolmogorovMDEstimator(x = x, ParamFamily = G) +Evaluations of Minimum Kolmogorov distance estimate : +------------------------------------------------------ +An object of class "Estimate" +generated by call + KolmogorovMDEstimator(x = x, ParamFamily = G) +samplesize: 50 +estimate: + scale shape +0.5325299 2.4106229 +Criterion: +Kolmogorov distance + 0.07111522 > > ## von Mises minimum distance estimator with default mu > MDEstimator(x = x, ParamFamily = G, distance = CvMDist) -Evaluations of Minimum CvM distance estimate: ---------------------------------------------- +Evaluations of Minimum CvM distance estimate ( mu = emp. cdf ) : +----------------------------------------------------------------- An object of class "Estimate" generated by call MDEstimator(x = x, ParamFamily = G, distance = CvMDist) samplesize: 50 estimate: scale shape -0.3401751 4.1262425 +0.4683173 2.6527970 Criterion: CvM distance - 0.02931495 + 0.03266119 > > > @@ -1631,15 +1730,15 @@ > (res <- MLEstimator(x = x, ParamFamily = C)) Evaluations of Maximum likelihood estimate: ------------------------------------------- - loc scale - 1.2124856 1.6358162 - (0.3271632) (0.3271632) + loc scale + 1.088544 1.527400 + (0.305480) (0.305480) > ## Asymptotic (CLT-based) confidence interval > confint(res) A[n] asymptotic (CLT-based) confidence interval: 2.5 % 97.5 % -loc 0.5712574 1.853714 -scale 0.9945880 2.277044 +loc 0.4898137 1.687273 +scale 0.9286703 2.126130 > > > @@ -2133,7 +2232,7 @@ return(abs(x)) else return(sqrt(colSums(x^2))) } - + > name(EuclNorm) [1] "EuclideanNorm" @@ -2168,7 +2267,7 @@ return(abs(x)) else return(sqrt(colSums(x^2))) } - + > @@ -2651,8 +2750,8 @@ Slot "fct": function (x) QuadFormNorm(x, A = A0) - - + + > > ## The function is currently defined as @@ -2693,8 +2792,8 @@ Slot "fct": function (x) QuadFormNorm(x, A = A) - - + + > > ## The function is currently defined as @@ -3820,7 +3919,7 @@ dimnames(mat) <- list(nfval, c("mean", "sd")) return(list(fval = fval, mat = mat)) } - + > print(param(NS), show.details = "minimal") An object of class "ParamWithScaleFamParameter" name: location and scale @@ -3869,7 +3968,7 @@ dimnames(mat) <- list(nfval, c("mean", "sd")) return(list(fval = fval, mat = mat)) } - + Trafo / derivative matrix: mean sd mu/sig 0.3668695 -0.3024814 @@ -3912,7 +4011,7 @@ dimnames(mat) <- list(nfval, c("mean", "sd")) return(list(fval = fval, mat = mat)) } - + Trafo / derivative matrix: mean sd mu/sig 0.3669 -0.3025 @@ -4333,7 +4432,7 @@ > cleanEx() > options(digits = 7L) > base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n") -Time elapsed: 22.44 0.43 23.27 NA NA +Time elapsed: 34.67 0.58 37.27 NA NA > grDevices::dev.off() null device 1 From noreply at r-forge.r-project.org Mon Aug 6 02:11:46 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 02:11:46 +0200 (CEST) Subject: [Distr-commits] r1250 - branches/distr-2.8/pkg/distrMod/R Message-ID: <20180806001146.914A1187FC5@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 02:11:46 +0200 (Mon, 06 Aug 2018) New Revision: 1250 Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R Log: [distrMod] branch 2.8 + new model class / generator LogisticLocationScaleFamily / typo fixed Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-06 00:09:35 UTC (rev 1249) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-06 00:11:46 UTC (rev 1250) @@ -773,7 +773,7 @@ name = "normal location and scale family", locscalename = lsname, modParam = function(theta) Logis(location = theta[1], scale = theta[2]), - LogDeriv = function(x) (1-exp(x))/(1+exp(x)), + LogDeriv = function(x) (exp(x)-1)/(1+exp(x)), FisherInfo.0 = matrix(c(1/3,0,0,LOGISTINT2),2,2, dimnames = list(lsname, lsname)), distrSymm = SphericalSymmetry(SymmCenter = location), From noreply at r-forge.r-project.org Mon Aug 6 02:24:21 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 02:24:21 +0200 (CEST) Subject: [Distr-commits] r1251 - in branches/distr-2.8/pkg/distrMod: inst man Message-ID: <20180806002421.837A318A319@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 02:24:21 +0200 (Mon, 06 Aug 2018) New Revision: 1251 Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/LogisticLocationScaleFamily.Rd Log: [distrMod] branch 2.8 + new model class / generator LogisticLocationScaleFamily / yet another typo fixed and NEWS updated Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-06 00:11:46 UTC (rev 1250) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-06 00:24:21 UTC (rev 1251) @@ -47,7 +47,7 @@ under the hood: + As this is more for internal purposes, example code for the parsing of dots argument - is in lines ll 256--294 in mleCalc-methods.R (wrapped in a if(FALSE){ }). + is in lines ll 275--334 in mleCalc-methods.R (wrapped in a if(FALSE){ }). + in code in SimpleL2ParamFamilies.R: + param.0 denotes the local current parameter of the L2Family + param is used as function argument Modified: branches/distr-2.8/pkg/distrMod/man/LogisticLocationScaleFamily.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/LogisticLocationScaleFamily.Rd 2018-08-06 00:11:46 UTC (rev 1250) +++ branches/distr-2.8/pkg/distrMod/man/LogisticLocationScaleFamily.Rd 2018-08-06 00:24:21 UTC (rev 1251) @@ -22,7 +22,7 @@ parameteric family are filled. \code{LOGISTINT2} is a constant used for the scale part of the Fisher information. More precisely \code{LOGISTINT2} equals to - \eqn{\int_{-\infty}^{\infty} (\tanh(x/2)\,x-1)^2\,{\rm dlogis}(x)\,dx)}{% + \eqn{\int_{-\infty}^{\infty} (\tanh(x/2)\,x-1)^2\,{\rm dlogis}(x)\,dx}{% integral_{-Inf}^{Inf} (tanh(x/2)x-1)^2 dlogis(x) dx}. } \value{Object of class \code{"L2LocationScaleFamily"}} From noreply at r-forge.r-project.org Mon Aug 6 04:10:36 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 04:10:36 +0200 (CEST) Subject: [Distr-commits] r1252 - in branches/distr-2.8/pkg/distrMod: . R inst man Message-ID: <20180806021036.9AF5118004C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 04:10:35 +0200 (Mon, 06 Aug 2018) New Revision: 1252 Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE branches/distr-2.8/pkg/distrMod/R/AllClass.R branches/distr-2.8/pkg/distrMod/R/MDEstimator.R branches/distr-2.8/pkg/distrMod/R/MLEstimator.R branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/MCEstimate-class.Rd branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd Log: [distrMod] branch 2.8 + new subclasses "MLEstimate", "MDEstimate", "CvMMDEstimate" as return classes of the respective estimators for internal method dispatch Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-06 00:24:21 UTC (rev 1251) +++ branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-06 02:10:35 UTC (rev 1252) @@ -39,7 +39,7 @@ "LnormScaleFamily", "GammaFamily", "BetaFamily", "NormLocationScaleFamily", "CauchyLocationScaleFamily", "LogisticLocationScaleFamily") exportClasses("NormType", "QFNorm", "InfoNorm", "SelfNorm") -exportClasses("Estimate", "MCEstimate") +exportClasses("Estimate", "MCEstimate", "MLEstimate", "MDEstimate", "CvMMDEstimate") exportClasses("Confint") exportMethods("distrSymm") exportMethods("distribution", "props", "props<-", "addProp<-", "main", "main<-", Modified: branches/distr-2.8/pkg/distrMod/R/AllClass.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/AllClass.R 2018-08-06 00:24:21 UTC (rev 1251) +++ branches/distr-2.8/pkg/distrMod/R/AllClass.R 2018-08-06 02:10:35 UTC (rev 1252) @@ -488,6 +488,11 @@ ), contains = "Estimate") + +setClass("MLEstimate", contains="MCEstimate") +setClass("MDEstimate", contains="MCEstimate") +setClass("CvMMDEstimate", contains="MCEstimate") + ## To Do: class MLEstimate which is compatible with class ## mle or maybe class summary.mle of package "stats4" Modified: branches/distr-2.8/pkg/distrMod/R/MDEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-06 00:24:21 UTC (rev 1251) +++ branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-06 02:10:35 UTC (rev 1252) @@ -46,6 +46,9 @@ } } + toClass <- "MDEstimate" + if(distfc %in% c("CvMDist", "CvMDist2")) toClass <- "CvMMDEstimate" + if(paramDepDist) dots$thetaPar <-NULL distanceFctWithoutVal <- function(e1,e2,check.validity=NULL,...) @@ -79,6 +82,7 @@ argList$validity.check <- TRUE argList <- c(argList, x = x) if(any(nmsffx!="")) argList <- c(argList, nmsffx = nmsffx) + argList$toClass <- toClass ## digesting the results of mceCalc res <- do.call(.process.meCalcRes, argList) Modified: branches/distr-2.8/pkg/distrMod/R/MLEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-06 00:24:21 UTC (rev 1251) +++ branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-06 02:10:35 UTC (rev 1252) @@ -51,6 +51,7 @@ if(!is.null(dots)) argList <- c(argList, dots) argList <- c(argList, x = x) if(any(nmsffx!="")) argList <- c(argList, nmsffx = nmsffx) + argList$toClass <- "MLEstimate" ## digesting the results of mceCalc res <- do.call(what = ".process.meCalcRes", args = argList) Modified: branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R 2018-08-06 00:24:21 UTC (rev 1251) +++ branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R 2018-08-06 02:10:35 UTC (rev 1252) @@ -23,7 +23,7 @@ #internal helper ########################################################################## .process.meCalcRes <- function(res, PFam, trafo, res.name, call, - asvar.fct, check.validity, ..., + asvar.fct, check.validity, ..., toClass = "", .withEvalAsVar = TRUE, x = NULL, nmsffx = ""){ lmx <- length(main(PFam)) @@ -139,7 +139,8 @@ if(hasnodim.main & hasnodim.nuis) untransformed.estimate <- .deleteDim(untransformed.estimate) - res.me <- new("MCEstimate", name = est.name, estimate = estimate, + if(missing(toClass)||toClass == "") toClass <- "MCEstimate" + res.me <- new(toClass, name = est.name, estimate = estimate, criterion = crit, asvar = asvar, Infos = Infos, samplesize = res$samplesize, nuis.idx = nuis.idx, estimate.call = call, trafo = traf0, Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-06 00:24:21 UTC (rev 1251) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-06 02:10:35 UTC (rev 1252) @@ -81,7 +81,7 @@ is appended to the default estimator name + based on this tag "( mu = ... )" later on, in pkg RobAStBase, a (conditional) coerce method produces the pIC of the MDE by means of .CvMMDCovariance[WithMux] - ++ new subclasses "MLEstimate", "MDEstimate", "CvMMDEstimate" for internal method dispatch ############## v 2.7 ############## Modified: branches/distr-2.8/pkg/distrMod/man/MCEstimate-class.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MCEstimate-class.Rd 2018-08-06 00:24:21 UTC (rev 1251) +++ branches/distr-2.8/pkg/distrMod/man/MCEstimate-class.Rd 2018-08-06 02:10:35 UTC (rev 1252) @@ -1,6 +1,9 @@ \name{MCEstimate-class} \docType{class} \alias{MCEstimate-class} +\alias{MDEstimate-class} +\alias{MLEstimate-class} +\alias{CvMMDEstimate-class} \alias{criterion} \alias{criterion,MCEstimate-method} \alias{criterion.fct} @@ -23,7 +26,12 @@ \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("MCEstimate", ...)}. More frequently they are created via the generating functions - \code{MCEstimator}, \code{MDEstimator} or \code{MLEstimator}. + \code{MCEstimator}, \code{MDEstimator} or \code{MLEstimator}. + More specifically, \code{MDEstimator}, \code{CvMMDEstimator}, + and \code{MLEstimator} return objects of classes \code{MDEstimate}, + \code{CvMMDEstimate}, and \code{MLEstimate} respectively, which each + are immediate subclasses of \code{MCEstimate} (without further slots, + for internal use in method dispatch). } \section{Slots}{ \describe{ Modified: branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd 2018-08-06 00:24:21 UTC (rev 1251) +++ branches/distr-2.8/pkg/distrMod/man/internalmleHelpers.Rd 2018-08-06 02:10:35 UTC (rev 1252) @@ -15,7 +15,7 @@ \usage{ .negLoglikelihood(x, Distribution, ..., dropZeroDensity = TRUE) .process.meCalcRes(res, PFam, trafo, res.name, call, asvar.fct, check.validity, - ..., .withEvalAsVar = TRUE, x = NULL, nmsffx = "") + ..., toClass="", .withEvalAsVar = TRUE, x = NULL, nmsffx = "") .callParamFamParameter(PFam, theta, idx, nuis, fixed) } @@ -48,6 +48,7 @@ density zero be dropped? Optimizers like \code{optim} require finite values, so get problems when negative loglikelihood is evaluated. } \item{nmsffx}{character: a potential suffix to be appended to the estimator name.} + \item{toClass}{character: if not \code{""} the name of a more specific return class.} } \details{ From noreply at r-forge.r-project.org Mon Aug 6 08:28:03 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 08:28:03 +0200 (CEST) Subject: [Distr-commits] r1253 - in branches/distr-2.8/pkg/distrMod: R inst man Message-ID: <20180806062803.6D923183F53@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 08:28:02 +0200 (Mon, 06 Aug 2018) New Revision: 1253 Modified: branches/distr-2.8/pkg/distrMod/R/AllShow.R branches/distr-2.8/pkg/distrMod/R/MCEstimator.R branches/distr-2.8/pkg/distrMod/R/MDEstimator.R branches/distr-2.8/pkg/distrMod/R/MLEstimator.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/MCEstimator.Rd branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd branches/distr-2.8/pkg/distrMod/man/MLEstimator.Rd Log: [distrMod] branch 2.8: + show-method for ParamWithShapeFamParameter and MCEstimate did unnecessary casting to superclasses hence hid the true class + argument distance did not show it came from CvMDist, CvMDist2 via CvMMDEstiamtor when unparsed -- now the unparsed argument in CvMMDEstimator is called CvMDist0 so shows that it is related to + for later purposes (in RobAStBase to use this to autmatically append pIC information to CvMMDEs and MLEs), .checkEstClassForParamFamily has to "see" the L2Family, so has to be called from the top layer -> controlled by .with.checkEstClassForParamFamily (also a possible point to save time during evaluation ...) Modified: branches/distr-2.8/pkg/distrMod/R/AllShow.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/AllShow.R 2018-08-06 02:10:35 UTC (rev 1252) +++ branches/distr-2.8/pkg/distrMod/R/AllShow.R 2018-08-06 06:28:02 UTC (rev 1253) @@ -82,7 +82,7 @@ setMethod("show", "ParamWithShapeFamParameter", function(object){ - show(as(object,"ParamFamParameter")) + getMethod("show","ParamFamParameter")(object) if(object at withPosRestr) cat(gettext("Shape parameter must not be negative.\n")) }) @@ -259,7 +259,7 @@ setMethod("show", "MCEstimate", function(object){ digits <- getOption("digits") - show(as(object,"Estimate")) + getMethod("show", "Estimate")(object) if(getdistrModOption("show.details")!="minimal"){ cat("Criterion:\n") print(criterion(object), quote = FALSE)} Modified: branches/distr-2.8/pkg/distrMod/R/MCEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MCEstimator.R 2018-08-06 02:10:35 UTC (rev 1252) +++ branches/distr-2.8/pkg/distrMod/R/MCEstimator.R 2018-08-06 06:28:02 UTC (rev 1253) @@ -5,7 +5,7 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., .withEvalAsVar = TRUE, - nmsffx = ""){ + nmsffx = "", .with.checkEstClassForParamFamily = TRUE){ ## preparation: getting the matched call es.call <- match.call() @@ -60,6 +60,7 @@ ## digesting the results of mceCalc res <- do.call(.process.meCalcRes, argList) res at completecases <- completecases - - return(.checkEstClassForParamFamily(ParamFamily,res)) + if(.with.checkEstClassForParamFamily) + res <- .checkEstClassForParamFamily(ParamFamily,res) + return(res) } Modified: branches/distr-2.8/pkg/distrMod/R/MDEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-06 02:10:35 UTC (rev 1252) +++ branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-06 06:28:02 UTC (rev 1253) @@ -6,7 +6,8 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, - ..., .withEvalAsVar = TRUE, nmsffx = ""){ + ..., .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE){ ## preparation: getting the matched call es.call <- match.call() @@ -47,7 +48,7 @@ } toClass <- "MDEstimate" - if(distfc %in% c("CvMDist", "CvMDist2")) toClass <- "CvMMDEstimate" + if(distfc %in% c("CvMDist", "CvMDist2", "CvMDist0")) toClass <- "CvMMDEstimate" if(paramDepDist) dots$thetaPar <-NULL @@ -88,7 +89,9 @@ res <- do.call(.process.meCalcRes, argList) res at completecases <- completecases - return(.checkEstClassForParamFamily(ParamFamily,res)) + if(.with.checkEstClassForParamFamily) + res <- .checkEstClassForParamFamily(ParamFamily,res) + return(res) } CvMMDEstimator <- function(x, ParamFamily, muDatOrMod = c("Dat","Mod", "Other"), @@ -98,23 +101,23 @@ trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct = .CvMMDCovariance, na.rm = TRUE, ..., .withEvalAsVar = TRUE, - nmsffx = ""){ + nmsffx = "", .with.checkEstClassForParamFamily = TRUE){ muDatOrMod <- match.arg(muDatOrMod) if(muDatOrMod=="Dat") { - distance0 <- CvMDist + CvMDist0 <- CvMDist estnsffx <- "( mu = emp. cdf )" if(missing(asvar.fct)) asvar.fct <- .CvMMDCovarianceWithMux }else{ if(muDatOrMod=="Mod") { - distance0 <- CvMDist2 + CvMDist0 <- CvMDist2 estnsffx <- "( mu = model distr. )" if(missing(asvar.fct)) asvar.fct <- .CvMMDCovariance }else{ if(missing(mu)||is.null(mu)) stop(gettextf("This choice of 'muDatOrMod' requires a non-null 'mu'")) muc <- paste(deparse(substitute(mu))) - distance0 <- function(e1,e2,... ) CvMDist(e1, e2, mu = mu, ...) + CvMDist0 <- function(e1,e2,... ) CvMDist(e1, e2, mu = mu, ...) estnsffx <- paste("( mu = ", muc, ")") if(missing(asvar.fct)) asvar.fct <- function(L2Fam, param, N = 400, rel.tol=.Machine$double.eps^0.3, @@ -127,14 +130,17 @@ } } - res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = distance0, + res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = CvMDist0, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, - ..., .withEvalAsVar = .withEvalAsVar) + ..., .withEvalAsVar = .withEvalAsVar, + .with.checkEstClassForParamFamily = FALSE) # print(list(estnsffx, nmsffx)) res at name <- paste("Minimum CvM distance estimate", estnsffx, nmsffx, collapse="") res at estimate.call <- match.call() + if(.with.checkEstClassForParamFamily) + res <- .checkEstClassForParamFamily(ParamFamily,res) return(res) } @@ -142,13 +148,17 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., - .withEvalAsVar = TRUE, nmsffx = ""){ + .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE){ res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = KolmogorovDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, - ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx) + ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx, + .with.checkEstClassForParamFamily = FALSE) res at estimate.call <- match.call() + if(.with.checkEstClassForParamFamily) + res <- .checkEstClassForParamFamily(ParamFamily,res) return(res) } @@ -156,13 +166,17 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., - .withEvalAsVar = TRUE, nmsffx = ""){ + .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE){ res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = TotalVarDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, - ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx) + ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx, + .with.checkEstClassForParamFamily = FALSE) res at estimate.call <- match.call() + if(.with.checkEstClassForParamFamily) + res <- .checkEstClassForParamFamily(ParamFamily,res) return(res) } @@ -170,13 +184,17 @@ startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., - .withEvalAsVar = TRUE, nmsffx = ""){ + .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE){ res <- MDEstimator(x = x, ParamFamily = ParamFamily, distance = HellingerDist, paramDepDist = paramDepDist, startPar = startPar, Infos = Infos, trafo = trafo, penalty = penalty, validity.check = validity.check, asvar.fct = asvar.fct, na.rm = na.rm, - ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx) + ..., .withEvalAsVar = .withEvalAsVar, nmsffx = nmsffx, + .with.checkEstClassForParamFamily = FALSE) res at estimate.call <- match.call() + if(.with.checkEstClassForParamFamily) + res <- .checkEstClassForParamFamily(ParamFamily,res) return(res) } Modified: branches/distr-2.8/pkg/distrMod/R/MLEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-06 02:10:35 UTC (rev 1252) +++ branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-06 06:28:02 UTC (rev 1253) @@ -9,7 +9,7 @@ validity.check = TRUE, na.rm = TRUE, ..., .withEvalAsVar = TRUE, dropZeroDensity = TRUE, - nmsffx = ""){ + nmsffx = "", .with.checkEstClassForParamFamily = TRUE){ ## preparation: getting the matched call es.call <- match.call() @@ -61,5 +61,8 @@ res at name <- "Maximum likelihood estimate" res at completecases <- completecases - return(.checkEstClassForParamFamily(ParamFamily,res)) + if(.with.checkEstClassForParamFamily) + res <- .checkEstClassForParamFamily(ParamFamily,res) + + return(res) } Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-06 02:10:35 UTC (rev 1252) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-06 06:28:02 UTC (rev 1253) @@ -43,7 +43,12 @@ the asyCov was using mu the current best fit model distribution + in the wrappers to MDEstimator: CvMMDEstimator, KolmogorovMDEstimator, TotalVarMDEstimator, HellingerMDEstimator, we had the "wrong" call in slot estimate.call - ++ show-method for ParamWithShapeFamParameter and MCEstimate did unnecessary casting to superclasses + hence hid the true class ++ argument distance did not show it came from CvMDist, CvMDist2 via CvMMDEstiamtor when unparsed -- + now the unparsed argument in CvMMDEstimator is called CvMDist0 so shows that it is related to + CvMDist + under the hood: + As this is more for internal purposes, example code for the parsing of dots argument Modified: branches/distr-2.8/pkg/distrMod/man/MCEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MCEstimator.Rd 2018-08-06 02:10:35 UTC (rev 1252) +++ branches/distr-2.8/pkg/distrMod/man/MCEstimator.Rd 2018-08-06 06:28:02 UTC (rev 1253) @@ -14,7 +14,8 @@ MCEstimator(x, ParamFamily, criterion, crit.name, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, - ..., .withEvalAsVar = TRUE, nmsffx = "") + ..., .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE) } \arguments{ \item{x}{ (empirical) data } @@ -46,6 +47,10 @@ (if \code{asvar.fct} is given) or just the call be returned?} \item{nmsffx}{character: a potential suffix to be appended to the estimator name.} + \item{.with.checkEstClassForParamFamily}{logical: Should a the end of the + function \code{.checkEstClassForParamFamily}; defaults to \code{TRUE}; + can be switched off for computational time or because this is already + checked in a calling wrapper function.} } \details{ The argument \code{criterion} has to be a function with arguments the Modified: branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-06 02:10:35 UTC (rev 1252) +++ branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-06 06:28:02 UTC (rev 1253) @@ -15,21 +15,26 @@ MDEstimator(x, ParamFamily, distance = KolmogorovDist, dist.name, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, - ..., .withEvalAsVar = TRUE, nmsffx = "") + ..., .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE) CvMMDEstimator(x, ParamFamily, muDatOrMod = c("Dat","Mod", "Other"), mu = NULL, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct = .CvMMDCovariance, na.rm = TRUE, ..., - .withEvalAsVar = TRUE, nmsffx = "") + .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE) KolmogorovMDEstimator(x, ParamFamily, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, - na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "") + na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE) TotalVarMDEstimator(x, ParamFamily, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, - na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "") + na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE) HellingerMDEstimator(x, ParamFamily, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct, - na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "") + na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE) CvMDist2(e1,e2,... ) } %- maybe also 'usage' for other objects documented here. @@ -85,6 +90,10 @@ \item{nmsffx}{character: a potential suffix to be appended to the estimator name.} \item{e1}{object of class \code{"Distribution"} or class \code{"numeric"} } \item{e2}{object of class \code{"Distribution"} } + \item{.with.checkEstClassForParamFamily}{logical: Should a the end of the + function \code{.checkEstClassForParamFamily}; defaults to \code{TRUE}; + can be switched off for computational time or because this is already + checked in a calling wrapper function.} } \details{ The argument \code{distance} has to be a (generic) function with arguments Modified: branches/distr-2.8/pkg/distrMod/man/MLEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MLEstimator.Rd 2018-08-06 02:10:35 UTC (rev 1252) +++ branches/distr-2.8/pkg/distrMod/man/MLEstimator.Rd 2018-08-06 06:28:02 UTC (rev 1253) @@ -12,7 +12,8 @@ MLEstimator(x, ParamFamily, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, na.rm = TRUE, ..., - .withEvalAsVar = TRUE, dropZeroDensity = TRUE, nmsffx = "") + .withEvalAsVar = TRUE, dropZeroDensity = TRUE, nmsffx = "", + .with.checkEstClassForParamFamily = TRUE) } %- maybe also 'usage' for other objects documented here. \arguments{ @@ -40,6 +41,10 @@ density zero be dropped? Optimizers like \code{optim} require finite values, so get problems when negative loglikelihood is evaluated. } \item{nmsffx}{character: a potential suffix to be appended to the estimator name.} + \item{.with.checkEstClassForParamFamily}{logical: Should a the end of the + function \code{.checkEstClassForParamFamily}; defaults to \code{TRUE}; + can be switched off for computational time or because this is already + checked in a calling wrapper function.} } \details{ The function uses \code{\link{mleCalc}} From noreply at r-forge.r-project.org Mon Aug 6 14:46:06 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 6 Aug 2018 14:46:06 +0200 (CEST) Subject: [Distr-commits] r1254 - branches/distr-2.8/pkg/distrMod/R Message-ID: <20180806124606.84BC9185631@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-06 14:46:06 +0200 (Mon, 06 Aug 2018) New Revision: 1254 Modified: branches/distr-2.8/pkg/distrMod/R/MDEstimator.R Log: [distrMod] branch 2.8: yet some issues with comparisons of functions (deparse substitute is a dead end...) Modified: branches/distr-2.8/pkg/distrMod/R/MDEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-06 06:28:02 UTC (rev 1253) +++ branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-06 12:46:06 UTC (rev 1254) @@ -13,7 +13,7 @@ es.call <- match.call() dots <- match.call(expand.dots = FALSE)$"..." - distfc <- paste(substitute(distance)) + #distfc <- paste(deparse(substitute(distance))) completecases <- complete.cases(x) if(na.rm) x <- na.omit(x) @@ -23,6 +23,7 @@ stop(gettext("'x' has to be a numeric vector")) if(is.null(startPar)) startPar <- startPar(ParamFamily)(x,...) + isCvM <- FALSE if(missing(dist.name)){ dist.name0 <- names(distance(x, ParamFamily at distribution)) # print(dist.name0) @@ -31,25 +32,30 @@ nmsffx <- paste( gsub(".+distance","",gsub("(.+distance) (.+)","\\2", dist.name0)), nmsffx, collapse=" ") - if(distfc=="CvMDist2"){ + if(isTRUE(all.equal(distance, CvMDist2))){ dist.name <- "CvM distance" nmsffx <- paste("( mu = model distr. )",nmsffx, collapse=" ") + isCvM <- TRUE } - if(distfc=="CvMDist"&&is.null(dots$mu)){ + if(isTRUE(all.equal(distance,CvMDist))&&is.null(dots$mu)){ dist.name <- "CvM distance" nmsffx <- paste("( mu = emp. cdf )",nmsffx, collapse=" ") + isCvM <- TRUE } - if(distfc=="CvMDist"&&!is.null(dots$mu)){ + if(isTRUE(all.equal(distance,CvMDist))&&!is.null(dots$mu)){ muc <- paste(deparse((dots$mu))) dots$mu <- eval(dots$mu) dist.name <- "CvM distance" nmsffx <- paste("( mu = ", muc, ")", nmsffx, collapse=" ") + isCvM <- TRUE } } toClass <- "MDEstimate" - if(distfc %in% c("CvMDist", "CvMDist2", "CvMDist0")) toClass <- "CvMMDEstimate" + if(any(grepl("CvMDist", paste(deparse(substitute(distance)))))) isCvM <- TRUE + if(isCvM) toClass <- "CvMMDEstimate" + if(paramDepDist) dots$thetaPar <-NULL distanceFctWithoutVal <- function(e1,e2,check.validity=NULL,...) From noreply at r-forge.r-project.org Wed Aug 8 01:19:25 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 01:19:25 +0200 (CEST) Subject: [Distr-commits] r1255 - in branches/distr-2.8/pkg/distr: . R inst man Message-ID: <20180807231926.02393180309@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 01:19:25 +0200 (Wed, 08 Aug 2018) New Revision: 1255 Added: branches/distr-2.8/pkg/distr/man/distr-defunct.Rd Removed: branches/distr-2.8/pkg/distr/man/GeomParameter-class.Rd Modified: branches/distr-2.8/pkg/distr/NAMESPACE branches/distr-2.8/pkg/distr/R/AllClasses.R branches/distr-2.8/pkg/distr/R/AllGenerics.R branches/distr-2.8/pkg/distr/R/AllInitialize.R branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R branches/distr-2.8/pkg/distr/R/GeometricDistribution.R branches/distr-2.8/pkg/distr/R/LatticeDistribution.R branches/distr-2.8/pkg/distr/R/MinMaximum.R branches/distr-2.8/pkg/distr/R/Truncate.R branches/distr-2.8/pkg/distr/R/UnivarLebDecDistribution.R branches/distr-2.8/pkg/distr/R/UtilitiesDistributions.R branches/distr-2.8/pkg/distr/R/bAcDcLcDistribution.R branches/distr-2.8/pkg/distr/R/decomposePM.R branches/distr-2.8/pkg/distr/R/flat.R branches/distr-2.8/pkg/distr/R/internalUtils.R branches/distr-2.8/pkg/distr/R/liesInSupport.R branches/distr-2.8/pkg/distr/inst/NEWS branches/distr-2.8/pkg/distr/man/DiscreteDistribution-class.Rd branches/distr-2.8/pkg/distr/man/liesInSupport.Rd Log: + accessor & replacer for prob, GeomParameter are finally Defunct + liesInSupport gains an argument checkFin; in case of DiscreteDistributions, it tries to use additional information from internal slot .finSupport, and e.g. if there is a lattice. + liesInSupport now also is available for UnivarLebDecDistribution, LatticeDistribution, and UnivarMixingDistribution under the hood: + DiscreteDistribution(s) gain a logical slot .finSupport to better control whether the "true" support (not the possibly truncated one in slot support) is infinite (more precisely it is of length 2 -- first coordinate if the lower bound of the support is finite, second if the upper bound is finite) Modified: branches/distr-2.8/pkg/distr/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distr/NAMESPACE 2018-08-06 12:46:06 UTC (rev 1254) +++ branches/distr-2.8/pkg/distr/NAMESPACE 2018-08-07 23:19:25 UTC (rev 1255) @@ -30,7 +30,7 @@ "CauchyParameter", "ChisqParameter", "DiracParameter", "ExpParameter", "FParameter", "GammaParameter", - "HyperParameter", "GeomParameter", + "HyperParameter", "LogisParameter", "LnormParameter", "NbinomParameter", "NormParameter", "PoisParameter", "TParameter", Modified: branches/distr-2.8/pkg/distr/R/AllClasses.R =================================================================== --- branches/distr-2.8/pkg/distr/R/AllClasses.R 2018-08-06 12:46:06 UTC (rev 1254) +++ branches/distr-2.8/pkg/distr/R/AllClasses.R 2018-08-07 23:19:25 UTC (rev 1255) @@ -196,16 +196,17 @@ ## no longer needed: this is a negBinom with size 1 no longer #- ### !!! deprecated as of version 1.9 !!! +## defunct as of 2.8.0 ## ## Class: GeomParameter -setClass("GeomParameter", - representation = representation(prob = "numeric"), - prototype = prototype(prob = 0.5, name = - gettext("Parameter of a Geometric distribution") - ), - contains = "Parameter" - ) -### !!! end of deprecated !!! +#setClass("GeomParameter", +# representation = representation(prob = "numeric"), +# prototype = prototype(prob = 0.5, name = +# gettext("Parameter of a Geometric distribution") +# ), +# contains = "Parameter" +# ) +### !!! end of deprecated !!! of defunct ## Class: CauchyParameter setClass("CauchyParameter", @@ -812,7 +813,7 @@ ## DiscreteDistribution setClass("DiscreteDistribution", - representation = representation(support = "numeric"), + representation = representation(support = "numeric", .finSupport = "logical"), prototype = prototype( r = function(n){ rbinom(n, size=1, prob=0.5) }, d = function(x, log = FALSE) @@ -824,7 +825,8 @@ { qbinom(p, size=1, prob=0.5, lower.tail = lower.tail, log.p = log.p) }, img = new("Reals"), - support = 0:1 + support = 0:1, + .finSupport = c(TRUE,TRUE) ), contains = "UnivariateDistribution" ) @@ -868,7 +870,8 @@ gettext("lattice of a Dirac distribution") ), .logExact = TRUE, - .lowerExact = TRUE + .lowerExact = TRUE, + .finSupport = c(TRUE,TRUE) ), contains = "LatticeDistribution" ) @@ -897,7 +900,8 @@ gettext("lattice of a Poisson distribution") ), .logExact = TRUE, - .lowerExact = TRUE + .lowerExact = TRUE, + .finSupport = c(TRUE,FALSE) ), contains = "LatticeDistribution" ) @@ -933,7 +937,8 @@ ) ), .logExact = TRUE, - .lowerExact = TRUE + .lowerExact = TRUE, + .finSupport = c(TRUE,FALSE) ), contains = "LatticeDistribution" ) @@ -963,7 +968,8 @@ ) ), .logExact = TRUE, - .lowerExact = TRUE + .lowerExact = TRUE, + .finSupport = c(TRUE,TRUE) ), contains = "LatticeDistribution" ) @@ -993,7 +999,8 @@ ) ), .logExact = TRUE, - .lowerExact = TRUE + .lowerExact = TRUE, + .finSupport = c(TRUE,TRUE) ), contains = "LatticeDistribution" ) @@ -1025,7 +1032,8 @@ ) ), .logExact = TRUE, - .lowerExact = TRUE + .lowerExact = TRUE, + .finSupport = c(TRUE, FALSE) ), contains = "Nbinom" ) Modified: branches/distr-2.8/pkg/distr/R/AllGenerics.R =================================================================== --- branches/distr-2.8/pkg/distr/R/AllGenerics.R 2018-08-06 12:46:06 UTC (rev 1254) +++ branches/distr-2.8/pkg/distr/R/AllGenerics.R 2018-08-07 23:19:25 UTC (rev 1255) @@ -300,7 +300,7 @@ setGeneric("liesIn", function(object, x) standardGeneric("liesIn")) if(!isGeneric("liesInSupport")) - setGeneric("liesInSupport", function(object, x) + setGeneric("liesInSupport", function(object, x, checkFin = FALSE) standardGeneric("liesInSupport")) if(!isGeneric("convpow")) setGeneric("convpow", function(D1, ...) standardGeneric("convpow")) Modified: branches/distr-2.8/pkg/distr/R/AllInitialize.R =================================================================== --- branches/distr-2.8/pkg/distr/R/AllInitialize.R 2018-08-06 12:46:06 UTC (rev 1254) +++ branches/distr-2.8/pkg/distr/R/AllInitialize.R 2018-08-07 23:19:25 UTC (rev 1255) @@ -25,17 +25,18 @@ ## PARAMETERS ################################################################################ -setMethod("initialize", "GeomParameter", - function(.Object, prob = .5) { - .Deprecated(new = "new(\"NbinomParameter\"(size = 1, prob, name)", - package = "distr", - msg = gettext( -"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon." - )) - .Object at prob <- prob - .Object at name <- gettext("Parameter of a Geometric distribution") - .Object - }) +# defunct as of 2.8.0 +#setMethod("initialize", "GeomParameter", +# function(.Object, prob = .5) { +# .Deprecated(new = "new(\"NbinomParameter\"(size = 1, prob, name)", +# package = "distr", +# msg = gettext( +#"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon." +# )) +# .Object at prob <- prob +# .Object at name <- gettext("Parameter of a Geometric distribution") +# .Object +# }) ################################################################################ ## DISTRIBUTIONS ################################################################################ @@ -163,6 +164,7 @@ support = NULL, param = NULL, img = new("Reals"), .withSim = FALSE, .withArith = FALSE, .lowerExact = FALSE, .logExact = FALSE, + .finSupport = c(TRUE,TRUE), Symmetry = NoSymmetry()) { ## don't use this if the call is new("DiscreteDistribution") @@ -224,6 +226,7 @@ .Object at .lowerExact <- .lowerExact .Object at .logExact <- .logExact .Object at Symmetry <- Symmetry + .Object at .finSupport <- .finSupport .Object }) @@ -233,14 +236,14 @@ support = NULL, a = 1, b = 0, X0 = Binom(), param = NULL, img = new("Reals"), .withSim = FALSE, .withArith = FALSE, .lowerExact = FALSE, .logExact = FALSE, - Symmetry = NoSymmetry()) { + Symmetry = NoSymmetry(), .finSupport = c(TRUE,TRUE)) { ## don't use this if the call is new("DiscreteDistribution") LL <- length(sys.calls()) if(sys.calls()[[LL-3]] == "new(\"AffLinDiscreteDistribution\")") X <- new("DiscreteDistribution") else X <- new("DiscreteDistribution", r = r, d = d, p = p, q = q, support = support, param = param, img = img, .withSim = .withSim, - .withArith = .withArith) + .withArith = .withArith, .finSupport = .finSupport) .Object at support <- X at support .Object at img <- X at img .Object at param <- X at param @@ -256,6 +259,7 @@ .Object at .lowerExact <- .lowerExact .Object at .logExact <- .logExact .Object at Symmetry <- Symmetry + .Object at .finSupport <- .finSupport .Object }) @@ -265,7 +269,7 @@ support = NULL, lattice = NULL, param = NULL, img = new("Reals"), .withSim = FALSE, .withArith = FALSE, .lowerExact = FALSE, .logExact = FALSE, - Symmetry = NoSymmetry()) { + Symmetry = NoSymmetry(), .finSupport = c(TRUE,TRUE)) { LL <- length(sys.calls()) @@ -274,7 +278,8 @@ else D <- new("DiscreteDistribution", r = r, d = d, p = p, q = q, support = support, param = param, img = img, - .withSim = .withSim, .withArith = .withArith) + .withSim = .withSim, .withArith = .withArith, + .finSupport = .finSupport) OS <- D at support @@ -301,6 +306,7 @@ .Object at .lowerExact <- .lowerExact .Object at .logExact <- .logExact .Object at Symmetry <- Symmetry + .Object at .finSupport <- .finSupport .Object }) @@ -310,7 +316,7 @@ support = NULL, lattice = NULL, a = 1, b = 0, X0 = Binom(), param = NULL, img = new("Reals"), .withSim = FALSE, .withArith = FALSE, .lowerExact = FALSE, .logExact = FALSE, - Symmetry = NoSymmetry()) { + Symmetry = NoSymmetry(), .finSupport = c(TRUE, TRUE)) { LL <- length(sys.calls()) if(sys.calls()[[LL-3]] == "new(\"AffLinLatticeDistribution\")") @@ -318,7 +324,7 @@ else X <- new("LatticeDistribution", r = r, d = d, p = p, q = q, support = support, lattice = lattice, param = param, img = img, .withSim = .withSim, - .withArith = .withArith) + .withArith = .withArith, .finSupport = .finSupport) .Object at support <- X at support .Object at lattice <- X at lattice @@ -336,6 +342,7 @@ .Object at .lowerExact <- .lowerExact .Object at .logExact <- .logExact .Object at Symmetry <- Symmetry + .Object at .finSupport <- .finSupport .Object }) @@ -384,6 +391,7 @@ .Object at lattice <- new("Lattice", pivot = location, width = 1, Length = 1) .Object at .withArith <- .withArith + .Object at .finSupport <- c(TRUE,TRUE)&(location> -Inf & location < Inf) .Object }) @@ -420,6 +428,7 @@ .Object at lattice = new("Lattice", pivot = 0, width = 1, Length = size+1) .Object at .withArith <- .withArith + .Object at .finSupport <- c(TRUE,TRUE) .Object }) @@ -458,6 +467,7 @@ .Object at lattice <- new("Lattice", pivot = 0, width = 1, Length = min(k,m)+1 ) .Object at .withArith <- .withArith + .Object at .finSupport <- c(TRUE,TRUE) .Object }) @@ -495,6 +505,7 @@ .Object at lattice <- new("Lattice", pivot = 0, width = 1, Length = Inf) .Object at .withArith <- .withArith + .Object at .finSupport <- c(TRUE,FALSE) .Object }) @@ -534,6 +545,7 @@ ) .Object at lattice <- new("Lattice", pivot = 0, width = 1, Length = Inf) + .Object at .finSupport <- c(TRUE,FALSE) .Object }) @@ -564,6 +576,7 @@ log.p = log.p) }, list(probSub = prob)) .Object at .withArith <- .withArith + .Object at .finSupport <- c(TRUE,FALSE) .Object }) Modified: branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R =================================================================== --- branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R 2018-08-06 12:46:06 UTC (rev 1254) +++ branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R 2018-08-07 23:19:25 UTC (rev 1255) @@ -237,9 +237,14 @@ W <- sort(abs(c(w1,w2))) if (abs(abs(w1)-abs(w2))1-ep) + } + if(e2<0) Distr at .finSupport <- rev(Distr at .finSupport) + return(Distr) }) setMethod("+", c("DiscreteDistribution","numeric"), function(e1, e2) { Distr <- .plusm(e1,e2, "DiscreteDistribution") @@ -267,7 +279,9 @@ Distr at Symmetry <- SphericalSymmetry(SymmCenter(e1 at Symmetry)+e2) - Distr + isfe2 <- c(e2 >(-Inf), e21-ep) + } + if(e2<0) Distr at .finSupport <- rev(Distr at .finSupport) + return(Distr) }) setMethod("+", c("AffLinDiscreteDistribution","numeric"), function(e1, e2) { @@ -284,7 +305,9 @@ if(is(e1 at Symmetry,"SphericalSymmetry")) Distr at Symmetry <- SphericalSymmetry(SymmCenter(e1 at Symmetry)*e2) - Distr + isfe2 <- c(e2 >(-Inf), e2ep) stop(gettextf("log(%s) is not well-defined with positive probability ", xs)) - else return(.logm.d(x)/basl)}) + else{ + obj <- .logm.d(x)/basl + obj at .finSupport <- c(TRUE, x at .finSupport[2]) + return(obj) + }}) setMethod("log", "Dirac", function(x, base = exp(1)){ @@ -472,6 +507,8 @@ object <- DiscreteDistribution( supp=digamma(support(x)), prob=prob(x), .withArith = TRUE) + + object at .finSupport <- c(TRUE, x at .finSupport[2]) object }) @@ -481,6 +518,7 @@ body(rnew) <- substitute({ lgamma(g(n, ...)) }, list(g = x at r)) object <- new("DiscreteDistribution", r = rnew, .withSim = TRUE, .withArith = TRUE) + object at .finSupport <- c(TRUE, x at .finSupport[2]) object }) @@ -490,6 +528,7 @@ body(rnew) <- substitute({ gamma(g(n, ...)) }, list(g = x at r)) object <- new("DiscreteDistribution", r = rnew, .withSim = TRUE, .withArith = TRUE) + object at .finSupport <- c(TRUE, x at .finSupport[2]) object }) setMethod("sqrt", "DiscreteDistribution", Modified: branches/distr-2.8/pkg/distr/R/GeometricDistribution.R =================================================================== --- branches/distr-2.8/pkg/distr/R/GeometricDistribution.R 2018-08-06 12:46:06 UTC (rev 1254) +++ branches/distr-2.8/pkg/distr/R/GeometricDistribution.R 2018-08-07 23:19:25 UTC (rev 1255) @@ -9,38 +9,45 @@ ### Replaced by NbinomParameter .... ### pre v1.9 /deprecated -setMethod("prob", "GeomParameter", function(object) - {.Deprecated(new = "", - package = "distr", - msg = gettext( -"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon." - ) - ) - object at prob - } - ) -setMethod("prob", "NbinomParameter", function(object) object at prob) +### defunct as of 2.8.0 +#setMethod("prob", "GeomParameter", function(object) +# {.Defunct(new = "", +# package = "distr", +# msg = gettext( +#"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon." +# ) +# ) +# object at prob +# } +# ) +## code is in NegbinomDistribution.R +# setMethod("prob", "NbinomParameter", function(object) object at prob) + + ## Replace Methods ### Replaced by NbinomParameter .... ### pre v1.9: /deprecated -setReplaceMethod("prob", "GeomParameter", - function(object, value) - {.Deprecated(new = "", - package = "distr", - msg = gettext( -"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon." - ) - ) - object at prob <- value; - object}) -setReplaceMethod("prob", "NbinomParameter", - function(object, value) - { object at prob <- value; object} - ) +### defunct as of 2.8.0 +#setReplaceMethod("prob", "GeomParameter", +# function(object, value) +# {.Defunct(new = "", +# package = "distr", +# msg = gettext( +#"Class 'GeomParameter' is no longer needed and will be replaced by \nclass 'NbinomParameter' soon." +# ) +# ) +# object at prob <- value; +# object}) +## code is in NegbinomDistribution.R +#setReplaceMethod("prob", "NbinomParameter", +# function(object, value) +# { object at prob <- value; object} +# ) + ### no longer needed from version 1.9 on #setValidity("GeomParameter", function(object){ # if(length(prob(object)) != 1) Modified: branches/distr-2.8/pkg/distr/R/LatticeDistribution.R =================================================================== --- branches/distr-2.8/pkg/distr/R/LatticeDistribution.R 2018-08-06 12:46:06 UTC (rev 1254) +++ branches/distr-2.8/pkg/distr/R/LatticeDistribution.R 2018-08-07 23:19:25 UTC (rev 1255) @@ -8,6 +8,13 @@ .withArith = FALSE, .withSim = FALSE, DiscreteDistribution = NULL, check = TRUE, Symmetry = NoSymmetry()){ + if(is(lattice,"Lattce")){ + if(width(lattice)>0){ + .finS <- c(TRUE,is.finite(Length(lattice))) + }else{ + .finS <- c(is.finite(Length(lattice)), TRUE) + } + }else .finS <- c(TRUE,TRUE) if (is(DiscreteDistribution, "AffLinDiscreteDistribution")) { D <- DiscreteDistribution if (is(lattice, "Lattice")) @@ -18,12 +25,13 @@ " the support of argument 'DiscreteDistribution'." , sep = "")) } - return(new("AffLinLatticeDistribution", r = D at r, d = D at d, + return(new("AffLinLatticeDistribution", r = D at r, d = D at d, q = D at q, p = D at p, support = D at support, a = D at a, b = D at b, X0 = D at X0, lattice = lattice, .withArith = .withArith, .withSim = .withSim, img = D at img, - param = D at param, Symmetry = Symmetry)) + param = D at param, Symmetry = Symmetry, + .finSupport = .finS)) }else{ if (check){ if( !.is.vector.lattice(support(D))) @@ -36,7 +44,8 @@ a = D at a, b = D at b, X0 = D at X0, .withArith = .withArith, .withSim = .withSim, img = D at img, - param = D at param, Symmetry = Symmetry)) + param = D at param, Symmetry = Symmetry, + .finSupport = .finS)) } } @@ -54,7 +63,8 @@ q = D at q, p = D at p, support = D at support, lattice = lattice, .withArith = .withArith, .withSim = .withSim, img = D at img, - param = D at param, Symmetry = Symmetry)) + param = D at param, Symmetry = Symmetry, + .finSupport = .finS)) }else{ if (check){ if( !.is.vector.lattice(support(D))) @@ -67,7 +77,8 @@ lattice = .make.lattice.es.vector(D at support), .withArith = .withArith, .withSim = .withSim, img = D at img, - param = D at param, Symmetry = Symmetry)) + param = D at param, Symmetry = Symmetry, + .finSupport = .finS)) } } @@ -84,7 +95,8 @@ return(new("LatticeDistribution", r = r(D), d = d(D), q = q.l(D), p = p(D), support = supp, lattice = lattice, .withArith = .withArith, - .withSim = .withSim, Symmetry = Symmetry)) + .withSim = .withSim, Symmetry = Symmetry, + .finSupport = .finS)) } if (is(lattice, "Lattice")) @@ -101,7 +113,8 @@ return(new("LatticeDistribution", r = r(D), d = d(D), q = q.l(D), p = p(D), support = supp, lattice = lattice, .withArith = .withArith, - .withSim = .withSim, Symmetry = Symmetry)) + .withSim = .withSim, Symmetry = Symmetry, + .finSupport = .finS)) }else{ #if (check) stop("Lengths of lattice and probabilities differ.") @@ -120,7 +133,8 @@ return(new("LatticeDistribution", r = r(D), d = d(D), q = q.l(D), p = p(D), support = supp, lattice = lattice, .withArith = .withArith, - .withSim = .withSim, Symmetry = Symmetry)) + .withSim = .withSim, Symmetry = Symmetry, + .finSupport = .finS)) } } }else if (!is.null(supp)) @@ -136,7 +150,8 @@ lattice = .make.lattice.es.vector(D at support), .withArith = D at .withArith, .withSim = D at .withSim, img = D at img, - param = D at param, Symmetry = Symmetry)) + param = D at param, Symmetry = Symmetry, + .finSupport = .finS)) }else stop("Insufficient information given to determine distribution.") } @@ -335,8 +350,10 @@ SymmCenter(e2 at Symmetry)) if( length(supp1) >= 2 * length(supp2)){ - return(DiscreteDistribution(supp = supp2, prob = newd2, - .withArith = TRUE, Symmetry = Symmetry)) + res <- DiscreteDistribution(supp = supp2, prob = newd2, + .withArith = TRUE, Symmetry = Symmetry) + res at .finSupport <- e1 at .finSupport & e2 at .finSupport + return(res) }else{ lat <- Lattice(pivot=supp1[1],width=wa, Length=length(supp1)) @@ -350,6 +367,7 @@ }else{ Lattice(pivot = su12.r, width = -wa, Length = Inf)} } + e0 at .finSupport <- e1 at .finSupport & e2 at .finSupport return(e0) } }) @@ -369,17 +387,19 @@ if(is(e1 at Symmetry,"SphericalSymmetry")) Symmetry <- SphericalSymmetry(SymmCenter(e1 at Symmetry)+e2) - LatticeDistribution(lattice = L, + res <- LatticeDistribution(lattice = L, DiscreteDistribution = Distr, Symmetry = Symmetry, - check = FALSE) + check = FALSE) + res at .finSupport <- e1 at .finSupport & c(e2>(-Inf),(e2=1-ep)) + } + if(e2<0) res at .finSupport <- rev(res at .finSupport) + return(res) } } ) @@ -404,12 +432,14 @@ Symmetry <- NoSymmetry() if(is(e1 at Symmetry,"SphericalSymmetry")) Symmetry <- SphericalSymmetry(SymmCenter(e1 at Symmetry) + e2) - LatticeDistribution(lattice = L, + res <- LatticeDistribution(lattice = L, DiscreteDistribution = as(e1, "AffLinDiscreteDistribution") + e2, Symmetry = Symmetry, check = FALSE) - }) + res at .finSupport <- e1 at .finSupport & c(e2>(-Inf),(e2=1-ep)) + } + if(e2<0) res at .finSupport <- rev(res at .finSupport) + return(res) } } ) Modified: branches/distr-2.8/pkg/distr/R/MinMaximum.R =================================================================== --- branches/distr-2.8/pkg/distr/R/MinMaximum.R 2018-08-06 12:46:06 UTC (rev 1254) +++ branches/distr-2.8/pkg/distr/R/MinMaximum.R 2018-08-07 23:19:25 UTC (rev 1255) @@ -75,7 +75,10 @@ p1 <- p(e1)(supp,lower.tail = FALSE) p2 <- p(e2)(supp,lower.tail = FALSE) d0 <- d1*p2 + d2*p1 + d1*d2 - DiscreteDistribution(supp=supp, prob=d0, .withArith= TRUE) + res <- DiscreteDistribution(supp=supp, prob=d0, .withArith= TRUE) + res at .finSupport <- c(e1 at .finSupport[1]&e2 at .finSupport[1], + e1 at .finSupport[2]|e2 at .finSupport[2]) + res }) setMethod("Minimum", @@ -213,7 +216,9 @@ supp <- support(e1) pnew <- 1 - (p(e1)(supp, lower.tail = FALSE))^e2 dnew <- c(pnew[1],diff(pnew)) - DiscreteDistribution(supp = supp, prob = dnew, .withArith = TRUE) + res <- DiscreteDistribution(supp = supp, prob = dnew, .withArith = TRUE) + res at .finSupport = e1 at .finSupport + res }) setMethod("Minimum", Modified: branches/distr-2.8/pkg/distr/R/Truncate.R =================================================================== --- branches/distr-2.8/pkg/distr/R/Truncate.R 2018-08-06 12:46:06 UTC (rev 1254) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/distr -r 1255 From noreply at r-forge.r-project.org Wed Aug 8 01:47:41 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 01:47:41 +0200 (CEST) Subject: [Distr-commits] r1256 - in branches/distr-2.8/pkg/distrEx: R inst man Message-ID: <20180807234741.1C73E188712@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 01:47:40 +0200 (Wed, 08 Aug 2018) New Revision: 1256 Modified: branches/distr-2.8/pkg/distrEx/R/AllClass.R branches/distr-2.8/pkg/distrEx/R/DiscreteMVDistribution.R branches/distr-2.8/pkg/distrEx/R/liesInSupport.R branches/distr-2.8/pkg/distrEx/inst/NEWS branches/distr-2.8/pkg/distrEx/man/DiscreteMVDistribution-class.Rd branches/distr-2.8/pkg/distrEx/man/liesInSupport.Rd Log: [distrEx] branch 2.8: + DiscreteMVDistribution gains a (matrix valued) slot .FinSupport in analogy to the univariate DiscreteDistribution (idea: coordinatewise checking whether a multivariate observation could, in principle, lie in the support -- the 1st row states whether the ith marginal distribution has a finite left endpoint, and the 2nd row if it is has a finite right endpoint); not yet further used + for consistency to the univariate methods, the liesInSupport() method for DiscreteMVDistribution gains an argument checkFin, which is not yet used. Modified: branches/distr-2.8/pkg/distrEx/R/AllClass.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/AllClass.R 2018-08-07 23:19:25 UTC (rev 1255) +++ branches/distr-2.8/pkg/distrEx/R/AllClass.R 2018-08-07 23:47:40 UTC (rev 1256) @@ -50,11 +50,12 @@ contains = "Distribution") # discrete mulitvariate distribution -setClass("DiscreteMVDistribution", representation(support = "matrix"), +setClass("DiscreteMVDistribution", representation(support = "matrix", .finSupport = "matrix"), prototype(r = function(n){ matrix(rep(c(0,0), n), ncol=2) }, d = NULL, p = NULL, q = NULL, param = NULL, img = new("EuclideanSpace", dimension = 2), - support = matrix(c(0,0), ncol = 2)), + support = matrix(c(0,0), ncol = 2), + .finSupport = matrix(TRUE, nrow=2, ncol = 2)), contains = "MultivariateDistribution") # condition Modified: branches/distr-2.8/pkg/distrEx/R/DiscreteMVDistribution.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/DiscreteMVDistribution.R 2018-08-07 23:19:25 UTC (rev 1255) +++ branches/distr-2.8/pkg/distrEx/R/DiscreteMVDistribution.R 2018-08-07 23:47:40 UTC (rev 1256) @@ -77,7 +77,10 @@ ind <- ind1 & ind2 sum(prob[ind]) } - + + lB <- apply(supp,2,function(x) all(x> (-Inf))) + uB <- apply(supp,2,function(x) all(x< Inf)) + MVD <- new("DiscreteMVDistribution") MVD at r <- rfun MVD at d <- dfun @@ -91,7 +94,8 @@ MVD at .logExact <- TRUE MVD at .lowerExact <- FALSE MVD at Symmetry <- Symmetry - + MVD at .finSupport <- rbind(lB,uB) + return(MVD) } Modified: branches/distr-2.8/pkg/distrEx/R/liesInSupport.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/liesInSupport.R 2018-08-07 23:19:25 UTC (rev 1255) +++ branches/distr-2.8/pkg/distrEx/R/liesInSupport.R 2018-08-07 23:47:40 UTC (rev 1256) @@ -1,6 +1,6 @@ setMethod("liesInSupport", signature(object = "DiscreteMVDistribution", x = "numeric"), - function(object, x){ + function(object, x, checkFin = FALSE){ k <- dimension(img(object)) if(length(x) != k) stop("'x' has wrong dimension") @@ -11,12 +11,12 @@ }) setMethod("liesInSupport", signature(object = "DiscreteMVDistribution", x = "matrix"), - function(object, x){ + function(object, x, checkFin = FALSE){ if(ncol(x) != dimension(img(object))) stop("'x' has wrong dimension") res <- logical(nrow(x)) - for(i in 1:nrow(x)) res[i] <- liesInSupport(object, x[i,]) + for(i in 1:nrow(x)) res[i] <- liesInSupport(object, x[i,], checkFin) return(res) }) Modified: branches/distr-2.8/pkg/distrEx/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-07 23:19:25 UTC (rev 1255) +++ branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-07 23:47:40 UTC (rev 1256) @@ -22,6 +22,13 @@ + cleaned .Rd file E.Rd: It contained still some references to methods for extreme value distributions which are now in RobExtremes and some old mail reference peter.ruckdeschel at uni-bayreuth.de ++ DiscreteMVDistribution gains a (matrix valued) slot .FinSupport in analogy to the + univariate DiscreteDistribution (idea: coordinatewise checking whether a multivariate + observation could, in principle, lie in the support -- the 1st row states + whether the ith marginal distribution has a finite left endpoint, and the + 2nd row if it is has a finite right endpoint); not yet further used ++ for consistency to the univariate methods, the liesInSupport() method for + DiscreteMVDistribution gains an argument checkFin, which is not yet used. ############## v 2.7 Modified: branches/distr-2.8/pkg/distrEx/man/DiscreteMVDistribution-class.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/DiscreteMVDistribution-class.Rd 2018-08-07 23:19:25 UTC (rev 1255) +++ branches/distr-2.8/pkg/distrEx/man/DiscreteMVDistribution-class.Rd 2018-08-07 23:47:40 UTC (rev 1256) @@ -27,6 +27,11 @@ optional quantile function } \item{\code{support}}{ numeric matrix whose rows form the support of the distribution} + \item{\code{.finSupport}}{logical: (later on to be) used internally to check + whether the true support is finite; the element in the 1st row and ith column + indicates whether the ith marginal distribution has a finite left endpoint, + and the element in the 2nd row and ith column if it is has a finite right + endpoint); not yet further used.} \item{\code{.withArith}}{logical: used internally to issue warnings as to interpretation of arithmetics} \item{\code{.withSim}}{logical: used internally to issue warnings as to accuracy} \item{\code{.logExact}}{logical: used internally to flag the case where there are explicit formulae for the Modified: branches/distr-2.8/pkg/distrEx/man/liesInSupport.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/liesInSupport.Rd 2018-08-07 23:19:25 UTC (rev 1255) +++ branches/distr-2.8/pkg/distrEx/man/liesInSupport.Rd 2018-08-07 23:47:40 UTC (rev 1256) @@ -8,12 +8,16 @@ distribution \code{object}. } \usage{ -\S4method{liesInSupport}{DiscreteMVDistribution,numeric}(object, x) -\S4method{liesInSupport}{DiscreteMVDistribution,matrix}(object, x) +\S4method{liesInSupport}{DiscreteMVDistribution,numeric}(object, x, checkFin = FALSE) +\S4method{liesInSupport}{DiscreteMVDistribution,matrix}(object, x, checkFin = FALSE) } \arguments{ \item{object}{ object of class \code{"Distribution"} } \item{x}{ numeric vector or matrix } + \item{checkFin}{ logical: in case \code{FALSE}, we simply check whether + \code{x} lies exactly in the \emph{numerical} support (of finitely many + support points); later on we might try to mimick the univariate case + more closely in case \code{TRUE}, but so far this is not yet used.} } %\details{} \value{logical vector} From noreply at r-forge.r-project.org Wed Aug 8 01:54:32 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 01:54:32 +0200 (CEST) Subject: [Distr-commits] r1257 - branches/distr-2.8/pkg/distr/man Message-ID: <20180807235432.C4E6E18A79C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 01:54:32 +0200 (Wed, 08 Aug 2018) New Revision: 1257 Modified: branches/distr-2.8/pkg/distr/man/DiscreteDistribution-class.Rd Log: [distr] branch 2.8: minor clitch in Rd to DiscreteDistribution-class.Rd Modified: branches/distr-2.8/pkg/distr/man/DiscreteDistribution-class.Rd =================================================================== --- branches/distr-2.8/pkg/distr/man/DiscreteDistribution-class.Rd 2018-08-07 23:47:40 UTC (rev 1256) +++ branches/distr-2.8/pkg/distr/man/DiscreteDistribution-class.Rd 2018-08-07 23:54:32 UTC (rev 1257) @@ -38,7 +38,7 @@ function} \item{\code{.finSupport}}{logical: used internally to check whether the true support is finite; in case \code{img} is one-dimensional, it is - of length 2 (left and right end), otherwise it is of length 1.} + of length 2 (left and right end).} \item{\code{Symmetry}}{object of class \code{"DistributionSymmetry"}; used internally to avoid unnecessary calculations.} } From noreply at r-forge.r-project.org Wed Aug 8 02:03:59 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 02:03:59 +0200 (CEST) Subject: [Distr-commits] r1258 - in branches/distr-2.8/pkg/distrMod: . R Message-ID: <20180808000400.07E1218A23B@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 02:03:59 +0200 (Wed, 08 Aug 2018) New Revision: 1258 Modified: branches/distr-2.8/pkg/distrMod/DESCRIPTION branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R Log: [distrMod] branch 2.8 + require more recent versions of distr, distrEx + the L2derivatives of the SimpleL2ParamFamilies and the L2GroupFamilies now respect restrictions in the support of the underlying distribution: the L2derivatives are 0 whenever the argument x has liesInSupport(distribution,x, checkFin = TRUE) == FALSE (i.e., in discrete distiributions, with a more refined version, extending the checking of the numerically truncated support). Modified: branches/distr-2.8/pkg/distrMod/DESCRIPTION =================================================================== --- branches/distr-2.8/pkg/distrMod/DESCRIPTION 2018-08-07 23:54:32 UTC (rev 1257) +++ branches/distr-2.8/pkg/distrMod/DESCRIPTION 2018-08-08 00:03:59 UTC (rev 1258) @@ -7,7 +7,7 @@ Authors at R: c(person("Matthias", "Kohl", role=c("aut", "cph")), person("Peter", "Ruckdeschel", role=c("cre", "cph"), email="peter.ruckdeschel at uni-oldenburg.de"), person("R Core Team", role = c("ctb", "cph"), comment="for source file 'format.perc'")) -Depends: R(>= 2.14.0), distr(>= 2.5.2), distrEx(>= 2.4), RandVar(>= 0.6.3), MASS, stats4, +Depends: R(>= 2.14.0), distr(>= 2.8.0), distrEx(>= 2.8.0), RandVar(>= 0.6.3), MASS, stats4, methods Imports: startupmsg, sfsmisc, graphics, stats, grDevices Suggests: ismev, evd, Modified: branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R 2018-08-07 23:54:32 UTC (rev 1257) +++ branches/distr-2.8/pkg/distrMod/R/L2GroupFamilies.R 2018-08-08 00:03:59 UTC (rev 1258) @@ -200,7 +200,7 @@ distr.0 <- scale.0*centraldistribution + loc fct <- function(x){} body(fct) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- ((x[inS] - loc.1)/scale*LogDeriv((x[inS] - loc.1)/scale.1)-1)/scale.1 return(y)}, list(loc.1 = loc, scale.1 = scale.0)) @@ -744,12 +744,12 @@ fct1 <- function(x){} fct2 <- function(x){} body(fct1) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- LogDeriv((x[inS] - loc.1)/scale.1)/scale.1 return(y)}, list(loc.1 = mean.0, scale.1 = sd.0)) body(fct2) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- ((x[inS] - loc.1)/scale.1 * LogDeriv((x[inS] - loc.1)/scale.1)-1)/scale.1 return(y)}, Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-07 23:54:32 UTC (rev 1257) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-08 00:03:59 UTC (rev 1258) @@ -31,7 +31,7 @@ distr.0 <- Binom(size = size, prob = prob.0) fct <- function(x){} body(fct) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- (x[inS]-size*prob.1)/(prob.1*(1-prob.1)) return(y)}, list(size = size, prob.1 = prob.0)) @@ -90,7 +90,7 @@ distr.0 <- Pois(lambda=lambda.0) fct <- function(x){} body(fct) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- x[inS]/lambda.1-1 return(y)}, list(lambda.1 = lambda.0)) @@ -153,7 +153,7 @@ fct <- function(x){} body(fct) <- substitute({ y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- (size/prob.1- x[inS]/(1-prob.1)) return(y)}, list(size = size, prob.1 = prob.0)) @@ -217,13 +217,13 @@ fct2 <- function(x){} body(fct2) <- substitute({ y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- (size.1/prob.1- x[inS]/(1-prob.1)) return(y)}, list(size.1 = size.0, prob.1 = prob.0)) body(fct1) <- substitute({ y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- digamma(x[inS]+size.1)-digamma(size.1)+log(prob.1) return(y)}, list(size.1 = size.0, prob.1 = prob.0)) @@ -303,17 +303,17 @@ fct1.2 <- function(x){} fct2 <- function(x){} body(fct1) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- digamma(x[inS]+size.1)-digamma(size.1)+log(prob.1) return(y)}, list(size.1 = size.00, prob.1 = prob.00)) body(fct1.2)<- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- (size.1/prob.1- x[inS]/(1-prob.1)) return(y)}, list(size.1 = size.00, prob.1 = prob.00)) body(fct2) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- (1/prob.1-1)* fct1(x[inS]) - size.1/prob.1^2 * fct1.2(x[inS]) return(y)}, @@ -403,12 +403,12 @@ fct1 <- function(x){} fct2 <- function(x){} body(fct1) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- (x[inS]/scale.1 - shape.1)/scale.1 return(y)}, list(scale.1 = scale.0, shape.1 = shape.0)) body(fct2) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- log(x[inS]/scale.1) - digamma(shape.1) return(y)}, list(scale.1 = scale.0, shape.1 = shape.0)) @@ -500,13 +500,13 @@ fct1 <- function(x){} fct2 <- function(x){} body(fct1) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- log(x[inS])-digamma(shape1.1)+ digamma(shape1.1+shape2.1) return(y)}, list(shape1.1 = shape1.0, shape2.1 = shape2.0)) body(fct2) <- substitute({y <- 0*x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- log(1-x[inS])-digamma(shape2.1)+ digamma(shape1.1+shape2.1) return(y)}, From noreply at r-forge.r-project.org Wed Aug 8 02:04:51 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 02:04:51 +0200 (CEST) Subject: [Distr-commits] r1259 - branches/distr-2.8/pkg/distrMod/inst Message-ID: <20180808000452.028F518A1E7@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 02:04:51 +0200 (Wed, 08 Aug 2018) New Revision: 1259 Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS Log: .. and the NEWS for the last commit Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-08 00:03:59 UTC (rev 1258) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-08 00:04:51 UTC (rev 1259) @@ -13,6 +13,7 @@ user-visible CHANGES: ++ require more recent versions of distr, distrEx + plot methods now return an S3 object of class \code{c("plotInfo","DiagnInfo")}, i.e., a list containing the information needed to produce the respective plot, which at a later stage could be used by different graphic engines (like, e.g. \code{ggplot}) to produce the plot in a different framework. A more detailed description will follow in a subsequent version. @@ -34,7 +35,9 @@ + added some theory/references to help file to MD estimators + the L2derivatives of the SimpleL2ParamFamilies and the L2GroupFamilies now respect restrictions in the support of the underlying distribution: the L2derivatives are 0 - whenever the argument x has liesInSupport(distribution,x) == FALSE + whenever the argument x has liesInSupport(distribution,x, checkFin = TRUE) == FALSE + (i.e., in discrete distiributions, with a more refined version, extending the checking + of the numerically truncated support). + new model class / generator LogisticLocationScaleFamily bug fixes From noreply at r-forge.r-project.org Wed Aug 8 02:55:06 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 02:55:06 +0200 (CEST) Subject: [Distr-commits] r1260 - branches/distr-2.8/pkg/distrMod/R Message-ID: <20180808005506.45A57181058@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 02:55:06 +0200 (Wed, 08 Aug 2018) New Revision: 1260 Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R Log: [distrMod] 2.8 : increase accuracy in Fisher information for Negbinom parameter size Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-08 00:04:51 UTC (rev 1259) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-08 00:55:06 UTC (rev 1260) @@ -187,7 +187,7 @@ } -NbinomwithSizeFamily <- function(size = 1, prob = 0.5, trafo, + NbinomwithSizeFamily <- function(size = 1, prob = 0.5, trafo, withL2derivDistr = TRUE){ name <- "Negative Binomial family" distribution <- Nbinom(size = size, prob = prob) @@ -240,8 +240,8 @@ FisherInfo.fct <- function(param){ prob.0 <- main(param)["prob"] size.0 <- main(param)["size"] - xn <- 0:min(max(support(Nbinom(size = size.0, prob = prob.0))), - qnbinom(1e-6,size=size.0,prob=prob.0,lower.tail=FALSE), + xn <- 1:min(max(max(support(Nbinom(size = size.0, prob = prob.0))), + qnbinom(1e-6,size=size.0,prob=prob.0,lower.tail=FALSE)), 1e5) I11 <- -sum((trigamma(xn+size.0)-trigamma(size.0))*dnbinom(xn,size=size.0,prob=prob.0)) I12 <- -1/prob.0 @@ -338,8 +338,8 @@ mean.0 <- main(param)["mean"] size.0 <- main(param)["size"] prob.00 <- size.0/(size.0+mean.0) - xn <- 0:min(max(support(Nbinom(size = size.0, prob = prob.00))), - qnbinom(1e-6,size=size.0,prob=prob.00,lower.tail=FALSE), + xn <- 1:min(max(max(support(Nbinom(size = size.0, prob = prob.0))), + qnbinom(1e-6,size=size.0,prob=prob.0,lower.tail=FALSE)), 1e5) I11 <- -sum((trigamma(xn+size.0)-trigamma(size.0))*dnbinom(xn,size=size.0,prob=prob.00)) I12 <- -1/prob.00 From noreply at r-forge.r-project.org Wed Aug 8 03:04:11 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 8 Aug 2018 03:04:11 +0200 (CEST) Subject: [Distr-commits] r1261 - in branches/distr-2.8/pkg/distrDoc: inst vignettes Message-ID: <20180808010411.8B9CB189FA8@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-08 03:04:10 +0200 (Wed, 08 Aug 2018) New Revision: 1261 Modified: branches/distr-2.8/pkg/distrDoc/inst/NEWS branches/distr-2.8/pkg/distrDoc/vignettes/distr.Rnw Log: [distrDoc] branch 2.8: + mention the more refined version of liesInSupport in the vignette Modified: branches/distr-2.8/pkg/distrDoc/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrDoc/inst/NEWS 2018-08-08 00:55:06 UTC (rev 1260) +++ branches/distr-2.8/pkg/distrDoc/inst/NEWS 2018-08-08 01:04:10 UTC (rev 1261) @@ -13,6 +13,7 @@ user-visible CHANGES: + DESCRIPTION tag SVNRevision changed to VCS/SVNRevision ++ mention the more refined version of liesInSupport in the vignette ############## v 2.7 Modified: branches/distr-2.8/pkg/distrDoc/vignettes/distr.Rnw =================================================================== --- branches/distr-2.8/pkg/distrDoc/vignettes/distr.Rnw 2018-08-08 00:55:06 UTC (rev 1260) +++ branches/distr-2.8/pkg/distrDoc/vignettes/distr.Rnw 2018-08-08 01:04:10 UTC (rev 1261) @@ -465,7 +465,10 @@ Class \code{DiscreteDistribution} has a slot \code{support}, a vector containing the support of the distribution, which is truncated to the lower/upper \code{TruncQuantile} in case of an infinite support. \code{TruncQuantile} is a -global option of \pkg{distr} described in section~{\ref{options}}. +global option of \pkg{distr} described in section~{\ref{options}}. For version +2.8.0 on, it has an additional internal slot \code{.finSupport} which is a +logical of length 2. The first entry says if the left endpoint of the distribution +is finite, the second if the right endpoint is finite. Also from version 1.9 on, class \code{DiscreteDistribution} has a subclass @@ -1674,7 +1677,10 @@ \subsection[liesInSupport]{\code{liesInSupport}} For all discrete distribution classes, we have methods \code{liesInSupport} to check whether a given vector/ a matrix of points lies in the support of the -distribution. +distribution. From version 2.8.0 on, we have better control on situations +where the true support of the distribution is large/infinite to one or both +sides---before it used \code{support}, which in this case is truncated to +the relevant support points. \subsection[Simulation (in package distrSim)]% {Simulation (in package \pkg{distrSim})} From noreply at r-forge.r-project.org Fri Aug 10 01:29:21 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 01:29:21 +0200 (CEST) Subject: [Distr-commits] r1262 - in branches/distr-2.8/pkg/distrMod: R inst man Message-ID: <20180809232921.6D8A6189B27@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 01:29:20 +0200 (Fri, 10 Aug 2018) New Revision: 1262 Modified: branches/distr-2.8/pkg/distrMod/R/MDEstimator.R branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd Log: [distrMod] branch 2.8: + changed default for CvMMDEstiamtor to variant "Mod" (consistent to fitdistrplus) + extended accuracy in NbinomFamily + bugfix : set.seed(123) xn1 <- rnbinom(100,size=25,prob=0.2) N1.w <- NbinomwithSizeFamily(size = 25, prob = 0.25) x=CvMMDEstimator(xn1,N1.w,.withEvalAsVar=FALSE) Modified: branches/distr-2.8/pkg/distrMod/R/MDEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-08 01:04:10 UTC (rev 1261) +++ branches/distr-2.8/pkg/distrMod/R/MDEstimator.R 2018-08-09 23:29:20 UTC (rev 1262) @@ -100,7 +100,7 @@ return(res) } -CvMMDEstimator <- function(x, ParamFamily, muDatOrMod = c("Dat","Mod", "Other"), +CvMMDEstimator <- function(x, ParamFamily, muDatOrMod = c("Mod", "Dat", "Other"), mu = NULL, paramDepDist = FALSE, startPar = NULL, Infos, Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-08 01:04:10 UTC (rev 1261) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-09 23:29:20 UTC (rev 1262) @@ -272,6 +272,10 @@ NbinomMeanSizeFamily <- function(size = 1, mean = .5, trafo, withL2derivDistr = TRUE){ + + TQ <- getdistrOption("TruncQuantile") + on.exit(distroptions(TruncQuantile=TQ)) + distroptions(TruncQuantile=1e-8) name <- "Negative Binomial family" prob.0 <- size/(size+mean) distribution <- Nbinom(size = size, prob = size/(size+mean)) @@ -338,8 +342,8 @@ mean.0 <- main(param)["mean"] size.0 <- main(param)["size"] prob.00 <- size.0/(size.0+mean.0) - xn <- 1:min(max(max(support(Nbinom(size = size.0, prob = prob.0))), - qnbinom(1e-6,size=size.0,prob=prob.0,lower.tail=FALSE)), + xn <- 1:min(max(max(support(Nbinom(size = size.0, prob = prob.00))), + qnbinom(1e-6,size=size.0,prob=prob.00,lower.tail=FALSE)), 1e5) I11 <- -sum((trigamma(xn+size.0)-trigamma(size.0))*dnbinom(xn,size=size.0,prob=prob.00)) I12 <- -1/prob.00 Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-08 01:04:10 UTC (rev 1261) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-09 23:29:20 UTC (rev 1262) @@ -39,6 +39,7 @@ (i.e., in discrete distiributions, with a more refined version, extending the checking of the numerically truncated support). + new model class / generator LogisticLocationScaleFamily ++ changed default for CvMMDEstiamtor to variant "Mod" (consistent to fitdistrplus) bug fixes + discovered some issues with local variables in L2Families (global values were used instead...) @@ -90,6 +91,7 @@ + based on this tag "( mu = ... )" later on, in pkg RobAStBase, a (conditional) coerce method produces the pIC of the MDE by means of .CvMMDCovariance[WithMux] + new subclasses "MLEstimate", "MDEstimate", "CvMMDEstimate" for internal method dispatch + ############## v 2.7 ############## Modified: branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-08 01:04:10 UTC (rev 1261) +++ branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-09 23:29:20 UTC (rev 1262) @@ -17,7 +17,7 @@ penalty = 1e20, validity.check = TRUE, asvar.fct, na.rm = TRUE, ..., .withEvalAsVar = TRUE, nmsffx = "", .with.checkEstClassForParamFamily = TRUE) -CvMMDEstimator(x, ParamFamily, muDatOrMod = c("Dat","Mod", "Other"), +CvMMDEstimator(x, ParamFamily, muDatOrMod = c("Mod","Dat", "Other"), mu = NULL, paramDepDist = FALSE, startPar = NULL, Infos, trafo = NULL, penalty = 1e20, validity.check = TRUE, asvar.fct = .CvMMDCovariance, na.rm = TRUE, ..., @@ -52,7 +52,7 @@ integration (probability) measure / distribution \code{mu} (corresponding to argument value \code{"Other"}) is to be used; must be one of "Dat" (default) or "Mod" or "Other". - You can specify just the initial letter.} + You can specify just the initial letter; the default is \code{"Mod"}.} \item{mu}{ optional integration (probability) measure for CvM MDE. defaults to \code{NULL} and is ignored in options \code{muDatOrMod} in \code{"Dat"} and \code{"Mod"}; @@ -191,21 +191,21 @@ ## or KolmogorovMDEstimator(x = x, ParamFamily = G) -## von Mises minimum distance estimator with default mu +## von Mises minimum distance estimator with default mu = Mod MDEstimator(x = x, ParamFamily = G, distance = CvMDist) \donttest{ -## von Mises minimum distance estimator with default mu +## von Mises minimum distance estimator with default mu = Mod MDEstimator(x = x, ParamFamily = G, distance = CvMDist, asvar.fct = .CvMMDCovarianceWithMux) ## or CvMMDEstimator(x = x, ParamFamily = G) ## or +CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Mod") + +## or with data based integration measure: CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Dat") -## or with model based integration measure: -CvMMDEstimator(x = x, ParamFamily = G, muDatOrMod="Mod") - ## von Mises minimum distance estimator with mu = N(0,1) MDEstimator(x = x, ParamFamily = G, distance = CvMDist, mu = Norm()) ## or, with asy Var From noreply at r-forge.r-project.org Fri Aug 10 02:00:00 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 02:00:00 +0200 (CEST) Subject: [Distr-commits] r1263 - branches/distr-2.8/pkg/distrMod/R Message-ID: <20180810000000.84153189BCD@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 02:00:00 +0200 (Fri, 10 Aug 2018) New Revision: 1263 Modified: branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R Log: [distrMod] branch 2.8: bugfix failed to be commited last time Modified: branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R 2018-08-09 23:29:20 UTC (rev 1262) +++ branches/distr-2.8/pkg/distrMod/R/internalMleCalc.R 2018-08-10 00:00:00 UTC (rev 1263) @@ -104,8 +104,10 @@ as0 <- if(is(asvar.try,"try-error")) NULL else asvar.try return(as0) } - asvar <- substitute(do.call(asfct, args=c(list(PFam0, param0, ...))), - list(asfct=asvar.tfct, PFam0=PFam, param0=param)) + dots.now <- list(...) + asvar <- substitute(do.call(asfct, args=c(list(PFam0, param0),dots.s)), + list(asfct=asvar.tfct, PFam0=PFam, param0=param, + dots.s = dots.now)) } # print(eval(asvar)) if(.withEvalAsVar) asvar <- eval(asvar) From noreply at r-forge.r-project.org Fri Aug 10 14:53:27 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 14:53:27 +0200 (CEST) Subject: [Distr-commits] r1264 - in branches/distr-2.8/pkg/distrMod: . R inst man Message-ID: <20180810125327.D414A18A7E8@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 14:53:27 +0200 (Fri, 10 Aug 2018) New Revision: 1264 Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE branches/distr-2.8/pkg/distrMod/R/AllReturnClasses.R branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/InternalReturnClasses-class.Rd Log: [distrMod] branch 2.8 + (triggered by examples in asCvMVarianceQtl.R: new model classe / generator for CauchyLocationFamily (the numeric logDeriv was too inexact at the borders) + revised .CvMMDCovariance() to get more performant for discrete distributions / -> thereby corrected an error in the intermediate formulae, which by centering/standarizing of the IC in the end already cancelled out beforehand... but now we are more accurate as to differences in the integration measure mu and the model distribution (important for integration w.r.t. emp. measure) Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-10 00:00:00 UTC (rev 1263) +++ branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-10 12:53:27 UTC (rev 1264) @@ -37,7 +37,7 @@ exportClasses("BinomFamily","PoisFamily", "NormLocationFamily", "NormScaleFamily", "ExpScaleFamily", "LnormScaleFamily", "GammaFamily", "BetaFamily", "NormLocationScaleFamily", - "CauchyLocationScaleFamily", "LogisticLocationScaleFamily") + "CauchyLocationScaleFamily", "LogisticLocationScaleFamily", "CauchyLocationFamily") exportClasses("NormType", "QFNorm", "InfoNorm", "SelfNorm") exportClasses("Estimate", "MCEstimate", "MLEstimate", "MDEstimate", "CvMMDEstimate") exportClasses("Confint") Modified: branches/distr-2.8/pkg/distrMod/R/AllReturnClasses.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/AllReturnClasses.R 2018-08-10 00:00:00 UTC (rev 1263) +++ branches/distr-2.8/pkg/distrMod/R/AllReturnClasses.R 2018-08-10 12:53:27 UTC (rev 1264) @@ -39,6 +39,9 @@ ## Normal location family setClass("NormLocationFamily", contains = "L2LocationFamily") +## Cauchy location family +setClass("CauchyLocationFamily", + contains = "L2LocationFamily") ## Normal scale family setClass("NormScaleFamily", Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-10 00:00:00 UTC (rev 1263) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-10 12:53:27 UTC (rev 1264) @@ -623,7 +623,7 @@ if(missing(trafo)) {trafo <- diag(2) dimnames(trafo) <- list(lsname,lsname)} res <- L2LocationScaleFamily(loc = mean, scale = sd, - name = "normal location and scale family", + name = "normal location and scale family", locscalename = lsname, modParam = function(theta) Norm(mean = theta[1], sd = theta[2]), LogDeriv = function(x) x, @@ -727,6 +727,35 @@ } +################################################################## +## Cauchy location family +################################################################## +CauchyLocationFamily <- function(loc = 0, scale = 1, trafo){ + if(missing(trafo)) trafo <- matrix(1, dimnames=list("loc","loc")) + modParam <- function(theta){} + body(modParam) <- substitute({ Cauchy(loc = theta, scale = scale0) }, + list(scale0 = scale)) + res <- L2LocationFamily(loc = loc, name = "Cauchy location family", + locname = c("loc"="loc"), + centraldistribution = Cauchy(location = 0, scale = scale), + modParam = modParam, + LogDeriv = function(x) 2*x/(x^2+1), + L2derivDistr.0 = Arcsine(), + distrSymm = SphericalSymmetry(SymmCenter = loc), + L2derivSymm = FunSymmList(OddSymmetric(SymmCenter = loc)), + L2derivDistrSymm = DistrSymmList(SphericalSymmetry()), + FisherInfo.0 = matrix(1/2/scale^2, dimnames = list("loc","loc")), + trafo = trafo, .returnClsName = "CauchyLocationFamily") + if(!is.function(trafo)) + f.call <- substitute(CauchyLocationFamily(loc = m, scale = s, + trafo = matrix(Tr, dimnames=list("mean","mean"))), + list(m = loc, s = scale, Tr = trafo)) + else + f.call <- substitute(NormLocationFamily(loc = m, scale = s, trafo = Tr), + list(m = loc, s = scale, Tr = trafo)) + res at fam.call <- f.call + return(res) +} ################################################################## Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-10 00:00:00 UTC (rev 1263) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-10 12:53:27 UTC (rev 1264) @@ -34,6 +34,8 @@ dotsInt[["stop.on.error"]] <- NULL dotsInt[["distr"]] <- NULL + if(missing(TruncQuantile)||TruncQuantile>1e-7) TruncQuantile <- 1e-8 + N.1 <- round(0.2*N) N.3 <- N.1 N.2 <- N-N.1-N.3 @@ -62,10 +64,12 @@ up <- 1-TruncQuantile - if(is(distr,"DiscreteDistribution")) + if(is(distr,"DiscreteDistribution")){ x.seq <-support(distr) - else - {if(is(distr,"AbscontDistribution")){ + if(length(x.seq) > 1000){} + prob <- d(distr)(x.seq) + }else{ + if(is(distr,"AbscontDistribution")){ ## split up the integration range into # .1 = lower tail, .2 mid range, .3 upper tail @@ -96,17 +100,29 @@ x.seq <- seq(low,up, length = N) } } - if(is(mu,"DiscreteDistribution")) + if(is(mu,"DiscreteDistribution")){ x.mu.seq <- support(mu) - else - {if(is(mu,"AbscontDistribution")){ - x.mu.seq0 <- x.seq0 - h0.mu <- h0 - x.mu.seq <- x.seq - x.mu.seq.1 <- x.seq.1 - x.mu.seq.2 <- x.seq.2 - x.mu.seq.3 <- x.seq.3 - x.mu.seq.a <- x.seq.a + if(length(x.mu.seq) > 1000){} + prob.mu <- d(mu)(x.mu.seq) + }else{ + if(is(mu,"AbscontDistribution")){ + + + x.mu.seq0 <- seq(0, 1, length = N1) + h0.mu <- diff(x.mu.seq0[1:2]) + x.mu.seq0.1 <- seq(0, 1, length = N1.1) + h0.mu.1 <- diff(x.mu.seq0.1[1:2]) + x.mu.seq0.2 <- seq(0, 1, length = N1.2) + h0.mu.2 <- diff(x.mu.seq0.2[1:2]) + x.mu.seq <- x.mu.seq0[odd] + x.mu.seq.1 <- low+(1-low)*x.mu.seq0.1/100 + x.mu.seq.3 <- 1-rev(x.mu.seq.1) + x.mu.seq.la <- rev(x.mu.seq.1)[1] + del.mu <- 1-2*(x.mu.seq.la+(h0.mu.1/100+h0.mu.2)/2) + x.mu.seq.2l <- x.mu.seq.la+(h0.mu.1/100+h0.mu.2)/2+del.mu*x.mu.seq0.2 + x.mu.seq.2r <- 1-rev(x.mu.seq.2l) + x.mu.seq.2 <- (x.mu.seq.2l+x.mu.seq.2r)/2 + x.mu.seq.a <- c(x.mu.seq.1[odd.1],x.mu.seq.2[odd.2],x.mu.seq.3[odd.3]) # x.mu.seq.b <- x.seq.b # iN.mu.1 <- iN.1 # iN.mu.2 <- iN.2 @@ -117,7 +133,7 @@ }else{ x.mu.seq <- seq(low, up, length = N) } - } + } L2deriv.0 <- L2deriv(L2Fam)[[1]] # y.seq <- sapply(x.seq, function(x) evalRandVar(L2deriv, x)) @@ -158,22 +174,33 @@ J1 <- do.call(myint, c(list(f=Delta1.q), dotsInt)) Delta.0 <- function(x) Delta1.q(p(distr)(x))-J1 J <- do.call(myint, c(list(f=function(x) (Delta1.q(x)-J1)^2),dotsInt)) +# print(J1) +# print(J) }else{ - L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) - Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) L2x(x,y=Y) + if(is(distr,"DiscreteDistribution")){ + L2x <- sapply(x.seq, function(x) evalRandVar(L2deriv.0, x)) + L2xdx <- L2x*prob + Delta0 <- cumsum(L2xdx) + J1 <- sum(Delta0*prob) + Delta <- Delta0-J1 + J <- sum((Delta)^2*prob) + Delta.0 <- approxfun(x.seq, Delta, yleft = 0, yright = 0) + Delta <- Delta/J + }else{ + L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) + Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) L2x(x,y=Y) return(E(object=distr, fun = fct))}) - Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) - Delta <- Delta1 - if(is(distr,"DiscreteDistribution")) - Delta <- function(x) Delta1(x) * (x %in% support(distr)) - J1 <- E(object=distr, fun = Delta) - Delta.0 <- function(x) Delta(x) - J1 - J <- E(object=distr, fun = function(x) Delta.0(x)^2 ) + Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) + Delta <- Delta1 + J1 <- E(object=distr, fun = Delta) + Delta.0 <- function(x) Delta(x) - J1 + J <- E(object=distr, fun = function(x) Delta.0(x)^2 ) + } } ### CvM-IC phi phi <- function(x) Delta.0(x)/J - +# print(head(sapply(x.seq,phi))) ## obtaining IC psi (formula (51)) if(is(mu,"AbscontDistribution")){ @@ -199,22 +226,40 @@ psi.q1 <- approxfun(x.mu.seq.a, psi0q, yleft = 0, yright = rev(psi0q)[1]) psi <- function(x) psi.q1(p(mu)(x))-psi1 }else{ + if(is(mu,"DiscreteDistribution")&&is(distr,"DiscreteDistribution")){ + if(!all(support(mu)==support(distr))){ + Delta.mu <- sapply(x.mu.seq, phi) + pprob.mu <- sapply(x.mu.seq, p(distr)) + L2x.mu <- sapply(x.mu.seq, function(x) evalRandVar(L2deriv.0, x)) + }else{ + Delta.mu <- sapply(x.mu.seq, phi) + pprob.mu <- cumsum(prob) + L2x.mu <- L2x + } + psi1 <- sum(pprob.mu*Delta.mu*prob.mu) + psi0 <- cumsum(rev(Delta.mu*prob.mu)) +# psi1 <- psi0[1] + psi0 <- rev(psi0)-psi1 + psi <- approxfun(x.mu.seq, psi0, yleft = -psi1, yright = -psi1) +# print(sapply(x.mu.seq,psi)) + }else{ ## integrand phi x Ptheta in formula (51) [ibid] - phi1 <- function(x) phi(x) * p(distr)(x) - psi1 <- E(object = mu, fun = phi1) + phi1 <- function(x) phi(x) * p(distr)(x) + psi1 <- E(object = mu, fun = phi1) - phixy <- function(x,y) (x<=y)*phi(y) - psi0 <- sapply(x.mu.seq, function(X){ fct <- function(y) phixy(x=X,y=y) + phixy <- function(x,y) (x<=y)*phi(y) + psi0 <- sapply(x.mu.seq, function(X){ fct <- function(y) phixy(x=X,y=y) return(E(object=mu, fun = fct))}) - psi.1 <- approxfun(x.mu.seq, psi0, yleft = 0, yright = rev(psi0)[1]) - psi <- function(x) psi.1(x)-psi1 - if(is(distr,"DiscreteDistribution")) - psi <- function(x) (psi.1(x)-psi1) * (x %in% support(mu)) + psi.1 <- approxfun(x.mu.seq, psi0, yleft = 0, yright = rev(psi0)[1]) + psi <- function(x) psi.1(x)-psi1 +# if(is(distr,"DiscreteDistribution")) +# psi <- function(x) (psi.1(x)-psi1) * (x %in% support(mu)) + } } # print(psi0) if(is(distr,"AbscontDistribution")){ psi.q <- function(x){qx <- q.l(distr)(x); return(psi(qx))} - E2 <- do.call(myint, c(list(f=function(x)psi.q(x)^2),dotsInt)) +# E2 <- do.call(myint, c(list(f=function(x)psi.q(x)^2),dotsInt)) E1 <- do.call(myint, c(list(f=psi.q),dotsInt)) E3 <- do.call(myint, c(list(f=function(x){ qx <- q.l(distr)(x) @@ -225,13 +270,23 @@ psi.01 <- function(x) (psi(x)-E1)/E3 E4 <- do.call(myint, c(list(f=function(x) (psi.q(x)-E1)^2/E3^2),dotsInt)) }else{ - E2 <- E(object=distr, fun = function(x) psi(x)^2) - L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) - E1 <- E(object=distr, fun = psi ) - E3 <- E(object=distr, fun = function(x) psi(x)*evalRandVar(L2deriv.0, x)) - psi.0 <- function(x) psi(x) - E1 - psi.01 <- function(x) psi.0(x)/E3 - E4 <- E(object=distr, fun = function(x) psi.01(x)^2) + if(is(distr,"DiscreteDistribution")){ +# E2 <- sum(psi0^2*prob) + psi0 <- sapply(x.seq, psi) + + E1 <- sum(psi0*prob) + E3 <- sum(psi0*L2x*prob) + psi.01d <- (psi0-E1)/E3 + E4 <- sum(psi.01d^2*prob) + psi.01 <- function(x) (psi(x)-E1)/E3*liesInSupport(distr,x) + }else{ +# E2 <- E(object=distr, fun = function(x) psi(x)^2) + L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) + E1 <- E(object=distr, fun = psi ) + E3 <- E(object=distr, fun = function(x) psi(x)*evalRandVar(L2deriv.0, x)) + psi.01 <- function(x) (psi(x) - E1)/E3 + E4 <- E(object=distr, fun = function(x) psi.01(x)^2) + } } ## E2 = Cov_mu (psi) @@ -286,21 +341,32 @@ assign("Delta1.q", Delta1.q, envir=env.i) assign("Delta", Delta, envir=env.i) }else{ - fct0 <- function(x,y) L2deriv.0 at Map[[i]](x)*(x<=y) - Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) fct0(x,y=Y) - return(E(object=distr, fun = fct))}) - Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) - if(is(distr,"DiscreteDistribution")) - Delta <- function(x) Delta1(x) * (x %in% support(distr)) - else Delta <- function(x) Delta1(x) - Map.Delta[[i]] <- Delta - env.i <- environment(Map.Delta[[i]]) <- new.env() - assign("i", i, envir=env.i) - assign("fct", fct, envir=env.i) - assign("fct0", fct0, envir=env.i) - assign("Delta", Delta, envir=env.i) - assign("Delta0", Delta0, envir=env.i) - assign("Delta1", Delta1, envir=env.i) + if(is(distr,"DiscreteDistribution")){ + L2x <- sapply(x.seq, function(x) evalRandVar(L2deriv.0, x)[i]) + L2xdx <- L2x*prob + Delta.0 <- cumsum(L2xdx) + Delta.f <- approxfun(x.seq, Delta.0, yleft = 0, yright = 0) + Map.Delta[[i]] <- function(x) Delta.f(x) + env.i <- environment(Map.Delta[[i]]) <- new.env() + assign("Delta.f", Delta.f, envir=env.i) + assign("Delta.0", Delta.0, envir=env.i) + }else{ + fct0 <- function(x,y) L2deriv.0 at Map[[i]](x)*(x<=y) + Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) fct0(x,y=Y) + return(E(object=distr, fun = fct))}) + Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) + if(is(distr,"DiscreteDistribution")) + Delta <- function(x) Delta1(x) * (x %in% support(distr)) + else Delta <- function(x) Delta1(x) + Map.Delta[[i]] <- Delta + env.i <- environment(Map.Delta[[i]]) <- new.env() + assign("i", i, envir=env.i) + assign("fct", fct, envir=env.i) + assign("fct0", fct0, envir=env.i) + assign("Delta", Delta, envir=env.i) + assign("Delta0", Delta0, envir=env.i) + assign("Delta1", Delta1, envir=env.i) + } } #print(Delta0) if(withplot){ @@ -336,9 +402,17 @@ phi1 <- EuclRandVariable(Map = Map.phi1, Domain = Reals()) psi1 <- E(object=mu, fun = phi1) +# for(i in 1:Dim) +# { Map.phi1[[i]] <- function(x) evalRandVar(phi,x)[i] +# env.i <- environment(Map.phi1[[i]]) <- new.env() +# assign("i", i, envir=env.i) +# } + ## obtaining IC psi (formula (51)) Map.psi <- vector("list",Dim) + + for(i in 1:Dim) { @@ -346,7 +420,8 @@ assign("i", i, envir=env.i) if(is(mu,"AbscontDistribution")){ - fct01.q <- function(x){qx <- q.l(mu)(x); return(phi at Map[[i]](qx))} + fct01.q <- function(x){qx <- q.l(mu)(x); + return(evalRandVar(phi,qx)[i])} #fct0.q <- sapply(rev(x.mu.seq.b),fct01.q) #fct0.q1 <- fct0.q[riN.mu.1] #fct0.q2 <- fct0.q[riN.mu.2] @@ -359,7 +434,7 @@ phi0.q1 <- phi0.q2[1]+h0.mu/100*rev(.csimpsum(fct0.q1)) phi0.q <- c(phi0.q1,phi0.q2,phi0.q3) phi0a.q <- approxfun(x.mu.seq.a, phi0.q, yleft = 0, yright = rev(phi0.q)[1]) - psi0 <- function(x)phi0a.q(p(mu)(x)) + psi0 <- function(x) {phi0a.q(p(mu)(x))-psi1[i]} assign("fct01.q", fct01.q, envir=env.i) assign("fct0.q1", fct0.q1, envir=env.i) @@ -372,22 +447,33 @@ assign("phi0a.q", phi0a.q, envir=env.i) assign("psi0", psi0, envir=env.i) }else{ - fct0 <- function(x,y) evalRandVar(phi, y)[i]*(x<=y) - phi0 <- sapply(x.mu.seq, - function(X){ - fct <- function(y) fct0(x = X, y) - return(E(object = mu, fun = fct)) - }) - phi0a <- approxfun(x.mu.seq, phi0, yleft = 0, yright = rev(phi0)[1]) - if(is(distr,"DiscreteDistribution")) - psi0 <- function(x) phi0a(x) * (x %in% support(mu)) - else psi0 <- function(x) phi0a(x) + if(is(mu,"DiscreteDistribution")){ + phi.mu <- sapply(x.mu.seq, function(x) evalRandVar(phi,x)[i]) + psi0.d <- cumsum(phi.mu*prob.mu) + psi0.a <- approxfun(x.mu.seq, psi0.d, yleft = 0, yright = 0) + psi0 <- function(x) psi0.a(x) + assign("phi.mu", phi.mu, envir=env.i) + assign("psi0.a", psi0.a, envir=env.i) + assign("psi0.d", psi0.d, envir=env.i) + assign("psi0", psi0, envir=env.i) + }else{ + fct0 <- function(x,y) evalRandVar(phi, y)[i]*(x<=y) + phi0 <- sapply(x.mu.seq, + function(X){ + fct <- function(y) fct0(x = X, y) + return(E(object = mu, fun = fct)) + }) + phi0a <- approxfun(x.mu.seq, phi0, yleft = 0, yright = rev(phi0)[1]) + if(is(distr,"DiscreteDistribution")) + psi0 <- function(x) phi0a(x) * (x %in% support(mu)) + else psi0 <- function(x) phi0a(x) - assign("fct", fct, envir=env.i) - assign("fct0", fct0, envir=env.i) - assign("phi0", phi0, envir=env.i) - assign("phi0a", phi0a, envir=env.i) - assign("psi0", psi0, envir=env.i) + assign("fct", fct, envir=env.i) + assign("fct0", fct0, envir=env.i) + assign("phi0", phi0, envir=env.i) + assign("phi0a", phi0a, envir=env.i) + assign("psi0", psi0, envir=env.i) + } } # env.i0 <- environment(phi1) <- new.env() @@ -397,6 +483,7 @@ environment(Map.psi[[i]]) <- env.i } +# print(Map.psi) psi <- EuclRandVariable(Map = Map.psi, Domain = Reals()) E2 <- E(object=distr, fun = psi %*%t(psi)) @@ -421,6 +508,23 @@ E4 <- PosSemDefSymmMatrix(E4) psi <- EuclRandVarList(psi.01) + + if(onedim){ + fct1 <- psi[[1]]@Map[[1]] + psi[[1]]@Map[[1]] <- function(x) fct1(x)*liesInSupport(distr,x,checkFin=TRUE) + }else{ + fctl <- vector("list",Dim) + for(i in 1:Dim){ + fcti <- psi[[1]]@Map[[i]] + fctl[[i]] <- function(x) fcti(x)*liesInSupport(distr,x,checkFin=TRUE) + env.i <- environment(fctl[[i]]) <- new.env() + assign("i", i, env.i) + assign("distr", distr, env.i) + assign("fcti", fcti, env.i) + assign("psi", psi, env.i) + } + psi[[1]]@Map <- fctl + } nms <- names(c(main(param(L2Fam)),nuisance(param(L2Fam)))) dimnames(E4) = list(nms,nms) if(withpreIC) return(list(preIC=psi, Var=E4)) @@ -538,6 +642,7 @@ ### CvM-IC phi phi <- function(x) Delta.0(x)/J +# print(head(sapply(x.seq,phi))) ## integrand phi x Ptheta in formula (51) [ibid] phi1 <- function(x) phi(x) * p(distr)(x) @@ -557,10 +662,12 @@ } # print(psi0) psi.1 <- approxfun(x.mu.seq, psi0, yleft = 0, yright = rev(psi0)[1]) - if(is(distr,"DiscreteDistribution")) + if(is(mu,"DiscreteDistribution")) psi <- function(x) (psi.1(x)-psi1) * (x %in% support(mu)) else psi <- function(x) psi.1(x)-psi1 +# print(sapply(x.mu.seq,psi)) + E2 <- E(object=distr, fun = function(x) psi(x)^2) L2deriv <- L2Fam at L2deriv[[1]] ## E2 = Cov_mu (psi) @@ -723,7 +830,7 @@ N0 <- NormLocationFamily(); .CvMMDCovariance(N0,par=ParamFamParameter("",0), withplot=TRUE, N = 200) .oldCvMMDCovariance(N0,par=ParamFamParameter("",0), withplot=TRUE, N = 200) -C0 <- L2LocationFamily(central=Cauchy()) +C0 <- CauchyLocationFamily() .oldCvMMDCovariance(C0,par=ParamFamParameter("",0), withplot=TRUE, N = 200) .CvMMDCovariance(C0,par=ParamFamParameter("",0), withplot=TRUE, N = 200) N1 <- NormScaleFamily() @@ -775,8 +882,23 @@ system.time(print(.CvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=4.3))))) system.time(print(.oldCvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=0.3))))) system.time(print(.CvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=0.3))))) - +system.time(print(.oldCvMMDCovariance(P0,par=ParamFamParameter("lambda",1),mu=Norm()))) +system.time(print(.CvMMDCovariance(P0,par=ParamFamParameter("lambda",1),mu=Norm()))) +system.time(print(.oldCvMMDCovariance(Nb,par=ParamFamParameter(main=c(size=2.3,prob=0.3)),mu=Norm()))) +system.time(print(.CvMMDCovariance(Nb,par=ParamFamParameter(main=c(size=2.3,prob=0.3)),mu=Norm()))) +set.seed(123) +x <- rnorm(100) +diF <- DiscreteDistribution(x) +system.time(print(.oldCvMMDCovariance(N0,par=ParamFamParameter("",0),mu=diF))) +system.time(print(.CvMMDCovariance(N0,par=ParamFamParameter("",0),mu=diF))) +system.time(print(.oldCvMMDCovariance(NS,par=paramP,mu=diF))) +system.time(print(.CvMMDCovariance(NS,par=paramP,mu=diF))) +IC <- .CvMMDCovariance(N0,par=ParamFamParameter("",0),withpreIC=TRUE)$preIC +sapply(c(-1e8,-3,0,0.1,1,2,1e8), function(x) evalRandVar(IC[[1]],x)) +IC <- .CvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=4.3)),withpreIC=TRUE)$preIC +sapply(c(-1e8,-3,0,0.1,1,2,1e8), function(x) evalRandVar(IC[[1]],x)) +IC <- .CvMMDCovariance(P0,par=ParamFamParameter("lambda",1),withpreIC=TRUE)$preIC +sapply(c(-1e8,-3,0,0.1,1,2,1e8), function(x) evalRandVar(IC[[1]],x)) +IC <- .CvMMDCovariance(Nb,par=ParamFamParameter(main=c(size=2.3,prob=0.3)),withpreIC=TRUE)$preIC +sapply(c(-1e8,-3,0,0.1,1,2,1e8), function(x) evalRandVar(IC[[1]],x)) } - - - Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-10 00:00:00 UTC (rev 1263) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-10 12:53:27 UTC (rev 1264) @@ -38,7 +38,7 @@ whenever the argument x has liesInSupport(distribution,x, checkFin = TRUE) == FALSE (i.e., in discrete distiributions, with a more refined version, extending the checking of the numerically truncated support). -+ new model class / generator LogisticLocationScaleFamily ++ new model classes / generators LogisticLocationScaleFamily, CauchyLocationFamily + changed default for CvMMDEstiamtor to variant "Mod" (consistent to fitdistrplus) bug fixes @@ -70,6 +70,11 @@ otherwise they are not; correspondingly "x" is passed on to .process.meCalcRes in MCEstimator(), MDEstimator(), MLEstimator(). + old .CvMMDCovariance() becomes .oldCvMMDCovariance ++ revised .CvMMDCovariance() to get more performant for discrete distributions / + -> thereby corrected an error in the intermediate formulae, which by + centering/standarizing of the IC in the end already cancelled out beforehand... + but now we are more accurate as to differences in the integration measure mu + and the model distribution (important for integration w.r.t. emp. measure) + new wrapper .CvMMDCovarianceWithMux which uses emp cdf as mu + new wrappe CvMDist2 which by default uses model distribution as mu + CvMMDEstimator gains argument muDatOrMod = c("Dat","Mod") to distinguish two cases Modified: branches/distr-2.8/pkg/distrMod/man/InternalReturnClasses-class.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/InternalReturnClasses-class.Rd 2018-08-10 00:00:00 UTC (rev 1263) +++ branches/distr-2.8/pkg/distrMod/man/InternalReturnClasses-class.Rd 2018-08-10 12:53:27 UTC (rev 1264) @@ -12,6 +12,7 @@ \alias{GParetoFamily-class} \alias{BetaFamily-class} \alias{NormLocationScaleFamily-class} +\alias{CauchyLocationFamily-class} \alias{CauchyLocationScaleFamily-class} \alias{LogisticLocationScaleFamily-class} @@ -24,7 +25,7 @@ \code{BinomFamily}, \code{PoisFamily}, \code{GammaFamily}, \code{BetaFamily}, and class \code{GParetoFamily} ``extending'' (no new slots!) class \code{L2ParamFamily} (the latter via \code{L2ScaleShapeUnion}), -class \code{NormLocationFamily}, +class \code{NormLocationFamily}, class \code{CauchyLocationFamily} ``extending'' (no new slots!) class \code{"L2LocationFamily"}, classes \code{NormScaleFamily}, \code{ExpScaleFamily}, and \code{LnormScaleFamily} ``extending'' (no new slots!) class \code{"L2ScaleFamily"}, and classes @@ -119,8 +120,8 @@ Class \code{"ParamFamily"}, by class \code{"L2ParamFamily"}.\cr Class \code{"ProbFamily"}, by class \code{"ParamFamily"}. \cr -Class \code{NormLocationFamily}, -``extends'' (no new slots!):\cr +Class \code{NormLocationFamily}, class \code{CauchyLocationFamily} +``extend'' (no new slots!):\cr Class \code{"L2LocationFamily"}, directly.\cr Class \code{"L2LocationScaleUnion"}, by class \code{"L2LocationFamily"}.\cr Class \code{"L2GroupParamFamily"}, by class \code{"L2LocationScaleUnion"}.\cr From noreply at r-forge.r-project.org Fri Aug 10 15:55:48 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 15:55:48 +0200 (CEST) Subject: [Distr-commits] r1265 - in branches/distr-2.8/pkg/distrEx: R inst man Message-ID: <20180810135548.A3A2B18A7F8@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 15:55:48 +0200 (Fri, 10 Aug 2018) New Revision: 1265 Modified: branches/distr-2.8/pkg/distrEx/R/Expectation.R branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R branches/distr-2.8/pkg/distrEx/inst/NEWS branches/distr-2.8/pkg/distrEx/man/E.Rd Log: [distrEx] + the Cauchy distribution now also uses quantile integration Modified: branches/distr-2.8/pkg/distrEx/R/Expectation.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-10 12:53:27 UTC (rev 1264) +++ branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-10 13:55:48 UTC (rev 1265) @@ -467,8 +467,8 @@ ### source: https://mathworld.wolfram.com/BinomialDistribution.html -setMethod("E", signature(object = "Cauchy", - fun = "missing", +setMethod("E", signature(object = "Cauchy", + fun = "missing", cond = "missing"), function(object, low = NULL, upp = NULL, ...){ if(is.null(low) && is.null(upp)) @@ -476,16 +476,16 @@ else{ if(is.null(low)) low <- -Inf if(is.null(upp)) upp <- Inf - if(low == -Inf){ + if(low == -Inf){ if(upp == Inf) return(NA) else return(-Inf) }else{ - return(if(upp == Inf) - Inf else - E(as(object,"AbscontDistribution"), low=low, upp=upp,...)) + return(if(upp == Inf) Inf else{ + getMethod("E", signature(object = "Cauchy", + fun = "function", cond = "missing"))(object, + fun=function(x)(xlow)*1.0,...)}) } } -# return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...)) }) ### source https://mathworld.wolfram.com/CauchyDistribution.html Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-10 12:53:27 UTC (rev 1264) +++ branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-10 13:55:48 UTC (rev 1265) @@ -98,3 +98,18 @@ IQR.fac = IQR.fac, ..., .withLeftTail = TRUE, .withRightTail = TRUE) }) + + +setMethod("E", signature(object = "Cauchy", fun = "function", cond = "missing"), + function(object, fun, low = NULL, upp = NULL, + rel.tol= getdistrExOption("ErelativeTolerance"), + lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), + upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ... + ){ + .qtlIntegrate(object = object, fun = fun, low = low, upp = upp, + rel.tol= rel.tol, lowerTruncQuantile = lowerTruncQuantile, + upperTruncQuantile = upperTruncQuantile, + IQR.fac = IQR.fac, ..., + .withLeftTail = TRUE, .withRightTail = TRUE) + }) Modified: branches/distr-2.8/pkg/distrEx/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-10 12:53:27 UTC (rev 1264) +++ branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-10 13:55:48 UTC (rev 1265) @@ -16,7 +16,8 @@ under the hood: + moved quantile integration methods for expectation for Weibull and - Gamma distribution from pkg RobExtremes to distrEx + Gamma distribution from pkg RobExtremes to distrEx; this is now also used + for Cauchy distributions + introduce exported helper function .qtlIntegrate to achieve this (is reused in RobExtremes for the GEV methods there) + cleaned .Rd file E.Rd: It contained still some references to methods Modified: branches/distr-2.8/pkg/distrEx/man/E.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-10 12:53:27 UTC (rev 1264) +++ branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-10 13:55:48 UTC (rev 1265) @@ -62,6 +62,7 @@ \alias{E,Weibull,missing,missing-method} \alias{E,Gammad,function,missing-method} \alias{E,Weibull,function,missing-method} +\alias{E,Cauchy,function,missing-method} \alias{.qtlIntegrate} \title{Generic Function for the Computation of (Conditional) Expectations} @@ -194,6 +195,11 @@ \S4method{E}{Beta,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Binom,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Cauchy,missing,missing}(object, low = NULL, upp = NULL, ...) +\S4method{E}{Weibull,function,missing}(object, fun, low = NULL, upp = NULL, + rel.tol = getdistrExOption("ErelativeTolerance"), + lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), + upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), + IQR.fac = max(1e4,getdistrExOption("IQR.fac")), ...) \S4method{E}{Chisq,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{Dirac,missing,missing}(object, low = NULL, upp = NULL, ...) \S4method{E}{DExp,missing,missing}(object, low = NULL, upp = NULL, ...) @@ -267,11 +273,12 @@ expectation; no conditioning with respect to \code{low <= object <= upp} is done. - For the Gamma and Weibull distribution for integration with missing argument - \code{cond} but given argument \code{fun}, we use integration on [0,1] - (i.e, via the respective probability transformation). This done via helper + For the Cauchy, the Gamma and Weibull distribution for integration with + missing argument \code{cond} but given argument \code{fun}, we use + integration on [0,1] (i.e, via the respective probability transformation). + This done via helper function \code{.qtlIntegrate}, where both arguments \code{.withLeftTail} - and \code{.withRightTail} are \code{TRUE} for the Gamma distribution, + and \code{.withRightTail} are \code{TRUE} for the Cauchy and Gamma distributions, and only \code{.withRightTail} ist \code{TRUE} for the Weibull distribution. } From noreply at r-forge.r-project.org Fri Aug 10 16:04:24 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 16:04:24 +0200 (CEST) Subject: [Distr-commits] r1266 - in branches/distr-2.8/pkg: distr distr/man distrDoc distrDoc/man distrEx distrEx/man distrMod distrMod/man Message-ID: <20180810140424.3EBC718A7F8@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 16:04:23 +0200 (Fri, 10 Aug 2018) New Revision: 1266 Added: branches/distr-2.8/pkg/distrMod/man/CauchyLocationFamily.Rd Modified: branches/distr-2.8/pkg/distr/DESCRIPTION branches/distr-2.8/pkg/distr/man/0distr-package.Rd branches/distr-2.8/pkg/distrDoc/DESCRIPTION branches/distr-2.8/pkg/distrDoc/man/0distrDoc-package.Rd branches/distr-2.8/pkg/distrEx/DESCRIPTION branches/distr-2.8/pkg/distrEx/man/0distrEx-package.Rd branches/distr-2.8/pkg/distrMod/DESCRIPTION branches/distr-2.8/pkg/distrMod/NAMESPACE branches/distr-2.8/pkg/distrMod/man/0distrMod-package.Rd branches/distr-2.8/pkg/distrMod/man/CauchyLocationScaleFamily.Rd Log: [distrMod] branch 2.8: forgot to export the CauchyLocationFamily in rev1264 [distr, distrEx, distrMod, distrDoc] branch 2.8: updated date&rev information in DESCRIPTION and similar Modified: branches/distr-2.8/pkg/distr/DESCRIPTION =================================================================== --- branches/distr-2.8/pkg/distr/DESCRIPTION 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distr/DESCRIPTION 2018-08-10 14:04:23 UTC (rev 1266) @@ -1,6 +1,6 @@ Package: distr Version: 2.8.0 -Date: 2018-07-08 +Date: 2018-08-10 Title: Object Oriented Implementation of Distributions Description: S4-classes and methods for distributions. Authors at R: c(person("Florian", "Camphausen", role="ctb", comment="contributed as student in the @@ -20,4 +20,4 @@ URL: http://distr.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1171 +VCS/SVNRevision: 1265 Modified: branches/distr-2.8/pkg/distr/man/0distr-package.Rd =================================================================== --- branches/distr-2.8/pkg/distr/man/0distr-package.Rd 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distr/man/0distr-package.Rd 2018-08-10 14:04:23 UTC (rev 1266) @@ -52,14 +52,14 @@ \tabular{ll}{ Package: \tab distr \cr Version: \tab 2.8.0 \cr -Date: \tab 2018-07-08 \cr +Date: \tab 2018-08-10 \cr Depends: \tab R(>= 2.14.0), methods, graphics, startupmsg, sfsmisc \cr Suggests: \tab distrEx, svUnit (>= 0.7-11) \cr Imports: \tab stats, grDevices, utils, MASS \cr LazyLoad: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://distr.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1171 \cr +VCS/SVNRevision: \tab 1265 \cr }} Modified: branches/distr-2.8/pkg/distrDoc/DESCRIPTION =================================================================== --- branches/distr-2.8/pkg/distrDoc/DESCRIPTION 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distrDoc/DESCRIPTION 2018-08-10 14:04:23 UTC (rev 1266) @@ -1,9 +1,9 @@ Package: distrDoc Version: 2.8.0 -Date: 2018-07-08 +Date: 2018-08-10 Title: Documentation for 'distr' Family of R Packages -Description: Provides documentation in form of a common vignette to packages 'distr', 'distrEx', - 'distrMod', 'distrSim', 'distrTEst', 'distrTeach', and 'distrEllipse'. +Description: Provides documentation in form of a common vignette to packages 'distr', + 'distrEx', 'distrMod', 'distrSim', 'distrTEst', 'distrTeach', and 'distrEllipse'. Authors at R: c(person("Florian", "Camphausen", role="ctb", comment="contributed as student to the documented packages in the initial phase --2005"), person("Matthias", "Kohl", role=c("aut", "cph")), person("Peter", "Ruckdeschel", role=c("cre", "cph"), @@ -21,4 +21,4 @@ URL: http://distr.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1171 +VCS/SVNRevision: 1265 Modified: branches/distr-2.8/pkg/distrDoc/man/0distrDoc-package.Rd =================================================================== --- branches/distr-2.8/pkg/distrDoc/man/0distrDoc-package.Rd 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distrDoc/man/0distrDoc-package.Rd 2018-08-10 14:04:23 UTC (rev 1266) @@ -14,7 +14,7 @@ \tabular{ll}{ Package: \tab distrDoc \cr Version: \tab 2.8.0 \cr -Date: \tab 2018-07-08 \cr +Date: \tab 2018-08-10 \cr Depends: \tab R(>= 2.14.0) \cr Imports: \tab distr(>= 2.2.0), distrEx(>= 2.2.0), distrSim(>= 2.2.0), distrTEst(>= 2.2.0), distrTeach(>= 2.2.0), RandVar(>= 0.7), distrMod(>= 2.2.0), MASS, methods, @@ -23,7 +23,7 @@ ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://distr.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1171 \cr +VCS/SVNRevision: \tab 1265 \cr }} Modified: branches/distr-2.8/pkg/distrEx/DESCRIPTION =================================================================== --- branches/distr-2.8/pkg/distrEx/DESCRIPTION 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distrEx/DESCRIPTION 2018-08-10 14:04:23 UTC (rev 1266) @@ -1,6 +1,6 @@ Package: distrEx Version: 2.8.0 -Date: 2018-07-08 +Date: 2018-08-10 Title: Extensions of Package 'distr' Description: Extends package 'distr' by functionals, distances, and conditional distributions. Depends: R(>= 2.10.0), methods, distr(>= 2.2) @@ -15,4 +15,4 @@ URL: http://distr.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1171 +VCS/SVNRevision: 1265 Modified: branches/distr-2.8/pkg/distrEx/man/0distrEx-package.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/0distrEx-package.Rd 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distrEx/man/0distrEx-package.Rd 2018-08-10 14:04:23 UTC (rev 1266) @@ -28,14 +28,14 @@ \tabular{ll}{ Package: \tab distrEx \cr Version: \tab 2.8.0 \cr -Date: \tab 2018-07-08 \cr +Date: \tab 2018-08-10 \cr Depends: \tab R(>= 2.10.0), methods, distr(>= 2.2) \cr Imports: \tab startupmsg, utils, stats \cr Suggests: \tab tcltk \cr LazyLoad: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://distr.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1171 \cr +VCS/SVNRevision: \tab 1265 \cr } } \section{Classes}{ Modified: branches/distr-2.8/pkg/distrMod/DESCRIPTION =================================================================== --- branches/distr-2.8/pkg/distrMod/DESCRIPTION 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distrMod/DESCRIPTION 2018-08-10 14:04:23 UTC (rev 1266) @@ -1,6 +1,6 @@ Package: distrMod Version: 2.8.0 -Date: 2018-07-08 +Date: 2018-08-10 Title: Object Oriented Implementation of Probability Models Description: Implements S4 classes for probability models based on packages 'distr' and 'distrEx'. @@ -18,4 +18,4 @@ URL: http://distr.r-forge.r-project.org/ LastChangedDate: {$LastChangedDate$} LastChangedRevision: {$LastChangedRevision$} -VCS/SVNRevision: 1171 +VCS/SVNRevision: 1265 Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-10 14:04:23 UTC (rev 1266) @@ -82,7 +82,7 @@ "NormScaleFamily", "ExpScaleFamily", "LnormScaleFamily", "GammaFamily", "BetaFamily", "NormLocationScaleFamily", "CauchyLocationScaleFamily", "NbinomwithSizeFamily", "NbinomMeanSizeFamily", - "LogisticLocationScaleFamily") + "LogisticLocationScaleFamily", "CauchyLocationFamily") export("asCov", "trAsCov", "asHampel", "asBias", "asMSE", "asUnOvShoot", "fiCov", "trFiCov", "fiHampel", "fiMSE", "fiBias", "fiUnOvShoot") export("positiveBias", "negativeBias", "symmetricBias", Modified: branches/distr-2.8/pkg/distrMod/man/0distrMod-package.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/0distrMod-package.Rd 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distrMod/man/0distrMod-package.Rd 2018-08-10 14:04:23 UTC (rev 1266) @@ -16,7 +16,7 @@ \tabular{ll}{ Package: \tab distrMod \cr Version: \tab 2.8.0 \cr -Date: \tab 2018-07-08 \cr +Date: \tab 2018-08-10 \cr Depends: \tab R(>= 2.14.0), distr(>= 2.5.2), distrEx(>= 2.4), RandVar(>= 0.6.3), MASS, stats4, methods \cr Imports: \tab startupmsg, sfsmisc, graphics, stats, grDevices \cr @@ -25,7 +25,7 @@ ByteCompile: \tab yes \cr License: \tab LGPL-3 \cr URL: \tab http://distr.r-forge.r-project.org/\cr -VCS/SVNRevision: \tab 1171 \cr +VCS/SVNRevision: \tab 1265 \cr }} \section{Classes}{ Added: branches/distr-2.8/pkg/distrMod/man/CauchyLocationFamily.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/CauchyLocationFamily.Rd (rev 0) +++ branches/distr-2.8/pkg/distrMod/man/CauchyLocationFamily.Rd 2018-08-10 14:04:23 UTC (rev 1266) @@ -0,0 +1,38 @@ +\name{CauchyLocationFamily} +\alias{CauchyLocationFamily} + +\title{Generating function for Cauchy location families} +\description{ + Generates an object of class \code{"L2LocationFamily"} which + represents a Cauchy location family. +} +\usage{ +CauchyLocationFamily(loc = 0, scale = 1, trafo) +} +\arguments{ + \item{loc}{ location } + \item{scale}{ scale } + \item{trafo}{ function in \code{param} or matrix: transformation of the parameter } +} +\details{ + The slots of the corresponding L2 differentiable + parameteric family are filled. +} +\value{Object of class \code{"L2LocationScaleFamily"}} +\references{ + Kohl, M. (2005) \emph{Numerical Contributions to + the Asymptotic Theory of Robustness}. Bayreuth: Dissertation. +} +\author{Peter Ruckdeschel \email{Peter.Ruckdeschel at uni-oldenburg.de}} +%\note{} +\seealso{\code{\link{L2ParamFamily-class}}, \code{\link[distr]{Cauchy-class}}} +\examples{ +(C1 <- CauchyLocationFamily()) +plot(C1) +FisherInfo(C1) +### need smaller integration range: +checkL2deriv(C1) +} +\concept{Cauchy location and scale model} +\concept{location and scale model} +\keyword{models} Modified: branches/distr-2.8/pkg/distrMod/man/CauchyLocationScaleFamily.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/CauchyLocationScaleFamily.Rd 2018-08-10 13:55:48 UTC (rev 1265) +++ branches/distr-2.8/pkg/distrMod/man/CauchyLocationScaleFamily.Rd 2018-08-10 14:04:23 UTC (rev 1266) @@ -4,7 +4,7 @@ \title{Generating function for Cauchy location and scale families} \description{ Generates an object of class \code{"L2LocationScaleFamily"} which - represents a normal location and scale family. + represents a Cauchy location and scale family. } \usage{ CauchyLocationScaleFamily(loc = 0, scale = 1, trafo) From noreply at r-forge.r-project.org Fri Aug 10 19:37:37 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 19:37:37 +0200 (CEST) Subject: [Distr-commits] r1267 - in branches/distr-2.8/pkg/distr: R inst Message-ID: <20180810173738.0435418A81D@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 19:37:37 +0200 (Fri, 10 Aug 2018) New Revision: 1267 Modified: branches/distr-2.8/pkg/distr/R/AllInitialize.R branches/distr-2.8/pkg/distr/inst/NEWS Log: [distr] branch 2.8 + changed definition of q(DExp(..)) in initialize method in AllInitialize.R from ifelse expressions to index operations to avoid warnings Modified: branches/distr-2.8/pkg/distr/R/AllInitialize.R =================================================================== --- branches/distr-2.8/pkg/distr/R/AllInitialize.R 2018-08-10 14:04:23 UTC (rev 1266) +++ branches/distr-2.8/pkg/distr/R/AllInitialize.R 2018-08-10 17:37:37 UTC (rev 1267) @@ -909,17 +909,12 @@ body(.Object at q) <- substitute( { if (log.p) p <- exp(p) if (!lower.tail) p <- 1-p - ifelse( p <= 0.25, - -qexp(2*p, rate = rateSub, lower.tail =FALSE), - ifelse( p <= 0.5, - -qexp(1-2*p, rate = rateSub), - ifelse( p <= 0.75 , - qexp(2*p - 1, rate = rateSub), - qexp(2*(1-p), rate = rateSub, - lower.tail = FALSE) - ) - ) - ) + q0 <- p + q0[p <=0.25] <- -qexp(2*p[p <=0.25], rate = rateSub, lower.tail =FALSE) + q0[p>0.25&p<=.50] <- -qexp(1-2*p[p>0.25&p<=.50], rate = rateSub) + q0[p>0.5&p<=.75] <- qexp(2*p[p>0.5&p<=.75] - 1, rate = rateSub) + q0[p>0.75] <- qexp(2*(1-p[p>0.75]), rate = rateSub, lower.tail = FALSE) + return(q0) }, list(rateSub = rate) ) .Object at .withSim <- FALSE Modified: branches/distr-2.8/pkg/distr/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-10 14:04:23 UTC (rev 1266) +++ branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-10 17:37:37 UTC (rev 1267) @@ -26,7 +26,9 @@ "true" support (not the possibly truncated one in slot support) is infinite (more precisely it is of length 2 -- first coordinate if the lower bound of the support is finite, second if the upper bound is finite) - ++ changed definition of q(DExp(..)) in initialize method in AllInitialize.R + from ifelse expressions to index operations to avoid warnings + ############## v 2.7 ############## From noreply at r-forge.r-project.org Fri Aug 10 19:47:04 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 10 Aug 2018 19:47:04 +0200 (CEST) Subject: [Distr-commits] r1268 - in branches/distr-2.8/pkg/distrMod: R man tests/Examples Message-ID: <20180810174705.024CB18A320@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-10 19:47:04 +0200 (Fri, 10 Aug 2018) New Revision: 1268 Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R branches/distr-2.8/pkg/distrMod/man/internals.Rd branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save Log: [distrMod] branch 2.8 + tuned .CvMMDCovariance() in asCvMVarianceQtl.R for speed (like with kStepEstimator timings are taken in comment ##-t-##) as the function .CvMMDCovariance was much slower than .oldCvMMDCovariance for Generalized EVD with Mu Unknown... / now they are at equal there Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-10 17:37:37 UTC (rev 1267) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-10 17:47:04 UTC (rev 1268) @@ -1,5 +1,5 @@ .CvMMDCovarianceWithMux <- function(L2Fam, param, withplot = FALSE, withpreIC = FALSE, - N = 400, rel.tol=.Machine$double.eps^0.3, + N = 1021, rel.tol=.Machine$double.eps^0.3, TruncQuantile = getdistrOption("TruncQuantile"), IQR.fac = 15, ..., x=NULL){ mu <- distribution(L2Fam) @@ -21,7 +21,7 @@ # via quantile transformation .CvMMDCovariance<- function(L2Fam, param, mu = distribution(L2Fam), withplot = FALSE, withpreIC = FALSE, - N = 400, rel.tol=.Machine$double.eps^0.3, + N = 1021, rel.tol=.Machine$double.eps^0.3, TruncQuantile = getdistrOption("TruncQuantile"), IQR.fac = 15, ...){ @@ -89,13 +89,6 @@ x.seq.2r <- 1-rev(x.seq.2l) x.seq.2 <- (x.seq.2l+x.seq.2r)/2 x.seq.a <- c(x.seq.1[odd.1],x.seq.2[odd.2],x.seq.3[odd.3]) -# x.seq.b <- c(x.seq.1,x.seq.2,x.seq.3) -# iN.1 <- 1:N1.1 -# iN.2 <- N1.1+(1:N1.2) -# iN.3 <- N1.1+N1.2+(1:N1.3) -# riN.3 <- 1:N1.3 -# riN.2 <- N1.3+1:N1.2 -# riN.1 <- N1.3+N1.2+1:N1.1 }else{ x.seq <- seq(low,up, length = N) } @@ -123,13 +116,10 @@ x.mu.seq.2r <- 1-rev(x.mu.seq.2l) x.mu.seq.2 <- (x.mu.seq.2l+x.mu.seq.2r)/2 x.mu.seq.a <- c(x.mu.seq.1[odd.1],x.mu.seq.2[odd.2],x.mu.seq.3[odd.3]) -# x.mu.seq.b <- x.seq.b -# iN.mu.1 <- iN.1 -# iN.mu.2 <- iN.2 -# iN.mu.3 <- iN.3 -# riN.mu.1 <- riN.1 -# riN.mu.2 <- riN.2 -# riN.mu.3 <- riN.3 + x.mu.seq.b <- c(x.mu.seq.1,x.mu.seq.2,x.mu.seq.3) + iN.mu.1 <- seq(N1.1) + iN.mu.2 <- N1.1+seq(N1.2) + iN.mu.3 <- N1.1+N1.2+seq(N1.3) }else{ x.mu.seq <- seq(low, up, length = N) } @@ -159,10 +149,6 @@ fqx <- function(x){qx <- q.l(distr)(x) return(sapply(qx,function(y)evalRandVar(L2deriv.0, y))) } - #Delta0x <- sapply(x.seq.b,fqx) - #Delta0x.1 <- Delta0x[iN.1] - #Delta0x.2 <- Delta0x[iN.2] - #Delta0x.3 <- Delta0x[iN.3] Delta0x.1 <- sapply(x.seq.1,fqx) Delta0x.2 <- sapply(x.seq.2,fqx) Delta0x.3 <- sapply(x.seq.3,fqx) @@ -174,8 +160,6 @@ J1 <- do.call(myint, c(list(f=Delta1.q), dotsInt)) Delta.0 <- function(x) Delta1.q(p(distr)(x))-J1 J <- do.call(myint, c(list(f=function(x) (Delta1.q(x)-J1)^2),dotsInt)) -# print(J1) -# print(J) }else{ if(is(distr,"DiscreteDistribution")){ L2x <- sapply(x.seq, function(x) evalRandVar(L2deriv.0, x)) @@ -211,10 +195,6 @@ phiqx <- function(x){qx <- q.l(mu)(x) return(phi(qx))} - #psi0qx <- sapply(rev(x.mu.seq.b), phiqx) - #psi0qx.1 <- psi0qx[riN.mu.1] - #psi0qx.2 <- psi0qx[riN.mu.2] - #psi0qx.3 <- psi0qx[riN.mu.3] psi0qx.1 <- sapply(rev(x.mu.seq.1), phiqx) psi0qx.2 <- sapply(rev(x.mu.seq.2), phiqx) psi0qx.3 <- sapply(rev(x.mu.seq.3), phiqx) @@ -224,7 +204,7 @@ psi0q <- c(psi0q.1,psi0q.2,psi0q.3) psi.q1 <- approxfun(x.mu.seq.a, psi0q, yleft = 0, yright = rev(psi0q)[1]) - psi <- function(x) psi.q1(p(mu)(x))-psi1 + psi.fct <- function(x) psi.q1(p(mu)(x))-psi1 }else{ if(is(mu,"DiscreteDistribution")&&is(distr,"DiscreteDistribution")){ if(!all(support(mu)==support(distr))){ @@ -238,10 +218,8 @@ } psi1 <- sum(pprob.mu*Delta.mu*prob.mu) psi0 <- cumsum(rev(Delta.mu*prob.mu)) -# psi1 <- psi0[1] psi0 <- rev(psi0)-psi1 - psi <- approxfun(x.mu.seq, psi0, yleft = -psi1, yright = -psi1) -# print(sapply(x.mu.seq,psi)) + psi.fct <- approxfun(x.mu.seq, psi0, yleft = -psi1, yright = -psi1) }else{ ## integrand phi x Ptheta in formula (51) [ibid] phi1 <- function(x) phi(x) * p(distr)(x) @@ -251,56 +229,57 @@ psi0 <- sapply(x.mu.seq, function(X){ fct <- function(y) phixy(x=X,y=y) return(E(object=mu, fun = fct))}) psi.1 <- approxfun(x.mu.seq, psi0, yleft = 0, yright = rev(psi0)[1]) - psi <- function(x) psi.1(x)-psi1 -# if(is(distr,"DiscreteDistribution")) -# psi <- function(x) (psi.1(x)-psi1) * (x %in% support(mu)) + psi.fct <- function(x) psi.1(x)-psi1 } } # print(psi0) if(is(distr,"AbscontDistribution")){ - psi.q <- function(x){qx <- q.l(distr)(x); return(psi(qx))} + psi.q <- function(x){qx <- q.l(distr)(x); return(psi.fct(qx))} + ## E2 = Cov_mu (psi) # E2 <- do.call(myint, c(list(f=function(x)psi.q(x)^2),dotsInt)) E1 <- do.call(myint, c(list(f=psi.q),dotsInt)) E3 <- do.call(myint, c(list(f=function(x){ qx <- q.l(distr)(x) L2qx <- sapply(qx,function(y) evalRandVar(L2deriv.0, y)) - return(psi(qx)*L2qx) + return(psi.fct(qx)*L2qx) }), dotsInt)) - psi.01 <- function(x) (psi(x)-E1)/E3 + psi.01.f <- function(x) (psi.fct(x)-E1)/E3 E4 <- do.call(myint, c(list(f=function(x) (psi.q(x)-E1)^2/E3^2),dotsInt)) }else{ if(is(distr,"DiscreteDistribution")){ + ## E2 = Cov_mu (psi) # E2 <- sum(psi0^2*prob) - psi0 <- sapply(x.seq, psi) + psi0 <- sapply(x.seq, psi.fct) E1 <- sum(psi0*prob) E3 <- sum(psi0*L2x*prob) psi.01d <- (psi0-E1)/E3 E4 <- sum(psi.01d^2*prob) - psi.01 <- function(x) (psi(x)-E1)/E3*liesInSupport(distr,x) + psi.01.f <- function(x) (psi.fct(x)-E1)/E3*liesInSupport(distr,x) }else{ + ## E2 = Cov_mu (psi) # E2 <- E(object=distr, fun = function(x) psi(x)^2) L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) - E1 <- E(object=distr, fun = psi ) - E3 <- E(object=distr, fun = function(x) psi(x)*evalRandVar(L2deriv.0, x)) - psi.01 <- function(x) (psi(x) - E1)/E3 - E4 <- E(object=distr, fun = function(x) psi.01(x)^2) + E1 <- E(object=distr, fun = psi.fct ) + E3 <- E(object=distr, fun = function(x) psi.fct(x)*evalRandVar(L2deriv.0, x)) + psi.01.f <- function(x) (psi.fct(x) - E1)/E3 + E4 <- E(object=distr, fun = function(x) psi.01.f(x)^2) } } - ## E2 = Cov_mu (psi) # ### control: centering & standardization if(withplot) { dev.new() #windows() x0.seq <- x.seq if(is(distr,"AbscontDistribution")) x0.seq <- q.l(distr)(x.seq) - plot(x0.seq, psi.01(x0.seq), + plot(x0.seq, psi.01.f(x0.seq), type = if(is(distr,"DiscreteDistribution")) "p" else "l") } - psi.01 <- EuclRandVariable(Map = list(psi.01), Domain = Reals()) + psi.01 <- EuclRandVariable(Map = list(psi.01.f), Domain = Reals()) + }else{ ## multivariate case @@ -314,32 +293,18 @@ for(i in 1:Dim) { if(is(distr,"AbscontDistribution")){ - #fct0.q <- sapply(x.seq.b, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) - #fct0.q1 <- fct0.q[iN.1] - #fct0.q2 <- fct0.q[iN.2] - #fct0.q3 <- fct0.q[iN.3] fct0.q1 <- sapply(x.seq.1, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) fct0.q2 <- sapply(x.seq.2, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) fct0.q3 <- sapply(x.seq.3, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) - #print(fct0) Delta0.q1 <- h0/100*.csimpsum(fct0.q1) Delta0.q2 <- rev(Delta0.q1)[1]+h0*.csimpsum(fct0.q2) Delta0.q3 <- rev(Delta0.q2)[1]+h0/100*.csimpsum(fct0.q3) Delta0.q <- c(Delta0.q1,Delta0.q2,Delta0.q3) Delta1.q <- approxfun(x.seq.a, Delta0.q, yleft = 0, yright = 0) - Delta <- function(x) Delta1.q(p(distr)(x)) - Map.Delta[[i]] <- Delta + Map.Delta[[i]] <- function(x) Delta1.q(p(distr)(x)) env.i <- environment(Map.Delta[[i]]) <- new.env() assign("i", i, envir=env.i) - assign("fct0.q1", fct0.q1, envir=env.i) - assign("fct0.q2", fct0.q2, envir=env.i) - assign("fct0.q3", fct0.q3, envir=env.i) - assign("Delta0.q1", Delta0.q1, envir=env.i) - assign("Delta0.q2", Delta0.q2, envir=env.i) - assign("Delta0.q3", Delta0.q3, envir=env.i) - assign("Delta0.q", Delta0.q, envir=env.i) assign("Delta1.q", Delta1.q, envir=env.i) - assign("Delta", Delta, envir=env.i) }else{ if(is(distr,"DiscreteDistribution")){ L2x <- sapply(x.seq, function(x) evalRandVar(L2deriv.0, x)[i]) @@ -384,9 +349,14 @@ ## J = Var_Ptheta Delta +##-t-## print(system.time({ J1 <- E(object=distr, fun = Delta) +##-t-## })) Delta.0 <- Delta - J1 + +##-t-## print(system.time({ J <- E(object=distr, fun = Delta.0 %*%t(Delta.0)) +##-t-## })) ### CvM-IC phi phi <- as(solve(J)%*%Delta.0,"EuclRandVariable") @@ -394,25 +364,21 @@ Map.phi1 <- vector("list",Dim) for(i in 1:Dim) - { Map.phi1[[i]] <- function(x) evalRandVar(phi,x)[i] * p(distr)(x) + { Map.phi1[[i]] <- function(x) phi at Map[[i]](x)* p(distr)(x) env.i <- environment(Map.phi1[[i]]) <- new.env() assign("i", i, envir=env.i) } phi1 <- EuclRandVariable(Map = Map.phi1, Domain = Reals()) +##-t-## print(system.time({ psi1 <- E(object=mu, fun = phi1) +##-t-## })) -# for(i in 1:Dim) -# { Map.phi1[[i]] <- function(x) evalRandVar(phi,x)[i] -# env.i <- environment(Map.phi1[[i]]) <- new.env() -# assign("i", i, envir=env.i) -# } - - ## obtaining IC psi (formula (51)) Map.psi <- vector("list",Dim) +##-t-## print(system.time({ for(i in 1:Dim) { @@ -420,29 +386,20 @@ assign("i", i, envir=env.i) if(is(mu,"AbscontDistribution")){ - fct01.q <- function(x){qx <- q.l(mu)(x); - return(evalRandVar(phi,qx)[i])} - #fct0.q <- sapply(rev(x.mu.seq.b),fct01.q) - #fct0.q1 <- fct0.q[riN.mu.1] - #fct0.q2 <- fct0.q[riN.mu.2] - #fct0.q3 <- fct0.q[riN.mu.3] - fct0.q1 <- sapply(rev(x.mu.seq.1),fct01.q) - fct0.q2 <- sapply(rev(x.mu.seq.2),fct01.q) - fct0.q3 <- sapply(rev(x.mu.seq.3),fct01.q) + qxm <- q.l(mu)(x.mu.seq.b) + +##-t-## print(system.time({ + fct0.qq <- sapply(qxm, phi at Map[[i]]) +##-t-## })) + fct0.q1 <- rev(fct0.qq[iN.mu.1]) + fct0.q2 <- rev(fct0.qq[iN.mu.2]) + fct0.q3 <- rev(fct0.qq[iN.mu.3]) phi0.q3 <- h0.mu/100*rev(.csimpsum(fct0.q3)) phi0.q2 <- phi0.q3[1]+h0.mu*rev(.csimpsum(fct0.q2)) phi0.q1 <- phi0.q2[1]+h0.mu/100*rev(.csimpsum(fct0.q1)) phi0.q <- c(phi0.q1,phi0.q2,phi0.q3) phi0a.q <- approxfun(x.mu.seq.a, phi0.q, yleft = 0, yright = rev(phi0.q)[1]) psi0 <- function(x) {phi0a.q(p(mu)(x))-psi1[i]} - - assign("fct01.q", fct01.q, envir=env.i) - assign("fct0.q1", fct0.q1, envir=env.i) - assign("fct0.q2", fct0.q2, envir=env.i) - assign("fct0.q3", fct0.q3, envir=env.i) - assign("phi0.q1", phi0.q1, envir=env.i) - assign("phi0.q2", phi0.q2, envir=env.i) - assign("phi0.q3", phi0.q3, envir=env.i) assign("phi0.q", phi0.q, envir=env.i) assign("phi0a.q", phi0a.q, envir=env.i) assign("psi0", psi0, envir=env.i) @@ -476,23 +433,25 @@ } } -# env.i0 <- environment(phi1) <- new.env() -# assign("i", i, envir=env.i0) - Map.psi[[i]] <- psi0 environment(Map.psi[[i]]) <- env.i } +##-t-## })) # print(Map.psi) psi <- EuclRandVariable(Map = Map.psi, Domain = Reals()) - E2 <- E(object=distr, fun = psi %*%t(psi)) +# E2 <- E(object=distr, fun = psi %*%t(psi)) ## E2 = Cov_mu (psi) ### control: centering & standardization L2deriv.0 <- L2Fam at L2deriv[[1]] +##-t-## print(system.time({ E1 <- E(object=distr, fun = psi ) +##-t-## })) +##-t-## print(system.time({ E3 <- E(object=distr, fun = psi %*%t(L2deriv.0)) +##-t-## })) psi.0 <- psi - E1 psi.01 <- as(solve(E3)%*%psi.0,"EuclRandVariable") if(withplot) @@ -503,15 +462,22 @@ plot(x0.mu.seq, sapply(x0.mu.seq,psi.01 at Map[[i]]), type = if(is(distr,"DiscreteDistribution")) "p" else "l") }} +##-t-## print(system.time({ E4 <- E(object=distr, fun = psi.01 %*%t(psi.01)) +##-t-## })) } E4 <- PosSemDefSymmMatrix(E4) psi <- EuclRandVarList(psi.01) - if(onedim){ - fct1 <- psi[[1]]@Map[[1]] - psi[[1]]@Map[[1]] <- function(x) fct1(x)*liesInSupport(distr,x,checkFin=TRUE) + fctl <- vector("list",1) + fct1 <- psi.01 at Map[[1]] + fctl[[1]] <- function(x) fct1(x)*liesInSupport(distr,x,checkFin=TRUE) + env.1 <- environment(fctl[[1]]) <- new.env() + assign("distr", distr, env.1) + assign("fct1", fct1, env.1) + assign("psi", psi, env.1) + psi[[1]]@Map <- fctl }else{ fctl <- vector("list",Dim) for(i in 1:Dim){ @@ -573,7 +539,6 @@ up1.mu <- m0.mu + IQR.fac * s0.mu low.mu <- max(low0.mu,low1.mu); up.mu <- min(up0.mu,up1.mu) - if(is(distr,"DiscreteDistribution")) x.seq <-support(distr) else @@ -738,9 +703,13 @@ ## J = Var_Ptheta Delta +##-t-## print(system.time({ J1 <- E(object=distr, fun = Delta) +##-t-## })) Delta.0 <- Delta - J1 +##-t-## print(system.time({ J <- E(object=distr, fun = Delta.0 %*%t(Delta.0)) +##-t-## })) ### CvM-IC phi phi <- as(solve(J)%*%Delta.0,"EuclRandVariable") @@ -754,7 +723,9 @@ } phi1 <- EuclRandVariable(Map = Map.phi1, Domain = Reals()) +##-t-## print(system.time({ psi1 <- E(object=mu, fun = phi1) +##-t-## })) ## obtaining IC psi (formula (51)) @@ -793,13 +764,19 @@ } psi <- EuclRandVariable(Map = Map.psi, Domain = Reals()) +##-t-## print(system.time({ E2 <- E(object=distr, fun = psi %*%t(psi)) +##-t-## })) ## E2 = Cov_mu (psi) ### control: centering & standardization L2deriv <- L2Fam at L2deriv[[1]] +##-t-## print(system.time({ E1 <- E(object=distr, fun = psi ) +##-t-## })) +##-t-## print(system.time({ E3 <- E(object=distr, fun = psi %*%t(L2deriv)) +##-t-## })) psi.0 <- psi - E1 psi.01 <- as(solve(E3)%*%psi.0,"EuclRandVariable") if(withplot) @@ -808,7 +785,9 @@ plot(x.mu.seq, sapply(x.mu.seq,psi.01 at Map[[i]]), type = if(is(distr,"DiscreteDistribution")) "p" else "l") }} +##-t-## print(system.time({ E4 <- E(object=distr, fun = psi.01 %*%t(psi.01)) +##-t-## })) } E4 <- PosSemDefSymmMatrix(E4) @@ -860,6 +839,21 @@ .oldCvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=0.3)), withplot=TRUE, N = 100) .CvMMDCovariance(GF,par=ParamFamParameter(main=c(scale=2.3,shape=0.3)), withplot=TRUE, N = 100) +P0 <- PoisFamily() +B0 <- BinomFamily(size=8, prob=0.3) +N0 <- NormLocationFamily(); +C0 <- CauchyLocationFamily() +cls <- CauchyLocationScaleFamily(); +N1 <- NormScaleFamily() +NS <- NormLocationScaleFamily(); paramP <- ParamFamParameter(name = "locscale", main = c("loc"=0,"scale"=1),trafo = diag(2)); +Els <- L2LocationScaleFamily(loc = 0, scale = 1, + name = "Laplace Location and scale family", + centraldistribution = DExp(), + LogDeriv = function(x) sign(x), + FisherInfo = diag(2), + trafo = diag(2)) +Nb <- NbinomwithSizeFamily() +GF <- GammaFamily() system.time(print(.oldCvMMDCovariance(P0,par=ParamFamParameter("lambda",1)))) system.time(print(.CvMMDCovariance(P0,par=ParamFamParameter("lambda",1)))) system.time(print(.oldCvMMDCovariance(B0,par=ParamFamParameter("",.3)))) @@ -886,6 +880,35 @@ system.time(print(.CvMMDCovariance(P0,par=ParamFamParameter("lambda",1),mu=Norm()))) system.time(print(.oldCvMMDCovariance(Nb,par=ParamFamParameter(main=c(size=2.3,prob=0.3)),mu=Norm()))) system.time(print(.CvMMDCovariance(Nb,par=ParamFamParameter(main=c(size=2.3,prob=0.3)),mu=Norm()))) + +" ## Code capsulated as string to avoid interpretation during R CMD Check + +require(RobExtremes) +Pf <- ParetoFamily() +.oldCvMMDCovariance(Pf,par=param(Pf), withplot=TRUE) +.CvMMDCovariance(Pf,par=param(Pf), withplot=TRUE) ## better trust this one +GPDf <- GParetoFamily() +.oldCvMMDCovariance(GPDf,par=param(GPDf), withplot=TRUE) +.CvMMDCovariance(GPDf,par=param(GPDf), withplot=TRUE) ## better trust this one +GEVf <- GEVFamily() +.oldCvMMDCovariance(GEVf,par=param(GEVf), withplot=TRUE) +.CvMMDCovariance(GEVf,par=param(GEVf), withplot=TRUE) ## better trust this one +GEVuf <- GEVFamilyMuUnknown() +.oldCvMMDCovariance(GEVuf,par=param(GEVuf), withplot=TRUE) +.CvMMDCovariance(GEVuf,par=param(GEVuf), withplot=TRUE) ## better trust this one + + +system.time(print(.oldCvMMDCovariance(Pf,par=param(Pf)))) +system.time(print(.CvMMDCovariance(Pf,par=param(Pf)))) ## better trust this one +system.time(print(.oldCvMMDCovariance(GPDf,par=param(GPDf)))) +system.time(print(.CvMMDCovariance(GPDf,par=param(GPDf)))) ## better trust this one +system.time(print(.oldCvMMDCovariance(GEVf,par=param(GEVf)))) +system.time(print(.CvMMDCovariance(GEVf,par=param(GEVf)))) ## better trust this one +system.time(print(.oldCvMMDCovariance(GEVuf,par=param(GEVuf)))) +system.time(print(.CvMMDCovariance(GEVuf,par=param(GEVuf)))) ## better trust this one + +" + set.seed(123) x <- rnorm(100) diF <- DiscreteDistribution(x) Modified: branches/distr-2.8/pkg/distrMod/man/internals.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/internals.Rd 2018-08-10 17:37:37 UTC (rev 1267) +++ branches/distr-2.8/pkg/distrMod/man/internals.Rd 2018-08-10 17:47:04 UTC (rev 1268) @@ -23,7 +23,7 @@ .CvMMDCovariance(L2Fam, param, mu = distribution(L2Fam), withplot = FALSE, withpreIC = FALSE, - N = 400, rel.tol=.Machine$double.eps^0.3, + N = 1021, rel.tol=.Machine$double.eps^0.3, TruncQuantile = getdistrOption("TruncQuantile"), IQR.fac = 15, ...) .oldCvMMDCovariance(L2Fam, param, mu = distribution(L2Fam), @@ -33,7 +33,7 @@ TruncQuantile = getdistrOption("TruncQuantile"), IQR.fac = 15, ...) .CvMMDCovarianceWithMux(L2Fam, param, withplot = FALSE, withpreIC = FALSE, - N = 400, rel.tol=.Machine$double.eps^0.3, + N = 1021, rel.tol=.Machine$double.eps^0.3, TruncQuantile = getdistrOption("TruncQuantile"), IQR.fac = 15, ..., x=NULL) Modified: branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save =================================================================== --- branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save 2018-08-10 17:37:37 UTC (rev 1267) +++ branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save 2018-08-10 17:47:04 UTC (rev 1268) @@ -280,6 +280,63 @@ > base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") > base::cat("BinomFamily", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() +> nameEx("CauchyLocationFamily") +> ### * CauchyLocationFamily +> +> flush(stderr()); flush(stdout()) +> +> base::assign(".ptime", proc.time(), pos = "CheckExEnv") +> ### Name: CauchyLocationFamily +> ### Title: Generating function for Cauchy location families +> ### Aliases: CauchyLocationFamily +> ### Keywords: models +> +> ### ** Examples +> +> (C1 <- CauchyLocationFamily()) +An object of class "CauchyLocationFamily" +### name: Cauchy location family + +### distribution: Distribution Object of Class: Cauchy + location: 0 + scale: 1 + +### param: An object of class "ParamFamParameter" +name: loc +loc: 0 +trafo: + loc +loc 1 + +### props: +[1] "The Cauchy location family is invariant under" +[2] "the group of transformations 'g(x) = x + loc'" +[3] "with location parameter 'loc'" +> plot(C1) +> FisherInfo(C1) +An object of class "PosDefSymmMatrix" + loc +loc 0.5 +> ### need smaller integration range: +> checkL2deriv(C1) +precision of centering: 9.75782e-18 +precision of Fisher information: + loc +loc -1.061373e-13 +precision of Fisher information - relativ error [%]: + loc +loc -2.122746e-11 +condition of Fisher information: +[1] 1 +$maximum.deviation +[1] 1.061373e-13 + +> +> +> +> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") +> base::cat("CauchyLocationFamily", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") +> cleanEx() > nameEx("CauchyLocationScaleFamily") > ### * CauchyLocationScaleFamily > @@ -323,19 +380,19 @@ > ### need smaller integration range: > distrExoptions("ElowerTruncQuantile"=1e-4,"EupperTruncQuantile"=1e-4) > checkL2deriv(C1) -precision of centering: 0 -0.02119711 +precision of centering: 9.97466e-18 -2e-04 precision of Fisher information: + loc scale +loc -2.631895e-11 -3.577867e-17 +scale -3.577867e-17 -2.000000e-04 +precision of Fisher information - relativ error [%]: loc scale -loc -3.137524e-05 0.00000000 -scale 0.000000e+00 -0.02118143 -precision of Fisher information - relativ error [%]: - loc scale -loc -0.006275047 NaN -scale NaN -4.236286 +loc -5.263789e-09 -Inf +scale -Inf -0.03999999 condition of Fisher information: [1] 1 $maximum.deviation -[1] 0.02119711 +[1] 2e-04 > distrExoptions("ElowerTruncQuantile"=1e-7,"EupperTruncQuantile"=1e-7) > @@ -402,7 +459,7 @@ dimnames = list(nms, nms0)) list(fval = fval0, mat = mat0) } - + Trafo / derivative matrix at which estimate was produced: scale shape shape 0.000 1 @@ -613,12 +670,12 @@ function (x) { y <- 0 * x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- ((x[inS] - 0)/scale * LogDeriv((x[inS] - 0)/c(scale = 1)) - 1)/c(scale = 1) return(y) } - + > checkL2deriv(E1) precision of centering: -2.04266e-06 @@ -741,7 +798,7 @@ shape: 1 scale: 1 -### param: An object of class "ParamFamParameter" +### param: An object of class "ParamWithScaleAndShapeFamParameter" name: scale and shape scale: 1 shape: 1 @@ -806,8 +863,8 @@ Slot "fct": function (x) QuadFormNorm(x, A = A) - - + + > > ## The function is currently defined as @@ -1120,12 +1177,12 @@ function (x) { y <- 0 * x - inS <- liesInSupport(distr.0, x) + inS <- liesInSupport(distr.0, x, checkFin = TRUE) y[inS] <- ((x[inS] - 0)/scale * LogDeriv((x[inS] - 0)/c(meanlog = 1)) - 1)/c(meanlog = 1) return(y) } - + > checkL2deriv(L1) precision of centering: -0.003003394 @@ -1192,42 +1249,42 @@ > ### need smaller integration range: > distrExoptions("ElowerTruncQuantile"=1e-4,"EupperTruncQuantile"=1e-4) > checkL2deriv(L1) -precision of centering: -2.264121e-17 -1.41228 +precision of centering: 2.264121e-17 -0.5873198 precision of Fisher information: - location scale -location -1.600022e-01 4.454916e-17 -scale 4.454916e-17 8.149930e-01 + location scale +location -1.600022e-01 -6.600106e-18 +scale -6.600106e-18 -8.349279e-01 precision of Fisher information - relativ error [%]: - location scale -location -48.00065 Inf -scale Inf 56.99427 + location scale +location -48.00065 -Inf +scale -Inf -58.38836 condition of Fisher information: [1] 3.667949 $maximum.deviation -[1] 1.41228 +[1] 0.8349279 > distrExoptions("ElowerTruncQuantile"=1e-7,"EupperTruncQuantile"=1e-7) > ## > set.seed(123) > x <- rlogis(100,location=1,scale=2) > CvMMDEstimator(x, L1) -Evaluations of Minimum CvM distance estimate ( mu = emp. cdf ) : ----------------------------------------------------------------- -An object of class "Estimate" +Evaluations of Minimum CvM distance estimate ( mu = model distr. ) : +-------------------------------------------------------------------- +An object of class "CvMMDEstimate" generated by call CvMMDEstimator(x = x, ParamFamily = L1) samplesize: 100 estimate: location scale - 0.9199612 1.9512792 - (2.2045470) (0.6064406) + 0.9691129 1.9522622 + (0.4035840) (0.1868609) asymptotic (co)variance (multiplied with samplesize): - location scale -location 486.0028 130.60897 -scale 130.6090 36.77702 + location scale +location 1.628800e+01 -3.750942e-06 +scale -3.750942e-06 3.491701e+00 Criterion: CvM distance - 0.01414319 + 0.01469024 > > > @@ -1242,7 +1299,8 @@ > base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: MCEstimate-class > ### Title: MCEstimate-class. -> ### Aliases: MCEstimate-class criterion criterion,MCEstimate-method +> ### Aliases: MCEstimate-class MDEstimate-class MLEstimate-class +> ### CvMMDEstimate-class criterion criterion,MCEstimate-method > ### criterion.fct criterion.fct,MCEstimate-method > ### startPar,MCEstimate-method method method,MCEstimate-method optimwarn > ### optimwarn,MCEstimate-method optimReturn optimReturn,MCEstimate-method @@ -1262,7 +1320,7 @@ > MDEstimator(x, G) Evaluations of Minimum Kolmogorov distance estimate : ------------------------------------------------------ -An object of class "Estimate" +An object of class "MDEstimate" generated by call MDEstimator(x = x, ParamFamily = G) samplesize: 50 @@ -1275,7 +1333,7 @@ > (m <- MLEstimator(x, G)) Evaluations of Maximum likelihood estimate: ------------------------------------------- -An object of class "Estimate" +An object of class "MLEstimate" generated by call MLEstimator(x = x, ParamFamily = G) samplesize: 50 @@ -1330,7 +1388,7 @@ > MCEstimator(x = x, ParamFamily = G, criterion = negLoglikelihood) Evaluations of Minimum criterion estimate: ------------------------------------------ -An object of class "Estimate" +An object of class "MCEstimate" generated by call MCEstimator(x = x, ParamFamily = G, criterion = negLoglikelihood) samplesize: 50 @@ -1359,7 +1417,7 @@ Evaluations of Minimum Kolmogorov distance estimate: ---------------------------------------------------- -An object of class "Estimate" +An object of class "MCEstimate" generated by call MCEstimator(x = x, ParamFamily = G, criterion = KolmogorovDist, crit.name = "Kolmogorov distance") @@ -1378,7 +1436,7 @@ + crit.name = "Total variation distance") Evaluations of Minimum Total variation distance estimate: --------------------------------------------------------- -An object of class "Estimate" +An object of class "MCEstimate" generated by call MCEstimator(x = x, ParamFamily = G, criterion = TotalVarDist, crit.name = "Total variation distance") @@ -1402,7 +1460,7 @@ + crit.name = "Hellinger Distance", startPar = c(1,2)) Evaluations of Minimum Hellinger Distance estimate: --------------------------------------------------- -An object of class "Estimate" +An object of class "MCEstimate" generated by call MCEstimator(x = x, ParamFamily = G, criterion = HellingerDist, crit.name = "Hellinger Distance", startPar = c(1, 2)) @@ -1449,7 +1507,7 @@ > MDEstimator(x = x, ParamFamily = G, distance = KolmogorovDist) Evaluations of Minimum Kolmogorov distance estimate : ------------------------------------------------------ -An object of class "Estimate" +An object of class "MDEstimate" generated by call MDEstimator(x = x, ParamFamily = G, distance = KolmogorovDist) samplesize: 50 @@ -1463,7 +1521,7 @@ > KolmogorovMDEstimator(x = x, ParamFamily = G) Evaluations of Minimum Kolmogorov distance estimate : ------------------------------------------------------ -An object of class "Estimate" +An object of class "MDEstimate" generated by call KolmogorovMDEstimator(x = x, ParamFamily = G) samplesize: 50 @@ -1474,11 +1532,11 @@ Kolmogorov distance 0.07111522 > -> ## von Mises minimum distance estimator with default mu +> ## von Mises minimum distance estimator with default mu = Mod > MDEstimator(x = x, ParamFamily = G, distance = CvMDist) Evaluations of Minimum CvM distance estimate ( mu = emp. cdf ) : ----------------------------------------------------------------- -An object of class "Estimate" +An object of class "CvMMDEstimate" generated by call MDEstimator(x = x, ParamFamily = G, distance = CvMDist) samplesize: 50 @@ -1518,7 +1576,7 @@ > MLEstimator(x, BinomFamily(size = 25)) Evaluations of Maximum likelihood estimate: ------------------------------------------- -An object of class "Estimate" +An object of class "MLEstimate" generated by call MLEstimator(x = x, ParamFamily = BinomFamily(size = 25)) samplesize: 100 @@ -1548,7 +1606,7 @@ > MLEstimator(x, PoisFamily()) Evaluations of Maximum likelihood estimate: ------------------------------------------- -An object of class "Estimate" +An object of class "MLEstimate" generated by call MLEstimator(x = x, ParamFamily = PoisFamily()) samplesize: 2608 @@ -1573,7 +1631,7 @@ > MLEstimator(x, NormLocationScaleFamily()) Evaluations of Maximum likelihood estimate: ------------------------------------------- -An object of class "Estimate" +An object of class "MLEstimate" generated by call MLEstimator(x = x, ParamFamily = NormLocationScaleFamily()) samplesize: 100 @@ -1606,7 +1664,7 @@ > (res <- MLEstimator(x = x, ParamFamily = G)) Evaluations of Maximum likelihood estimate: ------------------------------------------- -An object of class "Estimate" +An object of class "MLEstimate" generated by call MLEstimator(x = x, ParamFamily = G) samplesize: 50 @@ -1813,20 +1871,20 @@ > FisherInfo(N1.w) An object of class "PosSemDefSymmMatrix" size prob -size 0.03044946 -4.0000 +size 0.03044974 -4.0000 prob -4.00000000 533.3333 > checkL2deriv(N1.w) precision of centering: -6.245978e-06 0.001177892 precision of Fisher information: size prob -size -4.182531e-06 0.0008481424 +size -4.462854e-06 0.0008481424 prob 8.481424e-04 -0.1601189384 precision of Fisher information - relativ error [%]: size prob -size -0.01373598 -0.02120356 +size -0.01465646 -0.02120356 prob -0.02120356 -0.03002230 condition of Fisher information: -[1] 1195572 +[1] 1194827 $maximum.deviation [1] 0.1601189 @@ -1849,20 +1907,20 @@ > FisherInfo(N2.w) An object of class "PosSemDefSymmMatrix" size mean -size 3.044946e-02 1600.091 +size 3.044974e-02 1600.091 mean 1.600091e+03 85342933.607 > checkL2deriv(N2.w) precision of centering: -6.245978e-06 -0.4711755 precision of Fisher information: size mean -size -4.182531e-06 -3.392695e-01 -mean -3.392695e-01 -2.562107e+04 +size -4.462854e-06 -3.392704e-01 +mean -3.392704e-01 -2.562107e+04 precision of Fisher information - relativ error [%]: size mean -size -0.01373598 -0.02120313 -mean -0.02120313 -0.03002131 +size -0.01465646 -0.02120319 +mean -0.02120319 -0.03002131 condition of Fisher information: -[1] 1.89903e+11 +[1] 189784664099 $maximum.deviation [1] 25621.07 @@ -2232,7 +2290,7 @@ return(abs(x)) else return(sqrt(colSums(x^2))) } - + > name(EuclNorm) [1] "EuclideanNorm" @@ -2267,7 +2325,7 @@ return(abs(x)) else return(sqrt(colSums(x^2))) } - + > @@ -2663,7 +2721,7 @@ shape: 2 scale: 1 -### param: An object of class "ParamFamParameter" +### param: An object of class "ParamWithScaleAndShapeFamParameter" name: scale and shape scale: 1 shape: 2 @@ -2750,8 +2808,8 @@ Slot "fct": function (x) QuadFormNorm(x, A = A0) - [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/distr -r 1268 From noreply at r-forge.r-project.org Sat Aug 11 00:11:43 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 00:11:43 +0200 (CEST) Subject: [Distr-commits] r1269 - in branches/distr-2.8/pkg/distrMod: R inst Message-ID: <20180810221143.5981F18A73C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 00:11:43 +0200 (Sat, 11 Aug 2018) New Revision: 1269 Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R branches/distr-2.8/pkg/distrMod/inst/NEWS Log: [distrMod] branch 2.8: + in fam.fall to NbinomFamily (with two parameters ) we had matrix(Tr, dimnames = DN) without specifying nrow and ncol + (robust) start parameters for Nbinom family with two parameters Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-10 17:47:04 UTC (rev 1268) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-10 22:11:43 UTC (rev 1269) @@ -202,7 +202,11 @@ body(modifyParam) <- substitute({ Nbinom(size = theta[1], prob = theta[2]) }) props <- "" - startPar <- function(x,...){ param1 <- c(1,0.5) + startPar <- function(x,...){ m0 <- median(x) + s0 <- mad(x) + p0 <- min(0.99,max(m0/s0^2,0.01)) + n0 <- m0^2/max(s0^2-m0,0.1) + param1 <- c(n0,p0) names(param1) <- c("size","prob") return(param1)} makeOKPar <- function(param) {if(param["prob"]<=0) param["prob"] <- .Machine$double.eps @@ -259,7 +263,7 @@ .returnClsName = "NbinomwithSizeFamily") if(!is.function(trafo)) f.call <- substitute(NbinomwithSizeFamily(size = s, prob = p, - trafo = matrix(Tr, dimnames = DN)), + trafo = matrix(Tr, 2,2, dimnames = DN)), list(s = size, p = prob, Tr = trafo, DN = list(nms,nms))) else @@ -290,7 +294,10 @@ body(modifyParam) <- substitute({ Nbinom(size = theta[1], prob = theta[1]/(theta[1]+theta[2])) }) props <- "" - startPar <- function(x,...){ param1 <- c(1,0.5) + startPar <- function(x,...){ m0 <- median(x) + s0 <- mad(x) + n0 <- m0^2/max(s0^2-m0,0.1) + param1 <- c(n0,m0) names(param1) <- c("size","mean") return(param1)} makeOKPar <- function(param) {if(param["mean"]<=0) param["mean"] <- .Machine$double.eps @@ -363,7 +370,7 @@ .returnClsName = "NbinomMeanSizeFamily") if(!is.function(trafo)){ f.call <- substitute(NbinomMeanSizeFamily(size = s, mean = m, - trafo = matrix(Tr, dimnames = DN)), + trafo = matrix(Tr, 2,2, dimnames = DN)), list(s = size, m = mean, Tr = trafo, DN = list(nms,nms))) }else{ f.call <- substitute(NbinomMeanSizeFamily(size = s, mean = m, Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-10 17:47:04 UTC (rev 1268) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-10 22:11:43 UTC (rev 1269) @@ -52,6 +52,8 @@ + argument distance did not show it came from CvMDist, CvMDist2 via CvMMDEstiamtor when unparsed -- now the unparsed argument in CvMMDEstimator is called CvMDist0 so shows that it is related to CvMDist ++ in fam.fall to NbinomFamily (with two parameters ) we had matrix(Tr, dimnames = DN) without + specifying nrow and ncol under the hood: @@ -65,16 +67,19 @@ + in case .0 is already used otherwise (as in NbinomMeanSizeFamily) we use .00 instead + replaced integration for AbscontDistribution(s) in .CvMMDCovariance by integration on quantile scale => CvMMDEstimator now works with variances even for Gamma distributions for shape < 1 ... ++ tuned .CvMMDCovariance() in asCvMVarianceQtl.R for speed (like with kStepEstimator timings are + taken in comment ##-t-##) as the function .CvMMDCovariance was much slower than + .oldCvMMDCovariance for Generalized EVD with Mu Unknown... / now they are at equal there ++ revised .CvMMDCovariance() to get more performant for discrete distributions / + -> thereby corrected an error in the intermediate formulae, which by + centering/standarizing of the IC in the end already cancelled out beforehand... + but now we are more accurate as to differences in the integration measure mu + and the model distribution (important for integration w.r.t. emp. measure) + .process.meCalcRes gains arg "x" to be able to pass on emp.CDF for mu in CvMMDEstimator if arg asvar.fct of MCEstimator has "x" in formals the observations x are passed on to asvar.fct, otherwise they are not; correspondingly "x" is passed on to .process.meCalcRes in MCEstimator(), MDEstimator(), MLEstimator(). + old .CvMMDCovariance() becomes .oldCvMMDCovariance -+ revised .CvMMDCovariance() to get more performant for discrete distributions / - -> thereby corrected an error in the intermediate formulae, which by - centering/standarizing of the IC in the end already cancelled out beforehand... - but now we are more accurate as to differences in the integration measure mu - and the model distribution (important for integration w.r.t. emp. measure) + new wrapper .CvMMDCovarianceWithMux which uses emp cdf as mu + new wrappe CvMDist2 which by default uses model distribution as mu + CvMMDEstimator gains argument muDatOrMod = c("Dat","Mod") to distinguish two cases @@ -96,7 +101,9 @@ + based on this tag "( mu = ... )" later on, in pkg RobAStBase, a (conditional) coerce method produces the pIC of the MDE by means of .CvMMDCovariance[WithMux] + new subclasses "MLEstimate", "MDEstimate", "CvMMDEstimate" for internal method dispatch ++ (robust) start parameters for Nbinom family with two parameters + ############## v 2.7 ############## From noreply at r-forge.r-project.org Sat Aug 11 00:45:52 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 00:45:52 +0200 (CEST) Subject: [Distr-commits] r1270 - in branches/distr-2.8/pkg/distrMod: R inst Message-ID: <20180810224552.994C618A89F@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 00:45:52 +0200 (Sat, 11 Aug 2018) New Revision: 1270 Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R branches/distr-2.8/pkg/distrMod/inst/NEWS Log: [distrMod] branch 2.8 + (robust) start (search) parameters for Poisson family Modified: branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-10 22:11:43 UTC (rev 1269) +++ branches/distr-2.8/pkg/distrMod/R/SimpleL2ParamFamilies.R 2018-08-10 22:45:52 UTC (rev 1270) @@ -82,7 +82,7 @@ trafo = trafo) modifyParam <- function(theta){ Pois(lambda = theta) } props <- character(0) - startPar <- function(x,...) c(.Machine$double.eps,max(x)) + startPar <- function(x,...) c(.Machine$double.eps,median(x)+10*max(mad(x),1)) makeOKPar <- function(param) {if(param<=0) return(.Machine$double.eps) return(param)} L2deriv.fct <- function(param){ Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-10 22:11:43 UTC (rev 1269) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-10 22:45:52 UTC (rev 1270) @@ -102,6 +102,7 @@ coerce method produces the pIC of the MDE by means of .CvMMDCovariance[WithMux] + new subclasses "MLEstimate", "MDEstimate", "CvMMDEstimate" for internal method dispatch + (robust) start parameters for Nbinom family with two parameters ++ (robust) start (search) parameters for Poisson family ############## From noreply at r-forge.r-project.org Sat Aug 11 15:36:17 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 15:36:17 +0200 (CEST) Subject: [Distr-commits] r1271 - in branches/distr-2.8/pkg/distr: R inst Message-ID: <20180811133617.B0F7C18A88C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 15:36:17 +0200 (Sat, 11 Aug 2018) New Revision: 1271 Modified: branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R branches/distr-2.8/pkg/distr/R/UtilitiesDistributions.R branches/distr-2.8/pkg/distr/R/bAcDcLcDistribution.R branches/distr-2.8/pkg/distr/inst/NEWS Log: [distr] branch 2.8 + fixed a (newly introduced) bug in exp() for DiscreteDistribution -- forgot to return obj ... + minor cleanups Modified: branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R =================================================================== --- branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R 2018-08-10 22:45:52 UTC (rev 1270) +++ branches/distr-2.8/pkg/distr/R/DiscreteDistribution.R 2018-08-11 13:36:17 UTC (rev 1271) @@ -452,6 +452,7 @@ setMethod("exp", "DiscreteDistribution", function(x){ obj <- .expm.d(x) obj at .finSupport <- c(TRUE, x at .finSupport[2]) + obj } ) Modified: branches/distr-2.8/pkg/distr/R/UtilitiesDistributions.R =================================================================== --- branches/distr-2.8/pkg/distr/R/UtilitiesDistributions.R 2018-08-10 22:45:52 UTC (rev 1270) +++ branches/distr-2.8/pkg/distr/R/UtilitiesDistributions.R 2018-08-11 13:36:17 UTC (rev 1271) @@ -85,8 +85,8 @@ rm(zz.T) f.d <- Dirac(0) - if(w.d) - {hasDis <- TRUE + if(w.d){ + hasDis <- TRUE zz.nr <- zz[! zz %in% zz.replic] d.r <- zz.T1/sum(zz.T1) f.d <- DiscreteDistribution(supp = zz.replic, prob = d.r, Modified: branches/distr-2.8/pkg/distr/R/bAcDcLcDistribution.R =================================================================== --- branches/distr-2.8/pkg/distr/R/bAcDcLcDistribution.R 2018-08-10 22:45:52 UTC (rev 1270) +++ branches/distr-2.8/pkg/distr/R/bAcDcLcDistribution.R 2018-08-11 13:36:17 UTC (rev 1271) @@ -144,8 +144,8 @@ dP <- discretePart(e2D) dP at .finSupport <- c(TRUE,TRUE) # as both pos&neg part are bounded away from 0 discretePart(e2D) <- dP - ## obj at .finSupport <- + if(getdistrOption("simplifyD")) e2D <- simplifyD(e2D) Modified: branches/distr-2.8/pkg/distr/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-10 22:45:52 UTC (rev 1270) +++ branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-11 13:36:17 UTC (rev 1271) @@ -28,6 +28,9 @@ the upper bound is finite) + changed definition of q(DExp(..)) in initialize method in AllInitialize.R from ifelse expressions to index operations to avoid warnings + +bug fixes ++ fixed a (newly introduced) bug in exp() for DiscreteDistribution -- forgot to return obj ... ############## v 2.7 From noreply at r-forge.r-project.org Sat Aug 11 15:41:43 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 15:41:43 +0200 (CEST) Subject: [Distr-commits] r1272 - in branches/distr-2.8/pkg: distrEllipse/R distrEllipse/inst distrMod/R distrMod/inst Message-ID: <20180811134143.872B11896EB@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 15:41:43 +0200 (Sat, 11 Aug 2018) New Revision: 1272 Modified: branches/distr-2.8/pkg/distrEllipse/R/EllipticalDistribution.R branches/distr-2.8/pkg/distrEllipse/inst/NEWS branches/distr-2.8/pkg/distrMod/R/MCEstimator.R branches/distr-2.8/pkg/distrMod/R/MLEstimator.R branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R branches/distr-2.8/pkg/distrMod/R/existsPIC.R branches/distr-2.8/pkg/distrMod/R/setAs.R branches/distr-2.8/pkg/distrMod/inst/NEWS Log: [distrMod/distrEllipse] branch 2.8 + now specified that we want to use distr::solve Modified: branches/distr-2.8/pkg/distrEllipse/R/EllipticalDistribution.R =================================================================== --- branches/distr-2.8/pkg/distrEllipse/R/EllipticalDistribution.R 2018-08-11 13:36:17 UTC (rev 1271) +++ branches/distr-2.8/pkg/distrEllipse/R/EllipticalDistribution.R 2018-08-11 13:41:43 UTC (rev 1272) @@ -5,7 +5,7 @@ ldscale <- as.numeric(determinant(as.matrix(scale), logarithm = TRUE)$modulus) - Iscale <- solve(scale) + Iscale <- distr::solve(scale) dim0 <- length(loc) Modified: branches/distr-2.8/pkg/distrEllipse/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrEllipse/inst/NEWS 2018-08-11 13:36:17 UTC (rev 1271) +++ branches/distr-2.8/pkg/distrEllipse/inst/NEWS 2018-08-11 13:41:43 UTC (rev 1272) @@ -14,6 +14,9 @@ user-visible CHANGES: + DESCRIPTION tag SVNRevision changed to VCS/SVNRevision +under the hood: ++ now specified that we want to use distr::solve + ############## v 2.7 ############## Modified: branches/distr-2.8/pkg/distrMod/R/MCEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MCEstimator.R 2018-08-11 13:36:17 UTC (rev 1271) +++ branches/distr-2.8/pkg/distrMod/R/MCEstimator.R 2018-08-11 13:41:43 UTC (rev 1272) @@ -41,7 +41,7 @@ asv <- if("FisherInfo" %in% slotNames(ParamFamily)){ function(ParamFamily, param) - solve(FisherInfo(ParamFamily, param = param)) + distr::solve(FisherInfo(ParamFamily, param = param)) }else NULL argList <- c(list(res0, PFam = ParamFamily, Modified: branches/distr-2.8/pkg/distrMod/R/MLEstimator.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-11 13:36:17 UTC (rev 1271) +++ branches/distr-2.8/pkg/distrMod/R/MLEstimator.R 2018-08-11 13:41:43 UTC (rev 1272) @@ -39,7 +39,7 @@ asv <- if("FisherInfo" %in% slotNames(ParamFamily)){ function(PFam = ParamFamily, param, ...) - solve(FisherInfo(PFam, param = param)) + distr::solve(FisherInfo(PFam, param = param)) }else NULL argList <- list(res0, PFam = ParamFamily, trafo = trafo, Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-11 13:36:17 UTC (rev 1271) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-11 13:41:43 UTC (rev 1272) @@ -358,7 +358,7 @@ J <- E(object=distr, fun = Delta.0 %*%t(Delta.0)) ##-t-## })) ### CvM-IC phi - phi <- as(solve(J)%*%Delta.0,"EuclRandVariable") + phi <- as(distr::solve(J)%*%Delta.0,"EuclRandVariable") ## integrand phi x Ptheta in formula (51) [ibid] @@ -453,7 +453,7 @@ E3 <- E(object=distr, fun = psi %*%t(L2deriv.0)) ##-t-## })) psi.0 <- psi - E1 - psi.01 <- as(solve(E3)%*%psi.0,"EuclRandVariable") + psi.01 <- as(distr::solve(E3)%*%psi.0,"EuclRandVariable") if(withplot) { for(i in 1:Dim) { dev.new() @@ -711,7 +711,7 @@ J <- E(object=distr, fun = Delta.0 %*%t(Delta.0)) ##-t-## })) ### CvM-IC phi - phi <- as(solve(J)%*%Delta.0,"EuclRandVariable") + phi <- as(distr::solve(J)%*%Delta.0,"EuclRandVariable") ## integrand phi x Ptheta in formula (51) [ibid] @@ -778,7 +778,7 @@ E3 <- E(object=distr, fun = psi %*%t(L2deriv)) ##-t-## })) psi.0 <- psi - E1 - psi.01 <- as(solve(E3)%*%psi.0,"EuclRandVariable") + psi.01 <- as(distr::solve(E3)%*%psi.0,"EuclRandVariable") if(withplot) { for(i in 1:Dim) { dev.new() Modified: branches/distr-2.8/pkg/distrMod/R/existsPIC.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/existsPIC.R 2018-08-11 13:36:17 UTC (rev 1271) +++ branches/distr-2.8/pkg/distrMod/R/existsPIC.R 2018-08-11 13:41:43 UTC (rev 1272) @@ -4,7 +4,7 @@ if (sum(A.svd$d > tol * max(A.svd$d))>0) {kerA.perp <- A.svd$v[,A.svd$d > tol * max(A.svd$d)] ## projector to ker A perp - Pi.kerA.perp <- kerA.perp%*%solve(t(kerA.perp)%*%kerA.perp, tol = tol)%*%t(kerA.perp) + Pi.kerA.perp <- kerA.perp%*%distr::solve(t(kerA.perp)%*%kerA.perp, tol = tol)%*%t(kerA.perp) }else{Pi.kerA.perp <- 0*A} B <- as.matrix(B) @@ -12,7 +12,7 @@ if (sum(B.svd$d > tol * max(B.svd$d))>0) {kerB.perp <- B.svd$v[,B.svd$d > tol * max(B.svd$d)] ## projector to ker B perp - Pi.kerB.perp <- kerB.perp%*%solve(t(kerB.perp)%*%kerB.perp, tol = tol)%*%t(kerB.perp) + Pi.kerB.perp <- kerB.perp%*%distr::solve(t(kerB.perp)%*%kerB.perp, tol = tol)%*%t(kerB.perp) }else{Pi.kerB.perp <- 0*B} isTRUE(all.equal(Pi.kerB.perp%*%Pi.kerA.perp, Pi.kerB.perp, tolerance = tol )) } Modified: branches/distr-2.8/pkg/distrMod/R/setAs.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/setAs.R 2018-08-11 13:36:17 UTC (rev 1271) +++ branches/distr-2.8/pkg/distrMod/R/setAs.R 2018-08-11 13:41:43 UTC (rev 1272) @@ -42,7 +42,7 @@ ## "invert" (locally!) the transformation, # i.e. th1 "=" trafo^-1(th0) D1 <- (trafo(from)$fct)(th0)$mat - th1 <- est1 + solve(D1, th0-est0) + th1 <- est1 + distr::solve(D1, th0-est0) ## call critrium.fct with this transformed parameter do.call(from at criterion.fct,as.list(th1)) } Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-11 13:36:17 UTC (rev 1271) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-11 13:41:43 UTC (rev 1272) @@ -103,6 +103,7 @@ + new subclasses "MLEstimate", "MDEstimate", "CvMMDEstimate" for internal method dispatch + (robust) start parameters for Nbinom family with two parameters + (robust) start (search) parameters for Poisson family ++ now specified that we want to use distr::solve ############## From noreply at r-forge.r-project.org Sat Aug 11 16:33:45 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 16:33:45 +0200 (CEST) Subject: [Distr-commits] r1273 - in branches/distr-2.8/pkg/distr: R inst Message-ID: <20180811143345.CA4CE187FB6@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 16:33:45 +0200 (Sat, 11 Aug 2018) New Revision: 1273 Modified: branches/distr-2.8/pkg/distr/R/solve.R branches/distr-2.8/pkg/distr/inst/NEWS Log: [distr] branch 2.8.0 + in distr::solve only try base::solve if arg "a" has no dim or if it has then if nrow(a)==nrow(b); otherwise directly use MASS::ginv Modified: branches/distr-2.8/pkg/distr/R/solve.R =================================================================== --- branches/distr-2.8/pkg/distr/R/solve.R 2018-08-11 13:41:43 UTC (rev 1272) +++ branches/distr-2.8/pkg/distr/R/solve.R 2018-08-11 14:33:45 UTC (rev 1273) @@ -1,21 +1,26 @@ setMethod("solve", signature(a = "ANY", b = "ANY"), function(a,b, generalized = getdistrOption("use.generalized.inverse.by.default"), - tol = .Machine$double.eps, ...) { - if(!generalized) return(base::solve(a,b, tol = tol, ...)) - else if(is(try({ - ab <- base::solve(a,b, tol = tol, ...) - if(missing(b)) - dimnames(ab) <- rev(dimnames(a)) - else names(ab) <- colnames(a) - return(ab) - }, silent = TRUE), "try-error")){ - if (!missing(b)) - if(!(length(b)==nrow(a))) stop("non-conformable arguments") - a.m <- MASS::ginv(a) - dimnames(a.m) <- rev(dimnames(a)) - if (missing(b)) return(a.m) - else return(a.m %*% b) - }}) + tol = .Machine$double.eps, ...) { + if(!generalized|is.null(dim(a))) return(base::solve(a,b, tol = tol, ...)) + else if(nrow(a)==ncol(a)){ + abtry <- try({ + ab <- base::solve(a,b, tol = tol, ...) + if(missing(b)){ + dimnames(ab) <- rev(dimnames(a)) + }else{ + names(ab) <- colnames(a) + } + return(ab) + }, silent = TRUE) + if(!is(abtry, "try-error")) return(abtry) + } + if (!missing(b)) + if(!(length(b)==nrow(a))) stop("non-conformable arguments") + a.m <- MASS::ginv(a) + dimnames(a.m) <- rev(dimnames(a)) + if (missing(b)) return(a.m) + else return(a.m %*% b) + }) setMethod("solve", signature(a = "PosSemDefSymmMatrix", b = "ANY"), function(a,b, Modified: branches/distr-2.8/pkg/distr/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-11 13:41:43 UTC (rev 1272) +++ branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-11 14:33:45 UTC (rev 1273) @@ -28,6 +28,8 @@ the upper bound is finite) + changed definition of q(DExp(..)) in initialize method in AllInitialize.R from ifelse expressions to index operations to avoid warnings ++ in distr::solve only try base::solve if arg "a" has no dim or if it has then + if nrow(a)==nrow(b); otherwise directly use MASS::ginv bug fixes + fixed a (newly introduced) bug in exp() for DiscreteDistribution -- forgot to return obj ... From noreply at r-forge.r-project.org Sat Aug 11 20:57:41 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Aug 2018 20:57:41 +0200 (CEST) Subject: [Distr-commits] r1274 - in branches/distr-2.8/pkg/distrMod: R man Message-ID: <20180811185741.40463187A74@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-11 20:57:40 +0200 (Sat, 11 Aug 2018) New Revision: 1274 Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R branches/distr-2.8/pkg/distrMod/man/L2ParamFamily-class.Rd branches/distr-2.8/pkg/distrMod/man/L2ParamFamily.Rd Log: [distrMod] branch 2.8: + more precise / explicite description of the requirements of slots L2deriv and L2deriv.fct in the help files to generator L2ParamFamily and to L2ParamFamily-class. + the revised .CvMMDCovariance() uses vectorization in evaluation of random variables and, wherever possible in integration; for the latter, this can be suppressed by an argument useApply=TRUE through the ... argument Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-11 14:33:45 UTC (rev 1273) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-11 18:57:40 UTC (rev 1274) @@ -33,6 +33,8 @@ dotsInt[["upper"]] <- NULL dotsInt[["stop.on.error"]] <- NULL dotsInt[["distr"]] <- NULL + .useApply <- FALSE + if(!is.null(dotsInt$useApply)) .useApply <- dotsInt$useApply if(missing(TruncQuantile)||TruncQuantile>1e-7) TruncQuantile <- 1e-8 @@ -147,11 +149,11 @@ if(is(distr,"AbscontDistribution")){ fqx <- function(x){qx <- q.l(distr)(x) - return(sapply(qx,function(y)evalRandVar(L2deriv.0, y))) + evalRandVar(L2deriv.0, as.matrix(qx))[,,1] } - Delta0x.1 <- sapply(x.seq.1,fqx) - Delta0x.2 <- sapply(x.seq.2,fqx) - Delta0x.3 <- sapply(x.seq.3,fqx) + Delta0x.1 <- fqx(x.seq.1) + Delta0x.2 <- fqx(x.seq.2) + Delta0x.3 <- fqx(x.seq.3) Delta0.1 <- h0/100*.csimpsum(Delta0x.1) Delta0.2 <- rev(Delta0.1)[1]+h0*.csimpsum(Delta0x.2) Delta0.3 <- rev(Delta0.2)[1]+h0/100*.csimpsum(Delta0x.3) @@ -162,7 +164,7 @@ J <- do.call(myint, c(list(f=function(x) (Delta1.q(x)-J1)^2),dotsInt)) }else{ if(is(distr,"DiscreteDistribution")){ - L2x <- sapply(x.seq, function(x) evalRandVar(L2deriv.0, x)) + L2x <- evalRandVar(L2deriv.0, as.matrix(x.seq))[,,1] L2xdx <- L2x*prob Delta0 <- cumsum(L2xdx) J1 <- sum(Delta0*prob) @@ -171,14 +173,14 @@ Delta.0 <- approxfun(x.seq, Delta, yleft = 0, yright = 0) Delta <- Delta/J }else{ - L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) + L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, as.matrix(x))[,,1] Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) L2x(x,y=Y) - return(E(object=distr, fun = fct))}) + return(E(object=distr, fun = fct, useApply = .useApply))}) Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) Delta <- Delta1 - J1 <- E(object=distr, fun = Delta) + J1 <- E(object=distr, fun = Delta, useApply = .useApply) Delta.0 <- function(x) Delta(x) - J1 - J <- E(object=distr, fun = function(x) Delta.0(x)^2 ) + J <- E(object=distr, fun = function(x) Delta.0(x)^2, useApply = .useApply ) } } @@ -195,9 +197,9 @@ phiqx <- function(x){qx <- q.l(mu)(x) return(phi(qx))} - psi0qx.1 <- sapply(rev(x.mu.seq.1), phiqx) - psi0qx.2 <- sapply(rev(x.mu.seq.2), phiqx) - psi0qx.3 <- sapply(rev(x.mu.seq.3), phiqx) + psi0qx.1 <- phiqx(x.mu.seq.1) + psi0qx.2 <- phiqx(x.mu.seq.2) + psi0qx.3 <- phiqx(x.mu.seq.3) psi0q.3 <- h0.mu/100*rev(.csimpsum(psi0qx.3)) psi0q.2 <- psi0q.3[1]+h0.mu*rev(.csimpsum(psi0qx.2)) psi0q.1 <- psi0q.2[1]+h0.mu/100*rev(.csimpsum(psi0qx.1)) @@ -207,13 +209,11 @@ psi.fct <- function(x) psi.q1(p(mu)(x))-psi1 }else{ if(is(mu,"DiscreteDistribution")&&is(distr,"DiscreteDistribution")){ + Delta.mu <- phi(x.mu.seq) + pprob.mu <- p(distr)(x.mu.seq) if(!all(support(mu)==support(distr))){ - Delta.mu <- sapply(x.mu.seq, phi) - pprob.mu <- sapply(x.mu.seq, p(distr)) - L2x.mu <- sapply(x.mu.seq, function(x) evalRandVar(L2deriv.0, x)) + L2x.mu <- evalRandVar(L2deriv.0, as.matrix(x.mu.seq))[,,1] }else{ - Delta.mu <- sapply(x.mu.seq, phi) - pprob.mu <- cumsum(prob) L2x.mu <- L2x } psi1 <- sum(pprob.mu*Delta.mu*prob.mu) @@ -223,11 +223,11 @@ }else{ ## integrand phi x Ptheta in formula (51) [ibid] phi1 <- function(x) phi(x) * p(distr)(x) - psi1 <- E(object = mu, fun = phi1) + psi1 <- E(object = mu, fun = phi1, useApply = .useApply) phixy <- function(x,y) (x<=y)*phi(y) psi0 <- sapply(x.mu.seq, function(X){ fct <- function(y) phixy(x=X,y=y) - return(E(object=mu, fun = fct))}) + return(E(object=mu, fun = fct, useApply = .useApply))}) psi.1 <- approxfun(x.mu.seq, psi0, yleft = 0, yright = rev(psi0)[1]) psi.fct <- function(x) psi.1(x)-psi1 } @@ -240,8 +240,7 @@ E1 <- do.call(myint, c(list(f=psi.q),dotsInt)) E3 <- do.call(myint, c(list(f=function(x){ qx <- q.l(distr)(x) - L2qx <- sapply(qx,function(y) - evalRandVar(L2deriv.0, y)) + L2qx <- evalRandVar(L2deriv.0,as.matrix(qx))[,,1] return(psi.fct(qx)*L2qx) }), dotsInt)) psi.01.f <- function(x) (psi.fct(x)-E1)/E3 @@ -250,8 +249,7 @@ if(is(distr,"DiscreteDistribution")){ ## E2 = Cov_mu (psi) # E2 <- sum(psi0^2*prob) - psi0 <- sapply(x.seq, psi.fct) - + psi0 <- psi.fct(x.seq) E1 <- sum(psi0*prob) E3 <- sum(psi0*L2x*prob) psi.01d <- (psi0-E1)/E3 @@ -259,12 +257,13 @@ psi.01.f <- function(x) (psi.fct(x)-E1)/E3*liesInSupport(distr,x) }else{ ## E2 = Cov_mu (psi) -# E2 <- E(object=distr, fun = function(x) psi(x)^2) - L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, x) - E1 <- E(object=distr, fun = psi.fct ) - E3 <- E(object=distr, fun = function(x) psi.fct(x)*evalRandVar(L2deriv.0, x)) +# E2 <- E(object=distr, fun = function(x) psi(x)^2, useApply = .useApply) + L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, as.matrix(x))[,,1] + E1 <- E(object=distr, fun = psi.fct, useApply = .useApply ) + E3 <- E(object=distr, fun = function(x) + psi.fct(x)*evalRandVar(L2deriv.0, as.matrix(x))[,,1], useApply = .useApply) psi.01.f <- function(x) (psi.fct(x) - E1)/E3 - E4 <- E(object=distr, fun = function(x) psi.01.f(x)^2) + E4 <- E(object=distr, fun = function(x) psi.01.f(x)^2, useApply = .useApply) } } @@ -293,9 +292,10 @@ for(i in 1:Dim) { if(is(distr,"AbscontDistribution")){ - fct0.q1 <- sapply(x.seq.1, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) - fct0.q2 <- sapply(x.seq.2, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) - fct0.q3 <- sapply(x.seq.3, function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))}) + fct.q <- function(x){qx <- q.l(distr)(x); return(L2deriv.0 at Map[[i]](qx))} + fct0.q1 <- fct.q(x.seq.1) + fct0.q2 <- fct.q(x.seq.2) + fct0.q3 <- fct.q(x.seq.3) Delta0.q1 <- h0/100*.csimpsum(fct0.q1) Delta0.q2 <- rev(Delta0.q1)[1]+h0*.csimpsum(fct0.q2) Delta0.q3 <- rev(Delta0.q2)[1]+h0/100*.csimpsum(fct0.q3) @@ -307,7 +307,7 @@ assign("Delta1.q", Delta1.q, envir=env.i) }else{ if(is(distr,"DiscreteDistribution")){ - L2x <- sapply(x.seq, function(x) evalRandVar(L2deriv.0, x)[i]) + L2x <- evalRandVar(L2deriv.0, as.matrix(x.seq))[i,,1] L2xdx <- L2x*prob Delta.0 <- cumsum(L2xdx) Delta.f <- approxfun(x.seq, Delta.0, yleft = 0, yright = 0) @@ -318,7 +318,7 @@ }else{ fct0 <- function(x,y) L2deriv.0 at Map[[i]](x)*(x<=y) Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) fct0(x,y=Y) - return(E(object=distr, fun = fct))}) + return(E(object=distr, fun = fct, useApply=.useApply))}) Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) if(is(distr,"DiscreteDistribution")) Delta <- function(x) Delta1(x) * (x %in% support(distr)) @@ -350,12 +350,12 @@ ## J = Var_Ptheta Delta ##-t-## print(system.time({ - J1 <- E(object=distr, fun = Delta) + J1 <- E(object=distr, fun = Delta)#, useApply = .useApply) ##-t-## })) Delta.0 <- Delta - J1 ##-t-## print(system.time({ - J <- E(object=distr, fun = Delta.0 %*%t(Delta.0)) + J <- E(object=distr, fun = Delta.0 %*%t(Delta.0))#, useApply = .useApply) ##-t-## })) ### CvM-IC phi phi <- as(distr::solve(J)%*%Delta.0,"EuclRandVariable") @@ -371,7 +371,7 @@ phi1 <- EuclRandVariable(Map = Map.phi1, Domain = Reals()) ##-t-## print(system.time({ - psi1 <- E(object=mu, fun = phi1) + psi1 <- E(object=mu, fun = phi1)#, useApply = .useApply) ##-t-## })) ## obtaining IC psi (formula (51)) @@ -389,7 +389,7 @@ qxm <- q.l(mu)(x.mu.seq.b) ##-t-## print(system.time({ - fct0.qq <- sapply(qxm, phi at Map[[i]]) + fct0.qq <- phi at Map[[i]](qxm) ##-t-## })) fct0.q1 <- rev(fct0.qq[iN.mu.1]) fct0.q2 <- rev(fct0.qq[iN.mu.2]) @@ -405,7 +405,7 @@ assign("psi0", psi0, envir=env.i) }else{ if(is(mu,"DiscreteDistribution")){ - phi.mu <- sapply(x.mu.seq, function(x) evalRandVar(phi,x)[i]) + phi.mu <- evalRandVar(phi,as.matrix(x.mu.seq))[i,,1] psi0.d <- cumsum(phi.mu*prob.mu) psi0.a <- approxfun(x.mu.seq, psi0.d, yleft = 0, yright = 0) psi0 <- function(x) psi0.a(x) @@ -414,11 +414,11 @@ assign("psi0.d", psi0.d, envir=env.i) assign("psi0", psi0, envir=env.i) }else{ - fct0 <- function(x,y) evalRandVar(phi, y)[i]*(x<=y) + fct0 <- function(x,y) evalRandVar(phi, as.matrix(y))[i,,1]*(x<=y) phi0 <- sapply(x.mu.seq, function(X){ fct <- function(y) fct0(x = X, y) - return(E(object = mu, fun = fct)) + return(E(object = mu, fun = fct, useApply = .useApply)) }) phi0a <- approxfun(x.mu.seq, phi0, yleft = 0, yright = rev(phi0)[1]) if(is(distr,"DiscreteDistribution")) @@ -441,13 +441,13 @@ # print(Map.psi) psi <- EuclRandVariable(Map = Map.psi, Domain = Reals()) -# E2 <- E(object=distr, fun = psi %*%t(psi)) +# E2 <- E(object=distr, fun = psi %*%t(psi), useApply = .useApply) ## E2 = Cov_mu (psi) ### control: centering & standardization L2deriv.0 <- L2Fam at L2deriv[[1]] ##-t-## print(system.time({ - E1 <- E(object=distr, fun = psi ) + E1 <- E(object=distr, fun = psi) ##-t-## })) ##-t-## print(system.time({ E3 <- E(object=distr, fun = psi %*%t(L2deriv.0)) @@ -563,8 +563,6 @@ } L2deriv <- L2deriv(L2Fam)[[1]] -# y.seq <- sapply(x.seq, function(x) evalRandVar(L2deriv, x)) -# plot(x.seq[!is.na(y.seq)],y.seq ,type="l") ## are we working with a one-dim L2deriv or not? Modified: branches/distr-2.8/pkg/distrMod/man/L2ParamFamily-class.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/L2ParamFamily-class.Rd 2018-08-11 14:33:45 UTC (rev 1273) +++ branches/distr-2.8/pkg/distrMod/man/L2ParamFamily-class.Rd 2018-08-11 18:57:40 UTC (rev 1274) @@ -69,7 +69,10 @@ properties of the family. } \item{\code{L2deriv}}{ object of class \code{"EuclRandVariable"}: - L2 derivative of the family. } + L2 derivative of the family. Its map slot must contain a list of functions. + Each function in this list must have just one argument \code{x}, + which is vectorized, (i.e., callable for a vector-valued \code{x}), + and has a one-dimensional, numeric return value.} \item{\code{L2deriv.fct}}{ object of class \code{"function"}: mapping from the parameter space (argument \code{param} of class @@ -77,18 +80,32 @@ value of the L2derivative; \code{L2deriv.fct} is then used from observation \code{x} to value of the L2derivative; \code{L2deriv.fct} is used by \code{modifyModel} to move the L2deriv according to a change in the - parameter } - \item{\code{L2derivSymm}}{[ - object of class \code{"FunSymmList"}: - symmetry of the maps included in \code{L2deriv}. } - \item{\code{L2derivDistr}}{ - object of class \code{"OptionalDistrListOrCall"} (i.e., \code{NULL} or - an object of class \code{"DistrList"} or the respective call to generate - the latter object): if non-null and non-call, a - list which includes the distribution of \code{L2deriv}. } - \item{\code{L2derivDistrSymm}}{ - object of class \code{"DistrSymmList"}: - symmetry of the distributions included in \code{L2derivDistr}. } + parameter. + More specifically, let us call the parts \code{main} and \code{nuisance} + of the parameter the \emph{unknown} parameter. If this unknown parameter is + one-dimensional, the return value of \code{L2deriv.fct} must be a function + in argument \code{x}, which is vectorized, (i.e., + callable for a vector-valued \code{x}), and has a one-dimensional, numeric + return value. In case the dimension of the unknown parameter is larger + than one, the return value must be a list of functions, each of which + satisfies the conditions formulated for the case of a one-dimensional + parameter of interest. The order of the components of this list is + the same as the order of the parameter coordinates in \code{main}, followed + by the ones in \code{nuisance}.} + \item{L2derivSymm}{ object of class \code{"FunSymmList"}: + symmetry of the maps contained in \code{L2deriv}; a list + of symmetry properties of the same length as the return value of + \code{ L2deriv.fct }.} + \item{L2derivDistr}{object of class \code{"OptionalDistrListOrCall"} + (i.e., \code{NULL} or an object of class \code{"DistrList"} or + the respective call to generate the latter object): if non-null + and non-call, a list which includes the distribution of \code{L2deriv}; + the length of this list of univariate distributions must be of the same + length as the return value of \code{ L2deriv.fct }.} + \item{L2derivDistrSymm}{ object of class \code{"DistrSymmList"}: + symmetry of the distributions contained in \code{L2derivDistr}; + the length of this list of symmetry properties must be + of the same length as the return value of \code{ L2deriv.fct }. } \item{\code{FisherInfo.fct}}{ object of class \code{"function"}: mapping from the parameter space (argument \code{param} of class Modified: branches/distr-2.8/pkg/distrMod/man/L2ParamFamily.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/L2ParamFamily.Rd 2018-08-11 14:33:45 UTC (rev 1273) +++ branches/distr-2.8/pkg/distrMod/man/L2ParamFamily.Rd 2018-08-11 18:57:40 UTC (rev 1274) @@ -51,13 +51,31 @@ \code{param} of class \code{"ParamFamParameter"}) to a mapping from observation \code{x} to the value of the L2derivative; \code{L2deriv.fct} is used by \code{modifyModel} to - move the L2deriv according to a change in the parameter } + move the L2deriv according to a change in the parameter, + and to fill slot \code{L2deriv}. + More specifically, let us call the parts \code{main} and \code{nuisance} + of the parameter the \emph{unknown} parameter. If this unknown parameter is + one-dimensional, the return value of \code{L2deriv.fct} must be a function + in argument \code{x}, which is vectorized, (i.e., + callable for a vector-valued \code{x}), and has a one-dimensional, numeric + return value. In case the dimension of the unknown parameter is larger + than one, the return value must be a list of functions, each of which + satisfies the conditions formulated for the case of a one-dimensional + parameter of interest. The order of the components of this list is + the same as the order of the parameter coordinates in \code{main}, followed + by the ones in \code{nuisance}.} \item{L2derivSymm}{ object of class \code{"FunSymmList"}: - symmetry of the maps contained in \code{L2deriv} } + symmetry of the maps contained in \code{L2deriv}; a list + of symmetry properties of the same length as the return value of + \code{ L2deriv.fct }.} \item{L2derivDistr}{ object of class \code{"UnivarDistrList"}: - distribution of \code{L2deriv} } + distribution of \code{L2deriv}; the length of this list + of univariate distributions must be of the same length as the + return value of \code{ L2deriv.fct }.} \item{L2derivDistrSymm}{ object of class \code{"DistrSymmList"}: - symmetry of the distributions contained in \code{L2derivDistr} } + symmetry of the distributions contained in \code{L2derivDistr}; + the length of this list of symmetry properties must be + of the same length as the return value of \code{ L2deriv.fct }. } \item{FisherInfo.fct}{function: mapping from the parameter space (argument \code{param} of class \code{"ParamFamParameter"}) to the set of positive semidefinite matrices; \code{FisherInfo.fct} is used by \code{modifyModel} to From noreply at r-forge.r-project.org Tue Aug 14 13:40:31 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 14 Aug 2018 13:40:31 +0200 (CEST) Subject: [Distr-commits] r1275 - in branches/distr-2.8/pkg/distr: . R inst man vignettes Message-ID: <20180814114031.9470C180257@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-14 13:40:31 +0200 (Tue, 14 Aug 2018) New Revision: 1275 Modified: branches/distr-2.8/pkg/distr/NAMESPACE branches/distr-2.8/pkg/distr/R/0pre270.R branches/distr-2.8/pkg/distr/R/plot-methods.R branches/distr-2.8/pkg/distr/inst/NEWS branches/distr-2.8/pkg/distr/man/internals.Rd branches/distr-2.8/pkg/distr/man/options.Rd branches/distr-2.8/pkg/distr/vignettes/newDistributions-knitr.Rnw Log: [distr] branch 2.8.0 -clarified that gumbel is now in RobExtremes in vignette newDistributions-knitr.Rnw -modified devNew(): in interactive mode it now asks the user to shut some devices first when length(dev.list())>20; and in non-interactive mode, when length(dev.list())>20, it shuts the first 15 open devices (except for the first one) first; this is documented now in ?devNew Modified: branches/distr-2.8/pkg/distr/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distr/NAMESPACE 2018-08-11 18:57:40 UTC (rev 1274) +++ branches/distr-2.8/pkg/distr/NAMESPACE 2018-08-14 11:40:31 UTC (rev 1275) @@ -1,7 +1,7 @@ useDynLib(distr, .registration = TRUE, .fixes = "C_") import("methods") import("stats") -importFrom("grDevices", "dev.list", "dev.new", "xy.coords") +importFrom("grDevices", "dev.list", "dev.new", "xy.coords", "dev.off") importFrom("graphics", "plot", "abline", "layout", "legend", "lines", "mtext", "par", "points", "title") importFrom("MASS", "ginv") importFrom("utils", "str") Modified: branches/distr-2.8/pkg/distr/R/0pre270.R =================================================================== --- branches/distr-2.8/pkg/distr/R/0pre270.R 2018-08-11 18:57:40 UTC (rev 1274) +++ branches/distr-2.8/pkg/distr/R/0pre270.R 2018-08-14 11:40:31 UTC (rev 1275) @@ -6,9 +6,30 @@ } }else{ devNew <- function(...){ - if(length(dev.list())>0) - if(!is.null(getOption("newDevice"))) - if(getOption("newDevice")) dev.new(...) + if(length(dev.list())>0){ + if(!is.null(getOption("newDevice"))){ + nrOpen <- length(grDevices::dev.list()) + if(getOption("newDevice")==TRUE) { + if(interactive()){ + while(nrOpen >20){ + invisible(readline(prompt= + paste(gettext( + "Too many open graphic devices; please shut some."), + "\n", gettext( + "When you have shut some devices, press [enter] to continue"), + "\n", sep=""))) + nrOpen <- length(grDevices::dev.list()) + } + }else{ + if(nrOpen >20){ + while(nrOpen<-length(grDevices::dev.list())>5) + grDevices::dev.off(which=grDevices::dev.list()[2]) + } + } + } + dev.new(...) + } + } } } options("newDevice"=FALSE) Modified: branches/distr-2.8/pkg/distr/R/plot-methods.R =================================================================== --- branches/distr-2.8/pkg/distr/R/plot-methods.R 2018-08-11 18:57:40 UTC (rev 1274) +++ branches/distr-2.8/pkg/distr/R/plot-methods.R 2018-08-14 11:40:31 UTC (rev 1275) @@ -870,7 +870,7 @@ plotInfoList <- vector("list",length(x)) plotInfoList$call <- mc for(i in 1:length(x)){ - devNew() + #devNew() plotInfoList[[i]] <- plot(x[[i]],...) } class(plotInfoList) <- c("plotInfo","DiagnInfo") Modified: branches/distr-2.8/pkg/distr/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-11 18:57:40 UTC (rev 1274) +++ branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-14 11:40:31 UTC (rev 1275) @@ -20,7 +20,10 @@ + liesInSupport gains an argument checkFin; in case of DiscreteDistributions, it tries to use additional information from internal slot .finSupport, and e.g. if there is a lattice. + liesInSupport now also is available for UnivarLebDecDistribution, LatticeDistribution, and UnivarMixingDistribution - ++ clarified that the Gumbel distribution has been moved to RobExtremes in vignette newDistributions-knitr.Rnw ++ modified devNew(): in interactive mode it now asks the user to shut some devices first when + length(dev.list())>20; and in non-interactive mode, when length(dev.list())>20, it shuts + the first 15 open devices first; this is documented now in ?devNew under the hood: + DiscreteDistribution(s) gain a logical slot .finSupport to better control whether the "true" support (not the possibly truncated one in slot support) is infinite (more precisely Modified: branches/distr-2.8/pkg/distr/man/internals.Rd =================================================================== --- branches/distr-2.8/pkg/distr/man/internals.Rd 2018-08-11 18:57:40 UTC (rev 1274) +++ branches/distr-2.8/pkg/distr/man/internals.Rd 2018-08-14 11:40:31 UTC (rev 1275) @@ -404,7 +404,11 @@ unevaluated, and otherwise the unchanged argument. \code{devNew} opens a new device. This function is for back compatibility -with R versions < 2.8.0. +with R versions < 2.8.0. To control the number of opened devices, when +\code{length(dev.list())>20}, in interactive mode we ask the user to shut +some windows until \code{length(dev.list())<=20}; in non-interactive mode +we shut the first 15 open devices (except for the first one) before opening +a new one. } Modified: branches/distr-2.8/pkg/distr/man/options.Rd =================================================================== --- branches/distr-2.8/pkg/distr/man/options.Rd 2018-08-11 18:57:40 UTC (rev 1274) +++ branches/distr-2.8/pkg/distr/man/options.Rd 2018-08-14 11:40:31 UTC (rev 1275) @@ -20,8 +20,8 @@ \section{Additionally available options in package 'distr'}{ \describe{ \item{\code{"newDevice"}}{logical; controls behaviour when generating several plots within -one function; if \code{TRUE} a call to \code{\link{devNew}} is inserted to hook function -\code{\link[graphics:frame]{plot.new}}; if \code{FALSE}, we reproduce the usual behaviour +one function; if \code{TRUE}, before each call to call to \code{\link[graphics:frame]{plot.new}}, +a call to \code{\link{devNew}} is inserted; if \code{FALSE}, we reproduce the usual behaviour in \pkg{graphics}, i.e.; we do not call \code{\link{devNew}}. Defaults to \code{FALSE}.} } } Modified: branches/distr-2.8/pkg/distr/vignettes/newDistributions-knitr.Rnw =================================================================== --- branches/distr-2.8/pkg/distr/vignettes/newDistributions-knitr.Rnw 2018-08-11 18:57:40 UTC (rev 1274) +++ branches/distr-2.8/pkg/distr/vignettes/newDistributions-knitr.Rnw 2018-08-14 11:40:31 UTC (rev 1275) @@ -617,7 +617,7 @@ \item {\footnotesize you could have: \file{man/Binom.Rd} for the generating function; in the Binomial case, documentation is in \file{Binom-class.Rd}; but in case of the Gumbel distribution, - in package \pkg{distrEx}, there is such an extra {\tt .Rd} file} + in package \pkg{RobExtremes}, there is such an extra {\tt .Rd} file} % \end{itemize} % @@ -712,7 +712,7 @@ \item[Comment] In the classes in package \pkg{distr} (historically the ``oldest'' in the development of this project), we still use \code{initialize} methods; this is no longer needed, if you provide generating functions; for this ``more - recent'' approach, confer the realization of class \code{Gumbel} in package \pkg{distrEx}. + recent'' approach, confer the realization of class \code{Gumbel} in package \pkg{RobExtremes}. \end{itemize} % ------------------------------------------------------------------------------- From noreply at r-forge.r-project.org Wed Aug 15 15:49:37 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Aug 2018 15:49:37 +0200 (CEST) Subject: [Distr-commits] r1276 - in branches/distr-2.8/pkg/distrEx: . R inst man Message-ID: <20180815134937.8946C1897CF@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-15 15:49:37 +0200 (Wed, 15 Aug 2018) New Revision: 1276 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/Internalfunctions.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/0distrEx-package.Rd 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: + introduced filter functions .filterEargs and .filterFunargs to warrant some safety that only those args from "..." become arguments of the integrand, of distrExIntegrate, of E(), of integrate, of GLIntegrate, of quantiles and IQR, which are within the formals of the respective function... + .filterEargs in fact is (almost) .filterEargs from RobAStBase version 1.2, but: (a) it takes the formals automatically and not by an explicit string (b) .filterEargs in RobAStBase also filters in the items of "E.argList" + the return values of distrExIntegrate and all E()-methods gain an optional attribute "diagnostic" which is filled if argument diagnostic is TRUE (the E()-methods whenever they use distrExIntegrate in (parts of) their computation. Modified: branches/distr-2.8/pkg/distrEx/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distrEx/NAMESPACE 2018-08-14 11:40:31 UTC (rev 1275) +++ branches/distr-2.8/pkg/distrEx/NAMESPACE 2018-08-15 13:49:37 UTC (rev 1276) @@ -53,4 +53,4 @@ "distrExMASK", "distrExoptions", "distrExMOVED") export("make01","PrognCondDistribution", "PrognCondition") -export(".getIntbounds", ".qtlIntegrate") +export(".getIntbounds", ".qtlIntegrate", ".filterEargs", ".filterFunargs") Modified: branches/distr-2.8/pkg/distrEx/R/AsymTotalVarDist.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/AsymTotalVarDist.R 2018-08-14 11:40:31 UTC (rev 1275) +++ branches/distr-2.8/pkg/distrEx/R/AsymTotalVarDist.R 2018-08-15 13:49:37 UTC (rev 1276) @@ -11,11 +11,14 @@ function(e1, e2, rho = 1, rel.tol = .Machine$double.eps^0.3, maxiter=1000, Ngrid = 10000, TruncQuantile = getdistrOption("TruncQuantile"), - IQR.fac = 15){ + IQR.fac = 15, ..., diagnostic = FALSE){ ## if we have to recall this method with a smaller TruncQuantile arg: mc <- as.list(match.call(call = sys.call(sys.parent(1)))[-1]) mc$TruncQuantile <- TruncQuantile * 1.8 + dots <- list(...) + dotsn <- names(dots) + dotsI <- dots[dotsn %in% c("order","subdivisions", "stop.on.error")] #block warnings: o.warn <- getOption("warn"); options(warn = -1) @@ -36,9 +39,11 @@ d1 <- d(e1); d2 <- d(e2) # ### integration as a function of c: - Eip <- function(f, c00) - distrExIntegrate(f, lower = low, upper = up, - rel.tol = rel.tol, c00 = c00) + Eip <- function(f, c00, diagnostic0 = FALSE) + do.call(distrExIntegrate,c(list(f, lower = low, upper = up, + rel.tol = rel.tol, c00 = c00, + diagnostic = diagnostic0),dotsI)) + # positive part integ.p <- function(x,c00) pmax(d2(x)-c00*d1(x),0) # negative part @@ -46,8 +51,8 @@ ## function zero c(rho) of which is to be found fct <- function(c0, rho = rho){ - e.p <- Eip(f=integ.p, c00=c0) - e.m <- Eip(f=integ.m, c00=c0) + e.p <- Eip(f=integ.p, c00=c0, diagnostic0 = FALSE) + e.m <- Eip(f=integ.m, c00=c0, diagnostic0 = FALSE) e.p*rho - e.m } @@ -73,8 +78,13 @@ tef <- fct(1, rho = rho) ### if c=1 is already a zero: if(tef == 0){ - res <- Eip(f=integ.p,c00=1) + res <- Eip(f=integ.p,c00=1, diagnostic0 = diagnostic) names(res) <- "asym. total variation distance" + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } return(res) } # else: only have to search in c in [low1;1] resp [1;up1] @@ -82,7 +92,7 @@ c.rho <- try(uniroot(fct, lower = low1, upper = up1, rho = rho, tol = rel.tol, - maxiter = maxiter)$root, + maxiter = maxiter)$root, silent = TRUE) ## if does not give reasonable solution recall function with @@ -93,7 +103,12 @@ e2 = "AbscontDistribution")), args = mc)) ## else: - res <- Eip(f=integ.p, c00=c.rho) + res <- Eip(f=integ.p, c00=c.rho, diagnostic0=diagnostic) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } names(res) <- "asym. total variation distance" return(res) }) @@ -186,11 +201,19 @@ up.discr = getUp(e2), h.smooth = getdistrExOption("hSmooth"), rel.tol = .Machine$double.eps^0.3, maxiter=1000, Ngrid = 10000, TruncQuantile = getdistrOption("TruncQuantile"), - IQR.fac = 15){ - .asis.smooth.discretize.distance(e1, e2, asis.smooth.discretize, n.discr, - low.discr, up.discr, h.smooth, AsymTotalVarDist, rho = rho, + IQR.fac = 15, ..., diagnostic = FALSE){ + res <- .asis.smooth.discretize.distance(x = e1, Distribution = e2, + asis.smooth.discretize=asis.smooth.discretize, n.discr = n.discr, + low.discr= low.discr, up.discr = up.discr, h.smooth = h.smooth, + distance = AsymTotalVarDist, rho = rho, rel.tol = rel.tol, maxiter = maxiter, Ngrid = Ngrid, - TruncQuantile = TruncQuantile, IQR.fac = IQR.fac) + TruncQuantile = TruncQuantile, IQR.fac = IQR.fac, ..., diagnostic = diagnostic) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) }) setMethod("AsymTotalVarDist", signature(e1 = "AbscontDistribution", e2 = "numeric"), @@ -199,12 +222,18 @@ up.discr = getUp(e1), h.smooth = getdistrExOption("hSmooth"), rel.tol = .Machine$double.eps^0.3, maxiter=1000, Ngrid = 10000, TruncQuantile = getdistrOption("TruncQuantile"), - IQR.fac = 15){ - return(AsymTotalVarDist(e2, e1, rho= 1/rho, + IQR.fac = 15, ..., diagnostic = FALSE){ + res <- AsymTotalVarDist(e1=e2, e2=e1, rho= 1/rho, asis.smooth.discretize = asis.smooth.discretize, low.discr = low.discr, up.discr = up.discr, h.smooth = h.smooth, rel.tol = rel.tol, maxiter = maxiter, Ngrid = Ngrid, - TruncQuantile = TruncQuantile, IQR.fac = IQR.fac)) + TruncQuantile = TruncQuantile, IQR.fac = IQR.fac, ..., diagnostic = diagnostic) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) }) setMethod("AsymTotalVarDist", signature(e1 = "AcDcLcDistribution", @@ -212,12 +241,15 @@ function(e1, e2, rho = 1, rel.tol = .Machine$double.eps^0.3, maxiter=1000, Ngrid = 10000, TruncQuantile = getdistrOption("TruncQuantile"), - IQR.fac = 15){ + IQR.fac = 15, ..., diagnostic = FALSE){ ## if we have to recall this method with a smaller TruncQuantile arg: mc <- as.list(match.call(call = sys.call(sys.parent(1)))[-1]) mc$TruncQuantile <- TruncQuantile * 1.8 + dots <- list(...) + dotsn <- names(dots) + dotsI <- dots[dotsn %in% c("order","subdivisions", "stop.on.error")] + #block warnings: - #block warnings: o.warn <- getOption("warn"); options(warn = -1) on.exit(options(warn=o.warn)) @@ -254,9 +286,10 @@ low <- max(low,low0); up <- min(up,up0) # ### integration as a function of c: - Eip <- function(f, c00) - distrExIntegrate(f, lower = low, upper = up, - rel.tol = rel.tol, c00 = c00) + Eip <- function(f, c00, diagnostic0 = FALSE) + do.call(distrExIntegrate, c(list(f, lower = low, upper = up, + rel.tol = rel.tol, c00 = c00, + diagnostic = diagnostic0),dotsI)) # positive part integ.p.c <- function(x,c00) pmax(ac2.d(x)-c00*ac1.d(x),0) # negative part @@ -275,8 +308,8 @@ ## function zero c(rho) of which is to be found fct <- function(c0, rho = rho){ - e.p.c <- Eip(f=integ.p.c, c00=c0) - e.m.c <- Eip(f=integ.m.c, c00=c0) + e.p.c <- Eip(f=integ.p.c, c00=c0, diagnostic0 = FALSE) + e.m.c <- Eip(f=integ.m.c, c00=c0, diagnostic0 = FALSE) e.p.d <- sum(integ.p.d(c0)) e.m.d <- sum(integ.m.d(c0)) e.p <- e.p.c + e.p.d @@ -310,11 +343,17 @@ ## gives range for c: low1 <- min(d.range,dx.range); up1 <- max(d.range,dx.range) ## in any case compare with c=1 - tef <- fct(1, rho = rho) + tef <- fct(1, rho = rho, ...) ### if c=1 is already a zero: if(tef == 0){ - res <- Eip(f=integ.p.c,c00=1)+sum(integ.p.d(1)) + res <- Eip(f=integ.p.c,c00=1, diagnostic0 = diagnostic) + if(diagnostic){ + diagn <- attr(res, "diagnostic") + diagn[["call"]] <- match.call() + } + res <- res +sum(integ.p.d(1)) names(res) <- "asym. total variation distance" + if(diagnostic) attr(res, "diagnostic") <- diagn return(res) } # else: only have to search in c in [low1;1] resp [1;up1] @@ -322,7 +361,7 @@ c.rho <- try(uniroot(fct, lower = low1, upper = up1, rho = rho, tol = rel.tol, - maxiter = maxiter)$root, + maxiter = maxiter)$root, silent = TRUE) ## if does not give reasonable solution recall function with @@ -331,12 +370,22 @@ return(do.call(getMethod("AsymTotalVarDist", signature(e1 = "AcDcLcDistribution", e2 = "AcDcLcDistribution")), - args = mc)) + args = mc)) } - res <- Eip(f=integ.p.c, c00=c.rho)+sum(integ.p.d(c.rho)) + res <- Eip(f=integ.p.c, c00=c.rho, diagnostic0 = diagnostic) + if(diagnostic){ + diagn <- attr(res, "diagnostic") + diagn[["call"]] <- match.call() + } + 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 + } return(res) - }) + }) setMethod("AsymTotalVarDist", signature(e1 = "LatticeDistribution", e2 = "LatticeDistribution"), Modified: branches/distr-2.8/pkg/distrEx/R/CvMDist.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/CvMDist.R 2018-08-14 11:40:31 UTC (rev 1275) +++ branches/distr-2.8/pkg/distrEx/R/CvMDist.R 2018-08-15 13:49:37 UTC (rev 1276) @@ -4,7 +4,7 @@ ############################################################################### setMethod("CvMDist", signature(e1 = "UnivariateDistribution", e2 = "UnivariateDistribution"), - function(e1, e2, mu = e1, useApply = FALSE, ... ){ + function(e1, e2, mu = e1, useApply = FALSE, ..., diagnostic = FALSE){ o.warn <- getOption("warn"); options(warn = -1) on.exit(options(warn=o.warn)) if(is.null(e1 at p)){ @@ -17,7 +17,12 @@ e2 <- new("UnivariateDistribution", r=e2 at r, p = e2.erg$pfun, d = e2.erg$dfun, q = e2.erg$qfun, .withSim = TRUE, .withArith = FALSE)} - res <- E(mu, fun = function(t) {(p(e1)(t)-p(e2)(t))^2}, useApply = useApply, ...)^.5 + res <- E(mu, fun = function(t) {(p(e1)(t)-p(e2)(t))^2}, useApply = useApply, ..., diagnostic = diagnostic)^.5 + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } names(res) <- "CvM distance" return(res) }) @@ -25,15 +30,21 @@ ## CvM distance setMethod("CvMDist", signature(e1 = "numeric", e2 = "UnivariateDistribution"), - function(e1, e2, mu = e1, ...) + function(e1, e2, mu = e1, ..., diagnostic = FALSE) { o.warn <- getOption("warn"); options(warn = -1) on.exit(options(warn=o.warn)) if(identical(mu,e2)){ if(is(e2, "AbscontDistribution")) - return(.newCvMDist(e1,e2)) } + return(.newCvMDist(e1,e2)) } e10 <- DiscreteDistribution(e1) if(identical(mu,e1)) mu <- e10 - CvMDist(e1 = e10, e2 = e2, mu = mu, ...) + res <- CvMDist(e1 = e10, e2 = e2, mu = mu, ..., diagnostic = diagnostic) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + attr(res,"diagnostic") <- diagn + } + return(res) } ) Modified: branches/distr-2.8/pkg/distrEx/R/Expectation.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-14 11:40:31 UTC (rev 1275) +++ branches/distr-2.8/pkg/distrEx/R/Expectation.R 2018-08-15 13:49:37 UTC (rev 1276) @@ -1,12 +1,41 @@ ## Helper function: +.filterEargs <- function(dots, neg=FALSE){ + if(length(dots)==0) return(NULL) + formIntNames <- setdiff(unique(c(names(formals(distrExIntegrate)), + names(formals(integrate)), + names(formals(GLIntegrate)))),c("f","...", "distr")) + if(neg) return(dots[! names(dots) %in% formIntNames]) + else return(dots[names(dots) %in% formIntNames]) +} +.filterFunargs <- function(dots, fun, neg=FALSE){ + if(length(dots)==0) return(NULL) + formFunNames <- names(formals(fun)) + + if(neg) return(dots[! names(dots) %in% formFunNames]) + else return(dots[names(dots) %in% formFunNames]) +} + .getIntbounds <- function(object, low, upp, lowTQ, uppTQ, IQR.fac, ...){ qx <- q.l(object) - low0 <- qx(lowTQ, lower.tail = TRUE, ...) - upp0 <- ifelse( "lower.tail" %in% names(formals(qx)), - qx(uppTQ, lower.tail = FALSE, ...), - qx(1-uppTQ, ...)) - m <- median(object, ...); s <- IQR(object, ...) + fqxn <- names(formals(qx)) + dots <- list(...) + dotsqx <- NULL + if(length(dots)){ + dotsqx <- dots[names(dots) %in% fqxn] + dotsqx[["lower.tail"]] <- NULL + dotsqx[["p"]] <- NULL + } +# print(c(list(lowTQ, lower.tail = TRUE), dotsqx)) + low0 <- do.call(qx,c(list(lowTQ, lower.tail = TRUE), dotsqx)) + upp0 <- if ("lower.tail" %in% fqxn) + do.call(qx,c(list(uppTQ, lower.tail = FALSE), dotsqx)) else + do.call(qx,c(list(1-uppTQ), dotsqx)) + if("cond" %in% names(dotsqx)){ + m <- median(object,cond=dots$cond); s <- IQR(object,cond=dots$cond) + }else{ + m <- median(object); s <- IQR(object) + } low1 <- m - IQR.fac * s upp1 <- m + IQR.fac * s low <- max(low0,low1,low) @@ -34,8 +63,9 @@ rel.tol= getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = getdistrExOption("IQR.fac"), ... + IQR.fac = getdistrExOption("IQR.fac"), ..., diagnostic = FALSE ){ + mc <- match.call() if(is(Symmetry(object),"SphericalSymmetry")) return(SymmCenter(Symmetry(object))) integrand <- function(x, dfun){ x * dfun(x) } @@ -49,12 +79,17 @@ upp <- Ib["upp"] #print(Ib) if(upp= 0){ - return(object at a * E(object at X0, low = (low-object at b)/object at a, - upp = (upp-object at b)/object at a, ...) + - object at b * (p(object)(upp)-p.l(object)(low))) + res0 <- E(object at X0, low = (low-object at b)/object at a, + upp = (upp-object at b)/object at a, ..., + diagnostic = diagnostic) }else{ - return(object at a * E(object at X0, low = (upp-object at b)/object at a, - upp = (low-object at b)/object at a, ...) + - object at b * (p(object)(upp)-p.l(object)(low))) + res0 <- E(object at X0, low = (upp-object at b)/object at a, + upp = (low-object at b)/object at a, ..., + diagnostic = diagnostic) } + res1 <- object at a * res0 + object at b * (p(object)(upp)-p.l(object)(low)) + if(diagnostic){ + diagn <- attr(res0, "diagnostic") + diagn[["call"]] <- mc + attr(res1, "diagnostic") <- diagn + } + return(res1) }) setMethod("E", signature(object = "AffLinAbscontDistribution", @@ -107,19 +150,23 @@ setMethod("E", signature(object = "AffLinDiscreteDistribution", fun = "missing", cond = "missing"), - getMethod("E", signature(object = "AffLinDistribution", + function(object, low = NULL, upp = NULL, ...){ + getMethod("E", signature(object = "AffLinDistribution", + fun = "missing", + cond = "missing"))(object = object, low = low, upp = upp, + ..., diagnostic = FALSE) + }) +setMethod("E", signature(object = "AffLinLatticeDistribution", fun = "missing", - cond = "missing"))) -setMethod("E", signature(object = "AffLinLatticeDistribution", - fun = "missing", cond = "missing"), - getMethod("E", signature(object = "AffLinDistribution", - fun = "missing", - cond = "missing"))) + function(object, low = NULL, upp = NULL, ...){ + getMethod("E", signature(object = "AffLinDistribution", + fun = "missing", + cond = "missing"))(object = object, low = low, upp = upp, + ..., diagnostic = FALSE) + }) - - setMethod("E", signature(object = "MultivariateDistribution", fun = "missing", cond = "missing"), @@ -151,10 +198,12 @@ if(is.null(low)) low <- -Inf if(is.null(upp)) upp <- Inf xsim <- xsim[xsim >= low & xsim <= upp] - if(useApply) - return(mean(sapply(xsim, fun, ...))) + dotsFun <- .filterFunargs(list(...), fun, neg=FALSE) + funwD <- function(x) do.call(fun,c(list(x),dotsFun)) + if(useApply) + return(mean(sapply(X=xsim, FUN=funwD))) else - return(mean(fun(xsim, ...))) + return(mean(fun(xsim))) }) setMethod("E", signature(object = "AbscontDistribution", @@ -164,17 +213,23 @@ rel.tol= getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = getdistrExOption("IQR.fac"), ...){ + IQR.fac = getdistrExOption("IQR.fac"), ..., diagnostic = FALSE){ + mc <- match.call() + + dotsFun <- .filterFunargs(list(...), fun, neg=FALSE) + funwD <- function(x) do.call(fun,c(list(x),dotsFun)) + if(useApply){ - integrand <- function(x, dfun, fun, ...){ - sapply(x, fun, ...) * dfun(x) + integrand <- function(x){ + sapply(x, funwD) * d(object)(x) } }else{ - integrand <- function(x, dfun, fun, ...){ - fun(x, ...) * dfun(x) + integrand <- function(x){ + funwD(x) * d(object)(x) } } + if(is.null(low)) low <- -Inf if(is.null(upp)) upp <- Inf @@ -182,12 +237,17 @@ upperTruncQuantile, IQR.fac) low <- Ib["low"] upp <- Ib["upp"] - - return(distrExIntegrate(f = integrand, - lower = low, - upper = upp, - rel.tol = rel.tol, - distr = object, fun = fun, dfun = d(object), ...)) + res <- distrExIntegrate(f = integrand, lower = low, upper = upp, + rel.tol = rel.tol, distr = object, ..., + diagnostic = diagnostic) + + if(diagnostic){ + diagn <- attr(res, "diagnostic") + diagn[["call"]] <- mc + attr(res, "diagnostic") <- diagn + } + + return(res) }) setMethod("E", signature(object = "DiscreteDistribution", @@ -198,16 +258,18 @@ if(is.null(upp)) upp <- Inf supp <- support(object) supp <- supp[supp>=low & supp<=upp] + dotsFun <- .filterFunargs(list(...), fun, neg=FALSE) + funwD <- function(x) do.call(fun,c(list(x),dotsFun)) if(useApply){ - integrand <- function(x, dfun, fun, ...){ - sapply(x, fun, ...) * dfun(x) + integrand <- function(x, dfun, fun){ + sapply(X=x, FUN=fun) * dfun(x) } }else{ - integrand <- function(x, dfun, fun, ...){ - fun(x, ...) * dfun(x) + integrand <- function(x, dfun, fun){ + fun(x) * dfun(x) } } - return(sum(integrand(x = supp, dfun = d(object), fun = fun, ...))) + return(sum(integrand(x = supp, dfun = d(object), fun = funwD))) }) setMethod("E", signature(object = "LatticeDistribution", fun = "function", @@ -222,14 +284,16 @@ function(object, fun, useApply = TRUE, Nsim = getdistrExOption("MCIterations"), ...){ x <- r(object)(Nsim) + dotsFun <- .filterFunargs(list(...), fun, neg=FALSE) + funwD <- function(x) do.call(fun,c(list(x),dotsFun)) if(useApply) - erg <- apply(x, 1, fun, ...) + erg <- apply(X=x, MARGIN=1, FUN=funwD) else - erg <- t(fun(x, ...)) + erg <- t(funwD(x)) if(is.vector(erg)) return(mean(erg)) else{ - res <- fun(x[1,], ...) + res <- funwD(x[1,]) res[] <- rowMeans(erg) return(res) } @@ -239,16 +303,18 @@ cond = "missing"), function(object, fun, useApply = TRUE, ...){ supp <- support(object) + dotsFun <- .filterFunargs(list(...), fun, neg=FALSE) + funwD <- function(x) do.call(fun,c(list(x),dotsFun)) if(useApply){ - integrand <- function(x, fun, dfun, ...){ fun(x, ...) * dfun(t(x)) } - erg <- apply(supp, 1, integrand, fun = fun, dfun = d(object), ...) + integrand <- function(x, fun, dfun){ fun(x) * dfun(t(x)) } + erg <- apply(supp, 1, integrand, fun = funwD, dfun = d(object)) }else{ - erg <- t(fun(supp, ...) * d(object)(supp)) + erg <- t(funwD(supp) * d(object)(supp)) } if(is.vector(erg)) return(sum(erg)) else{ - res <- fun(supp[1,], ...) + res <- funwD(supp[1,]) res[] <- rowSums(erg) return(res) } @@ -271,11 +337,12 @@ rel.tol= getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = getdistrExOption("IQR.fac"), ...){ - fct <- function(x, dfun, cond){ x * dfun(x, cond) } + IQR.fac = getdistrExOption("IQR.fac"), ..., diagnostic = FALSE){ + mc <- match.call() + fct <- function(x){ x * d(object)(x, cond) } if(useApply){ - integrand <- function(x, dfun, cond){ - return(sapply(x, fct, dfun = dfun, cond = cond)) + integrand <- function(x){ + return(sapply(x, fct)) } }else{ integrand <- fct @@ -289,10 +356,19 @@ low <- Ib["low"] upp <- Ib["upp"] - return(distrExIntegrate(integrand, - lower = low, upper = upp, rel.tol = rel.tol, distr = object, - dfun = d(object), cond = cond)) + res <- distrExIntegrate(f=integrand, + lower = low, upper = upp, rel.tol = rel.tol, distr = object, + dfun = d(object), cond = cond, diagnostic = FALSE) + + if(diagnostic){ + diagn <- attr(res, "diagnostic") + diagn[["call"]] <- mc + attr(res, "diagnostic") <- diagn + } + + return(res) }) + setMethod("E", signature(object = "DiscreteCondDistribution", fun = "missing", cond = "numeric"), @@ -313,20 +389,22 @@ cond = "numeric"), function(object, fun, cond, withCond = FALSE, useApply = TRUE, low = NULL, upp = NULL, Nsim = getdistrExOption("MCIterations"), ...){ + dotsFun <- .filterFunargs(list(...), fun, neg=FALSE) + funwD <- function(x) do.call(fun,c(list(x),dotsFun)) xsim <- r(object)(Nsim, cond) if(is.null(low)) low <- -Inf if(is.null(upp)) upp <- Inf xsim <- xsim[xsim >= low & xsim <= upp] if(withCond){ if(useApply) - res <- mean(sapply(xsim, fun, cond, ...)) + res <- mean(sapply(xsim, funwD, cond)) else - res <- mean(fun(xsim, cond, ...)) + res <- mean(funwD(xsim, cond)) }else{ if(useApply) - res <- mean(sapply(xsim, fun, ...)) + res <- mean(sapply(xsim, funwD)) else - res <- mean(fun(xsim, ...)) + res <- mean(funwD(xsim)) } return(res) @@ -338,28 +416,20 @@ rel.tol= getdistrExOption("ErelativeTolerance"), lowerTruncQuantile = getdistrExOption("ElowerTruncQuantile"), upperTruncQuantile = getdistrExOption("EupperTruncQuantile"), - IQR.fac = getdistrExOption("IQR.fac"), ...){ - if(withCond) - if(useApply){ - integrand <- function(x, dfun, fun, cond, ...){ - sapply(x, fun, cond, ...) * dfun(x, cond) - } - }else{ - integrand <- function(x, dfun, fun, cond, ...){ - fun(x, cond, ...) * dfun(x, cond) - } - } - else - if(useApply){ - integrand <- function(x, dfun, fun, cond, ...){ - sapply(x, fun, ...) * dfun(x, cond) - } - }else{ - integrand <- function(x, dfun, fun, cond, ...){ - fun(x, ...) * dfun(x, cond) - } - } + IQR.fac = getdistrExOption("IQR.fac"), ..., diagnostic = FALSE){ + mc <- match.call() + dotsFun <- .filterFunargs(list(...), fun, neg=FALSE) + + CondArg <- if(withCond) list(cond=cond) else NULL + funwD <- function(x) do.call(fun,c(list(x), CondArg,dotsFun)) + + if(useApply){ + integrand <- function(x) sapply(x, funwD) * d(object)(x, cond) + }else{ + integrand <- function(x) funwD(x) * d(object)(x, cond) + } + if(is.null(low)) low <- -Inf if(is.null(upp)) upp <- Inf @@ -368,41 +438,39 @@ low <- Ib["low"] upp <- Ib["upp"] - return(distrExIntegrate(integrand, - lower = low, upper = upp, rel.tol = rel.tol, distr = object, - dfun = d(object), fun = fun, cond = cond, ...)) + res <- distrExIntegrate(f=integrand, + lower = low, upper = upp, rel.tol = rel.tol, distr = object, + fun = funwD, ..., diagnostic = diagnostic) + + if(diagnostic){ + diagn <- attr(res, "diagnostic") + diagn[["call"]] <- mc + attr(res, "diagnostic") <- diagn + } + + return(res) }) setMethod("E", signature(object = "DiscreteCondDistribution", fun = "function", cond = "numeric"), function(object, fun, cond, withCond = FALSE, useApply = TRUE, low = NULL, upp = NULL, ...){ + + dotsFun <- .filterFunargs(list(...), fun, neg=FALSE) + + CondArg <- if(withCond) list(cond=cond) else NULL + funwD <- function(x) do.call(fun,c(list(x), CondArg,dotsFun)) + if(is.null(low)) low <- -Inf if(is.null(upp)) upp <- Inf supp <- support(object)(cond) supp <- supp[supp>=low & supp<=upp] - if(withCond){ - if(useApply){ - fct <- function(x, dfun, fun, cond, ...){ - sapply(x, fun, cond, ...) * dfun(x, cond) - } - }else{ - fct <- function(x, dfun, fun, cond, ...){ - fun(x, cond, ...) * dfun(x, cond) - } - } + + if(useApply){ + integrand <- function(x) sapply(x, funwD) * d(object)(x, cond) }else{ - if(useApply){ - fct <- function(x, dfun, fun, cond, ...){ - sapply(x, fun, ...) * dfun(x, cond) - } - }else{ - fct <- function(x, dfun, fun, cond, ...){ - fun(x, ...) * dfun(x, cond) - } - } + integrand <- function(x) funwD(x) * d(object)(x, cond) } - return(sum(fct(x = supp, dfun = d(object), fun = fun, - cond = cond, ...))) + return(sum(integrand(supp))) }) @@ -432,13 +500,23 @@ setMethod("E", signature(object = "Beta", fun = "missing", cond = "missing"), - function(object, low = NULL, upp = NULL, ...){ + function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){ + mc <- match.call() + if(!is.null(low)) if(low <= 0) low <- NULL if(!is.null(upp)) if(upp >= 1) upp <- NULL - if((!isTRUE(all.equal(ncp(object),0)))|| !is.null(low) || !is.null(upp)) - return(E(as(object,"AbscontDistribution"), low=low, upp=upp, ...)) - else - return(shape1(object)/(shape1(object)+shape2(object))) + if((!isTRUE(all.equal(ncp(object),0)))|| !is.null(low) || !is.null(upp)){ + + res <- E(as(object,"AbscontDistribution"), low=low, upp=upp, ..., diagnostic = diagnostic) + + if(diagnostic){ + diagn <- attr(res, "diagnostic") + diagn[["call"]] <- mc + attr(res, "diagnostic") <- diagn + } + + return(res) + }else return(shape1(object)/(shape1(object)+shape2(object))) }) ## source: https://mathworld.wolfram.com/BetaDistribution.html @@ -470,7 +548,8 @@ setMethod("E", signature(object = "Cauchy", fun = "missing", cond = "missing"), - function(object, low = NULL, upp = NULL, ...){ + function(object, low = NULL, upp = NULL, ..., diagnostic = FALSE){ + mc <- match.call() if(is.null(low) && is.null(upp)) return(NA) else{ @@ -480,10 +559,19 @@ if(upp == Inf) return(NA) else return(-Inf) }else{ - return(if(upp == Inf) Inf else{ - getMethod("E", signature(object = "Cauchy", - fun = "function", cond = "missing"))(object, - fun=function(x)(xlow)*1.0,...)}) + if(upp == Inf) return(Inf) else{ + res <- E(object, fun = function(x)1, low=low, upp= upp, [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/distr -r 1276 From noreply at r-forge.r-project.org Wed Aug 15 16:08:10 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Aug 2018 16:08:10 +0200 (CEST) Subject: [Distr-commits] r1277 - in branches/distr-2.8/pkg/distrEllipse: R inst Message-ID: <20180815140810.76EE218A6C6@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-15 16:08:10 +0200 (Wed, 15 Aug 2018) New Revision: 1277 Modified: branches/distr-2.8/pkg/distrEllipse/R/MVMixingDistribution.R branches/distr-2.8/pkg/distrEllipse/inst/NEWS Log: [distrEllipse] branch 2.8 + E methods for MultivarMixingDistribution gain argument diagnostic (like E()-methods in distrEx v 2.8.0) + E methods for MultivarMixingDistribution use filtering of dots arguments (like E()-methods in distrEx v 2.8.0) Modified: branches/distr-2.8/pkg/distrEllipse/R/MVMixingDistribution.R =================================================================== --- branches/distr-2.8/pkg/distrEllipse/R/MVMixingDistribution.R 2018-08-15 13:49:37 UTC (rev 1276) +++ branches/distr-2.8/pkg/distrEllipse/R/MVMixingDistribution.R 2018-08-15 14:08:10 UTC (rev 1277) @@ -125,26 +125,46 @@ setMethod("E", signature(object = "MultivarMixingDistribution", - fun = "missing", cond = "missing"), function(object, ...) { + fun = "missing", cond = "missing"), + function(object, ..., diagnostic=FALSE) { l <- length(object at mixCoeff) - res <- object at mixCoeff[1]*E(object=object at mixDistr[[1]], ...) + dotsI <- .filterEargs(list(...)) + diagn <- vector("list",l) + res0 <- do.call(E, c(list(object=object at mixDistr[[1]], diagnostic=diagnostic), dotsI)) + diagn[[1]] <- attr(res0,"diagnostic") + res <- object at mixCoeff[1]*res0 + diagn[["call"]] <- match.call() + if(diagnostic) attr(res,"diagnostic") <- diagn if(l==1) return(res) for(i in 2:l){ - res0 <- object at mixCoeff[i]*E(object=object at mixDistr[[i]], ...) - res <- res + res0 + res0 <- do.call(E, c(list(object=object at mixDistr[[i]], diagnostic=diagnostic), dotsI)) + diagn[[i]] <- attr(res0,"diagnostic") + res <- res + object at mixCoeff[i]*res0 } + if(diagnostic) attr(res,"diagnostic") <- diagn return(res) }) setMethod("E", signature(object = "MultivarMixingDistribution", fun = "function", cond = "missing"), - function(object, fun, ...) { + function(object, fun, ..., diagnostic=FALSE) { l <- length(object at mixCoeff) - res <- object at mixCoeff[1]*E(object=object at mixDistr[[1]], fun=fun,...) + dots <- list(...) + dotsI <- .filterEargs(dots) + dotsFun <- .filterFunargs(dots,fun) + funwD <- function(x) do.call(fun, c(list(x), dotsFun)) + diagn <- vector("list",l) + res0 <- do.call(E, c(list(object=object at mixDistr[[1]], fun = funwD, diagnostic=diagnostic), dotsI)) + diagn[[1]] <- attr(res0,"diagnostic") + res <- object at mixCoeff[1]*res0 + diagn[["call"]] <- match.call() + if(diagnostic) attr(res,"diagnostic") <- diagn if(l==1) return(res) for(i in 2:l){ - res0 <- object at mixCoeff[i]*E(object=object at mixDistr[[i]], fun=fun, ...) - res <- res + res0 + res0 <- do.call(E, c(list(object=object at mixDistr[[i]], fun = funwD, diagnostic=diagnostic), dotsI)) + diagn[[i]] <- attr(res0,"diagnostic") + res <- res + object at mixCoeff[i]*res0 } + if(diagnostic) attr(res,"diagnostic") <- diagn return(res) }) Modified: branches/distr-2.8/pkg/distrEllipse/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrEllipse/inst/NEWS 2018-08-15 13:49:37 UTC (rev 1276) +++ branches/distr-2.8/pkg/distrEllipse/inst/NEWS 2018-08-15 14:08:10 UTC (rev 1277) @@ -13,9 +13,13 @@ user-visible CHANGES: + DESCRIPTION tag SVNRevision changed to VCS/SVNRevision ++ E methods for MultivarMixingDistribution gain argument diagnostic + (like E()-methods in distrEx v 2.8.0) under the hood: + now specified that we want to use distr::solve ++ E methods for MultivarMixingDistribution use filtering of dots arguments + (like E()-methods in distrEx v 2.8.0) ############## v 2.7 From noreply at r-forge.r-project.org Wed Aug 15 21:58:22 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Aug 2018 21:58:22 +0200 (CEST) Subject: [Distr-commits] r1278 - in branches/distr-2.8/pkg/distrMod: . R inst man tests/Examples Message-ID: <20180815195822.2F76A189E85@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-15 21:58:21 +0200 (Wed, 15 Aug 2018) New Revision: 1278 Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE branches/distr-2.8/pkg/distrMod/R/AllPlot.R branches/distr-2.8/pkg/distrMod/R/Expectation.R branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/internals.Rd branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save Log: [distrMod] branch 2.8 + plot signature(x = "L2ParamFamily", y = "missing") allows for width and height to be given (then applied in devNew(...) + E() methods with signature(object = "L2ParamFamily" , ...) gain argument diagnostic and use filtering of dots arguments (like E()-methods in distrEx v 2.8.0) + similarly the asCvMVarianceQtl.R Modified: branches/distr-2.8/pkg/distrMod/NAMESPACE =================================================================== --- branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-15 14:08:10 UTC (rev 1277) +++ branches/distr-2.8/pkg/distrMod/NAMESPACE 2018-08-15 19:58:21 UTC (rev 1278) @@ -4,7 +4,7 @@ "points", "text", "title") importFrom("stats", "aggregate", "approxfun", "complete.cases", "dbinom", "dnbinom", "dnorm", "dpois", "na.omit", "optim", - "optimize", "ppoints", "qchisq", "qnbinom", "qnorm") + "optimize", "ppoints", "qchisq", "qnbinom", "qnorm", "quantile") import("MASS") import("distr") import("distrEx") Modified: branches/distr-2.8/pkg/distrMod/R/AllPlot.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/AllPlot.R 2018-08-15 14:08:10 UTC (rev 1277) +++ branches/distr-2.8/pkg/distrMod/R/AllPlot.R 2018-08-15 19:58:21 UTC (rev 1278) @@ -255,9 +255,12 @@ # opar$cin <- opar$cra <- opar$csi <- opar$cxy <- opar$din <- NULL on.exit(par(opar, no.readonly = TRUE)) - if (!withSweave) - devNew() - + 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)) Modified: branches/distr-2.8/pkg/distrMod/R/Expectation.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/Expectation.R 2018-08-15 14:08:10 UTC (rev 1277) +++ branches/distr-2.8/pkg/distrMod/R/Expectation.R 2018-08-15 19:58:21 UTC (rev 1278) @@ -2,24 +2,38 @@ setMethod("E", signature(object = "L2ParamFamily", fun = "EuclRandVariable", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - return(E(object = object at distribution, fun = fun, useApply = useApply, ...)) + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + return(E(object = object at distribution, fun = fun, useApply = useApply, ..., diagnostic = diagnostic)) }) setMethod("E", signature(object = "L2ParamFamily", fun = "EuclRandMatrix", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ - matrix(E(object = object, fun = as(fun, "EuclRandVariable"), - useApply = useApply, ...), nrow = nrow(fun)) + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ + res <- E(object = object, fun = as(fun, "EuclRandVariable"), + useApply = useApply, ...) + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + } + res <- matrix(res, nrow = nrow(fun)) + if(diagnostic) attr(res, "diagnostic") <- diagn + return(res) }) setMethod("E", signature(object = "L2ParamFamily", fun = "EuclRandVarList", cond = "missing"), - function(object, fun, useApply = TRUE, ...){ + function(object, fun, useApply = TRUE, ..., diagnostic = FALSE){ nrvalues <- length(fun) res <- vector("list", nrvalues) - for(i in 1:nrvalues) res[[i]] <- E(object = object, fun = fun[[i]], - useApply = useApply, ...) - + diagn <- if(diagnostic) vector("list",nrvalues) else NULL + for(i in 1:nrvalues){ + res[[i]] <- buf <- E(object = object, fun = fun[[i]], + useApply = useApply, ..., diagnostic = diagnostic) + if(diagnostic) diagn[[i]] <- attr(buf,"diagnostic") + } + if(diagnostic){ + diagn <- attr(res,"diagnostic") + diagn[["call"]] <- match.call() + } return(res) }) Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-15 14:08:10 UTC (rev 1277) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-15 19:58:21 UTC (rev 1278) @@ -24,17 +24,21 @@ N = 1021, rel.tol=.Machine$double.eps^0.3, TruncQuantile = getdistrOption("TruncQuantile"), IQR.fac = 15, - ...){ + ..., diagnostic = FALSE){ # preparations: + dots <- list(...) - dotsInt <- list(...) + dotsInt <- .filterEargs(dots) dotsInt[["f"]] <- NULL dotsInt[["lower"]] <- NULL dotsInt[["upper"]] <- NULL dotsInt[["stop.on.error"]] <- NULL dotsInt[["distr"]] <- NULL + dotsInt[["diagnostic"]] <- NULL + dotsInt[["useApply"]] <- NULL + .useApply <- FALSE - if(!is.null(dotsInt$useApply)) .useApply <- dotsInt$useApply + if(!is.null(dots$useApply)) .useApply <- dots$useApply if(missing(TruncQuantile)||TruncQuantile>1e-7) TruncQuantile <- 1e-8 @@ -59,6 +63,7 @@ paramP at trafo <- diag(dim0) L2Fam <- modifyModel(L2Fam, paramP) + diagn <- if(diagnostic) list(call=match.call()) else NULL distr <- L2Fam at distribution ### get a sensible integration range: @@ -136,9 +141,12 @@ onedim <- (length(L2deriv.0 at Map)==1) - myint <- function(f,...){ - distrExIntegrate(f=f, lower=0, upper=1, - stop.on.error=FALSE, distr=Unif(), ...) + myint <- function(f,...,diagnostic0 = FALSE){ + dotsFun <- .filterFunargs(dots,f) + fwD <- function(x) do.call(f, c(list(x),dotsFun)) + do.call(distrExIntegrate, c(list(f=fwD, lower=0, upper=1, + stop.on.error=FALSE, distr=Unif(), diagnostic=diagnostic0, + dotsInt))) } if(onedim){ @@ -159,9 +167,11 @@ Delta0.3 <- rev(Delta0.2)[1]+h0/100*.csimpsum(Delta0x.3) Delta0 <- c(Delta0.1,Delta0.2,Delta0.3) Delta1.q <- approxfun(x.seq.a, Delta0, yleft = 0, yright = 0) - J1 <- do.call(myint, c(list(f=Delta1.q), dotsInt)) + J1 <- myint(f=Delta1.q, diagnostic0=diagnostic) + if(diagnostic) diagn$J1 <- attr(J1,"diagnostic") Delta.0 <- function(x) Delta1.q(p(distr)(x))-J1 - J <- do.call(myint, c(list(f=function(x) (Delta1.q(x)-J1)^2),dotsInt)) + J <- myint(f=function(x) (Delta1.q(x)-J1)^2, diagnostic0=diagnostic) + if(diagnostic) diagn$J <- attr(J,"diagnostic") }else{ if(is(distr,"DiscreteDistribution")){ L2x <- evalRandVar(L2deriv.0, as.matrix(x.seq))[,,1] @@ -174,13 +184,25 @@ Delta <- Delta/J }else{ L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, as.matrix(x))[,,1] - Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) L2x(x,y=Y) - return(E(object=distr, fun = fct, useApply = .useApply))}) + diagn0 <- list() + xseq.i <- quantile(seq(x.seq),c(0,0.25,.5,.75,1)) + Delta0 <- sapply(seq(x.seq), function(Y){ + res <- do.call(E, c(list(object=distr, + fun = function(x) L2x(x,y=x.seq[Y]), + useApply = .useApply, + diagnostic=diagnostic),dotsInt)) + if(diagnostic) if(Y %in% xseq.i) diagn0[[paste(Y)]] <<- attr(res,"diagnostic") + }) + if(diagnostic) diagn$Delta0 <- diagn0 Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) Delta <- Delta1 - J1 <- E(object=distr, fun = Delta, useApply = .useApply) + J1 <- do.call(E, c(list(object=distr, fun = Delta, useApply = .useApply, + diagnostic=diagnostic), dotsInt)) + if(diagnostic) diagn$J1 <- attr(J1,"diagnostic") Delta.0 <- function(x) Delta(x) - J1 - J <- E(object=distr, fun = function(x) Delta.0(x)^2, useApply = .useApply ) + J <- do.call(E, c(list(object=distr, fun = function(x) Delta.0(x)^2, useApply = .useApply, + diagnostic=diagnostic), dotsInt)) + if(diagnostic) diagn$J <- attr(J,"diagnostic") } } @@ -193,7 +215,8 @@ ## integrand phi x Ptheta in formula (51) [ibid] phi1.q <- function(s){qs <- q.l(mu)(s) return(phi(qs)*p(distr)(qs)) } - psi1 <- do.call(myint, c(list(f=phi1.q),dotsInt)) + psi1 <- myint(f=phi1.q, diagnostic0=diagnostic) + if(diagnostic) diagn$psi1 <- attr(psi1,"diagnostic") phiqx <- function(x){qx <- q.l(mu)(x) return(phi(qx))} @@ -223,11 +246,21 @@ }else{ ## integrand phi x Ptheta in formula (51) [ibid] phi1 <- function(x) phi(x) * p(distr)(x) - psi1 <- E(object = mu, fun = phi1, useApply = .useApply) + psi1 <- do.call(E,c(list(object = mu, fun = phi1, useApply = .useApply, + diagnostic = diagnostic),dotsInt)) + if(diagnostic) diagn$psi1 <- attr(psi1,"diagnostic") phixy <- function(x,y) (x<=y)*phi(y) - psi0 <- sapply(x.mu.seq, function(X){ fct <- function(y) phixy(x=X,y=y) - return(E(object=mu, fun = fct, useApply = .useApply))}) + diagn1 <- list() + x.mu.seq.i <- quantile(seq(x.mu.seq),c(0,0.25,.5,.75,1)) + psi0 <- sapply(seq(x.mu.seq), function(X){ + fct <- function(y) phixy(x=x.mu.seq[X],y=y) + res <- do.call(E,c(list(object=mu, fun = fct, + useApply = .useApply), dotsInt)) + if(diagnostic) if(X %in% x.mu.seq.i) + diagn1[[paste(X)]] <<- attr(res,"diagnostic") + return(res)}) + psi.1 <- approxfun(x.mu.seq, psi0, yleft = 0, yright = rev(psi0)[1]) psi.fct <- function(x) psi.1(x)-psi1 } @@ -237,14 +270,17 @@ psi.q <- function(x){qx <- q.l(distr)(x); return(psi.fct(qx))} ## E2 = Cov_mu (psi) # E2 <- do.call(myint, c(list(f=function(x)psi.q(x)^2),dotsInt)) - E1 <- do.call(myint, c(list(f=psi.q),dotsInt)) - E3 <- do.call(myint, c(list(f=function(x){ - qx <- q.l(distr)(x) - L2qx <- evalRandVar(L2deriv.0,as.matrix(qx))[,,1] - return(psi.fct(qx)*L2qx) - }), dotsInt)) + E1 <- myint(f=psi.q, diagnostic0=diagnostic) + if(diagnostic) diagn$E1 <- attr(E1,"diagnostic") + E3 <- myint(f=function(x){ + qx <- q.l(distr)(x) + L2qx <- evalRandVar(L2deriv.0,as.matrix(qx))[,,1] + return(psi.fct(qx)*L2qx) + }, diagnostic0=diagnostic) + if(diagnostic) diagn$E3 <- attr(E3,"diagnostic") psi.01.f <- function(x) (psi.fct(x)-E1)/E3 - E4 <- do.call(myint, c(list(f=function(x) (psi.q(x)-E1)^2/E3^2),dotsInt)) + E4 <- myint(f=function(x) (psi.q(x)-E1)^2/E3^2, diagnostic0=diagnostic) + if(diagnostic) diagn$E4 <- attr(E4,"diagnostic") }else{ if(is(distr,"DiscreteDistribution")){ ## E2 = Cov_mu (psi) @@ -259,17 +295,23 @@ ## E2 = Cov_mu (psi) # E2 <- E(object=distr, fun = function(x) psi(x)^2, useApply = .useApply) L2x <- function(x,y) (x<=y)*evalRandVar(L2deriv.0, as.matrix(x))[,,1] - E1 <- E(object=distr, fun = psi.fct, useApply = .useApply ) - E3 <- E(object=distr, fun = function(x) - psi.fct(x)*evalRandVar(L2deriv.0, as.matrix(x))[,,1], useApply = .useApply) + E1 <- do.call(E, c(list(object=distr, fun = psi.fct, + useApply = .useApply, diagnostic=diagnostic), dotsInt)) + if(diagnostic) diagn$E1 <- attr(E1,"diagnostic") + E3 <- do.call(E, c(list(object=distr, fun = function(x) + psi.fct(x)*evalRandVar(L2deriv.0, as.matrix(x))[,,1], + diagnostic=diagnostic, useApply = .useApply),dotsInt)) + if(diagnostic) diagn$E3 <- attr(E3,"diagnostic") psi.01.f <- function(x) (psi.fct(x) - E1)/E3 - E4 <- E(object=distr, fun = function(x) psi.01.f(x)^2, useApply = .useApply) + E4 <- do.call(E, c(list(object=distr, fun = function(x) psi.01.f(x)^2, + diagnostic=diagnostic, useApply = .useApply),dotsInt)) + if(diagnostic) diagn$E4 <- attr(E4,"diagnostic") } } # ### control: centering & standardization if(withplot) - { dev.new() #windows() + { devNew() #windows() x0.seq <- x.seq if(is(distr,"AbscontDistribution")) x0.seq <- q.l(distr)(x.seq) plot(x0.seq, psi.01.f(x0.seq), @@ -289,6 +331,11 @@ ## Ptheta- primitive function for Lambda Map.Delta <- vector("list",Dim) + if(diagnostic) diagn <- list() + if(!is(distr,"AbscontDistribution") && + !is(distr,"DiscreteDistribution") ) diagn$Delta0 <- vector("list",Dim) + if(!is(mu,"AbscontDistribution") && + !is(mu,"DiscreteDistribution") ) diagn$phi0 <- vector("list",Dim) for(i in 1:Dim) { if(is(distr,"AbscontDistribution")){ @@ -317,8 +364,18 @@ assign("Delta.0", Delta.0, envir=env.i) }else{ fct0 <- function(x,y) L2deriv.0 at Map[[i]](x)*(x<=y) - Delta0 <- sapply(x.seq, function(Y){ fct <- function(x) fct0(x,y=Y) - return(E(object=distr, fun = fct, useApply=.useApply))}) + diagn0 <- list() + xseq.i <- quantile(seq(x.seq),c(0,0.25,.5,.75,1)) + Delta0 <- sapply(seq(x.seq), + function(Y){ + fct <- function(x) fct0(x,y=x.seq[Y]) + res <- do.call(E,c(list(object=distr, fun = fct, + useApply=.useApply),dotsInt)) + if(diagnostic) if(Y %in% xseq.i) + diagn0[[paste(Y)]] <<- attr(res,"diagnostic") + return(res) + }) + if(diagnostic) diagn[["Delta0"]][[i]] <- diagn0 Delta1 <- approxfun(x.seq, Delta0, yleft = 0, yright = 0) if(is(distr,"DiscreteDistribution")) Delta <- function(x) Delta1(x) * (x %in% support(distr)) @@ -350,12 +407,14 @@ ## J = Var_Ptheta Delta ##-t-## print(system.time({ - J1 <- E(object=distr, fun = Delta)#, useApply = .useApply) + J1 <- E(object=distr, fun = Delta, diagnostic=diagnostic)#, useApply = .useApply) + if(diagnostic) diagn$J1 <- attr(J1,"diagnostic") ##-t-## })) Delta.0 <- Delta - J1 ##-t-## print(system.time({ - J <- E(object=distr, fun = Delta.0 %*%t(Delta.0))#, useApply = .useApply) + J <- E(object=distr, fun = Delta.0 %*%t(Delta.0), diagnostic=diagnostic)#, useApply = .useApply) + if(diagnostic) diagn$J <- attr(J,"diagnostic") ##-t-## })) ### CvM-IC phi phi <- as(distr::solve(J)%*%Delta.0,"EuclRandVariable") @@ -371,7 +430,8 @@ phi1 <- EuclRandVariable(Map = Map.phi1, Domain = Reals()) ##-t-## print(system.time({ - psi1 <- E(object=mu, fun = phi1)#, useApply = .useApply) + psi1 <- E(object=mu, fun = phi1, diagnostic=diagnostic)#, useApply = .useApply) + if(diagnostic) diagn$psi1 <- attr(psi1,"diagnostic") ##-t-## })) ## obtaining IC psi (formula (51)) @@ -414,12 +474,21 @@ assign("psi0.d", psi0.d, envir=env.i) assign("psi0", psi0, envir=env.i) }else{ + fct0 <- function(x,y) evalRandVar(phi, as.matrix(y))[i,,1]*(x<=y) - phi0 <- sapply(x.mu.seq, - function(X){ - fct <- function(y) fct0(x = X, y) - return(E(object = mu, fun = fct, useApply = .useApply)) - }) + diagn1 <- list() + x.mu.seq.i <- quantile(seq(x.mu.seq),c(0,0.25,.5,.75,1)) + phi0 <- sapply(seq(x.mu.seq), + function(X){ + fct <- function(y) fct0(x=x.mu.seq[X],y) + res <- do.call(E,c(list(object=mu, fun = fct, + useApply=.useApply),dotsInt)) + if(diagnostic) if(X %in% x.mu.seq.i) + diagn1[[paste(X)]] <<- attr(res,"diagnostic") + return(res) + }) + if(diagnostic) diagn[["phi0"]][[i]] <- diagn1 + phi0a <- approxfun(x.mu.seq, phi0, yleft = 0, yright = rev(phi0)[1]) if(is(distr,"DiscreteDistribution")) psi0 <- function(x) phi0a(x) * (x %in% support(mu)) @@ -447,10 +516,13 @@ ### control: centering & standardization L2deriv.0 <- L2Fam at L2deriv[[1]] ##-t-## print(system.time({ - E1 <- E(object=distr, fun = psi) + E1 <- E(object=distr, fun = psi, diagnostic=diagnostic) + if(diagnostic) diagn$E1 <- attr(E1,"diagnostic") + ##-t-## })) ##-t-## print(system.time({ - E3 <- E(object=distr, fun = psi %*%t(L2deriv.0)) + E3 <- E(object=distr, fun = psi %*%t(L2deriv.0), diagnostic=diagnostic) + if(diagnostic) diagn$E3 <- attr(E3,"diagnostic") ##-t-## })) psi.0 <- psi - E1 psi.01 <- as(distr::solve(E3)%*%psi.0,"EuclRandVariable") @@ -463,7 +535,8 @@ type = if(is(distr,"DiscreteDistribution")) "p" else "l") }} ##-t-## print(system.time({ - E4 <- E(object=distr, fun = psi.01 %*%t(psi.01)) + E4 <- E(object=distr, fun = psi.01 %*%t(psi.01), diagnostic=diagnostic) + if(diagnostic) diagn$E4 <- attr(E4,"diagnostic") ##-t-## })) } E4 <- PosSemDefSymmMatrix(E4) @@ -493,7 +566,8 @@ } nms <- names(c(main(param(L2Fam)),nuisance(param(L2Fam)))) dimnames(E4) = list(nms,nms) - if(withpreIC) return(list(preIC=psi, Var=E4)) + if(diagnostic &&! withpreIC) attr(E4,"diagnostic") <- diagn + if(withpreIC) return(list(preIC=psi, Var=E4, diagnostic = diagn)) else return(E4) } @@ -779,7 +853,7 @@ psi.01 <- as(distr::solve(E3)%*%psi.0,"EuclRandVariable") if(withplot) { for(i in 1:Dim) - { dev.new() + { devNew() plot(x.mu.seq, sapply(x.mu.seq,psi.01 at Map[[i]]), type = if(is(distr,"DiscreteDistribution")) "p" else "l") }} Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-15 14:08:10 UTC (rev 1277) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-15 19:58:21 UTC (rev 1278) @@ -40,6 +40,10 @@ of the numerically truncated support). + new model classes / generators LogisticLocationScaleFamily, CauchyLocationFamily + changed default for CvMMDEstiamtor to variant "Mod" (consistent to fitdistrplus) ++ more precise / explicit description of the requirements of slots L2deriv and L2deriv.fct in + the help files to generator L2ParamFamily and to L2ParamFamily-class. ++ E() methods with signature(object = "L2ParamFamily" , ...) gain argument diagnostic + (like E()-methods in distrEx v 2.8.0) bug fixes + discovered some issues with local variables in L2Families (global values were used instead...) @@ -75,6 +79,11 @@ centering/standarizing of the IC in the end already cancelled out beforehand... but now we are more accurate as to differences in the integration measure mu and the model distribution (important for integration w.r.t. emp. measure) + the revised .CvMMDCovariance() uses vectorization in evaluation of random variables + and, wherever possible in integration; for the latter, this can be suppressed by + an argument useApply=TRUE through the ... argument + in addition .CvMMDCovariance() now has argument "diagnostic" (like E()) + and in calls to E(), the "..." argument is filtered + .process.meCalcRes gains arg "x" to be able to pass on emp.CDF for mu in CvMMDEstimator if arg asvar.fct of MCEstimator has "x" in formals the observations x are passed on to asvar.fct, otherwise they are not; correspondingly "x" is passed on to .process.meCalcRes in @@ -104,6 +113,8 @@ + (robust) start parameters for Nbinom family with two parameters + (robust) start (search) parameters for Poisson family + now specified that we want to use distr::solve ++ E() methods with signature(object = "L2ParamFamily" , ...) use filtering of dots arguments + (like E()-methods in distrEx v 2.8.0) ############## Modified: branches/distr-2.8/pkg/distrMod/man/internals.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/internals.Rd 2018-08-15 14:08:10 UTC (rev 1277) +++ branches/distr-2.8/pkg/distrMod/man/internals.Rd 2018-08-15 19:58:21 UTC (rev 1278) @@ -25,7 +25,7 @@ withplot = FALSE, withpreIC = FALSE, N = 1021, rel.tol=.Machine$double.eps^0.3, TruncQuantile = getdistrOption("TruncQuantile"), - IQR.fac = 15, ...) + IQR.fac = 15, ..., diagnostic = FALSE) .oldCvMMDCovariance(L2Fam, param, mu = distribution(L2Fam), withplot = FALSE, withpreIC = FALSE, N = getdistrOption("DefaultNrGridPoints")+1, @@ -86,6 +86,15 @@ \code{dim} attribute; in \code{.CvMMDCovarianceWithMux}: \code{NULL} (default) or the vector with observations to build integration measure \eqn{mu} as the empirical cdf. } + \item{diagnostic}{ logical; if \code{TRUE}, the return value of \code{.CvMMDCovariance} + obtains an attribute \code{"diagnostic"} (usually a lengthy list) + with diagnostic information on the call and on the integration, the latter + inherited from the calls to \code{distrExIntegrate} and \code{E} in this function. + Depending on the actually used \code{E} method, this comprises entries + \code{method} (\code{"integrate"} or \code{"GLIntegrate"}), + \code{result} (the complete return value of the integration method), + \code{args} (the args with which the integration method was called), + and \code{time} (the time to compute the integral). } } \details{ Modified: branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save =================================================================== --- branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save 2018-08-15 14:08:10 UTC (rev 1277) +++ branches/distr-2.8/pkg/distrMod/tests/Examples/distrMod-Ex.Rout.save 2018-08-15 19:58:21 UTC (rev 1278) @@ -93,7 +93,7 @@ IQR, mad, median, var Loading required package: RandVar -:RandVar> Implementation of Random Variables (version 1.1.0) +:RandVar> Implementation of Random Variables (version 1.2.0) :RandVar> :RandVar> For more information see ?"RandVar", NEWS("RandVar"), as :RandVar> well as @@ -459,7 +459,7 @@ dimnames = list(nms, nms0)) list(fval = fval0, mat = mat0) } - + Trafo / derivative matrix at which estimate was produced: scale shape shape 0.000 1 @@ -675,7 +675,7 @@ 1)/c(scale = 1) return(y) } - + > checkL2deriv(E1) precision of centering: -2.04266e-06 @@ -863,8 +863,8 @@ Slot "fct": function (x) QuadFormNorm(x, A = A) - - + + > > ## The function is currently defined as @@ -1182,7 +1182,7 @@ 1)/c(meanlog = 1) return(y) } - + > checkL2deriv(L1) precision of centering: -0.003003394 @@ -2290,7 +2290,7 @@ return(abs(x)) else return(sqrt(colSums(x^2))) } - + > name(EuclNorm) [1] "EuclideanNorm" @@ -2325,7 +2325,7 @@ return(abs(x)) else return(sqrt(colSums(x^2))) } - + > @@ -2808,8 +2808,8 @@ Slot "fct": function (x) QuadFormNorm(x, A = A0) - - + + > > ## The function is currently defined as @@ -2850,8 +2850,8 @@ Slot "fct": function (x) QuadFormNorm(x, A = A) - - + + > > ## The function is currently defined as @@ -3977,7 +3977,7 @@ dimnames(mat) <- list(nfval, c("mean", "sd")) return(list(fval = fval, mat = mat)) } - + > print(param(NS), show.details = "minimal") An object of class "ParamWithScaleFamParameter" name: location and scale @@ -4026,7 +4026,7 @@ dimnames(mat) <- list(nfval, c("mean", "sd")) return(list(fval = fval, mat = mat)) } - + Trafo / derivative matrix: mean sd mu/sig 0.3668695 -0.3024814 @@ -4069,7 +4069,7 @@ dimnames(mat) <- list(nfval, c("mean", "sd")) return(list(fval = fval, mat = mat)) } - + Trafo / derivative matrix: mean sd mu/sig 0.3669 -0.3025 @@ -4490,7 +4490,7 @@ > cleanEx() > options(digits = 7L) > base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n") -Time elapsed: 33.45 0.5 33.98 NA NA +Time elapsed: 52.66 0.75 55.35 NA NA > grDevices::dev.off() null device 1 From noreply at r-forge.r-project.org Thu Aug 16 10:00:51 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 10:00:51 +0200 (CEST) Subject: [Distr-commits] r1279 - in branches/distr-2.8/pkg/distrEx: R inst Message-ID: <20180816080051.8327518A53A@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 10:00:48 +0200 (Thu, 16 Aug 2018) New Revision: 1279 Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R branches/distr-2.8/pkg/distrEx/R/sysdata.rda branches/distr-2.8/pkg/distrEx/inst/NEWS Log: [distrEx] branch 2.8 + .qtlIntegrate now uses smaller values for args subdivisions and order in case partitioning into left/middle/right is used: they are multiplied by factors fac.L/fac.R/fac.M according to if( .withRightTail && .withLeftTail){fac.R <- fac.L <- 0.1; fac.M <- 0.8} if( .withRightTail && !.withLeftTail){fac.R <- 0.2; fac.M <- 0.8} if(!.withRightTail && .withLeftTail){fac.L <- 0.2; fac.M <- 0.8} if(!.withRightTail && !.withLeftTail){fac.M <- 1.0} => so at order 5000 we come up with orders in L/M/R of 500 / 4000 / 500 instead of 5000 / 5000 / 5000 + additional .AW-grid values into sysdata.rda for orders 50, 400, 800, 4000, 8000, 40000, 80000 as these grid values are needed in the partitioned integration in .qtlIntegrate + in addition grid value 100000 so far was not used as it is parsed to .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) { } extended NEWS on filtering to :: + introduced filter functions to warrant some safety that only those args from "..." become arguments of the integrand, of distrExIntegrate, of E(), of integrate, of GLIntegrate, of quantiles and IQR, which are within the formals of the respective function... as a consequence: * functions with more than one formal argument have to have named arguments, as these are then attached internally by name in wrapper functions; CAVEAT: integrands of form function(x, ...) will no longer get their arguments right -- this is intentional to safeguard against passing arguments to the integrand that it cannot digest; * For a call like E(distr, fun = myfun, ...), it is advisable to do something like dotsFun <- .filterFunargs(list(...), myfun) funwD <- function(x) do.call(fun,c(list(x), dotsFun)) dotsInt <- .filterEargs(list(...)) do.call(E, c(list(object = distr, fun = funwd), dotsInt)) to be on the safe side that both E() and myfun() obtain the correct parts of "..." Calls with E(distr, fun=myfun, cond = mycond, withCond = TRUE) are automatically treated in a way s.t. they do not break existing code, i.e., in case of random variables, argument "cond" is suitably attached to argument "x" of the Map of the random variable -- something like c(x,cond) Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-15 19:58:21 UTC (rev 1278) +++ branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-16 08:00:48 UTC (rev 1279) @@ -24,7 +24,6 @@ integrand <- function(x){ y <- ql(x)##quantile transformation if(useApply){ funy <- sapply(y,funwD) - # dim(y) <- di dim(funy) <- dim(x) }else funy <- fun(y) return(funy) } @@ -44,14 +43,23 @@ low.m <- low upp.m <- upp + .order <- if(!is.null(dots$order)) dots$order else .distrExOptions$GLIntegrateOrder + .subdivisions <- if(!is.null(dots$subdivisions)) dots$subdivisions else 100 + dots.withoutUseApply$order <- dots.withoutUseApply$subdivisions <- NULL + + if( .withRightTail && .withLeftTail){fac.R <- fac.L <- 0.1; fac.M <- 0.8} + if( .withRightTail && !.withLeftTail){fac.R <- 0.2; fac.M <- 0.8} + if(!.withRightTail && .withLeftTail){fac.L <- 0.2; fac.M <- 0.8} + if(!.withRightTail && !.withLeftTail){fac.M <- 1.0} + if(diagnostic) diagn <- list(call = mc) if(.withRightTail){ upp.m <- min(upp,0.98) if(upp>0.98){ intV.u <- do.call(distrExIntegrate, c(list(f = integrand, - lower = max(0.98,low), - upper = upp, + lower = max(0.98,low), upper = upp, + order = fac.R * .order, subdivisions = fac.R * .subdivisions, rel.tol = rel.tol, stop.on.error = FALSE, distr = object, dfun = dunif, diagnostic = diagnostic), dots.withoutUseApply)) if(diagnostic) diagn$rightTail <- attr(intV.u,"diagnostic") @@ -61,16 +69,16 @@ low.m <- max(low,0.02) if(low<0.02){ intV.l <- do.call(distrExIntegrate, c(list(f = integrand, - lower = low, - upper = min(0.02, upp), + lower = low, upper = min(0.02, upp), + order = fac.L * .order, subdivisions = fac.L * .subdivisions, rel.tol = rel.tol, stop.on.error = FALSE, distr = object, dfun = dunif), dots.withoutUseApply)) if(diagnostic) diagn$leftTail <- attr(intV.l,"diagnostic") } } intV.m <- do.call(distrExIntegrate, c(list(f = integrand, - lower = low.m, - upper = upp.m, + lower = low.m, upper = upp.m, + order = fac.M * .order, subdivisions = fac.M * .subdivisions, rel.tol = rel.tol, stop.on.error = FALSE, distr = object, dfun = dunif), dots.withoutUseApply)) if(diagnostic) diagn$main <- attr(intV.m,"diagnostic") Modified: branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R 2018-08-15 19:58:21 UTC (rev 1278) +++ branches/distr-2.8/pkg/distrEx/R/distrExIntegrate.R 2018-08-16 08:00:48 UTC (rev 1279) @@ -55,8 +55,61 @@ } +if(FALSE){ +# code to produce the AW values stored in the namespace of distrEx +## + +## timing code borrowed from base::system.time + + ppt <- function(y) { + if (!is.na(y[4L])) + y[1L] <- y[1L] + y[4L] + if (!is.na(y[5L])) + y[2L] <- y[2L] + y[5L] + paste(formatC(y[1L:3L]), collapse = " ") + } + + + +todo <- c(50, 100, 400, 500, 800, 1000, 4000, 5000, 8000, 10000, 40000, 50000, 80000, 100000) +l <- length(todo) +nE <- new.env() +svncheckout <- "C:/rtest/distr" +pkg <- file.path(svncheckout, "branches/distr-2.8/pkg/distrEx") +sysdataFilename <- file.path(pkg, "R/sysdata.rda") +load(sysdataFilename,envir=nE) + +gc() +starttime <- proc.time() +on.exit(message("Timing stopped at: ", ppt(proc.time() - starttime))) + +lasttime <- starttime +for(gridsize.i in seq(todo)){ + cat("Gridpoint i =", gridsize.i, ", order = ", todo[gridsize.i],", time needed: ") + res <- distrEx:::.GLaw(todo[gridsize.i]) + newtime <- proc.time() + timN <- structure(newtime - lasttime, class = "proc_time") + lasttime <- newtime + cat(paste(round(timN,3)), "\n") + nam <- paste(".AW",as.character(todo[gridsize.i]), sep = ".") + assign(x=nam, value=res, envir=nE) +} + + timN <- structure(proc.time() - starttime, class = "proc_time") + cat("Time altogether:", paste(round(timN,3)), "\n") + +rm(".AW.100000", envir=nE) +what <- ls(all=TRUE, env=nE) +for(item in what) {cat(item, ":\n");print(object.size(get(item, envir=nE)))} +on.exit() + +save(list=what,file=sysdataFilename,envir=nE) +rm(nE) +} + GLIntegrate <- function(f, lower, upper, order = 500, ...){ - if(order %in% c(100, 500, 1000, 5000, 10000, 50000, 100000)) + if(order %in% c(50, 100, 400, 500, 800, 1000, 4000, 5000, 8000, 10000, + 40000, 50000, 80000, 100000)) AW <- getFromNamespace(paste(".AW", as.character(order), sep = "."), ns = "distrEx") else Modified: branches/distr-2.8/pkg/distrEx/R/sysdata.rda =================================================================== (Binary files differ) Modified: branches/distr-2.8/pkg/distrEx/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-15 19:58:21 UTC (rev 1278) +++ branches/distr-2.8/pkg/distrEx/inst/NEWS 2018-08-16 08:00:48 UTC (rev 1279) @@ -38,7 +38,44 @@ "..." become arguments of the integrand, of distrExIntegrate, of E(), of integrate, of GLIntegrate, of quantiles and IQR, which are within the formals of the respective function... - + as a consequence: + * functions with more than one formal argument have to have named + arguments, as these are then attached internally by name in wrapper functions; + CAVEAT: integrands of form function(x, ...) will no longer get their arguments + right -- this is intentional to safeguard against passing arguments to the + integrand that it cannot digest; + * For a call like E(distr, fun = myfun, ...), it is advisable to do something like + + dotsFun <- .filterFunargs(list(...), myfun) + funwD <- function(x) do.call(fun,c(list(x), dotsFun)) + dotsInt <- .filterEargs(list(...)) + do.call(E, c(list(object = distr, fun = funwd), dotsInt)) + + to be on the safe side that both E() and myfun() obtain the correct + parts of "..." + + Calls with E(distr, fun=myfun, cond = mycond, withCond = TRUE) + are automatically treated in a way s.t. they do not break existing code, + i.e., in case of random variables, argument "cond" is suitably attached + to argument "x" of the Map of the random variable -- something like c(x,cond) + ++ .qtlIntegrate now uses smaller values for args subdivisions and order + in case partitioning into left/middle/right is used: they are multiplied + by factors fac.L/fac.R/fac.M according to + if( .withRightTail && .withLeftTail){fac.R <- fac.L <- 0.1; fac.M <- 0.8} + if( .withRightTail && !.withLeftTail){fac.R <- 0.2; fac.M <- 0.8} + if(!.withRightTail && .withLeftTail){fac.L <- 0.2; fac.M <- 0.8} + if(!.withRightTail && !.withLeftTail){fac.M <- 1.0} + => so at order 5000 we come up with orders in L/M/R of 500 / 4000 / 500 + instead of 5000 / 5000 / 5000 ++ additional .AW-grid values into sysdata.rda for orders + 50, 400, 800, 4000, 8000, 40000, 80000 + as these grid values are needed in the partitioned integration in + .qtlIntegrate ++ in addition grid value 100000 so far was not used as it is parsed to + .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) { } ############## v 2.7 ############## From noreply at r-forge.r-project.org Thu Aug 16 13:05:27 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 13:05:27 +0200 (CEST) Subject: [Distr-commits] r1280 - in branches/distr-2.8/pkg/distr: R inst man Message-ID: <20180816110527.E1BFF18A52A@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 13:05:27 +0200 (Thu, 16 Aug 2018) New Revision: 1280 Modified: branches/distr-2.8/pkg/distr/R/AllGenerics.R branches/distr-2.8/pkg/distr/R/liesInSupport.R branches/distr-2.8/pkg/distr/inst/NEWS branches/distr-2.8/pkg/distr/man/liesInSupport.Rd Log: [distr] branch 2.8 + liesInSupport: * taken out checkFin from definition of the generic * particular methods for all implemented (particular) a.c. distributions Modified: branches/distr-2.8/pkg/distr/R/AllGenerics.R =================================================================== --- branches/distr-2.8/pkg/distr/R/AllGenerics.R 2018-08-16 08:00:48 UTC (rev 1279) +++ branches/distr-2.8/pkg/distr/R/AllGenerics.R 2018-08-16 11:05:27 UTC (rev 1280) @@ -300,7 +300,7 @@ setGeneric("liesIn", function(object, x) standardGeneric("liesIn")) if(!isGeneric("liesInSupport")) - setGeneric("liesInSupport", function(object, x, checkFin = FALSE) + setGeneric("liesInSupport", function(object, x,...) standardGeneric("liesInSupport")) if(!isGeneric("convpow")) setGeneric("convpow", function(D1, ...) standardGeneric("convpow")) Modified: branches/distr-2.8/pkg/distr/R/liesInSupport.R =================================================================== --- branches/distr-2.8/pkg/distr/R/liesInSupport.R 2018-08-16 08:00:48 UTC (rev 1279) +++ branches/distr-2.8/pkg/distr/R/liesInSupport.R 2018-08-16 11:05:27 UTC (rev 1280) @@ -99,3 +99,34 @@ obj <- flat.mix(object) return(liesInSupport(obj,x,checkFin)) }) + +.alwaysInSupp <- function(object, x, checkFin = TRUE) is.finite(x) +.posInSupp <- function(object, x, checkFin = TRUE) (x>=0) +.stricposInSupp <- function(object, x, checkFin = TRUE) (x>0) + +setMethod("liesInSupport", signature(object = "ExpOrGammaOrChisq", + x = "numeric"),.posInSupp) +setMethod("liesInSupport", signature(object = "Lnorm", + x = "numeric"),.posInSupp) +setMethod("liesInSupport", signature(object = "Fd", + x = "numeric"),.posInSupp) + +setMethod("liesInSupport", signature(object = "Norm", + x = "numeric"),.alwaysInSupp) +setMethod("liesInSupport", signature(object = "DExp", + x = "numeric"),.alwaysInSupp) +setMethod("liesInSupport", signature(object = "Cauchy", + x = "numeric"),.alwaysInSupp) +setMethod("liesInSupport", signature(object = "Td", + x = "numeric"),.alwaysInSupp) +setMethod("liesInSupport", signature(object = "Logis", + x = "numeric"),.alwaysInSupp) +setMethod("liesInSupport", signature(object = "Weibull", + x = "numeric"),.alwaysInSupp) + +setMethod("liesInSupport", signature(object = "Unif", + x = "numeric"), + function(object, x, checkFin = TRUE){(x>=Min(object))&(x<=Max(object))}) +setMethod("liesInSupport", signature(object = "Beta", + x = "numeric"), + function(object, x, checkFin = TRUE){(x>=0)&(x<=1)}) Modified: branches/distr-2.8/pkg/distr/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-16 08:00:48 UTC (rev 1279) +++ branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-16 11:05:27 UTC (rev 1280) @@ -33,7 +33,8 @@ from ifelse expressions to index operations to avoid warnings + in distr::solve only try base::solve if arg "a" has no dim or if it has then if nrow(a)==nrow(b); otherwise directly use MASS::ginv - ++ introduced particular liesInSupport methods for all specific abs.cont distributions in distr + bug fixes + fixed a (newly introduced) bug in exp() for DiscreteDistribution -- forgot to return obj ... Modified: branches/distr-2.8/pkg/distr/man/liesInSupport.Rd =================================================================== --- branches/distr-2.8/pkg/distr/man/liesInSupport.Rd 2018-08-16 08:00:48 UTC (rev 1279) +++ branches/distr-2.8/pkg/distr/man/liesInSupport.Rd 2018-08-16 11:05:27 UTC (rev 1280) @@ -7,14 +7,43 @@ \alias{liesInSupport,DiscreteDistribution,numeric-method} \alias{liesInSupport,Distribution,matrix-method} \alias{liesInSupport,AbscontDistribution,numeric-method} +\alias{liesInSupport,ExpOrGammaOrChisq,numeric-method} +\alias{liesInSupport,Lnorm,numeric-method} +\alias{liesInSupport,Fd,numeric-method} +\alias{liesInSupport,Norm,numeric-method} +\alias{liesInSupport,DExp,numeric-method} +\alias{liesInSupport,Cauchy,numeric-method} +\alias{liesInSupport,Td,numeric-method} +\alias{liesInSupport,Logis,numeric-method} +\alias{liesInSupport,Weibull,numeric-method} +\alias{liesInSupport,Unif,numeric-method} +\alias{liesInSupport,Beta,numeric-method} + \title{Generic Function for Testing the Support of a Distribution } \description{ The function tests if \code{x} lies in the support of the distribution \code{object}. } \usage{ -liesInSupport(object, x, checkFin = FALSE) +liesInSupport(object, x, ...) +\S4method{liesInSupport}{UnivarLebDecDistribution,numeric}(object,x, checkFin = FALSE) +\S4method{liesInSupport}{UnivarMixingDistribution,numeric}(object,x, checkFin = FALSE) +\S4method{liesInSupport}{LatticeDistribution,numeric}(object,x, checkFin = FALSE) +\S4method{liesInSupport}{DiscreteDistribution,numeric}(object,x, checkFin = FALSE) +\S4method{liesInSupport}{AbscontDistribution,numeric}(object,x, checkFin = FALSE) +\S4method{liesInSupport}{Distribution,matrix}(object,x, checkFin = FALSE) +\S4method{liesInSupport}{ExpOrGammaOrChisq,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Lnorm,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Fd,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Norm,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{DExp,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Cauchy,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Td,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Logis,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Weibull,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Unif,numeric}(object,x, checkFin = TRUE) +\S4method{liesInSupport}{Beta,numeric}(object,x, checkFin = TRUE) } \arguments{ \item{object}{ object of class \code{"Distribution"} } @@ -26,6 +55,7 @@ and by using slot \code{.finSupport} / the return values of \code{q.l(object)} in \code{0} and \code{1}. This is only used on discrete (parts of) distributions).} + \item{\dots}{ used for specific arguments to particular methods. } } %\details{} \value{logical vector} From noreply at r-forge.r-project.org Thu Aug 16 13:50:49 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 13:50:49 +0200 (CEST) Subject: [Distr-commits] r1281 - branches/distr-2.8/pkg/distrEx/R Message-ID: <20180816115049.66A1D187EB8@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 13:50:49 +0200 (Thu, 16 Aug 2018) New Revision: 1281 Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R Log: [distrEx] branch 2.8.0 in .qtlIntegrate forgot to pass over argument diagnostic to left tail and center Modified: branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-16 11:05:27 UTC (rev 1280) +++ branches/distr-2.8/pkg/distrEx/R/GammaWeibullExpectation.R 2018-08-16 11:50:49 UTC (rev 1281) @@ -72,7 +72,7 @@ lower = low, upper = min(0.02, upp), order = fac.L * .order, subdivisions = fac.L * .subdivisions, rel.tol = rel.tol, stop.on.error = FALSE, - distr = object, dfun = dunif), dots.withoutUseApply)) + distr = object, dfun = dunif, diagnostic = diagnostic), dots.withoutUseApply)) if(diagnostic) diagn$leftTail <- attr(intV.l,"diagnostic") } } @@ -80,7 +80,7 @@ lower = low.m, upper = upp.m, order = fac.M * .order, subdivisions = fac.M * .subdivisions, rel.tol = rel.tol, stop.on.error = FALSE, - distr = object, dfun = dunif), dots.withoutUseApply)) + distr = object, dfun = dunif, diagnostic = diagnostic), dots.withoutUseApply)) if(diagnostic) diagn$main <- attr(intV.m,"diagnostic") int <- intV.l+intV.m+intV.u From noreply at r-forge.r-project.org Thu Aug 16 14:31:54 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Aug 2018 14:31:54 +0200 (CEST) Subject: [Distr-commits] r1282 - in branches/distr-2.8/pkg/distr: R inst Message-ID: <20180816123154.E5145189750@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-16 14:31:54 +0200 (Thu, 16 Aug 2018) New Revision: 1282 Modified: branches/distr-2.8/pkg/distr/R/0pre270.R branches/distr-2.8/pkg/distr/inst/NEWS Log: [distr] branch 2.8 Bernhard discovered a bug in devNew() -- it opened new devices even if option("newDevice"==FALSE) Modified: branches/distr-2.8/pkg/distr/R/0pre270.R =================================================================== --- branches/distr-2.8/pkg/distr/R/0pre270.R 2018-08-16 11:50:49 UTC (rev 1281) +++ branches/distr-2.8/pkg/distr/R/0pre270.R 2018-08-16 12:31:54 UTC (rev 1282) @@ -26,8 +26,8 @@ grDevices::dev.off(which=grDevices::dev.list()[2]) } } + dev.new(...) } - dev.new(...) } } } Modified: branches/distr-2.8/pkg/distr/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-16 11:50:49 UTC (rev 1281) +++ branches/distr-2.8/pkg/distr/inst/NEWS 2018-08-16 12:31:54 UTC (rev 1282) @@ -37,7 +37,7 @@ bug fixes + fixed a (newly introduced) bug in exp() for DiscreteDistribution -- forgot to return obj ... - ++ Bernhard discovered a bug in devNew() -- it opened new devices even if option("newDevice"==FALSE) ############## v 2.7 ############## From noreply at r-forge.r-project.org Sat Aug 18 22:02:47 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 22:02:47 +0200 (CEST) Subject: [Distr-commits] r1283 - in branches/distr-2.8/pkg/distrEx: . R inst man Message-ID: <20180818200247.171E018ACDA@r-forge.r-project.org> 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) { } ++ 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 From noreply at r-forge.r-project.org Sat Aug 18 22:22:24 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 22:22:24 +0200 (CEST) Subject: [Distr-commits] r1284 - branches/distr-2.8/pkg/distrEx/man Message-ID: <20180818202224.8DBB718ACE6@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 22:22:24 +0200 (Sat, 18 Aug 2018) New Revision: 1284 Modified: 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 Log: [distrEx] branch 2.8 fixed some links in Rd files Modified: branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd 2018-08-18 20:02:42 UTC (rev 1283) +++ branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd 2018-08-18 20:22:24 UTC (rev 1284) @@ -130,8 +130,8 @@ 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}}. + and accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and + \code{\link[distrExIntegrate]{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-18 20:02:42 UTC (rev 1283) +++ branches/distr-2.8/pkg/distrEx/man/CvMDist.Rd 2018-08-18 20:22:24 UTC (rev 1284) @@ -49,8 +49,8 @@ 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}}. + and accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and + \code{\link[distrExIntegrate]{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-18 20:02:42 UTC (rev 1283) +++ branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-18 20:22:24 UTC (rev 1284) @@ -293,8 +293,8 @@ 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}}. + and accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and + \code{\link[distrExIntegrate]{getDiagnostic}}. } Modified: branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd 2018-08-18 20:02:42 UTC (rev 1283) +++ branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd 2018-08-18 20:22:24 UTC (rev 1284) @@ -113,8 +113,8 @@ 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}}. + and accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and + \code{\link[distrExIntegrate]{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-18 20:02:42 UTC (rev 1283) +++ branches/distr-2.8/pkg/distrEx/man/OAsymTotalVarDist.Rd 2018-08-18 20:22:24 UTC (rev 1284) @@ -125,8 +125,8 @@ 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}}. + and accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and + \code{\link[distrExIntegrate]{getDiagnostic}}. } \value{ OAsymmetric Total variation distance of \code{e1} and \code{e2} } \section{Methods}{ Modified: branches/distr-2.8/pkg/distrEx/man/TotalVarDist.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/TotalVarDist.Rd 2018-08-18 20:02:42 UTC (rev 1283) +++ branches/distr-2.8/pkg/distrEx/man/TotalVarDist.Rd 2018-08-18 20:22:24 UTC (rev 1284) @@ -113,8 +113,8 @@ 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}}. + and accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and + \code{\link[distrExIntegrate]{getDiagnostic}}. } \value{ Total variation distance of \code{e1} and \code{e2} } \section{Methods}{ From noreply at r-forge.r-project.org Sat Aug 18 22:31:00 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 22:31:00 +0200 (CEST) Subject: [Distr-commits] r1285 - branches/distr-2.8/pkg/utils Message-ID: <20180818203100.5442618ACC6@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 22:31:00 +0200 (Sat, 18 Aug 2018) New Revision: 1285 Modified: branches/distr-2.8/pkg/utils/ladealles.R Log: [distr] branch 2.8 some minor additions to util ladealles.R Modified: branches/distr-2.8/pkg/utils/ladealles.R =================================================================== --- branches/distr-2.8/pkg/utils/ladealles.R 2018-08-18 20:22:24 UTC (rev 1284) +++ branches/distr-2.8/pkg/utils/ladealles.R 2018-08-18 20:31:00 UTC (rev 1285) @@ -9,7 +9,7 @@ } #ladeall(DIR="distr", develDir = "C:/rtest/distr/branches/distr-2.1/pkg") -#ladeall(DIR="distrEx", develDir = "C:/rtest/distr/pkg") +#ladeall(DIR="distrMod", develDir = "C:/rtest/distr/branches/distr-2.8/pkg") #ladeall(DIR="distrMod", develDir = "C:/rtest/distr/branches/distr-2.4/pkg",withPrint=FALSE) -ladeall(DIR="RobAstbase", develDir = "C:/rtest/robast/branches/robast-0.9/pkg") +ladeall(DIR="RobExtremes", develDir = "C:/rtest/robast/branches/robast-1.2/pkg") From noreply at r-forge.r-project.org Sat Aug 18 22:32:49 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 22:32:49 +0200 (CEST) Subject: [Distr-commits] r1286 - in branches/distr-2.8/pkg/distrMod: R inst man Message-ID: <20180818203249.281A618ACED@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 22:32:48 +0200 (Sat, 18 Aug 2018) New Revision: 1286 Modified: branches/distr-2.8/pkg/distrMod/R/Expectation.R branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R branches/distr-2.8/pkg/distrMod/inst/NEWS branches/distr-2.8/pkg/distrMod/man/L2ParamFamily-class.Rd branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd Log: [distrMod] branch 2.8 + E methods with signature(object = "L2ParamFamily" , ...) if (diagnostic==TRUE) return diagnostic attributes of S3 class "DiagnosticClass" + .CvMMDCovariance() if (diagnostic==TRUE) returns diagnostic attributes of S3 class "DiagnosticClass" Modified: branches/distr-2.8/pkg/distrMod/R/Expectation.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/Expectation.R 2018-08-18 20:31:00 UTC (rev 1285) +++ branches/distr-2.8/pkg/distrMod/R/Expectation.R 2018-08-18 20:32:48 UTC (rev 1286) @@ -16,7 +16,10 @@ diagn[["call"]] <- match.call() } res <- matrix(res, nrow = nrow(fun)) - if(diagnostic) attr(res, "diagnostic") <- diagn + if(diagnostic){ + attr(res, "diagnostic") <- diagn + class(attr(res,"diagnostic"))<- "DiagnosticClass" + } return(res) }) setMethod("E", signature(object = "L2ParamFamily", @@ -34,6 +37,8 @@ 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/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-18 20:31:00 UTC (rev 1285) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-18 20:32:48 UTC (rev 1286) @@ -566,7 +566,11 @@ } nms <- names(c(main(param(L2Fam)),nuisance(param(L2Fam)))) dimnames(E4) = list(nms,nms) - if(diagnostic &&! withpreIC) attr(E4,"diagnostic") <- diagn + if(diagnostic) class(diagn) <- "DiagnosticClass" + if(diagnostic &&! withpreIC){ + attr(E4,"diagnostic") <- diagn + class(attr(E4,"diagnostic"))<- "DiagnosticClass" + } if(withpreIC) return(list(preIC=psi, Var=E4, diagnostic = diagn)) else return(E4) } Modified: branches/distr-2.8/pkg/distrMod/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-18 20:31:00 UTC (rev 1285) +++ branches/distr-2.8/pkg/distrMod/inst/NEWS 2018-08-18 20:32:48 UTC (rev 1286) @@ -115,6 +115,10 @@ + now specified that we want to use distr::solve + E() methods with signature(object = "L2ParamFamily" , ...) use filtering of dots arguments (like E()-methods in distrEx v 2.8.0) ++ E methods with signature(object = "L2ParamFamily" , ...) if (diagnostic==TRUE) return + diagnostic attributes of S3 class "DiagnosticClass" ++ .CvMMDCovariance() if (diagnostic==TRUE) returns diagnostic attributes of S3 class + "DiagnosticClass" ############## Modified: branches/distr-2.8/pkg/distrMod/man/L2ParamFamily-class.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/L2ParamFamily-class.Rd 2018-08-18 20:31:00 UTC (rev 1285) +++ branches/distr-2.8/pkg/distrMod/man/L2ParamFamily-class.Rd 2018-08-18 20:32:48 UTC (rev 1286) @@ -251,6 +251,16 @@ moves the L2-parametric Family \code{model} to parameter \code{param} } } } + +\details{ +In the \code{E}-methods, 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 accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. + +} + \references{ Rieder, H. (1994) \emph{Robust Asymptotic Statistics}. New York: Springer. Modified: branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd =================================================================== --- branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-18 20:31:00 UTC (rev 1285) +++ branches/distr-2.8/pkg/distrMod/man/MDEstimator.Rd 2018-08-18 20:32:48 UTC (rev 1286) @@ -114,7 +114,14 @@ of helper function \code{.CvMMDCovarianceWithMux}, case of alternative \code{"Mod"} we use helper function \code{.CvMMDCovariance}. In both case one may use these helper function to get hand on the respective - influence function. + influence function. For covariances computed by \code{.CvMMDCovariance}, + 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 accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. + + \code{KolmogorovMDEstimator} uses Kolmogorov distance, see \code{\link[distrEx]{KolmogorovDist}}, \code{TotalVarMDEstimator}, uses total variation distance, see \code{\link[distrEx]{TotalVarDist}} From noreply at r-forge.r-project.org Sat Aug 18 22:38:22 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 22:38:22 +0200 (CEST) Subject: [Distr-commits] r1287 - in branches/distr-2.8/pkg/distrEllipse: R inst Message-ID: <20180818203822.AA55D18ACEF@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 22:38:22 +0200 (Sat, 18 Aug 2018) New Revision: 1287 Modified: branches/distr-2.8/pkg/distrEllipse/R/MVMixingDistribution.R branches/distr-2.8/pkg/distrEllipse/inst/NEWS Log: [distrEllipse] branch 2.8 + E methods for MultivarMixingDistribution if (diagnostic==TRUE) return diagnostic attributes of S3 class "DiagnosticClass" Modified: branches/distr-2.8/pkg/distrEllipse/R/MVMixingDistribution.R =================================================================== --- branches/distr-2.8/pkg/distrEllipse/R/MVMixingDistribution.R 2018-08-18 20:32:48 UTC (rev 1286) +++ branches/distr-2.8/pkg/distrEllipse/R/MVMixingDistribution.R 2018-08-18 20:38:22 UTC (rev 1287) @@ -141,7 +141,10 @@ diagn[[i]] <- attr(res0,"diagnostic") res <- res + object at mixCoeff[i]*res0 } - if(diagnostic) attr(res,"diagnostic") <- diagn + if(diagnostic){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic"))<- "DiagnosticClass" + } return(res) }) setMethod("E", signature(object = "MultivarMixingDistribution", @@ -164,7 +167,10 @@ diagn[[i]] <- attr(res0,"diagnostic") res <- res + object at mixCoeff[i]*res0 } - if(diagnostic) attr(res,"diagnostic") <- diagn + if(diagnostic){ + attr(res,"diagnostic") <- diagn + class(attr(res,"diagnostic"))<- "DiagnosticClass" + } return(res) }) Modified: branches/distr-2.8/pkg/distrEllipse/inst/NEWS =================================================================== --- branches/distr-2.8/pkg/distrEllipse/inst/NEWS 2018-08-18 20:32:48 UTC (rev 1286) +++ branches/distr-2.8/pkg/distrEllipse/inst/NEWS 2018-08-18 20:38:22 UTC (rev 1287) @@ -20,6 +20,8 @@ + now specified that we want to use distr::solve + E methods for MultivarMixingDistribution use filtering of dots arguments (like E()-methods in distrEx v 2.8.0) ++ E methods for MultivarMixingDistribution if (diagnostic==TRUE) return + diagnostic attributes of S3 class "DiagnosticClass" ############## v 2.7 From noreply at r-forge.r-project.org Sat Aug 18 23:17:30 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 18 Aug 2018 23:17:30 +0200 (CEST) Subject: [Distr-commits] r1288 - branches/distr-2.8/pkg/distrMod/R Message-ID: <20180818211730.AFE2A18AC7C@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-18 23:17:30 +0200 (Sat, 18 Aug 2018) New Revision: 1288 Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R Log: [distrMod] branch 2.8 + a minor safety add Modified: branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R =================================================================== --- branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-18 20:38:22 UTC (rev 1287) +++ branches/distr-2.8/pkg/distrMod/R/asCvMVarianceQtl.R 2018-08-18 21:17:30 UTC (rev 1288) @@ -566,10 +566,10 @@ } nms <- names(c(main(param(L2Fam)),nuisance(param(L2Fam)))) dimnames(E4) = list(nms,nms) - if(diagnostic) class(diagn) <- "DiagnosticClass" + if(diagnostic && !is.null(diagn)) class(diagn) <- "DiagnosticClass" if(diagnostic &&! withpreIC){ attr(E4,"diagnostic") <- diagn - class(attr(E4,"diagnostic"))<- "DiagnosticClass" + if(!is.null(diagn)) class(attr(E4,"diagnostic"))<- "DiagnosticClass" } if(withpreIC) return(list(preIC=psi, Var=E4, diagnostic = diagn)) else return(E4) From noreply at r-forge.r-project.org Sun Aug 19 01:23:21 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 19 Aug 2018 01:23:21 +0200 (CEST) Subject: [Distr-commits] r1289 - in branches/distr-2.8/pkg/distrEx: R man Message-ID: <20180818232321.8F1C718AD06@r-forge.r-project.org> Author: ruckdeschel Date: 2018-08-19 01:23:21 +0200 (Sun, 19 Aug 2018) New Revision: 1289 Modified: branches/distr-2.8/pkg/distrEx/R/DiagnUtils.R 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 Log: [distrEx] branch 2.8 some bugfixes w.r.t. the last commit Modified: branches/distr-2.8/pkg/distrEx/R/DiagnUtils.R =================================================================== --- branches/distr-2.8/pkg/distrEx/R/DiagnUtils.R 2018-08-18 21:17:30 UTC (rev 1288) +++ branches/distr-2.8/pkg/distrEx/R/DiagnUtils.R 2018-08-18 23:23:21 UTC (rev 1289) @@ -124,9 +124,9 @@ ############################################################################ -print.DiagnosticClass <- function(x, what, withNonShows = FALSE, ...){ +print.DiagnosticClass <- function(x, what, withNonShows = FALSE, xname, ...){ if(missing(what)) what <- .showallNamesDiagnosticList(x) - xn <- paste(deparse(substitute(x))) + xn <- if(missing(xname)) paste(deparse(substitute(x))) else xname 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="") @@ -144,7 +144,15 @@ if(names(diaglistsShow)[item]=="call"){ cat("Calls: \n") print(names(diaglistsShow[[item]]),...) - }else print(diaglistsShow[[item]], ...) + }else{ + toShow <- diaglistsShow[[item]] + clItem <- class(toShow) + if("DiagnosticClass" %in% clItem){ + if(length(clItem) == 1) class(toShow) <- "list" + class(toShow) <- clItem[clItem != "DiagnosticClass"] + } + print(toShow, ...) + } cat("\n") } if(withNonShows){ @@ -174,6 +182,7 @@ showDiagnostic <- function(x, what, withNonShows = FALSE, ...){ diagn <- attr(x,"diagnostic") + xn <- paste(deparse(substitute(x))) diagnKStep <- attr(x,"kStepDiagnostic") if(!is.null(diagnKStep)){ if(is.null(diagn)){ @@ -186,7 +195,7 @@ } if(is.null(diagn)) return(invisible(NULL)) if(missing(what)) what <- .showallNamesDiagnosticList(diagn) - res <- print(diagn, what = what, withNonShows=withNonShows, ...) + res <- print(diagn, what = what, withNonShows=withNonShows, xname=xn, ...) return(invisible(res)) } Modified: branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd 2018-08-18 21:17:30 UTC (rev 1288) +++ branches/distr-2.8/pkg/distrEx/man/AsymTotalVarDist.Rd 2018-08-18 23:23:21 UTC (rev 1289) @@ -130,8 +130,8 @@ 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 accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and - \code{\link[distrExIntegrate]{getDiagnostic}}. + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{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-18 21:17:30 UTC (rev 1288) +++ branches/distr-2.8/pkg/distrEx/man/CvMDist.Rd 2018-08-18 23:23:21 UTC (rev 1289) @@ -49,8 +49,8 @@ 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 accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and - \code{\link[distrExIntegrate]{getDiagnostic}}. + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{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-18 21:17:30 UTC (rev 1288) +++ branches/distr-2.8/pkg/distrEx/man/E.Rd 2018-08-18 23:23:21 UTC (rev 1289) @@ -293,8 +293,8 @@ 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 accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and - \code{\link[distrExIntegrate]{getDiagnostic}}. + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. } Modified: branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd 2018-08-18 21:17:30 UTC (rev 1288) +++ branches/distr-2.8/pkg/distrEx/man/HellingerDist.Rd 2018-08-18 23:23:21 UTC (rev 1289) @@ -113,8 +113,8 @@ 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 accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and - \code{\link[distrExIntegrate]{getDiagnostic}}. + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{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-18 21:17:30 UTC (rev 1288) +++ branches/distr-2.8/pkg/distrEx/man/OAsymTotalVarDist.Rd 2018-08-18 23:23:21 UTC (rev 1289) @@ -125,8 +125,8 @@ 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 accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and - \code{\link[distrExIntegrate]{getDiagnostic}}. + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. } \value{ OAsymmetric Total variation distance of \code{e1} and \code{e2} } \section{Methods}{ Modified: branches/distr-2.8/pkg/distrEx/man/TotalVarDist.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/TotalVarDist.Rd 2018-08-18 21:17:30 UTC (rev 1288) +++ branches/distr-2.8/pkg/distrEx/man/TotalVarDist.Rd 2018-08-18 23:23:21 UTC (rev 1289) @@ -113,8 +113,8 @@ 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 accessed through \code{\link[distrExIntegrate]{showDiagnostic}} and - \code{\link[distrExIntegrate]{getDiagnostic}}. + and accessed through \code{\link[distrEx:distrExIntegrate]{showDiagnostic}} and + \code{\link[distrEx:distrExIntegrate]{getDiagnostic}}. } \value{ Total variation distance of \code{e1} and \code{e2} } \section{Methods}{ Modified: branches/distr-2.8/pkg/distrEx/man/distrExIntegrate.Rd =================================================================== --- branches/distr-2.8/pkg/distrEx/man/distrExIntegrate.Rd 2018-08-18 21:17:30 UTC (rev 1288) +++ branches/distr-2.8/pkg/distrEx/man/distrExIntegrate.Rd 2018-08-18 23:23:21 UTC (rev 1289) @@ -16,7 +16,7 @@ distr, order, ..., diagnostic = FALSE) showDiagnostic(x, what, withNonShows = FALSE, ...) getDiagnostic(x, what, reorganized=TRUE) -\method{print}{DiagnosticClass}(x, what, withNonShows = FALSE, ...) +\method{print}{DiagnosticClass}(x, what, withNonShows = FALSE, xname, ...) } \arguments{ @@ -53,6 +53,7 @@ distinction is made according to the list item name. If \code{withNonShows==TRUE} one also attempts to show the selected items of the second kind, otherwise they are not shown (but returned). } + \item{xname}{ an optional name for the diagnostic object to be shown. } \item{reorganized}{should the diagnostic information be reorganized (using internal function \code{\link{.reorganizeDiagnosticList}}? } }