@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/stats/tests/glm.R

@@ -0,0 +1,82 @@
+## Example in which the fit for the null deviance fails to converge:
+# https://stat.ethz.ch/pipermail/r-help/2012-May/313161.html
+Y <- c(rep(0,35),1,2,0,6,8,16,43)
+beta <- 42:1
+cst <- lchoose(42, beta)
+tau <- (beta^2)/2
+fit <- glm(formula = Y ~ offset(cst) + beta + tau, family = poisson)
+
+## Ensure make.link() consistency:
+linkNames <- c("logit", "probit", "cauchit", "cloglog",
+               "identity",
+               "log",  "sqrt",  "1/mu^2", "inverse")
+links <- lapply(setNames(,linkNames), make.link)
+fns <- c("linkfun", "linkinv", "mu.eta", "valideta")
+stopifnot(exprs = {
+    is.matrix(nms <- sapply(links, names)) # matching number & type
+    is.character(nms)
+    nms[,1] == nms ## all columns are the same
+    identical(setNames(,linkNames), vapply(links, `[[`, "", "name"))
+    fns %in% nms[,1]
+})
+links <- lapply(links, `[`, fns) # functions only
+stopifnot(unlist(lapply(links, function(L) vapply(L, is.function, NA))))
+## all functions having consistent arguments :
+lf <- lapply(links, function(L) lapply(L, formals))
+stopifnot(exprs = { ## all functions have 1 argument
+    unlist(lapply(lf, lengths), recursive=FALSE) == 1L
+    is.matrix(argNms <- sapply(lf, function(L) vapply(L, names, "")))
+    argNms[,1] == argNms ## all columns are the same
+})
+noquote(t(argNms))
+
+## Calling all functions
+## 1. valideta
+stopifnot(vv <- vapply(links, function(L) L$valideta((1:3)/4), NA))
+## 2. all others
+other <- fns != "valideta"
+str(linkO <- lapply(links, function(L) L[other]))
+v <- sapply(linkO, function(L) sapply(L, function(F) F((0:4)/4)),
+            simplify = "array")
+stopifnot(exprs = {
+    is.numeric(v)
+    identical(dim(v), c(5L, sum(other), length(links)))
+    identical(dimnames(v)[[2]], fns[other])
+    ## check that all functions are monotone (incr. _or_ decr.) <==>
+    ## signs of differences are constant <==> var(*) == 0
+    apply(v, 2:3, function(f) var(sign(diff(f))) == 0)
+})
+
+## Could further check  [for 'okLinks' of given families]:
+##	<family>(          "<linkname>")  ==
+##      <family>(make.link("<linkname>"))
+
+
+## <family>$aic() vs logLik() vs AIC() -- for Gamma:
+# From example(glm) :
+clotting <- data.frame(
+    u    = c( 5, 10,15,20,30,40,60,80,100),
+    lot1 = c(118,58,42,35,27,25,21,19,18),
+    lot2 = c(69, 35,26,21,18,16,13,12,12))
+summary(fm1 <- glm(lot1 ~ log(u), data = clotting, family = Gamma))
+summary(fm2 <- glm(lot2 ~ log(u), data = clotting, family = Gamma))
+
+hasDisp <- 1 # have dispersion (here, but not e.g., for binomial, poisson)
+for(fm in list(fm1, fm2)) {
+    print(ll <- logLik(fm))
+    p <- attr(ll, "df")
+    A0 <- AIC(fm)
+    A1 <- -2*c(ll) + 2*p
+    aic.v <- fm$family$aic(y  = fm$y, mu = fitted(fm),
+                           wt = weights(fm), dev= deviance(fm))
+    stopifnot(p == (p. <- length(coef(fm))) + hasDisp,
+              all.equal(-2*c(ll) + 2*hasDisp, aic.v)) # <fam>$aic() = -2 * loglik + 2s
+    A2 <- aic.v + 2 * p.
+    stopifnot(exprs = {
+        all.equal(A0, A1)
+        all.equal(A1, A2)
+        all.equal(A1, fm$aic)
+    })
+}
+
+

package/dist/vfs/usr/lib/R/library/stats/tests/glm.Rout.save

@@ -0,0 +1,194 @@
+
+R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
+Copyright (C) 2022 The R Foundation for Statistical Computing
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+> ## Example in which the fit for the null deviance fails to converge:
+> # https://stat.ethz.ch/pipermail/r-help/2012-May/313161.html
+> Y <- c(rep(0,35),1,2,0,6,8,16,43)
+> beta <- 42:1
+> cst <- lchoose(42, beta)
+> tau <- (beta^2)/2
+> fit <- glm(formula = Y ~ offset(cst) + beta + tau, family = poisson)
+Warning messages:
+1: glm.fit: algorithm did not converge 
+2: In glm(formula = Y ~ offset(cst) + beta + tau, family = poisson) :
+  fitting to calculate the null deviance did not converge -- increase 'maxit'?
+> 
+> ## Ensure make.link() consistency:
+> linkNames <- c("logit", "probit", "cauchit", "cloglog",
++                "identity",
++                "log",  "sqrt",  "1/mu^2", "inverse")
+> links <- lapply(setNames(,linkNames), make.link)
+> fns <- c("linkfun", "linkinv", "mu.eta", "valideta")
+> stopifnot(exprs = {
++     is.matrix(nms <- sapply(links, names)) # matching number & type
++     is.character(nms)
++     nms[,1] == nms ## all columns are the same
++     identical(setNames(,linkNames), vapply(links, `[[`, "", "name"))
++     fns %in% nms[,1]
++ })
+> links <- lapply(links, `[`, fns) # functions only
+> stopifnot(unlist(lapply(links, function(L) vapply(L, is.function, NA))))
+> ## all functions having consistent arguments :
+> lf <- lapply(links, function(L) lapply(L, formals))
+> stopifnot(exprs = { ## all functions have 1 argument
++     unlist(lapply(lf, lengths), recursive=FALSE) == 1L
++     is.matrix(argNms <- sapply(lf, function(L) vapply(L, names, "")))
++     argNms[,1] == argNms ## all columns are the same
++ })
+> noquote(t(argNms))
+         linkfun linkinv mu.eta valideta
+logit    mu      eta     eta    eta     
+probit   mu      eta     eta    eta     
+cauchit  mu      eta     eta    eta     
+cloglog  mu      eta     eta    eta     
+identity mu      eta     eta    eta     
+log      mu      eta     eta    eta     
+sqrt     mu      eta     eta    eta     
+1/mu^2   mu      eta     eta    eta     
+inverse  mu      eta     eta    eta     
+> 
+> ## Calling all functions
+> ## 1. valideta
+> stopifnot(vv <- vapply(links, function(L) L$valideta((1:3)/4), NA))
+> ## 2. all others
+> other <- fns != "valideta"
+> str(linkO <- lapply(links, function(L) L[other]))
+List of 9
+ $ logit   :List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+ $ probit  :List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+ $ cauchit :List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+ $ cloglog :List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+ $ identity:List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+ $ log     :List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+ $ sqrt    :List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+ $ 1/mu^2  :List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+ $ inverse :List of 3
+  ..$ linkfun:function (mu)  
+  ..$ linkinv:function (eta)  
+  ..$ mu.eta :function (eta)  
+> v <- sapply(linkO, function(L) sapply(L, function(F) F((0:4)/4)),
++             simplify = "array")
+> stopifnot(exprs = {
++     is.numeric(v)
++     identical(dim(v), c(5L, sum(other), length(links)))
++     identical(dimnames(v)[[2]], fns[other])
++     ## check that all functions are monotone (incr. _or_ decr.) <==>
++     ## signs of differences are constant <==> var(*) == 0
++     apply(v, 2:3, function(f) var(sign(diff(f))) == 0)
++ })
+> 
+> ## Could further check  [for 'okLinks' of given families]:
+> ##	<family>(          "<linkname>")  ==
+> ##      <family>(make.link("<linkname>"))
+> 
+> 
+> ## <family>$aic() vs logLik() vs AIC() -- for Gamma:
+> # From example(glm) :
+> clotting <- data.frame(
++     u    = c( 5, 10,15,20,30,40,60,80,100),
++     lot1 = c(118,58,42,35,27,25,21,19,18),
++     lot2 = c(69, 35,26,21,18,16,13,12,12))
+> summary(fm1 <- glm(lot1 ~ log(u), data = clotting, family = Gamma))
+
+Call:
+glm(formula = lot1 ~ log(u), family = Gamma, data = clotting)
+
+Coefficients:
+              Estimate Std. Error t value Pr(>|t|)    
+(Intercept) -0.0165544  0.0009275  -17.85 4.28e-07 ***
+log(u)       0.0153431  0.0004150   36.98 2.75e-09 ***
+---
+Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+
+(Dispersion parameter for Gamma family taken to be 0.002446059)
+
+    Null deviance: 3.51283  on 8  degrees of freedom
+Residual deviance: 0.01673  on 7  degrees of freedom
+AIC: 37.99
+
+Number of Fisher Scoring iterations: 3
+
+> summary(fm2 <- glm(lot2 ~ log(u), data = clotting, family = Gamma))
+
+Call:
+glm(formula = lot2 ~ log(u), family = Gamma, data = clotting)
+
+Coefficients:
+              Estimate Std. Error t value Pr(>|t|)    
+(Intercept) -0.0239085  0.0013265  -18.02 4.00e-07 ***
+log(u)       0.0235992  0.0005768   40.91 1.36e-09 ***
+---
+Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+
+(Dispersion parameter for Gamma family taken to be 0.001813354)
+
+    Null deviance: 3.118557  on 8  degrees of freedom
+Residual deviance: 0.012672  on 7  degrees of freedom
+AIC: 27.032
+
+Number of Fisher Scoring iterations: 3
+
+> 
+> hasDisp <- 1 # have dispersion (here, but not e.g., for binomial, poisson)
+> for(fm in list(fm1, fm2)) {
++     print(ll <- logLik(fm))
++     p <- attr(ll, "df")
++     A0 <- AIC(fm)
++     A1 <- -2*c(ll) + 2*p
++     aic.v <- fm$family$aic(y  = fm$y, mu = fitted(fm),
++                            wt = weights(fm), dev= deviance(fm))
++     stopifnot(p == (p. <- length(coef(fm))) + hasDisp,
++               all.equal(-2*c(ll) + 2*hasDisp, aic.v)) # <fam>$aic() = -2 * loglik + 2s
++     A2 <- aic.v + 2 * p.
++     stopifnot(exprs = {
++         all.equal(A0, A1)
++         all.equal(A1, A2)
++         all.equal(A1, fm$aic)
++     })
++ }
+'log Lik.' -15.99496 (df=3)
+'log Lik.' -10.51608 (df=3)
+> 
+> 
+> 
+> proc.time()
+   user  system elapsed 
+  0.535   0.082   0.593 

package/dist/vfs/usr/lib/R/library/stats/tests/ig_glm.R

@@ -0,0 +1,68 @@
+## some tests of inverse-gaussian GLMs based on a file supplied by
+## David Firth, Feb 2009.
+
+options(digits=5)
+have_MASS <- requireNamespace('MASS', quietly = TRUE)
+
+##  Data from Whitmore, G A (1986), Inverse Gaussian Ratio Estimation.
+##  Applied Statistics 35(1), 8-15.
+##
+##  A "real, but disguised" set of data (Whitmore, 1986, p8).
+##
+##  For each of 20 products, x is projected sales and y is actual sales.
+
+x <- c(5959, 3534, 2641, 1965, 1738, 1182, 667, 613, 610, 549,
+       527, 353, 331, 290, 253, 193, 156, 133, 122, 114)
+y <- c(5673, 3659, 2565, 2182, 1839, 1236, 918, 902, 756, 500,
+       487, 463, 225, 257, 311, 212, 166, 123, 198, 99)
+
+## Whitmore's model (2.4) is
+
+fit <- glm(y ~ x - 1, weights = x^2,
+           family = inverse.gaussian(link = "identity"),
+           epsilon = 1e-12)
+fit
+coef(summary(fit))
+##  Alternatively, use the explicit formula that's available for the MLE
+##  in this example.  It's just a ratio estimate:
+(beta.exact <- sum(y)/sum(x))
+stopifnot(all.equal(beta.exact, as.vector(coef(fit))))
+## and for a confidence interval via confint
+if(have_MASS) {
+    ci <- confint(fit, 1, level = 0.95)
+    print(ci)
+}
+## and via asymptotic normality
+sterr <- coef(summary(fit))[, "Std. Error"]
+coef(fit) + (1.96 * sterr * c(-1, 1))
+
+## David suggested the use of an inverse link
+
+fit2 <- glm(y ~ I(1/x) - 1, weights = x^2,
+            family = inverse.gaussian(link = "inverse"),
+            epsilon = 1e-12)
+coef(summary(fit2))
+## which gives the same CIs both ways
+if(have_MASS) {
+    ci1 <- rev(1/(confint(fit2, 1, level = 0.95)))
+    print(ci1)
+    sterr <- (summary(fit2)$coefficients)[, "Std. Error"]
+    ci2 <- 1/(coef(fit2) - (1.96 * sterr * c(-1, 1)))
+    print(ci2)
+    stopifnot(all.equal(as.vector(ci), as.vector(ci1), tolerance = 1e-5),
+              all.equal(as.vector(ci), ci2, tolerance = 1e-3))
+}
+##  because the log likelihood for 1/beta is exactly quadratic.
+
+##  The approximate intervals above differ slightly from the exact
+##  confidence interval given in Whitmore (1986) -- as is to be
+##  expected (they are based on asymptotic approximations, not the
+##  exact pivot).
+
+
+## Now simulate from this model
+if(requireNamespace("SuppDists")) {
+    print( ys <- simulate(fit, nsim = 3, seed = 1) )
+    for(i in seq_len(3))
+        print(coef(summary(update(fit, ys[, i] ~ .))))
+}

package/dist/vfs/usr/lib/R/library/stats/tests/ks-test.R

@@ -0,0 +1,116 @@
+#### Some examples of the KS and Wilcoxon tests
+
+### ------ Kolmogorov Smirnov (KS) --------------
+
+## unrealistic one of PR#14561
+ds1 <- c(1.7,2,3,3,4,4,5,5,6,6)
+ks.test(ds1, "pnorm", mean = 3.3, sd = 1.55216)
+# how on earth can sigma = 1.55216 be known?
+
+# R >= 2.14.0 allows the equally invalid
+ks.test(ds1, "pnorm", mean = 3.3, sd = 1.55216, exact = TRUE)
+
+## Try out the effects of rounding
+set.seed(123)
+ds2 <- rnorm(1000)
+ks.test(ds2, "pnorm") # exact = FALSE is default for n = 1000
+ks.test(ds2, "pnorm", exact = TRUE)
+## next two are still close
+ks.test(round(ds2, 2), "pnorm")
+ks.test(round(ds2, 2), "pnorm", exact = TRUE)
+# now D has doubled, but p-values remain similar (if very different from ds2)
+ks.test(round(ds2, 1), "pnorm")
+ks.test(round(ds2, 1), "pnorm", exact = TRUE)
+
+
+### ------ Wilkoxon (Mann Whitney) --------------
+
+options(nwarnings = 1000)
+(alts <- setNames(, eval(formals(stats:::wilcox.test.default)$alternative)))
+x0 <- 0:4
+(x.set <- list(s0 = lapply(x0, function(m) 0:m),
+               s. = lapply(x0, function(m) c(1e-9, seq_len(m)))))
+stats <- setNames(nm = c("statistic", "p.value", "conf.int", "estimate"))
+
+## Even with  conf.int = TRUE, do not want errors :
+RR <-
+    lapply(x.set, ## for all data sets
+           function(xs)
+               lapply(alts, ## for all three alternatives
+                      function(alt)
+                          lapply(xs, function(x)
+                              ## try(
+                              wilcox.test(x, exact=TRUE, conf.int=TRUE, alternative = alt)
+                              ## )
+                              )))
+length(ww <- warnings()) # 52 (or 43 for x0 <- 0:3)
+unique(ww) # 4 different ones
+
+cc <- lapply(RR, function(A) lapply(A, function(bb) lapply(bb, class)))
+table(unlist(cc))
+## in R <= 3.3.1,  with try( .. ) above, we got
+## htest try-error
+##    23         7
+uc <- unlist(cc[["s0"]]); noquote(names(uc)[uc != "htest"]) ## these 7 cases :
+## two.sided1 two.sided2 two.sided3
+## less1      less2
+## greater1   greater2
+
+##--- How close are the stats of  (0:m)  to those of  (eps, 1:m) ------------
+
+## a version that still works with above try(.) and errors there:
+getC <- function(L, C) if(inherits(L,"try-error")) c(L) else L[[C]]
+stR <- lapply(stats, function(COMP)
+           lapply(RR, function(A)
+               lapply(A, function(bb)
+                   lapply(bb, getC, C=COMP) )))
+
+## a) P-value
+pv <- stR[["p.value"]]
+## only the first is NaN, all others in [0,1]:
+sapply(pv$s0, unlist)
+sapply(pv$s., unlist) # not really close, but ..
+
+pv$s0$two.sided[1] <-  1 ## artificially
+stopifnot(all.equal(pv$s0, pv$s., tol = 0.5 + 1e-6), # seen 0.5
+	  ## "less" are close:
+	  all.equal(unlist(pv[[c("s0","less")]]),
+		    unlist(pv[[c("s.","less")]]), tol = 0.03),
+	  0 <= unlist(pv), unlist(pv) <= 1) # <- no further NA ..
+## b)
+sapply(stR[["statistic"]], unlist)
+## Conf.int.:
+## c)
+sapply(stR[["estimate" ]], unlist)
+## d) confidence interval
+formatCI <- function(ci)
+    sprintf("[%g, %g] (%g%%)", ci[[1]], ci[[2]],
+	    round(100*attr(ci,"conf.level")))
+nx <- length(x0)
+noquote(vapply(stR[["conf.int"]], function(ss)
+    vapply(ss, function(alt) vapply(alt, formatCI, ""), character(nx)),
+    matrix("", nx, length(alts))))
+
+
+##-------- 2-sample tests (working unchanged) ------------------
+
+R2 <- lapply(alts, ## for all three alternatives
+             function(alt)
+                 lapply(seq_along(x0), function(k)
+                         wilcox.test(x = x.set$s0[[k]], y = x.set$s.[[k]],
+                                     exact=TRUE, conf.int=TRUE, alternative = alt)))
+length(w2 <- warnings()) # 27
+unique(w2) # 3 different ones
+
+table(uc2 <- unlist(c2 <- lapply(R2, function(A) lapply(A, class))))
+stopifnot(uc2 == "htest")
+
+stR2 <- lapply(stats,
+               function(COMP)
+                   lapply(R2, function(A) lapply(A, getC, C=COMP)))
+
+lapply(stats[-3], ## -3: "conf.int" separately
+       function(ST) sapply(stR2[[ST]], unlist))
+
+noquote(sapply(stR2[["conf.int"]], function(.) vapply(., formatCI, "")))
+