[Distr-commits] r124 - pkg/distr/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat May 3 11:29:38 CEST 2008
Author: ruckdeschel
Date: 2008-05-03 11:29:38 +0200 (Sat, 03 May 2008)
New Revision: 124
Added:
pkg/distr/R/01.R
pkg/distr/R/0pre230.R
pkg/distr/R/99.R
Removed:
pkg/distr/R/01.Ra
pkg/distr/R/0pre230.Ra
pkg/distr/R/99.Ra
Log:
some name changes II
Copied: pkg/distr/R/01.R (from rev 123, pkg/distr/R/01.Ra)
===================================================================
--- pkg/distr/R/01.R (rev 0)
+++ pkg/distr/R/01.R 2008-05-03 09:29:38 UTC (rev 124)
@@ -0,0 +1,29 @@
+.onLoad <- function(lib, pkg) { # extended 03-28-06: P.R.
+ require("methods", character = TRUE, quietly = TRUE)
+}
+
+distroptions <- function(...) {
+ if (nargs() == 0) return(.distroptions)
+ current <- .distroptions
+ temp <- list(...)
+ if (length(temp) == 1 && is.null(names(temp))) {
+ arg <- temp[[1]]
+ switch(mode(arg),
+ list = temp <- arg,
+ character = return(.distroptions[arg]),
+ stop("invalid argument: ", sQuote(arg)))
+ }
+ if (length(temp) == 0) return(current)
+ n <- names(temp)
+ if (is.null(n)) stop("options must be given by name")
+ changed <- current[n]
+ current[n] <- temp
+ env <- if (sys.parent() == 0) asNamespace("distr") else parent.frame()
+ assign(".distroptions", current, envir = env)
+ invisible(current)
+}
+
+getdistrOption<-function(x)distroptions(x)[[1]]
+
+###must happen between load and attach
+
Deleted: pkg/distr/R/01.Ra
===================================================================
--- pkg/distr/R/01.Ra 2008-05-03 09:28:16 UTC (rev 123)
+++ pkg/distr/R/01.Ra 2008-05-03 09:29:38 UTC (rev 124)
@@ -1,29 +0,0 @@
-.onLoad <- function(lib, pkg) { # extended 03-28-06: P.R.
- require("methods", character = TRUE, quietly = TRUE)
-}
-
-distroptions <- function(...) {
- if (nargs() == 0) return(.distroptions)
- current <- .distroptions
- temp <- list(...)
- if (length(temp) == 1 && is.null(names(temp))) {
- arg <- temp[[1]]
- switch(mode(arg),
- list = temp <- arg,
- character = return(.distroptions[arg]),
- stop("invalid argument: ", sQuote(arg)))
- }
- if (length(temp) == 0) return(current)
- n <- names(temp)
- if (is.null(n)) stop("options must be given by name")
- changed <- current[n]
- current[n] <- temp
- env <- if (sys.parent() == 0) asNamespace("distr") else parent.frame()
- assign(".distroptions", current, envir = env)
- invisible(current)
-}
-
-getdistrOption<-function(x)distroptions(x)[[1]]
-
-###must happen between load and attach
-
Copied: pkg/distr/R/0pre230.R (from rev 123, pkg/distr/R/0pre230.Ra)
===================================================================
--- pkg/distr/R/0pre230.R (rev 0)
+++ pkg/distr/R/0pre230.R 2008-05-03 09:29:38 UTC (rev 124)
@@ -0,0 +1,74 @@
+### for working under R < 2.3.0
+if(getRversion()<'2.3.0')
+{ ## ignore ncp
+
+ ###beta Distribution
+
+ qbeta <- function(p, shape1, shape2, ncp = 0, lower.tail = TRUE,
+ log.p = FALSE)
+ {if(isTRUE(all.equal(ncp,0)))
+ stats::qbeta(p, shape1, shape2, lower.tail, log.p)
+ else
+ {x <- c(0.0,1.0)
+ pfun <- function(x)
+ { pbeta(x, shape1=shape1, shape2=shape2, ncp=ncp)}
+ qfun <- P2Q(pfun,x)
+ p <- ifelse(log.p,exp(p),p)
+ p <- ifelse(lower.tail,p,1-p)
+ qfun(p)
+ }
+ }
+
+ rbeta <- function(n, shape1, shape2, ncp = 0)
+ {if(isTRUE(all.equal(ncp,0)))
+ stats::rbeta(n, shape1, shape2)
+ else
+ {X <- rchisq(n,df=2*shape1,ncp=ncp)
+ Y <- rchisq(n,df=2*shape2,ncp=0)
+ X/(X+Y)}
+ }
+
+ ###F Distribution
+
+ qf <- function(p, df1, df2, ncp = 0, lower.tail = TRUE, log.p = FALSE)
+ {if(isTRUE(all.equal(ncp,0)))
+ stats::qf(p, df1, df2, lower.tail, log.p)
+ else
+ {TQ <- getdistrOption("TruncQuantile")
+ xz <- qchisq(1-TQ,df=df1,ncp=ncp); xn<-qchisq(TQ,df=df2,ncp=0)
+ x <- c(0,xz/xn*df2/df1)
+ pfun <- function(x){pf(x, df1=df1, df2=df2, ncp=ncp)}
+ qfun <- P2Q(pfun,x)
+ p <- ifelse(log.p,exp(p),p)
+ p <- ifelse(lower.tail,p,1-p)
+ qfun(p)
+ }
+ }
+ rf <- function(n, df1, df2, ncp = 0)
+ {if(isTRUE(all.equal(ncp,0)))
+ stats::rf(n, df1, df2)
+ else df2*rchisq(n, df=df1, ncp=ncp)/rchisq(n, df=df2, ncp=0)/df1
+ }
+
+ ###T Distribution
+
+ qt <- function(p, df, ncp = 0, lower.tail = TRUE, log.p = FALSE)
+ {if(isTRUE(all.equal(ncp,0)))
+ stats::qt(p, df, lower.tail, log.p)
+ else
+ {TQ <- getdistrOption("TruncQuantile")*2
+ xz <- qnorm(1-TQ,mean=df); xn<-sqrt(qchisq(TQ,df=df,ncp=0)/df)
+ x <- c(-xz/xn,xz/xn)
+ pfun <- function(x){pt(x, df=df, ncp=ncp)}
+ qfun <- P2Q(pfun,x)
+ p <- ifelse(log.p,exp(p),p)
+ p <- ifelse(lower.tail,p,1-p)
+ qfun(p)
+ }
+ }
+ rt <- function(n, df, ncp = 0)
+ {if(isTRUE(all.equal(ncp,0)))
+ stats::rt(n, df)
+ else rnorm(n,mean=ncp)/sqrt(rchisq(n,df=df)/df)
+ }
+}
Deleted: pkg/distr/R/0pre230.Ra
===================================================================
--- pkg/distr/R/0pre230.Ra 2008-05-03 09:28:16 UTC (rev 123)
+++ pkg/distr/R/0pre230.Ra 2008-05-03 09:29:38 UTC (rev 124)
@@ -1,74 +0,0 @@
-### for working under R < 2.3.0
-if(getRversion()<'2.3.0')
-{ ## ignore ncp
-
- ###beta Distribution
-
- qbeta <- function(p, shape1, shape2, ncp = 0, lower.tail = TRUE,
- log.p = FALSE)
- {if(isTRUE(all.equal(ncp,0)))
- stats::qbeta(p, shape1, shape2, lower.tail, log.p)
- else
- {x <- c(0.0,1.0)
- pfun <- function(x)
- { pbeta(x, shape1=shape1, shape2=shape2, ncp=ncp)}
- qfun <- P2Q(pfun,x)
- p <- ifelse(log.p,exp(p),p)
- p <- ifelse(lower.tail,p,1-p)
- qfun(p)
- }
- }
-
- rbeta <- function(n, shape1, shape2, ncp = 0)
- {if(isTRUE(all.equal(ncp,0)))
- stats::rbeta(n, shape1, shape2)
- else
- {X <- rchisq(n,df=2*shape1,ncp=ncp)
- Y <- rchisq(n,df=2*shape2,ncp=0)
- X/(X+Y)}
- }
-
- ###F Distribution
-
- qf <- function(p, df1, df2, ncp = 0, lower.tail = TRUE, log.p = FALSE)
- {if(isTRUE(all.equal(ncp,0)))
- stats::qf(p, df1, df2, lower.tail, log.p)
- else
- {TQ <- getdistrOption("TruncQuantile")
- xz <- qchisq(1-TQ,df=df1,ncp=ncp); xn<-qchisq(TQ,df=df2,ncp=0)
- x <- c(0,xz/xn*df2/df1)
- pfun <- function(x){pf(x, df1=df1, df2=df2, ncp=ncp)}
- qfun <- P2Q(pfun,x)
- p <- ifelse(log.p,exp(p),p)
- p <- ifelse(lower.tail,p,1-p)
- qfun(p)
- }
- }
- rf <- function(n, df1, df2, ncp = 0)
- {if(isTRUE(all.equal(ncp,0)))
- stats::rf(n, df1, df2)
- else df2*rchisq(n, df=df1, ncp=ncp)/rchisq(n, df=df2, ncp=0)/df1
- }
-
- ###T Distribution
-
- qt <- function(p, df, ncp = 0, lower.tail = TRUE, log.p = FALSE)
- {if(isTRUE(all.equal(ncp,0)))
- stats::qt(p, df, lower.tail, log.p)
- else
- {TQ <- getdistrOption("TruncQuantile")*2
- xz <- qnorm(1-TQ,mean=df); xn<-sqrt(qchisq(TQ,df=df,ncp=0)/df)
- x <- c(-xz/xn,xz/xn)
- pfun <- function(x){pt(x, df=df, ncp=ncp)}
- qfun <- P2Q(pfun,x)
- p <- ifelse(log.p,exp(p),p)
- p <- ifelse(lower.tail,p,1-p)
- qfun(p)
- }
- }
- rt <- function(n, df, ncp = 0)
- {if(isTRUE(all.equal(ncp,0)))
- stats::rt(n, df)
- else rnorm(n,mean=ncp)/sqrt(rchisq(n,df=df)/df)
- }
-}
Copied: pkg/distr/R/99.R (from rev 123, pkg/distr/R/99.Ra)
===================================================================
--- pkg/distr/R/99.R (rev 0)
+++ pkg/distr/R/99.R 2008-05-03 09:29:38 UTC (rev 124)
@@ -0,0 +1,43 @@
+.distroptions <- list(
+ DefaultNrGridPoints = 2^12,
+ DistrResolution = 1e-6,
+ TruncQuantile = 1e-5,
+ DefaultNrFFTGridPointsExponent = 12,
+ RtoDPQ.e = 5,
+ # new Warning-items P.R. 28.03.06
+ WarningArith = TRUE,
+ WarningSim = TRUE,
+ ## new Items from 2.0:
+ withgaps = TRUE,
+ simplifyD = TRUE
+ )
+
+.OkTyp <- c("DiscreteDistribution","AbscontDistribution",
+ "UnivarLebDecDistribution", "UnivarMixingDistribution")
+
+
+
+.onAttach <- function(library, pkg)
+{
+ unlockBinding(".distroptions", asNamespace("distr"))
+ msga <- gettext(
+ "Attention: Arithmetics on distribution objects are understood as\n"
+ )
+ msgb <- gettext(
+ "operations on corresponding random variables (r.v.s); see distrARITH().\n"
+ )
+ msgc <- gettext(
+ "Some functions from package 'stats' are intentionally masked\n---see distrMASK().\n"
+ )
+ msgd <- gettext(
+ "Note that global options are controlled by distroptions()\n---c.f. ?\"distroptions\"."
+ )
+buildStartupMessage(pkg = "distr", msga, msgb, msgc, msgd, library = library,
+ packageHelp = TRUE,
+# MANUAL = "http://www.uni-bayreuth.de/departments/math/org/mathe7/DISTR/distr.pdf",
+ VIGNETTE = gettext(
+"Package \"distrDoc\" provides a vignette to this package as well as\nto several extension packages; try vignette(\"distr\")."
+ )
+ )
+ invisible()
+}
Deleted: pkg/distr/R/99.Ra
===================================================================
--- pkg/distr/R/99.Ra 2008-05-03 09:28:16 UTC (rev 123)
+++ pkg/distr/R/99.Ra 2008-05-03 09:29:38 UTC (rev 124)
@@ -1,43 +0,0 @@
-.distroptions <- list(
- DefaultNrGridPoints = 2^12,
- DistrResolution = 1e-6,
- TruncQuantile = 1e-5,
- DefaultNrFFTGridPointsExponent = 12,
- RtoDPQ.e = 5,
- # new Warning-items P.R. 28.03.06
- WarningArith = TRUE,
- WarningSim = TRUE,
- ## new Items from 2.0:
- withgaps = TRUE,
- simplifyD = TRUE
- )
-
-.OkTyp <- c("DiscreteDistribution","AbscontDistribution",
- "UnivarLebDecDistribution", "UnivarMixingDistribution")
-
-
-
-.onAttach <- function(library, pkg)
-{
- unlockBinding(".distroptions", asNamespace("distr"))
- msga <- gettext(
- "Attention: Arithmetics on distribution objects are understood as\n"
- )
- msgb <- gettext(
- "operations on corresponding random variables (r.v.s); see distrARITH().\n"
- )
- msgc <- gettext(
- "Some functions from package 'stats' are intentionally masked\n---see distrMASK().\n"
- )
- msgd <- gettext(
- "Note that global options are controlled by distroptions()\n---c.f. ?\"distroptions\"."
- )
-buildStartupMessage(pkg = "distr", msga, msgb, msgc, msgd, library = library,
- packageHelp = TRUE,
-# MANUAL = "http://www.uni-bayreuth.de/departments/math/org/mathe7/DISTR/distr.pdf",
- VIGNETTE = gettext(
-"Package \"distrDoc\" provides a vignette to this package as well as\nto several extension packages; try vignette(\"distr\")."
- )
- )
- invisible()
-}
More information about the Distr-commits
mailing list