sfsmisc/0000755000176200001440000000000014120063352011715 5ustar liggesuserssfsmisc/NAMESPACE0000644000176200001440000001001514116700160013131 0ustar liggesusersimportFrom("grDevices", boxplot.stats, cairo_pdf, dev.cur, dev.off , grSoftVersion , n2mfrow, pdf, postscript , xy.coords) importFrom("graphics", abline, arrows, axTicks, axis, axis.POSIXct, boxplot, curve, frame, hist, lines, locator, matplot, mtext, par, plot.new, points, polygon, rug, segments, symbols, text, xyinch) if(getRversion() < "4.0.0") importFrom("graphics", plot) importFrom("stats", IQR, approx, as.formula, as.ts, dchisq, dgamma, density.default, dnorm, dummy.coef, ecdf, end, family, fitted, formula, getCall, is.ts, lm, lowess, loess, loess.control, mad, median, model.frame, na.exclude, na.omit, napredict, pchisq, pf, plot.ts, predict, qchisq, qgamma, qnorm, qt, quantile, resid, residuals, runif, setNames, smooth.spline, spline, splinefun, start, stepfun, symnum, terms, time, update.formula, var, window) importFrom("utils", head, tail, toLatex, #<- S3 generics ! help, capture.output, data, packageDescription, read.table, sessionInfo, str) importFrom("tools", Rcmd) ## Using "::" in code -> no need here: importFrom("methods", existsFunction) ### Export almost all ## ------ ## New scheme (at first: for new things, only): # group exported objects __by ./R/ (and maybe ./man/) source file__ export ( ## ./R/prime-numbers-fn.R : primes, factorize, "AsciiToInt", "as.intBase", "bi2int", ## FIXME: currently needed from FrF2 (Ulrike Groemping): "as.integer.basedInt", "axTexpr", "repChar", "bl.string", "cairoSwd", "capture.and.write", "ccat", "chars8bit", "code2n", "col01scale", "colcenter", "compresid2way", "cum.Vert.funkt", "C.Monatsname", "C.weekday", "C.Wochentag", "C.Wochentagkurz", "D1D2", "D1ss", "D1tr", "D2ss", "dDA", "diagDA", "diagX", "digitsBase", "Duplicated", "eaxis", "ecdf.ksCI", "ellipsePoints", "empty.dimnames", "errbar", "f.robftest", funEnv, "hatMat", "histBxp", # defunct: "hist.bxp" helppdf, "ichar", "integrate.xy", "inv.seq", isRshared, "is.whole", "iterate.lin.recursion", "KSd", "last", "linesHyperb.lm", "list2mat", loessDemo, "lseq", "margin2table", "mat2tex", missingCh, "mpl", "mult.fig", ## FIXME: This is deprecated (but was never announced anyway...) : nearcor, "n.code", "n.plot", "nr.sign.chg", "paste.vec", "p.arrows", "p.datum", "p.dchisq", "p.dgamma", "p.dnorm", "p.hboxp", "plotDS", "pl.ds", ## <- deprecated "plotStep", "p.m", ## these should probably be deprecated for pmax.int(), pmin.int(): "pmax.sa", "pmin.sa", "polyn.eval", "posdefify", "p.pllines", "p.profileTraces", "p.res.2fact", "p.res.2x", "pretty10exp", ## not the S3 methods: ## "predict.dDA", ## "print.basedInt", "print.dDA", "print.margin2table", pkgDesc, pkgBuilt, "printTable2", "prt.DEBUG", "pdf.do", "pdf.end", "pdf.latex", "ps.do", "ps.end", "ps.latex", "p.scales", "p.tachoPlot", "p.ts", "quadrant", "QUnif", read.org.table, relErrV, relErr, "rot2", "rotn", "roundfixS", "rrange", "sHalton", "seqXtend", sessionInfoX, shortRversion, "signi", "sourceAttach", "strcodes", "str_data", "TA.plot", "tapplySimpl", "tkdensity", "u.boxplot.x", "u.date", "u.datumdecode", "u.Datumvonheute", "u.assign0", "u.get0", "u.log", "unif", "uniqueL", "u.sys", "vcat", "wrapFormula", "xy.grid", "xy.unique.x" ) export("Sys.ps.cmd") # now in general.. even though possibly nonfunctional in non-unix if(tools:::.OStype() == "unix") { ## those are inside R/unix/ export("Sys.ps", "Sys.sizes") if(identical(1L, grep("linux", R.version[["os"]]))) { ##--- Linux - only --- export("Sys.cpuinfo", "Sys.meminfo", "Sys.MIPS", "Sys.memGB") } export("pkgLibs") } S3method(predict, dDA) S3method(print, dDA) S3method(print, basedInt) S3method(print, sessionInfoX) S3method(as.integer, basedInt) S3method(print, margin2table) S3method(toLatex, numeric) S3method(p.res.2x, default) S3method(p.res.2x, formula) sfsmisc/demo/0000755000176200001440000000000013651517477012665 5ustar liggesuserssfsmisc/demo/prime-numbers.R0000644000176200001440000001234612371413475015572 0ustar liggesusers####---- Prime numbers, factorization, etc. --- "illustration of programming" ####---- A Collection of pure S / R -- Experiments from the 1990's ####---- mostly carried by discussions on the good old S-news mailing list ### Mostly using the functions currently hidden in sfsmisc namespace ### FIXME: ---> Move these function definitons to ../inst/ ---> see ../TODO (10) factorizeBV <- sfsmisc:::factorizeBV primes. <- sfsmisc:::primes. test.factorize <- sfsmisc:::test.factorize prime.sieve <- sfsmisc:::prime.sieve factors <- sfsmisc:::factors ## factorizeBV(6) ##[1] 2 3 str( factorizeBV(4:8) ) ### 1) The super speedy primes() function from Bill Venables ### {and improved by M.Maechler}: ## on a Pentium 4 2.80 GHz with 2 GB RAM ; N <- 1e7 ## keep this working for S+ ! compatible for(i in 1:3) print(system.time(p7 <- primes.(N))[1:3]) ## Bill Venables' original ##- [1] 3.86 1.93 8.75 ##- [1] 4.02 1.60 11.34 ##- [1] 4.14 1.60 11.51 ## about 10-20% slower on 'lynne' for(i in 1:3) print(system.time(p7. <- primes(N))[1:3]) ## Martin Maechler's improvement ##- [1] 2.29 0.76 6.47 ##- [1] 2.58 0.73 6.67 ##- [1] 2.71 0.59 6.64 stopifnot(p7 == p7.) ## On 'lynne' (AMD Athlon 64bit 2800+, 1G RAM), speedup somewhat similar; ## Also here system.time(for(i in 1:50) p5 <- primes (1e5))[1:3] system.time(for(i in 1:50) p5. <- primes.(1e5))[1:3] stopifnot(p5 == p5.) ## 2) factorize(n <- c(7,27,37,5*c(1:5, 8, 10))) factorize(47) factorize(7207619)## quick ! factorize(131301607)# prime -> still only 0.02 seconds (on lynne)! ## Factorizing larger than max.int -- not prime; ## should be much quicker with other algo (2nd largest prime == 71) !! factorize(76299312910) system.time(fac.1ex <- factorize(1000 + 1:99)) #-- 0.95 sec (sophie Sparc 5) #-- 0.02 sec (P 4, 1.6GHz); 0.4 / .65 sec (florence Ultra 1/170) system.time(fac.2ex <- factorize(10000 + 1:999)) ## R 0.49 : 5.4 sec (florence Ultra 1/170) ## ------ 6.1 sec (sophie Ultra 1/140) ## R 0.50-: ~ 3.5 sec (sophie ..........) <<< FASTER ! ## ------ ## This really used to take time -- no longer w/ current factorize() in 2004 ! system.time(factorize.10000 <- factorize(1:10000)) ## sophie: Sparc 5 (..) :lots of swapping after while, >= 20 minutes CPU; ## then using less and less CPU, ..more swapping ==> KILL ## florence (hypersparc): [1] 1038.90 5.09 1349. ( 17 min. CPU) ## lynne (Ultra-1): [1] 658.77 0.90 677. ## lynne (Pentium 4): [1] 2.43 0.16 2.68 ## helen (Pentium 4), R1.9.1: 1.02 0.01 1.04 ## lynne (64b,2800+), R2.0.1: 0.86 0.00 0.86 object.size(factorize.10000) #--> 3027743 now (R 1.5.1) 3188928; # '* 2' for 64-bit ###--- test test.factorize(fac.1ex[1:10]) #-- T T T .. which(!test.factorize(fac.1ex)) which(!test.factorize(factorize(8000 + 1:1000))) prime.sieve(prime.sieve()) system.time(P1e4 <- prime.sieve(prime.sieve(prime.sieve()), max=10000)) ##-> 1.45 (on sophie: fast Sparc 5 ..) ##-> ~0.8 (on jessica: Ultra-2) ##-> 0.08 (on lynne, Pentium 4 (1600 MHz)) ##----> see below for a sample of 20 ! stopifnot(length(P1e4) == 1229) CPU.p1e4 <- numeric(20) for(i in 1:20) CPU.p1e4[i] <- system.time(P1e4 <- prime.sieve(prime.sieve(prime.sieve()), max=10000))[1] CPU.p1e4 summary(CPU.p1e4) ##-Ultra-2 Min. 1st Qu. Median Mean 3rd Qu. Max. ##-Ultra-2 0.690 0.690 0.790 0.755 0.800 0.810 ## P4 R-?) 0.070 0.070 0.080 0.078 0.080 0.100 ## P4 R-1.9 0.040 0.050 0.050 0.048 0.050 0.050 system.time(P1e4.2 <- prime.sieve( max=10000)) ##-> 1.46 (sophie) maybe a little longer stopifnot(identical(P1e4 , P1e4.2)) system.time(P1e5 <- prime.sieve(P1e4, max=1e5)) ## note! primes() is faster! ##-> 105.7 (on sophie: fast Sparc 5) ##-> 58.83 (on jessica: Ultra2) ##-> 5.67 (on lynne: Pentium 4) ##-> 3.96 (on lynne: Pentium 4 -- R 1.9) ##-> 1.37 (on lynne: AMD 64 -- R 2.0.1) stopifnot(p5 == P1e5, length(P1e5) == 9592) P1000 <- prime.sieve(max=1000) plot(P1000, seq(P1000), type='b', main="Prime number theorem") lines(P1000, P1000/log(P1000), col=2, lty=2, lwd=1.5) plot(P1e4, seq(P1e4), type='l', main="Prime number theorem") lines(P1e4, P1e4/log(P1e4), col=2, lty=2, lwd=1.5) stopifnot(require("sfsmisc")) ## For a nice plot: ps.do("prime-number.ps") mult.fig(2, main="Prime number theorem") plot(P1e5,seq(P1e5), type='l', main="pi(n) & n/log(n) ", xlab='n',ylab='pi(n)', log='xy', sub = 'log - log - scale') lines(P1e5, P1e5/log(P1e5), col=2, lty=2, lwd=1.5) mtext("demo(\"prime-numbers\", package = \"sfsmisc\")", side = 3, cex=.75, adj=1, line=3, outer=TRUE) plot(P1e5, seq(P1e5) / (P1e5/log(P1e5)), type='b', pch='.', main= "Prime number theorem : pi(n) / {n/log(n)}", ylim =c(1,1.3), xlab = 'n', ylab='pi(n) / (n/log(n)', log='x') abline(h=1, col=3, lty=2) ps.end() ## 3) the factors() from Bill Dunlap etc factors( round(gamma(13:14))) ##- $"479001600": ##- [1] 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 5 5 7 11 ##- ##- $"6227020800": ##- [1] 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 5 5 7 11 13 ## --- You can use table() to collect repeated factors : ---- lapply( factors( round(gamma(13:14))), table) ##- $"479001600": ##- 2 3 5 7 11 ##- 10 5 2 1 1 ##- ##- $"6227020800": ##- 2 3 5 7 11 13 ##- 10 5 2 1 1 1 sfsmisc/demo/pretty-lab.R0000644000176200001440000000246712560623034015065 0ustar liggesusers## Original from David Seifert (ETHZ Basel, c/o Beerenwinkel) ## https://github.com/mmaechler/sfsmisc/pull/2 ### Example showing how eaxis() / pretty10exp() lab.type = "latex" ### can be used together with LaTeX package "tikz" and stopifnot(require("tikzDevice")) ### to produce LaTeX math labels require("sfsmisc") x <- (-3:10) * 10^10 y <- abs(x / 1e9) (t.file <- tempfile("tikz-eaxis", fileext = ".tex")) tikz(file = t.file, standAlone=TRUE) plot(x, y, axes=FALSE, type = "b") eaxis(1, at=x, lab.type="latex") eaxis(2, lab.type="latex") dev.off()# i.e. finish and close file 't.file' ## Now add two lines to (the preamble of the latex file ## such that all axis tick labels are in latex math if requested by lab.type="latex". ## {Note : "\" (backslash) must be doubled in R strings} helvet.lns <- c("\\renewcommand{\\familydefault}{\\sfdefault}", "\\usepackage{helvet}") str(ll <- readLines(t.file)) writeLines(c(ll[1:4], "", "%% Added from R (pkg 'sfsmisc', demo 'pretty-lab'):", helvet.lns, "", ll[-(1:5)]), t.file) ## Produce PDF from LaTeX system(paste(paste0("pdflatex -output-directory=", dirname(t.file)), t.file)) ## and view it if(file.exists(p.file <- sub("tex$", "pdf", t.file)) && interactive()) system(paste(getOption("pdfviewer"), p.file), wait=FALSE) sfsmisc/demo/00Index0000644000176200001440000000025612560623034014003 0ustar liggesusershatmat-ex hat matrix / smoother Matrix examples prime-numbers Prime numbers, factorization, etc: (Simple) implementations pretty-lab Pretty axis labels, including using tikz sfsmisc/demo/hatmat-ex.R0000644000176200001440000001007311450415657014671 0ustar liggesusers#### Demos for sfsmisc::hatMat() ##' Matrix trace -- tr(M) = \sum_i M_{i,i} ##' ##' .. content for \details{} .. ##' @title Matrix trace ##' @param m ##' @return sum() ##' @author Martin Maechler TR <- function(m) { ## Matrix trace(.) == tr(.) : stopifnot(length(d <- dim(m)) == 2, d[1] == d[2]) sum(diag(m)) } ## Take those from ?hatMat -- modified -- ##--.--.--.--.--.--.--.-- ## Example 'pred.sm' arguments for hatMat() : pspl <- function(x,y,...) predict(smooth.spline(x,y, ...), x = x)$y ## needed! default surface="interpolate" is not good enough : loess.C <- loess.control(surface = "direct") ploess <- function(x,y,...) predict(loess(y ~ x, ..., control=loess.C)) pksm <- function(x,y,...) ksmooth(sort(x),y, kernel="normal", x.points=x, ...)$y ## maybe rather than ksmooth(): if(require("sm")) pksm2 <- function(x,y,...) sm.regression(x,y, display="none", eval.points=x, ...)$estimate ##--.--.--.--.--.--.--.-- set.seed(21) x <- seq(0, 10, length= 201) ## sorted !! -- otherwise: mf <- function(x) x^1.5 * sin(x) y <- mf(x) + 5*rnorm(x) ## Plot data + smooths -- smoothing parameters carefully chosen ## such that df ~= 8.8 for all: plot(x,y, cex=.6) lines(x, mf(x), col="gray", lwd=3)## true m(x) lines(predict(s1 <- smooth.spline(x,y, spar=.8)), col="blue"); s1 #-> df = 8.8 lines(x, predict(s2 <- loess(y ~ x, span=.385, control=loess.C)), col="forest green"); s2 # df = 8.77 lines(x, s3y <- ksmooth(x,y, "normal", bandwidth= 1.3)$y, col="tomato") s4 <- sm.regression(x,y, h = 0.54, display="none", eval.points=x) lines(x, s4$estimate, col = "purple") legend("topleft", c("true m(.)", "sm.spline", "loess", "ksmooth", "sm.regression"), col=c("gray","blue","forest green","tomato","purple"), lty=1, lwd=c(3, 1,1,1,1), inset=.01) TR(H.sspl <- hatMat(x, pred.sm = pspl, spar = .8)) # 8.808432 TR(H.loess <- hatMat(x, pred.sm = ploess, span = .385)) # 8.865958 TR(H.ksm <- hatMat(x, pred.sm = pksm, bandwidth = 1.3))# 8.788017 TR(H.ksm2 <- hatMat(x, pred.sm = pksm2, h = 0.54)) # 8.80269 -- sm.regression is S.L.O.W ## Check consistency: stopifnot( ## Smoothing Spline: all.equal(c(H.sspl %*% y), fitted(s1)) , all.equal(sum(diag(H.sspl)), s1$df) , ## Loess all.equal(c(H.loess %*% y), fitted(s2)) , ## ksmooth() all.equal(c(H.ksm %*% y), s3y) , ## sm.regression() all.equal(c(H.ksm2 %*% y), s4$estimate) ) op <- mult.fig(mfrow=c(4,1), marP=-.5)$old.par yl <- c(-.01, 0.10) matplot(x, H.sspl, type="l", ylim=yl) matplot(x, H.loess, type="l", ylim=yl) matplot(x, H.ksm, type="l", ylim=yl) matplot(x, H.ksm2, type="l", ylim=yl) par(op) ## or just a subset i <- c(1, seq(10,200, by=20), length(x)) op <- mult.fig(mfrow=c(4,1), marP= -.5, main = paste("rows",paste(i,collapse=",")," of hat matrices"))$old.par matplot(x, H.sspl [,i], type="l", ylim=yl) matplot(x, H.loess[,i], type="l", ylim=yl) matplot(x, H.ksm [,i], type="l", ylim=yl) matplot(x, H.ksm2 [,i], type="l", ylim=yl) par(op) ##' Image plot of a symmetric matrix -- traditional graphics ##' ##' @title Image Plot of Symmetric Matrix ##' @param m symmetric numeric matrix ##' @param color ##' @param levels ##' @param ... passed to filled.contour() ##' @return ##' @author Martin Maechler pMatrix <- function(m, color=topo.colors, levels= pretty(range(m), 20), ...) { stopifnot(length(d <- dim(m)) == 2, d[1] == d[2]) n <- d[1] ii <- seq_len(n) i. <- rev(ii) il <- unique(c(1,pretty(ii))) op <- par(mgp = c(3, .6, 0)); on.exit(par(op)) filled.contour(ii, ii, m[i.,], color=color, levels=levels, plot.axes = { axis(3, il); axis(2, at = n+1-il, labels = il)}, ...) } levs <- pretty(c(-0.025, 0.15), 25) pMatrix(H.sspl, levels=levs, main = "hat matrix S for smooth.spline()") if(dev.interactive()) dev.new() pMatrix(H.loess, levels=levs, main = "hat matrix S for loess()") if(dev.interactive()) dev.new() pMatrix(H.ksm, levels=levs, main = "hat matrix S for ksmooth()") sfsmisc/README.md0000644000176200001440000000154113344304710013200 0ustar liggesuserssfsmisc ======= The R package sfsmisc has finally made it into a revision control system, and the fad of the day being git & github, so be it! sfsmisc has been on CRAN for a very long time, and containing R code that is up to 17.5 years old. ([See](https://mmaechler.blogspot.com/2014/08/how-i-got-175-years-old-github.html) on how I got this into github, including parts of the long history.) It is a collection of "goodies" as we used to call these nice utility functions. Whereas the package has been written and maintained by Martin Maechler, really there are quite a few more members of the SfS (Seminar fuer Statistik at ETH Zurich) who have authored some of the functions or contributed to them. DESCRIPTION =========== Useful utilities 'goodies' from Seminar fuer Statistik ETH Zurich, quite a few related to graphics; many ported from S-plus times. sfsmisc/data/0000755000176200001440000000000013651517477012652 5ustar liggesuserssfsmisc/data/potatoes.rda0000644000176200001440000000122512371413665015170 0ustar liggesusers;oA'~ļ,PRREtD<KVɆD2]tJ))) TYϹGEaݹ;^?[BʨL\~ͩZj&aҌbW8o"3cdgl1ѧzԉK8>fbOʐ_$`p=i;j4 6E8ntem\d2i2?()斘bVsW=1by 桘Gby"fMSW_V;}'Hv˞;ɇtclo;~J?ΡӮb>~wN0ts[t|c Nu@-Н;Bӽט"1BcשMcwP7ci*[YC>\o<uLC=>pߵ^߭~y5—̶OQvnr{1-97/ݥaa|1e117`2]NytΧ *tdh24 M&Cdh24 C!Ða0d2  COOOOOOOOOOF@F@F@F@Fp/da#L¥ͶC<+#\ sfsmisc/man/0000755000176200001440000000000014117733424012502 5ustar liggesuserssfsmisc/man/n.plot.Rd0000644000176200001440000000334707757444571014230 0ustar liggesusers\name{n.plot} \alias{n.plot} \title{Name Plot: Names or Numbers instead of Points in Plot} \description{ A utility function which basically calls \code{\link{plot}(*, type="n")} and \code{\link{text}}. To have names or numbers instead of points in a plot is useful for identifaction, e.g., in a residual plot, see also \code{\link{TA.plot}}. } \usage{ n.plot(x, y = NULL, nam = NULL, abbr = n >= 20 || max(nchar(nam))>=8, xlab = NULL, ylab = NULL, log = "", cex = par("cex"), col = par("col"), \dots) } \arguments{ \item{x,y}{coordinates at which to plot. If \code{y} is missing, \code{x} is used for both, if it's a \code{\link{data.frame}, \link{list}}, 2-column matrix etc -- via \code{\link{xy.coords}}; formula do \bold{not} work.} \item{nam}{the labels to plot at each (x,y). Per default, these taken from the data \code{x} and \code{y}; case numbers \code{1:n} are taken if no names are available.} \item{abbr}{logical indicating if the \code{nam} labels should be abbreviated -- with a sensible default.} \item{xlab,ylab}{labels for the x- and y- axis, the latter being empty by default.} \item{log}{character specifying if log scaled axes should be used, see \code{\link{plot.default}}.} \item{cex}{plotting character expansion, see \code{\link{par}}.} \item{col}{color to use for \code{\link{text}()}.} \item{\dots}{further arguments to be passed to the \code{\link{plot}} call.} } \value{ invisibly, a character vector with the labels used. } \author{Martin Maechler, since 1992} \seealso{\code{\link{plot.default}}, \code{\link{text}}.} \examples{ n.plot(1:20, cumsum(rnorm(20))) data(cars) with(cars, n.plot(speed, dist, cex = 0.8, col = "forest green")) } \keyword{hplot} sfsmisc/man/digitsBase.Rd0000644000176200001440000000727513246037205015056 0ustar liggesusers\name{digitsBase} \alias{digitsBase} \alias{as.intBase} \alias{bi2int} \alias{as.integer.basedInt} \alias{print.basedInt} \title{Digit/Bit Representation of Integers in any Base} \description{ Integer number representations in other Bases. Formally, for every element \eqn{N =}\code{x[i]}, compute the (vector of) \dQuote{digits} \eqn{A} of the \code{base} \eqn{b} representation of the number \eqn{N}, \eqn{N = \sum_{k=0}^M A_{M-k} b ^ k}{% N = sum(k = 0:M ; A[M-k] * b^k)}.\cr Revert such a representation to integers. } \usage{ digitsBase(x, base = 2, ndigits = 1 + floor(1e-9 + log(max(x,1), base))) \method{as.integer}{basedInt}(x, \dots) \method{print}{basedInt}(x, \dots) as.intBase(x, base = 2) bi2int(xlist, base) } \arguments{ \item{x}{For \code{digitsBase()}: non-negative integer (vector) whose base \code{base} digits are wanted. For \code{as.intBase()}: \cr a list of numeric vectors, a character vector, or an integer matrix as returned by \code{digitsBase()}, representing digits in base \code{base}. } \item{base}{integer, at least 2 specifying the base for representation.} \item{ndigits}{number of bits/digits to use.} \item{\dots}{potential further arguments passed to methods, notably \code{\link{print}}.} \item{xlist}{a \code{\link{list}} of integer vectors with entries typically in \code{0:(base-1)}, such as resulting from \code{digitsBase()}.} } \value{ For \code{digitsBase()}, an object, say \code{m}, of class \code{"basedInt"} which is basically a (\code{ndigits} x \code{n}) \code{\link{matrix}} where \code{m[,i]} corresponds to \code{x[i]}, \code{n <- length(x)} and \code{attr(m,"base")} is the input \code{base}. \code{as.intBase()} and the \code{\link{as.integer}} method for \code{basedInt} objects return an \code{\link{integer}} vector. \cr \code{bi2int()} is the low-level workhorse of \code{as.intBase()}. } \note{Some of these functions existed under names \code{digits} and \code{digits.v} in previous versions of the \pkg{sfsmisc} package. } \author{Martin Maechler, Dec 4, 1991 (for S-plus; then called \code{digits.v}).} \examples{ digitsBase(0:12, 8) #-- octal representation empty.dimnames(digitsBase(0:33, 2)) # binary ## This may be handy for just one number (and default decimal): digits <- function(n, base = 10) as.vector(digitsBase(n, base = base)) digits(128982734) # 1 2 8 9 8 2 7 3 4 digits(128, base = 8) # 2 0 0 ## one way of pretty printing (base <= 10!) b2ch <- function(db) noquote(gsub("^0+(.{1,})$"," \\\\1", % \\\\ |--> \\ in example R core apply(db, 2, paste, collapse = ""))) b2ch(digitsBase(0:33, 2)) #-> 0 1 10 11 100 101 ... 100001 b2ch(digitsBase(0:33, 4)) #-> 0 1 2 3 10 11 12 13 20 ... 200 201 ## Hexadecimal: i <- c(1:20, 100:106) M <- digitsBase(i, 16) hexdig <- c(0:9, LETTERS[1:6]) cM <- hexdig[1 + M]; dim(cM) <- dim(M) b2ch(cM) #-> 1 2 3 4 5 6 7 8 9 A B C D E F 10 11 ... 6A ## IP (Internet Protocol) numbers coding: ... <--> longinteger ip_ntoa <- function(n) apply(digitsBase(n, base = 256), 2, paste, collapse=".") ip_ntoa(2130706430 + (0:9))# "126.255.255.254" ... "127.0.0.7" ## and the inverse: ip_aton <- function(a) bi2int(lapply(strsplit(a, ".", fixed=TRUE), as.integer), 256) n <- 2130706430 + (0:9) head(ip <- ip_ntoa(n)) head(ip_aton(ip)) stopifnot( n == ip_aton(ip_ntoa(n )), ip == ip_ntoa(ip_aton(ip))) ## Inverse of digitsBase() : as.integer method for the "basedInt" class as.integer(M) ## or also as.intBase() working from strings: (cb <- apply(digitsBase(0:33, 4), 2, paste, collapse = "")) ##-> "000" "001" ..... "200" "201" all(0:33 == as.intBase(cb, base = 4)) } \keyword{arith} \keyword{utilities} sfsmisc/man/prt.DEBUG.Rd0000644000176200001440000000170712650406472014430 0ustar liggesusers\name{prt.DEBUG} \alias{prt.DEBUG} \title{Utility Printing in DEBUG mode} \description{ This is \bold{defunct} now: The global \code{DEBUG} has been a cheap precursor to \R's \code{\link{options}(verbose= .)} (or a \code{verbose} function argument). This function prints out its arguments as \code{\link{cat}()} does, additionally printing the name of function in which it's been called --- only when a global variable \code{DEBUG} exists and is \code{\link{TRUE}}.\cr } \usage{ prt.DEBUG(\dots, LEVEL = 1) } \arguments{ \item{\dots}{arguments to be passed to \code{\link{cat}(\dots)} for printing.} \item{LEVEL}{integer (or logical) indicating a debugging level for printing.} } \author{Martin Maechler, originally for S-PLUS.} %% \note{This is mainly kept for historical reasons (and old code %% fragments), but sometimes I still consider renaming it and have it %% work using \code{getOption("verbose")} alone. %% } \keyword{debugging} sfsmisc/man/paste.vec.Rd0000644000176200001440000000114310000531517014642 0ustar liggesusers\name{paste.vec} \alias{paste.vec} \title{Utility for 'Showing' S vectors} \description{ A simple utility for displaying simple S vectors; can be used as debugging utility. } \usage{ paste.vec(name, digits = options()$digits) } \arguments{ \item{name}{string with an variable name which must exist in the current environment (\R session).} \item{digits}{how many decimal digits to be used; passed to \code{\link{format}}.} } \value{ a string of the form "NAME = x1 x2 ..." } \author{Martin Maechler, about 1992.} \examples{ x <- 1:4 paste.vec(x) ##-> "x = 1 2 3 4" } \keyword{utilities} sfsmisc/man/unif.Rd0000644000176200001440000000171211131753061013723 0ustar liggesusers\name{unif} \alias{unif} \title{Nice Uniform Points in Interval} \description{ Give regularly spaced points on interval \eqn{[-c,c]} with mean 0 (exactly) and variance about 1 (very close for \bold{even} \code{n} and larger \code{round.dig}). Note that \eqn{c} depends on \code{n}. } \usage{ unif(n, round.dig = 1 + trunc(log10(n))) } \arguments{ \item{n}{positive integer specifying the number of points desired.} \item{round.dig}{integer indicating to how many digits the result is rounded.} } \value{ numeric vector of length \code{n}, symmetric around 0, hence with exact mean \code{0}, and variance approximately 1. } \note{It relies on the fact that \eqn{Var(1,2,...,n) = n(n+1)/12}. } \author{Martin Maechler, ca 1990} \seealso{\code{\link{runif}} for producing uniform \emph{random} numbers.} \examples{ (u <- unif(8)) var(u) (u. <- unif(8, 12))# more digits in result, hence precision for Var : var(u.) } \keyword{arith} \keyword{utilities} sfsmisc/man/u.boxplot.x.Rd0000644000176200001440000000141412575757743015211 0ustar liggesusers\name{u.boxplot.x} \alias{u.boxplot.x} \title{Utility Returning x-Coordinates of Boxplot} \description{ Return the x-coordinates in an \sQuote{n-way} side-by-side boxplot. This is an auxiliary function and exists mainly for backcompatibility with S-plus. } \usage{ u.boxplot.x(n, j = 1:n, fullrange = 100) } \arguments{ \item{n}{number of boxplots.} \item{j}{indices of boxplots.} \item{fullrange}{x-coords as 'uniform' in \eqn{[0,fullrange]}; (f.=100, corresponds to Splus 3.x (x = 1,2)).} } \value{ a numeric vector of length \code{n}, with values inside \eqn{(0,M)} where \eqn{M = } \code{fullrange}. } \author{Martin Maechler} \seealso{\code{\link{boxplot}}.} \examples{ u.boxplot.x(7) # == 8.93 22.62 36.3 ... 91.07 } \keyword{dplot} \keyword{utilities} sfsmisc/man/tapplySimpl.Rd0000644000176200001440000000325210000536320015270 0ustar liggesusers\name{tapplySimpl} \alias{tapplySimpl} \title{More simplification in tapply() result} \description{ For the case of more than two categories or indices (in \code{INDEX}), traditional \code{\link{tapply}(*, simplify = TRUE)} still returns a list when an array may seem more useful and natural. This is provided by \code{tapplySimpl()} if the function \code{FUN()} is defined such as to return a vector of the same length in all cases. } \usage{ tapplySimpl(X, INDEX, FUN, \dots) } \arguments{ \item{X}{an atomic object, typically a vector. All these arguments are as in \code{\link{tapply}()} and are passed to \code{tapply(..)}.} \item{INDEX}{list of (typically more than one) factors, each of same length as \code{X}.} \item{FUN}{the function to be applied. For the result to be simplifiable, \code{FUN()} must return a vector of always the same length.} \item{\dots}{optional arguments to \code{FUN}.} } \value{ If the above conditions are satisfied, the list returned from \code{r <- tapply(X, INDEX, FUN, \dots)} is simplified into an \code{\link{array}} of rank \eqn{1 + \#\{indices\}}, i.e., \code{1+length(INDEX)}; otherwise, \code{tapplySimpl()} returns the list \code{r}, i.e., the same as \code{tapply()}. } \author{Martin Maechler, 14 Jun 1993 (for S-plus).} \seealso{\code{\link{tapply}(*, simplify=TRUE)}.} \examples{ ## Using tapply() would give a list (with dim() of a matrix); ## here we get 3-array: data(esoph) with(esoph, { mima <<- tapplySimpl(ncases/ncontrols, list(agegp, alcgp), range) stopifnot(dim(mima) == c(2, nlevels(agegp), nlevels(alcgp))) }) aperm(mima) } \keyword{iteration} \keyword{category} sfsmisc/man/shortRversion.Rd0000644000176200001440000000355314022125541015654 0ustar liggesusers\name{shortRversion} \alias{shortRversion} \title{Short R Version String} \description{ From \pkg{base} \R's \code{\link{R.version.string}}, produce a somewhat shorter version, with or without date, notably also for \emph{patched} or \emph{devel}opment versions of \R. Main use is for plotting or construction of file of variable names. } \usage{ shortRversion(Rv = R.version, Rst = Rv$status, Rvstring = if (!is.null(s <- Rv$version.string)) s else R.version.string, date = Rst != "", spaces = TRUE) } \arguments{ \item{Rv}{a \code{\link{list}} with some of the same components as \code{\link{R.version}}.} \item{Rst}{a string specifying the \emph{status} of \R's version. For released versions of \R, this is \code{""}; almost always use the default \code{Rv$status}.} \item{Rvstring}{a string with a default that should work even for \R versions previous to 1.0.0.} \item{date}{logical specifying if the date of the \R version should be included in the result; by default, this will be true only for non-released versions of \R.} \item{spaces}{logical indicating if the result may contain spaces (aka \sQuote{blanks}); setting it to false, replaces the blanks by \code{"-"} and \code{"_"}.} } \value{ a \code{\link{character}} string, typically a shortened version of \code{Rvstring}. } \author{Martin Maechler} \seealso{ \code{\link{R.version}}, \code{\link{R.version.string}} } \examples{ shortRversion() ## (including the date, typically for an R Core developer) ## but this is shorter: (Rver <- shortRversion(date=FALSE)) shortRversion(spaces=FALSE)# e.g. for a file of even directory name shortRversion(spaces=FALSE, date=FALSE)# even shorter, ditto ## If you want even shorter { abbreviate() will remove spaces, too }: abbreviate(shortRversion(), 11) abbreviate(shortRversion(date=FALSE), 13) } \keyword{utilities} sfsmisc/man/xy.unique.x.Rd0000644000176200001440000000234012652714140015177 0ustar liggesusers\name{xy.unique.x} \alias{xy.unique.x} \title{Uniqify (X,Y) Values using Weights} \description{ Given \emph{smoother} data \eqn{(x_i, y_i)} and maybe weights \eqn{w_i}, with multiple \eqn{x_i}, use the unique x values, replacing the \eqn{y}'s by their (weighted) mean and updating the weights accordingly. } \usage{ xy.unique.x(x, y, w, fun.mean = mean, \dots) } \arguments{ \item{x,y}{numeric vectors of same length. Alternatively, \code{x} can be a \sQuote{xy} like structure, see \code{\link{xy.coords}}.} \item{w}{numeric vector of non-negative weights -- or missing which corresponds to all weights equal.} \item{fun.mean}{the mean \code{\link{function}} to use.} \item{\dots}{optional arguments all passed to \code{\link{unique}}.} } \value{ Numeric matrix with three columns, named \code{x}, \code{y} and \code{w} with unique \code{x} values and corresponding \code{y} and weights \code{w}. } \author{Martin Maechler, 8 Mar 1993.} \seealso{e.g., \code{\link{smooth.spline}} uses something like this internally.} \examples{ ## simple example: x <- c(1,1,2,4,3,1) y <- 1:6 rbind(x, y) xy.unique.x(x, y) # x y w # 1 1 3 3 # 2 2 3 1 # 3 4 4 1 # 4 3 5 1 xy.unique.x(x, y, fromLast = TRUE) } \keyword{utilities} sfsmisc/man/capture-n-write.Rd0000644000176200001440000000321012572463212016011 0ustar liggesusers\name{capture.and.write} \alias{capture.and.write} \title{Capture output and Write / Print First and Last Parts} \description{ Capture output and print first and last parts, eliding middle parts. Particularly useful for teaching purposes, and, e.g., in Sweave (\code{\link{RweaveLatex}}). By default, when \code{middle = NA}, \code{capture.output(EXPR, first, last)} basically does \preformatted{ co <- capture.output(EXPR) writeLines(head(co, first)) cat( ... dotdots ...) writeLines(tail(co, last)) } } \usage{ capture.and.write(EXPR, first, last = 2, middle = NA, i.middle, dotdots = " ....... ", n.dots = 2) } \arguments{ \item{EXPR}{the (literal) expression the output of which is to be captured.} \item{first}{integer: how many lines should be printed at beginning.} \item{last}{integer: how many lines should be printed at the end.} \item{middle}{numeric (or NA logical):} \item{i.middle}{index start of middle part} \item{dotdots}{string to be used for elided lines} \item{n.dots}{number of \code{dotdots} lines added between parts.} } \value{ return value of \code{\link{capture.output}(EXPR)}. } \seealso{ \code{\link{head}}, \code{\link{tail}} } \author{Martin Maechler, ETH Zurich} \examples{ x <- seq(0, 10, by = .1) ## for matrix, dataframe, .. first lines include a header line: capture.and.write( cbind(x, log1p(exp(x))), first = 5) ## first, *middle* and last : capture.and.write( cbind(x, x^2, x^3), first = 4, middle = 3, n.dots= 1) } %% some of MM's own "real use" examples: %% ~/R/Meetings-Kurse-etc/2012-Rmpfr-ZurichR/BinCoef.Rnw %% ~/R/MM/NUMERICS/log1exp/log1exp-note.Rnw sfsmisc/man/unix/0000755000176200001440000000000013651517477013477 5ustar liggesuserssfsmisc/man/unix/Sys.cpuinfo.Rd0000644000176200001440000000547412270253771016206 0ustar liggesusers\name{Sys.cpuinfo} \alias{Sys.procinfo} \alias{Sys.cpuinfo} \alias{Sys.meminfo} \alias{Sys.memGB} \alias{Sys.MIPS} \title{Provide Information about the Linux Hardware (CPU, Memory, etc)} \description{ Return information about the Linux hardware, notably the CPU (the central processor unit) and memory of the computer \R is running on. This is currently \bold{only available for Linux}. These functions exist on other unix-alike platforms, but produce an error when called. } \usage{ Sys.procinfo(procfile) Sys.cpuinfo() Sys.meminfo() Sys.memGB(kind = "MemTotal") Sys.MIPS() } \arguments{ \item{procfile}{name of file the lines of which give the CPU info ``as on Linux''} \item{kind}{a \code{\link{character}} string specifying which \emph{kind} of memory is desired.} } \value{ The \code{Sys.*info()} functions return a \code{"simple.list"}, here basically a named character vector, (where the names have been filtered through \code{\link{make.names}(*, unique=TRUE)} which is of importance for multi-processor or multi-core CPUs, such that vector can easily be indexed. \code{Sys.memGB()} returns available memory in giga bytes [GB];\cr \code{Sys.MIPS()} returns a number giving an approximation of the \bold{M}illion \bold{I}instructions \bold{P}er \bold{S}econd that the CPU processes (using \dQuote{bogomips}). This is a performance measure of the basic \emph{non-numeric} processing capabilities. For single-core Linux systems, often about twice the basic clock rate in ``MHz'' (as available by \code{Sys.cpuinfo()["cpu.MHz"]}); now, with multicore systems, the result is often around (but smaller than) \code{2 * #\{cores\} * clock.rate}. } \author{Martin Maechler} \note{These currently do rely on the Linux \file{/proc/} file system, and may not easily be portable to non-Linux environments. On multi-processor machines, \code{Sys.cpuinfo()} contains each field for each processor (i.e., \code{names(Sys.cpuinfo())} has \code{\link{duplicated}} entries). Conceivably, the bogoMIPS source code is open and available and could be built into \R. } \seealso{\code{\link{Sys.ps}}, etc.} \examples{ (n.cores <- parallel::detectCores()) if(substr(R.version[["os"]], 1,5) == "linux") { ##-- only on Linux Sys.cpuinfo() # which is often ugly; this looks much better: length(Sys.cpu2 <- local({I <- Sys.cpuinfo(); I[ !grepl("^flags", names(I)) ] })) ## may still be too much, notably if n.cores > 2: (Sys3 <- Sys.cpu2[!grepl("[.][0-9]+$", names(Sys.cpu2))]) Sys.MIPS() ## just the 'bogomips' from above: Sys.MIPS() / as.numeric(Sys.cpuinfo()["cpu.MHz"]) ## ~~ 2 * #{cores} ((no longer)) ## Available Memory -- can be crucial: Sys.memGB() #- default "MemTotal" if(Sys.memGB("MemFree") > 16) message("Be happy! You have more than 16 Gigabytes of free memory") } } \keyword{utilities} sfsmisc/man/unix/Sys.ps.Rd0000644000176200001440000004451412562441251015157 0ustar liggesusers\name{Sys.ps} \title{Return Process Status (Unix 'ps') Information} \alias{Sys.ps} %\alias{Sys.ps.cmd}-> now in ../u.sys.Rd \alias{Sys.sizes} \description{ These functions return process id and status information, typically about the running \R process. } \usage{ Sys.ps(process= Sys.getpid(), fields = c("pid", "pcpu", "time", "vsz", "comm"), usefile = length(fields) > 10, ps.cmd = Sys.ps.cmd(), verbose = getOption("verbose"), warn.multi = verbose || any(fields != "ALL")) Sys.sizes(process = Sys.getpid(), ps.cmd = Sys.ps.cmd()) } \arguments{ \item{process}{the process id, an integer.} \item{fields}{character strings of \code{"ALL"}, specifying which process status fields are desired.} \item{usefile}{logical; if true, \code{\link{system}} writes to a temporary file and that is \code{\link{scan}}ed subsequently.} \item{ps.cmd}{character string, giving the ``ps'' command name to be used.} \item{verbose}{logical ...} \item{warn.multi}{logical ...} } \details{ Use \code{man ps} on your respective Unix system, to see what fields are supported exactly. Unix dialects \emph{do} differ here, and, SunOS-Solaris even has more than one ps command\dots %%---- Solaris 2.5.1 man ps has : %% DISPLAY FORMATS %% Under the -f option, ps tries to determine the command name %% and arguments given when the process was created by examin- %% ing the user block. Failing this, the command name is %% printed, as it would have appeared without the -f option, in %% square brackets. %% %% The column headings and the meaning of the columns in a ps %% listing are given below; the letters f and l indicate the %% option (full or long, respectively) that causes the %% corresponding heading to appear; all means that the heading %% always appears. Note: These two options determine only %% what information is provided for a process; they do not %% determine which processes will be listed. %% %% F (l) Flags (hexadecimal and additive) associ- %% ated with the process. These flags are %% available for historical purposes; no %% meaning should be currently ascribed to %% them. %% %% S (l) The state of the process: %% %% O Process is running on a processor. %% S Sleeping: process is waiting for an %% event to complete. %% R Runnable: process is on run queue. %% Z Zombie state: process terminated %% and parent not waiting. %% T Process is stopped, either by a job %% control signal or because it is %% being traced. %% %% UID (f,l) The effective user ID number of the pro- %% cess (the login name is printed under %% the -f option). %% %% PID (all) The process ID of the process (this %% datum is necessary in order to kill a %% process). %% %% PPID (f,l) The process ID of the parent process. %% %% C (f,l) Processor utilization for scheduling %% (obsolete). Not printed when the -c %% option is used. %% %% CLS (f,l) Scheduling class. Printed only when the %% -c option is used. %% %% PRI (l) The priority of the process. Without %% the -c option, higher numbers mean lower %% priority. With the -c option, higher %% numbers mean higher priority. %% %% NI (l) Nice value, used in priority computa- %% tion. Not printed when the -c option is %% used. Only processes in the certain %% scheduling classes have a nice value. %% %% ADDR (l) The memory address of the process. %% %% SZ (l) The size (in pages) of the swappable %% process's image in main memory. %% %% WCHAN (l) The address of an event for which the %% process is sleeping (if blank, the pro- %% cess is running). %% %% STIME (f) The starting time of the process, given %% in hours, minutes, and seconds. (A pro- %% cess begun more than twenty-four hours %% before the ps inquiry is executed is %% given in months and days.) %% %% TTY (all) The controlling terminal for the process %% (the message, ?, is printed when there %% is no controlling terminal). %% %% TIME (all) The cumulative execution time for the %% process. %% %% CMD (all) The command name (the full command name %% and its arguments, up to a limit of 80 %% characters, are printed under the -f %% option). %% %% The following two additional columns are printed when the -j %% option is specified: %% %% PGID The process ID of the process group %% leader. %% %% SID The process ID of the session leader. %% %% A process that has exited and has a parent, but has not yet %% been waited for by the parent, is marked . %% %% -o format %% The -o option allows the output format to be specified under %% user control. %% %% The format specification must be a list of names presented %% as a single argument, blank- or comma-separated. Each vari- %% able has a default header. The default header can be over- %% ridden by appending an equals sign and the new text of the %% header. The rest of the characters in the argument will be %% used as the header text. The fields specified will be writ- %% ten in the order specified on the command line, and should %% be arranged in columns in the output. The field widths will %% be selected by the system to be at least as wide as the %% header text (default or overridden value). If the header %% text is null, such as -o user=, the field width will be at %% least as wide as the default header text. If all header %% text fields are null, no header line will be written. %% %% The following names are recognized in the POSIX locale: %% %% user The effective user ID of the process. This will %% be the textual user ID, if it can be obtained %% and the field width permits, or a decimal %% representation otherwise. %% %% ruser The real user ID of the process. This will be %% the textual user ID, if it can be obtained and %% the field width permits, or a decimal represen- %% tation otherwise. %% %% group The effective group ID of the process. This %% will be the textual group ID, if it can be %% obtained and the field width permits, or a %% decimal representation otherwise. %% %% rgroup The real group ID of the process. This will be %% the textual group ID, if it can be obtained and %% the field width permits, or a decimal represen- %% tation otherwise. %% %% pid The decimal value of the process ID. %% %% ppid The decimal value of the parent process ID. %% %% pgid The decimal value of the process group ID. %% %% pcpu The ratio of CPU time used recently to CPU time %% available in the same period, expressed as a %% percentage. The meaning of ``recently'' in this %% context is unspecified. The CPU time available %% is determined in an unspecified manner. %% %% vsz The size of the process in (virtual) memory in %% kilobytes as a decimal integer. %% %% nice The decimal value of the system scheduling %% %% priority of the process. See nice(1). %% %% etime In the POSIX locale, the elapsed time since the %% process was started, in the form: %% [[dd-]hh:]mm:ss %% %% where %% %% dd will represent the number of days, %% hh the number of hours, %% mm the number of minutes, and %% ss the number of seconds. %% %% The dd field will be a decimal integer. The hh, %% mm and ss fields will be two-digit decimal %% integers padded on the left with zeros. %% %% time In the POSIX locale, the cumulative CPU time of %% the process in the form: %% [dd-]hh:mm:ss %% %% The dd, hh, mm, and ss fields will be as %% described in the etime specifier. %% %% tty The name of the controlling terminal of the pro- %% cess (if any) in the same format used by the %% who(1) command. %% %% comm The name of the command being executed (argv[0] %% value) as a string. %% %% args The command with all its arguments as a string. %% The implementation may truncate this value to %% the field width; it is implementation-dependent %% whether any further truncation occurs. It is %% unspecified whether the string represented is a %% version of the argument list as it was passed to %% the command when it started, or is a version of %% the arguments as they may have been modified by %% the application. Applications cannot depend on %% being able to modify their argument list and %% having that modification be reflected in the %% output of ps. The Solaris implementation limits %% the string to 80 bytes; the string is the ver- %% sion of the argument list as it was passed to %% the command when it started. %% %% The following names are recognized in the Solaris implemen- %% tation: %% %% f Flags (hexadecimal and additive) associated with %% the process. %% %% s The state of the process. %% %% c Processor utilization for scheduling (obsolete). %% %% uid The effective user ID number of the process as a %% decimal integer. %% %% ruid The real user ID number of the process as a %% decimal integer. %% %% gid The effective group ID number of the process as %% a decimal integer. %% %% rgid The real group ID number of the process as a %% decimal integer. %% %% sid The process ID of the session leader. %% %% class The scheduling class of the process. %% %% pri The priority of the process. Higher numbers %% mean higher priority. %% %% opri The obsolete priority of the process. Lower %% numbers mean higher priority. %% %% addr The memory address of the process. %% %% osz The size (in pages) of the swappable process's %% image in main memory. %% %% wchan The address of an event for which the process is %% sleeping (if -, the process is running). %% %% stime The starting time or date of the process, %% printed with no blanks. %% %% rss The resident set size of the process, in kilo- %% bytes as a decimal integer. %% %% pmem The ratio of the process's resident set size to %% the physical memory on the machine, expressed as %% a percentage. %% %% fname The first 8 bytes of the base name of the %% process's executable file. %% %% Only comm and args are allowed to contain blank characters; %% all others, including the Solaris implementation variables, %% are not. %% %% The following table specifies the default header to be used %% in the POSIX locale corresponding to each format specifier. %% %% _______________________________________________________________________ %% | Format Specifier Default Header| Format Specifier Default Header| %% |__________________________________|___________________________________| %% | args COMMAND | ppid PPID | %% | comm COMMAND | rgroup RGROUP | %% | etime ELAPSED | ruser RUSER | %% | group GROUP | time TIME | %% | nice NI | tty TT | %% | pcpu %CPU | user USER | %% | pgid PGID | vsz VSZ | %% | pid PID | | %% |__________________________________|___________________________________| %% %% The following table lists the Solaris implementation format %% specifiers and the default header used with each. %% %% _______________________________________________________________________ %% | Format Specifier Default Header| Format Specifier Default Header| %% |__________________________________|___________________________________| %% | addr ADDR | pri PRI | %% | c C | rgid RGID | %% | class CLS | rss RSS | %% | f F | ruid RUID | %% | fname COMMAND | s S | %% | gid GID | sid SID | %% | opri PRI | stime STIME | %% | osz SZ | uid UID | %% | pmem %MEM | wchan WCHAN | %% |__________________________________|___________________________________| %% %%--- Linux man ps has : %% STANDARD FORMAT SPECIFIERS %% These may be used to control both output format and sorting. %% For example: %% ps -eo pid,user,args --sort user %% %% CODE HEADER %% ---- --------- %% %cpu %CPU %% %mem %MEM %% alarm ALARM %% args COMMAND %% blocked BLOCKED %% bsdstart START %% bsdtime TIME %% c C %% caught CAUGHT %% cmd CMD %% comm COMMAND %% command COMMAND %% cputime TIME %% drs DRS %% dsiz DSIZ %% egid EGID %% egroup EGROUP %% eip EIP %% esp ESP %% etime ELAPSED %% euid EUID %% euser EUSER %% f F %% fgid FGID %% fgroup FGROUP %% flag F %% flags F %% fname COMMAND %% fsgid FSGID %% fsgroup FSGROUP %% fsuid FSUID %% fsuser FSUSER %% fuid FUID %% fuser FUSER %% gid GID %% group GROUP %% ignored IGNORED %% intpri PRI %% lim LIM %% longtname TTY %% lstart STARTED %% m_drs DRS %% m_trs TRS %% maj_flt MAJFL %% majflt MAJFLT %% min_flt MINFL %% minflt MINFLT %% ni NI %% nice NI %% nwchan WCHAN %% opri PRI %% pagein PAGEIN %% pcpu %CPU %% pending PENDING %% pgid PGID %% pgrp PGRP %% pid PID %% pmem %MEM %% ppid PPID %% pri PRI %% rgid RGID %% rgroup RGROUP %% rss RSS %% rssize RSS %% rsz RSZ %% ruid RUID %% ruser RUSER %% s S %% sess SESS %% session SESS %% sgi_p P %% sgi_rss RSS %% sgid SGID %% sgroup SGROUP %% sid SID %% sig PENDING %% sig_block BLOCKED %% sig_catch CATCHED %% sig_ignore IGNORED %% sig_pend SIGNAL %% sigcatch CAUGHT %% sigignore IGNORED %% sigmask BLOCKED %% stackp STACKP %% start STARTED %% start_stack STACKP %% start_time START %% stat STAT %% state S %% stime STIME %% suid SUID %% suser SUSER %% svgid SVGID %% svgroup SVGROUP %% svuid SVUID %% svuser SVUSER %% sz SZ %% time TIME %% timeout TMOUT %% tmout TMOUT %% tname TTY %% tpgid TPGID %% trs TRS %% trss TRSS %% tsiz TSIZ %% tt TT %% tty TT %% tty4 TTY %% tty8 TTY %% ucomm COMMAND %% uid UID %% uid_hack UID %% uname USER %% user USER %% vsize VSZ %% vsz VSZ %% wchan WCHAN %%------------------------------------ %% } \value{ Note, that \code{Sys.sizes()} currently returns two integers which are ``common'' to Solaris and Linux. } \author{Martin Maechler} \seealso{\code{\link{Sys.info}}, \code{\link{Sys.getpid}}, \code{\link{proc.time}}. } \examples{ (.pid <- Sys.getpid()) ## process ID of current process Sys.sizes(.pid) ## The default process statistics about the running R process try( Sys.ps() ) } \keyword{utilities} sfsmisc/man/unix/pkgLibs.Rd0000644000176200001440000000465213642127223015352 0ustar liggesusers\name{pkgLibs} \alias{pkgLibs} \title{R Package Compiled Code Library Dependencies (on Unix-alikes)} \description{ List some system level information about the compiled code library, typically its dependencies, for \R packages with compiled code; for Unix-alikes or more generally when \code{cmd} is installed locally. } \usage{ pkgLibs(pkg, cmd = if(Sys.info()[["sysname"]] == "Darwin") "otool -L" else "ldd") } \arguments{ \item{pkg}{\code{\link{character}} vector of package names of \emph{installed} \R packages.} \item{cmd}{a \code{character} string with the name of an OS / system level program (to be called via \code{\link{system}(cmd, ..)}) which gives information about the shared library (of compiled code), also known as \dQuote{DLL} (dynamically loadable library) or \dQuote{so} ((dynamic) shared object) library. The default, \command{"ldd"} is a standard binary utility on Unix-alike platforms such as Linux. On macOS, \command{"oTool -L"} is used by default.} } \details{ Note that there seems some language confusion as \dQuote{DLL} on Windows is \emph{also} used for \dQuote{Dynamic-link Library} and Wikipedia warns about confusing the two concepts (\dQuote{dynamically loaded ..} vs \dQuote{dynamic-link ..}). } \value{ a named \code{\link{list}} with one entry per package in \code{pkg}, the \code{\link{names}} being the directory / folder names of the corresponding pkgs from \code{pkg}. The exact structure of such entries is currently subject to change and you should not rely on its exact format for now. } \references{ \sQuote{Dynamic Loading} on Wikipedia, \url{https://en.wikipedia.org/wiki/Dynamic_loading} On Windows, \dQuote{DLL} is also used for Dynamic-link library, \url{https://en.wikipedia.org/wiki/Dynamic-link_library}. \command{man ldd} from a terminal on a valid OS. } \author{Martin Maechler} \seealso{ \code{\link{dyn.load}()}, \code{\link{library.dynam}()}, and \code{\link{getLoadedDLLs}()}. Also, \code{\link{.C}}, \code{\link{.Call}} which use such DLLs. } \examples{ # for the example only using standard R packages : myPkgs <- c("stats", "MASS", "rpart", "Matrix") pl <- pkgLibs(myPkgs) pl stopifnot(exprs = { is.list(pl) length(pl) == length(myPkgs) is.character(pkgD <- names(pl)) }) ## Have seen this failing when a strange development version of "Matrix" was picked up: try( stopifnot( dir.exists(pkgD)) ) } \keyword{interface} sfsmisc/man/pkgDesc.Rd0000644000176200001440000000376414011167007014352 0ustar liggesusers\name{pkgDesc} \title{Version of packageDescription() as Simple Vector} \alias{pkgDesc} \alias{pkgBuilt} \description{ a simple \dQuote{version}, or wrapper for \code{\link{packageDescription}()}, returning a named character vector, including \code{"file"}, and still has a useful \code{\link{print}()} method. } \usage{ pkgDesc (pkg, lib.loc = NULL, fields = NULL, ...) pkgBuilt(pkg, lib.loc = NULL, ...) } \arguments{ \item{pkg}{a \code{\link{character}} string, name of an installed \R package.} \item{lib.loc}{library location to find the package in; the default \code{NULL} uses the full \code{\link{.libPaths}()}.} \item{fields}{a character vector (or \code{NULL}) specifying fields to be returned.} \item{...}{further optional arguments passed to \code{\link{packageDescription}()}.} } \value{ a named \code{\link{character}} vector, with \code{\link{names}}, the \emph{fields}, identical to the names of the \code{\link{list}} returned by \code{\link{packageDescription}}, plus its \code{"file"} attribute. Additionally the resulting vector is of class \code{"Dlist"} which activates a useful \code{\link{print}()} method. } \author{Martin Maechler, Jan. 2021} \note{The \code{file} is always returned; not the least that the author wants to see it quite often as his \code{\link{.libPaths}()} is non-trivial and typically longer than 4 entries. } \seealso{ \code{\link{packageDescription}}, \code{\link{.libPaths}}. } \examples{ str(pd <- pkgDesc("sfsmisc")) pd[c("Date","Packaged", "Built","file")] pkgBuilt("sfsmisc") ## Show "Built" (and "file") for all packages whose namespaces are loaded: lNs <- loadedNamespaces() mlNs <- sapply(lNs, pkgBuilt) t(mlNs) # typically prints nicely pkgs <- c("grid", "lattice", "MASS", "Matrix", "nlme", "lme4", "sfsmisc") pkgs <- c("foobar", "barbar", pkgs, "kitty") # + names that typically don't exist pkgsOk <- basename(find.package(pkgs, quiet=TRUE)) mpkg <- sapply(pkgsOk, pkgBuilt) stopifnot(is.matrix(mpkg), nrow(mpkg) == 2) mpkg["Built",] } sfsmisc/man/str_data.Rd0000644000176200001440000000315012623620111014555 0ustar liggesusers\name{str_data} \alias{str_data} \title{Overview on All Datasets in an R Package} \description{ Provide an overview over all datasets available by \code{\link{data}()} in a (list of) given \R packages. } \usage{ str_data(pkgs, filterFUN, \dots) } \arguments{ \item{pkgs}{character vector of names of \R packages.} \item{filterFUN}{optionally a \code{\link{logical}} \code{\link{function}} for filtering the \R objects.} \item{\dots}{potentical further arguments to be passed to \code{\link{str}}; \code{str(utils:::str.default)} gives useful list.} } \value{ invisibly (see \code{\link{invisible}}) a \code{\link{list}} with named components matching the \code{pkgs} argument. Each of these components is a named list with one entry per \code{data(.)} argument name. Each entry is a \code{\link{character}} vector of the names of all objects, typically only one. The side effect is, as with \code{\link{str}()}, to print everything (via \code{\link{cat}}) to the console. } \author{Martin Maechler} \seealso{\code{\link[utils]{str}}, \code{\link[utils]{data}}. } \examples{ str_data("cluster") str_data("datasets", max=0, give.attr = FALSE) ## Filtering (and return value) dfl <- str_data("datasets", filterFUN=is.data.frame) str(df.d <- dfl$datasets) ## dim() of all those data frames: t(sapply(unlist(df.d), function(.) dim(get(.)))) ### Data sets in all attached packages but "datasets" (and stubs): s <- search() (Apkgs <- sub("^package:", '', s[grep("^package:", s)])) str_data(Apkgs[!Apkgs \%in\% c("datasets", "stats", "base")]) } \keyword{datasets} \keyword{utilities} \keyword{documentation} sfsmisc/man/posdefify.Rd0000644000176200001440000000645214032027146014761 0ustar liggesusers\name{posdefify} \alias{posdefify} \title{Find a Close Positive Definite Matrix} \description{ From a matrix \code{m}, construct a \emph{"close"} positive definite one. } \usage{ posdefify(m, method = c("someEVadd", "allEVadd"), symmetric = TRUE, eigen.m = eigen(m, symmetric= symmetric), eps.ev = 1e-07) } \arguments{ \item{m}{a numeric (square) matrix.} \item{method}{a string specifying the method to apply; can be abbreviated.} \item{symmetric}{logical, simply passed to \code{\link{eigen}} (unless \code{eigen.m} is specified); currently, we do not see any reason for \emph{not} using \code{TRUE}.} \item{eigen.m}{the \code{\link{eigen}} value decomposition of \code{m}, can be specified in case it is already available.} \item{eps.ev}{number specifying the tolerance to use, see Details below.} } \details{ We form the eigen decomposition \deqn{m = V \Lambda V'}{m = V L V'} where \eqn{\Lambda}{L} is the diagonal matrix of eigenvalues, \eqn{\Lambda_{j,j} = \lambda_j}{L[j,j] = l[j]}, with \emph{decreasing} eigenvalues \eqn{\lambda_1 \ge \lambda_2 \ge \ldots \ge \lambda_n}{l[1] >= l[2] >= ... >= l[n]}. When the smallest eigenvalue \eqn{\lambda_n}{l[n]} are less than \code{Eps <- eps.ev * abs(lambda[1])}, i.e., negative or \dQuote{almost zero}, some or all eigenvalues are replaced by \emph{positive} (\code{>= Eps}) values, \eqn{\tilde\Lambda_{j,j} = \tilde\lambda_j}{L~[j,j] = l~[j]}. Then, \eqn{\tilde m = V \tilde\Lambda V'}{m~ = V L~ V'} is computed and rescaled in order to keep the original diagonal (where that is \code{>= Eps}). } \value{ a matrix of the same dimensions and the \dQuote{same} diagonal (i.e. \code{\link{diag}}) as \code{m} but with the property to be positive definite. } \author{Martin Maechler, July 2004} \note{As we found out, there are more sophisticated algorithms to solve this and related problems. See the references and the \code{\link[Matrix]{nearPD}()} function in the \CRANpkg{Matrix} package. We consider \code{nearPD()} to also be the successor of this package's \code{\link{nearcor}()}. } \references{ Section 4.4.2 of Gill, P.~E., Murray, W. and Wright, M.~H. (1981) \emph{Practical Optimization}, Academic Press. Cheng, Sheung Hun and Higham, Nick (1998) A Modified Cholesky Algorithm Based on a Symmetric Indefinite Factorization; \emph{SIAM J. Matrix Anal.\ Appl.}, \bold{19}, 1097--1110. Knol DL, ten Berge JMF (1989) Least-squares approximation of an improper correlation matrix by a proper one. \emph{Psychometrika} \bold{54}, 53--61. Highham (2002) Computing the nearest correlation matrix - a problem from finance; \emph{IMA Journal of Numerical Analysis} \bold{22}, 329--343. Lucas (2001) Computing nearest covariance and correlation matrices. A thesis submitted to the University of Manchester for the degree of Master of Science in the Faculty of Science and Engeneering. } \seealso{\code{\link{eigen}} on which the current methods rely. \code{\link[Matrix]{nearPD}()} in the \CRANpkg{Matrix} package. (Further, the deprecated \code{\link{nearcor}()} from this package.) } \examples{ set.seed(12) m <- matrix(round(rnorm(25),2), 5, 5); m <- 1+ m + t(m); diag(m) <- diag(m) + 4 m posdefify(m) 1000 * zapsmall(m - posdefify(m)) } \keyword{algebra} \keyword{array} sfsmisc/man/p.dnorm.Rd0000644000176200001440000000312507563236541014354 0ustar liggesusers\name{p.dnorm} \alias{p.dnorm} \alias{p.dchisq} \alias{p.dgamma} \title{Plot Parametric Density Functions} \description{ These are utilities for pretty plotting of often used parametric densities. } \usage{ p.dnorm (mu = 0, s = 1, h0.col = "light gray", ms.lines = TRUE, ms.col = "gray", ...) p.dchisq(nu, h0.col = "light gray", ...) p.dgamma(shape, h0.col = "light gray", ...) } \arguments{ \item{mu,s}{numbers, the mean and standard deviation of the normal distribution.} \item{nu}{positive number, the degrees of freedom \code{df} argument for the \eqn{\chi^2}{chi^2}-density function \code{\link{dchisq}}.} \item{shape}{number, the \code{shape} parameter for the Gamma distribution.} \item{h0.col}{color specification for the line \eqn{y = 0}.} \item{ms.lines}{logical, used for the normal only: should lines be drawn at the mean and \eqn{\pm}{+-} 1 standard deviation.} \item{ms.col}{color for the \code{ms} lines if \code{ms.lines} is TRUE.} \item{\dots}{further parameter passed to \code{\link{curve}()}, e.g., \code{add = TRUE} for adding to current plot.} } \author{Werner Stahel et al.} \seealso{the underlying density functions, \code{\link{dnorm}}, \code{\link{dchisq}}, \code{\link{dgamma}}.} \examples{ p.dnorm() p.dnorm(mu=1.5, add = TRUE, ms.lines = FALSE) # add to the plot above p.dchisq(2, main= "Chi^2 Densities -- nu = 2,3,4") p.dchisq(3, add = TRUE, col = "red") p.dchisq(4, add = TRUE, col = "blue") op <- par(mfrow = c(2,2), mgp = c(1.6, 0.6,0), mar = c(3,3,1,1)) for(sh in 1:4) p.dgamma(sh) par(op) } \keyword{hplot} \keyword{utilities} sfsmisc/man/p.res.2x.Rd0000644000176200001440000000715213246271653014360 0ustar liggesusers\name{p.res.2x} \title{Stahel's Residual Plot against 2 X's} \alias{p.res.2x} \alias{p.res.2x.default} \alias{p.res.2x.formula} \description{ Plot Residuals, e.g., of a multiple linear regression, against two (predictor) variables, using positively and negatively oriented line segments for positive and negative residuals. This is a (S3) \emph{generic} function with a \code{default} and a \code{\link{formula}} method. } \usage{ p.res.2x(x, \dots) \S3method{p.res.2x}{default}(x, y, z, restricted, size = 1, slwd = 1, scol = 2:3, xlab = NULL, ylab = NULL, main = NULL, xlim = range(x), ylim = range(y), \dots) \S3method{p.res.2x}{formula}(x = ~., data, main = deparse(substitute(data)), xlab = NULL, ylab = NULL, \dots) } \arguments{ \item{x, y}{numeric vectors of the same length specifying 2 covariates. For the \code{formula} method, \code{x} is a \code{\link{formula}}.} \item{z}{numeric vector of same length as \code{x} and \code{y}, typically residuals.} \item{restricted}{positive value which truncates the size. The corresponding symbols are marked by stars.} \item{size}{the symbols are scaled so that \code{size} is the size of the largest symbol in cm.} \item{slwd, scol}{line width and color(s) for the residual \code{\link{segments}}. If \code{scol} has length 2 as per default, the two colors are used for positive and negative \code{z} values, respectively.} \item{xlab, ylab, main}{axis labels, and title see \code{\link{title}}, each with a sensible default. To suppress, use, e.g., \code{main = ""}.} \item{xlim, ylim}{the basic x- and y- axis extents, see \code{\link{plot.default}}. Note that these will be slightly extended such that segments are not cut off.} \item{\dots}{further arguments passed to \code{plot}, or \code{p.res.2x.default()}, respectively.} \item{data}{(for the \code{\link{formula}} method:) a data frame or a fitted \code{"\link{lm}"} object.} } \details{ Each residual \code{zz[i]} is visualized as line segment centered at \eqn{(xx_i,yy_i)}{(xx[i], yy[i])}, \eqn{i=1,\dots,n}, where the \emph{length}s of the segments are proportional to the absolute values \eqn{\|zz_i\|}{|zz[i]|}. Positive residuals' line segments have slope \eqn{+1}, and negative ones slope \eqn{-1}, and \code{scol} is used to use different colors for negative and positive segments. The formula interface calls \code{\link{p.res.2fact}()} when \emph{both} \code{x} and \code{y} are \code{\link{factor}}s. } \references{ Stahel, W.~A. (2008) \emph{Statistische Datenanalyse: Eine \enc{Einführung für}{Einfuehrung fuer} Naturwissenschaftler}, 5. Auflage, Vieweg, Wiesbaden; Paragraph 13.8.r and 13.8.v. } \author{Andreas Ruckstuhl in June 1991 and Martin Maechler, in 1992, '94, 2003-4.} \seealso{\code{\link{p.res.2fact}}, \code{\link{plot.lm}}, \code{\link{TA.plot}}. } \examples{ xx <- rep(1:10,7) yy <- rep(1:7, rep(10,7)) zz <- rnorm(70) p.res.2x(xx,yy,zz, restricted = 2, main = "i.i.d. N(0,1) random residuals") \dontshow{ p.res.2x(xx,yy,zz, restricted = 2, main = "p.res.2x(*, xlim, ylim)", xlim = c(2,8), ylim = c(1,4)) } example(lm.influence, echo = FALSE) op <- mult.fig(2, marP=c(-1,-1,-1,0), main="p.res.2x(*,*, residuals(lm.SR))")$old.par with(LifeCycleSavings, { p.res.2x(pop15, ddpi, residuals(lm.SR), scol=c("red", "blue")) p.res.2x(pop75, dpi, residuals(lm.SR), scol=2:1) }) ## with formula interface: p.res.2x(~ pop15 + ddpi, lm.SR, scol=c("red", "blue")) p.res.2x(~ pop75 + dpi, lm.SR, scol=2:1) par(op) # revert par() settings above } \keyword{hplot} \keyword{regression} sfsmisc/man/sourceAttach.Rd0000644000176200001440000000225012177130423015407 0ustar liggesusers\name{sourceAttach} \alias{sourceAttach} \title{Source and Attach an R source file} \description{ Source (via \code{\link{sys.source}()}) and attach (\code{\link{attach}}) an \R source file. } \usage{ sourceAttach(file, pos=2, name = paste(abbreviate(gsub(fsep,"", dirname(file)), 12, method="both.sides"), basename(file), sep=fsep), keep.source = getOption("keep.source.pkgs"), warn.conflicts = TRUE) } \arguments{ \item{file}{file name} \item{pos}{passed to \code{\link{attach}()}} \item{name}{character, with a smart default, passed to \code{attach()}.} \item{keep.source}{logical, see \code{\link{sys.source}()}.} \item{warn.conflicts}{logical, see \code{\link{attach}}.} } \value{ the return value of \code{\link{attach}()}. } \author{Martin Maechler, 29 Jul 2011} \seealso{ \code{\link{attach}}, \code{\link{sys.source}}, \code{\link{source}} } \examples{ sourceAttach(system.file("test-tools-1.R", package="Matrix", mustWork=TRUE)) search() # shows the new "data base" at position 2 ## look what it contains: ls.str(pos = 2) } \keyword{file} \keyword{utilities} sfsmisc/man/u.date.Rd0000644000176200001440000000072712575757743014177 0ustar liggesusers\name{u.date} \alias{u.date} \title{Return Date[-Time] String in 'European' Format} \description{ Return one string of the form "day/month/year", plus "hour:minutes", optionally. } \usage{ u.date(short=FALSE) } \arguments{\item{short}{logical; if \code{TRUE}, no time is given.} } \value{String with current date (and time). } \author{Martin Maechler, ca. 1992} \seealso{\code{\link{u.Datumvonheute}}.} \examples{ u.date() u.date(short = TRUE) } \keyword{utilities} sfsmisc/man/wrapFormula.Rd0000644000176200001440000000320313246037205015262 0ustar liggesusers\name{wrapFormula} \alias{wrapFormula} \title{Enhance Formula by Wrapping each Term, e.g., by "s(.)"} \description{ The main motivation for this function has been the easy construction of a \dQuote{full GAM formula} from something as simple as \code{Y ~ .}. \cr The potential use is slightly more general. } \usage{ wrapFormula(f, data, wrapString = "s(*)") } \arguments{ \item{f}{the initial \code{\link{formula}}; typically something like \code{Y ~ .}.} \item{data}{\code{\link{data.frame}} to which the formula applies; see, \code{\link{formula}} or also \code{\link[mgcv]{gam}} or \code{\link{lm}}.} \item{wrapString}{\code{\link{character}} string, containing \code{"*"}, specifying the wrapping expression to use.} } \value{ a \code{\link{formula}} very similar to \code{f}; just replacing each \emph{additive} term by its wrapped version. } \note{ There are limits for this to work correctly; notably the right hand side of the formula \code{f} should not be nested or otherwise complicated, rather typically just \code{ . } as in the examples. } \author{Martin Maechler, May 2007.} \seealso{\code{\link{formula}}; \code{\link[mgcv]{gam}} from package \CRANpkg{mgcv} (or also from package \CRANpkg{gam}). } \examples{ myF <- wrapFormula(Fertility ~ . , data = swiss) myF # Fertility ~ s(Agriculture) + s(....) + ... if(require("mgcv")) { m1 <- gam(myF, data = swiss) print( summary(m1) ) plot(m1, pages = 1) ; title(format(m1$call), line= 2.5) } ## other wrappers: wrapFormula(Fertility ~ . , data = swiss, wrap = "lo(*)") wrapFormula(Fertility ~ . , data = swiss, wrap = "poly(*, 4)") } \keyword{models} sfsmisc/man/integrate.xy.Rd0000644000176200001440000000256107343123411015406 0ustar liggesusers\name{integrate.xy} \alias{integrate.xy} \title{Cheap Numerical Integration through Data points.} \description{ Given \eqn{(x_i, f_i)} where \eqn{f_i = f(x_i)}, compute a cheap approximation of \eqn{\int_a^b f(x) dx}{integral(a .. b) f(x) dx}. } \usage{ integrate.xy(x, fx, a, b, use.spline=TRUE, xtol=2e-08) } \arguments{ \item{x}{abscissa values.} \item{fx}{corresponding values of \eqn{f(x)}.} \item{a,b}{the boundaries of integration; these default to min(x) and max(x) respectively.} \item{use.spline}{logical; if TRUE use an interpolating spline.} \item{xtol}{tolerance factor, typically around \code{sqrt(.Machine$double.eps)} ......(fixme)....} } \details{ Note that this is really not good for noisy \code{fx} values; probably a smoothing spline should be used in that case. Also, we are not yet using Romberg in order to improve the trapezoid rule. This would be quite an improvement in equidistant cases. } \value{ the approximate integral. } \author{Martin Maechler, May 1994 (for S).} \seealso{\code{\link{integrate}} for numerical integration of \emph{functions}.} \examples{ x <- 1:4 integrate.xy(x, exp(x)) print(exp(4) - exp(1), digits = 10) # the true integral for(n in c(10, 20,50,100, 200)) { x <- seq(1,4, len = n) cat(formatC(n,wid=4), formatC(integrate.xy(x, exp(x)), dig = 9),"\n") } } \keyword{math} \keyword{utilities} sfsmisc/man/u.datumdecode.Rd0000644000176200001440000000217213131443372015507 0ustar liggesusers\name{u.datumdecode} \alias{u.datumdecode} \title{Convert \dQuote{Numeric} Dates} \description{ Daten der Form 8710230920 aufspalten in Jahr, Monat, Tag, Std, Min } \usage{ u.datumdecode(d, YMDHMnames = c("Jahr", "Monat", "Tag", "Std", "Min")) } \arguments{ \item{d}{numeric dates in the form YYMMDDHHMM.} \item{YMDHMnames}{(column) names to be used for the result.} } % \details{ % ~~ If necessary, more details than the __description__ above ~~ % } \value{ a numeric matrix (or vector) with 5 columns containing the year, month, etc. } \author{?? (someone at SfS ETH)} \note{%% Hence: DEPRECATE !? MM: This is a wrong concept, and also suffers from the \dQuote{millenium bug} (by using only 2 digits for the year). } \seealso{\R's \emph{proper} date-time coding: \code{\link{DateTimeClasses}}; \code{\link{u.date}} etc. } \examples{ u.datumdecode(8710230920) ## Jahr Monat Tag Std Min ## 87 10 23 9 20 u.datumdecode(c(8710230900, 9710230920, 0210230920)) ## Jahr Monat Tag Std Min ## [1,] 87 10 23 9 00 ## [2,] 97 10 23 9 20 ## [3,] 2 10 23 9 20 } \keyword{utilities} sfsmisc/man/AsciiToInt.Rd0000644000176200001440000000600313746476427015014 0ustar liggesusers\name{AsciiToInt} \encoding{latin1} \alias{AsciiToInt} \alias{ichar} \alias{chars8bit} \alias{strcodes} \title{Character to and from Integer Codes Conversion} \description{ \code{AsciiToInt} returns \code{\link{integer}} codes in \code{0:255} for each (one byte) character in \code{strings}. \code{ichar} is an alias for it, for old S compatibility. \code{strcodes} implements in \R the basic engine for translating characters to corresponding integer codes. \code{chars8bit()} is the \emph{inverse} function of \code{AsciiToint}, producing \dQuote{one byte} characters from integer codes. Note that it (and hence \code{strcodes()} depends on the locale, see \code{\link{Sys.getlocale}()}. } \usage{ AsciiToInt(strings) ichar(strings) chars8bit(i = 1:255) strcodes(x, table = chars8bit(1:255)) } \arguments{ \item{strings, x}{\code{\link{character}} vector.} \item{i}{numeric (integer) vector of values in \code{1:255}.} \item{table}{a vector of (unique) character strings, typically of one character each.} } \details{ Only codes in \code{1:127} make up the ASCII encoding which should be identical for all \R versions, whereas the \emph{\sQuote{upper}} half is often determined from the ISO-8859-1 (aka \dQuote{ISO-Latin 1)} encoding, but may well differ, depending on the locale setting, see also \code{\link{Sys.setlocale}}. Note that \code{0} is no longer allowed since, \R does not allow \code{\\0} aka \code{nul} characters in a string anymore. } \value{ \code{AsciiToInt} (and hence \code{ichar}) and \code{chars8bit} return a vector of the same length as their argument. \code{strcodes(x, tab)} returns a \code{\link{list}} of the same \code{\link{length}} and \code{\link{names}} as \code{x} with list components of integer vectors with codes in \code{1:255}. } \author{Martin Maechler, partly in 1991 for S-plus} \examples{ chars8bit(65:70)#-> "A" "B" .. "F" stopifnot(identical(LETTERS, chars8bit(65:90)), identical(AsciiToInt(LETTERS), 65:90)) % In R 2.1.0, the "" could not even be parsed in UTF-8; now gives NA ## may only work in ISO-latin1 locale (not in UTF-8): try( strcodes(c(a= "ABC", ch="1234", place = "Zrich")) ) ## in "latin-1" gives {otherwise should give NA instead of 252}: \dontrun{ $a [1] 65 66 67 $ch [1] 49 50 51 52 $place [1] 90 252 114 105 99 104 } myloc <- Sys.getlocale() if(.Platform $ OS.type == "unix") withAutoprint({ # ''should work'' here try( Sys.setlocale(locale = "de_CH") )# "try": just in case strcodes(c(a= "ABC", ch="1234", place = "Zrich")) # no NA hopefully AsciiToInt(chars8bit()) # -> 1:255 {if setting latin1 succeeded above} chars8bit(97:140) try( Sys.setlocale(locale = "de_CH.utf-8") )# "try": just in case chars8bit(97:140) ## typically looks different than above }) ## Resetting to original locale .. works "mostly": lapply(strsplit(strsplit(myloc, ";")[[1]], "="), function(cc) try(Sys.setlocale(cc[1], cc[2]))) -> .scratch Sys.getlocale() == myloc # TRUE if we have succeeded to reset it } \keyword{manip} sfsmisc/man/nr.sign.chg.Rd0000644000176200001440000000076207563237223015117 0ustar liggesusers\name{nr.sign.chg} \alias{nr.sign.chg} \title{Number of Sign Changes in Sequence} \description{ Compute the number of sign changes in the sequence \code{y}. } \usage{ nr.sign.chg(y) } \arguments{ \item{y}{numeric vector.} } \value{ an integer giving the number of sign changes in sequence \code{y}. Note that going from positive to 0 to positive is \emph{not} a sign change. } \author{Martin Maechler, 17 Feb 1993.} \examples{ (y <- c(1:2,1:-1,0:-2)) nr.sign.chg(y)## = 1 } \keyword{arith} sfsmisc/man/printTable2.Rd0000644000176200001440000000420212575757743015175 0ustar liggesusers\name{printTable2} \encoding{latin1} % source in ../R/printTable.R \alias{printTable2} \alias{margin2table} \alias{print.margin2table} \title{Add and Print Marginals for 2-way Contingency Tables} %\title{Berechne und Drucke Randtotale etc fr 2-weg Kontingenz Tafeln} \description{ \code{printTable2()} prints a 2-way contingency table \dQuote{with all bells and whistles} (currently using German labeling). \code{margin2table()} computes marginals, adds them to the table and returns a \code{margin2table} object the print method for which adds text decorations (using \code{"-"} and \code{"|"}). } \usage{ printTable2(table2, digits = 3) margin2table(x, totName = "sum", name.if.empty=FALSE) \method{print}{margin2table}(x, digits = 3, quote = FALSE, right = TRUE, \dots) } \arguments{ \item{table2}{a matrix with non-negative integer entries, i.e. the contingency table.}%Matrix mit Anzahlen, die Kontingenztafel. \item{x}{a matrix; for \code{print()}, the result of \code{margin2table}.} \item{digits}{Anzahl Dezimalstellen, auf die die Hufigkeiten gerundet werden sollen.} \item{quote, right}{logicals passed to \code{\link{print.default}()}, but with different default values.} \item{totName}{string to use as row- and column- name if \code{x} has corresponding \code{\link{dimnames}}.} \item{name.if.empty}{logical indicating if the margin \dQuote{totals} should be named in any case.} \item{\dots}{further potential arguments, unused currently.} } % \details{ % ......... % } \value{ \code{margin2table} returns a matrix with \emph{added marginals}, i.e., an extra row and column, and is of class \code{"margin2table"} (and \code{"\link{table}"} still) which has a nice print method. \code{printTable2} is just producing output. } \author{Martin Maechler, Feb.1993; then Dec 2003} \seealso{\code{\link{table}}, \code{\link{ftable}}.} \examples{ margin2table(diag(4),,TRUE) m <- diag(3); colnames(m) <- letters[1:3] margin2table(m) margin2table(m / sum(m)) data(HairEyeColor) margin2table(HairEyeColor[,, "Male"]) printTable2(HairEyeColor[,, "Male"]) printTable2(HairEyeColor[,, "Female"]) } \keyword{utilities} sfsmisc/man/uniqueL.Rd0000644000176200001440000000247511227623663014425 0ustar liggesusers\name{uniqueL} \alias{uniqueL} \title{A Reversable Version of unique()} \description{ A version of \code{\link{unique}} keeping enough information to reverse (or \emph{invert}) to the original data. } \usage{ uniqueL(x, isuniq = !duplicated(x), need.sort = is.unsorted(x)) } \arguments{ \item{x}{numeric vector, of length \code{n}, say.} \item{isuniq}{logical vector of the same length as \code{x}. For the reversion to work this should select at least all unique values of \code{x}.} \item{need.sort}{logical indicating if \code{x} is not yet sorted. Note that this argument exists only for speedup possibility when it is known, and that it \emph{must be set correctly}.} } \value{ list of two components, \item{ix}{integer vector of indices} \item{xU}{vector of values from \code{x}} such that both \code{x[isuniq] === xU} and \code{xU[ix] === x}. } \author{Martin Maechler} \seealso{\code{\link{Duplicated}} from the \pkg{sfsmisc} package in addition to the standard \code{\link{unique}} and \code{\link{duplicated}}. } \examples{ x0 <- c(1:3,2:7,8:4) str(r0 <- uniqueL(x0)) with(r0, xU[ix]) ## == x0 ! \dontshow{ for(n in 1:100) { x0 <- round((1+rpois(1,lam=1))*rnorm(40)) r0 <- uniqueL(x0) stopifnot(sort(unique(x0)) == r0$xU, with(r0, xU[ix]) == x0) } } } \keyword{utilities} sfsmisc/man/QUnif.Rd0000644000176200001440000000550512662651235014022 0ustar liggesusers\name{QUnif} \title{Quasi Randum Numbers via Halton Sequences} \alias{QUnif} \alias{sHalton} % \concept{Quasi Monte Carlo} \concept{low discrepancy sequence} \concept{space filling} % \description{ These functions provide quasi random numbers or \emph{space filling} or \emph{low discrepancy} sequences in the \eqn{p}-dimensional unit cube. } \usage{ sHalton(n.max, n.min = 1, base = 2, leap = 1) QUnif (n, min = 0, max = 1, n.min = 1, p, leap = 1, silent = FALSE) } \arguments{ \item{n.max}{maximal (sequence) number.} \item{n.min}{minimal sequence number.} \item{n}{number of \eqn{p}-dimensional points generated in \code{QUnif}. By default, \code{n.min = 1, leap = 1} and the maximal sequence number is \code{n.max = n.min + (n-1)*leap}.} \item{base}{integer \eqn{\ge 2}{>= 2}: The base with respect to which the Halton sequence is built.} \item{min, max}{lower and upper limits of the univariate intervals. Must be of length 1 or \code{p}.} \item{p}{dimensionality of space (the unit cube) in which points are generated.} \item{leap}{integer indicating (if \eqn{> 1}) if the series should be leaped, i.e., only every \code{leap}th entry should be taken.} \item{silent}{logical asking to suppress the message about enlarging the prime table for large \code{p}.} } \value{ \code{sHalton(n,m)} returns a numeric vector of length \code{n-m+1} of values in \eqn{[0,1]}. \code{QUnif(n, min, max, n.min, p=p)} generates \code{n-n.min+1} p-dimensional points in \eqn{[min,max]^p} returning a numeric matrix with p columns. } \note{ For \code{leap} Kocis and Whiten recommend values of \eqn{L=31,61,149,409}, and particularly the \eqn{L=409} for dimensions up to 400. } \references{ James Gentle (1998) \emph{Random Number Generation and Monte Carlo Simulation}; sec.\ 6.3. Springer. Kocis, L. and Whiten, W.J. (1997) Computational Investigations of Low-Discrepancy Sequences. \emph{ACM Transactions of Mathematical Software} \bold{23}, 2, 266--294. } \author{Martin Maechler} \examples{ 32*sHalton(20, base=2) stopifnot(sHalton(20, base=3, leap=2) == sHalton(20, base=3)[1+2*(0:9)]) ## ------- a 2D Visualization ------- Uplot <- function(xy, axes=FALSE, xlab="", ylab="", ...) { plot(xy, xaxs="i", yaxs="i", xlim=0:1, ylim=0:1, xpd = FALSE, axes=axes, xlab=xlab, ylab=ylab, ...) box(lty=2, col="gray40") } do4 <- function(n, ...) { op <- mult.fig(4, main=paste("n =", n,": Quasi vs. (Pseudo) Random"), marP=c(-2,-2,-1,0))$old.par on.exit(par(op)) for(i in 1:2) { Uplot(QUnif(n, p=2), main="QUnif", ...) Uplot(cbind(runif(n), runif(n)), main="runif", ...) } } do4(100) do4(500) do4(1000, cex = 0.8, col="slateblue") do4(10000, pch= ".", col="slateblue") do4(40000, pch= ".", col="slateblue") } \keyword{math} \keyword{multivariate} \keyword{datagen} sfsmisc/man/diagX.Rd0000644000176200001440000000112612575757743014045 0ustar liggesusers\name{diagX} \alias{diagX} \title{The \dQuote{Other} Diagonal Matrix} \description{ Compute the \emph{other} diagonal identity matrix. The result is basically a \emph{fast} version of \code{diag(n)[, n:1]}. } \usage{ diagX(n) } \arguments{ \item{n}{positive integer.} } \value{ a numeric \eqn{n \times n}{n * n} matrix with many zeros -- apart from \code{1}s in the \emph{other} diagonal. } \author{Martin Maechler, 1992.} \seealso{\code{\link{diag}}.} \examples{ diagX(4) for(m in 1:5) stopifnot(identical(diagX(m), diag(m)[, m:1, drop = FALSE])) } \keyword{array} \keyword{utilities} sfsmisc/man/xy.grid.Rd0000644000176200001440000000150312575757743014374 0ustar liggesusers\name{xy.grid} \alias{xy.grid} \title{Produce regular grid matrix.} \description{ Produce the grid used by \code{\link{persp}}, \link{contour}, etc, as an \code{N x 2} matrix. This is really outdated by \code{\link{expand.grid}()} nowadays. } \usage{ xy.grid(x, y) } \arguments{ \item{x,y}{any vectors of same mode.} } \value{ a 2-column matrix of \dQuote{points} for each combination of \code{x} and \code{y}, i.e. with \code{length(x) * length(y)} rows. } \author{Martin Maechler, 26 Oct 1994.} \seealso{\code{\link{expand.grid}} which didn't exist when \code{xy.grid} was first devised.} \examples{ plot(xy.grid(1:7, 10*(0:4))) x <- 1:3 ; y <- 10*(0:4) xyg <- xy.grid(x,y) ## Compare with expand.grid() : m2 <- as.matrix(expand.grid(y,x)[, 2:1]) dimnames(m2) <- NULL stopifnot(identical(xyg, m2)) } \keyword{array} sfsmisc/man/rrange.Rd0000644000176200001440000000312712575757631014266 0ustar liggesusers\name{rrange} \alias{rrange} \title{Robust Range using Boxplot 'Quartiles'} \description{ Compute a robust range, i.e. the usual \code{\link{range}()} as long as there are no outliers, using the \dQuote{whisker boundaries} of \code{\link{boxplot}}, i.e., \code{\link{boxplot.stats}}. } \usage{ rrange(x, range=1, coef = 1.5, na.rm = TRUE) } \arguments{ \item{x}{numeric vector the robust range of which shall be computed.} \item{range}{number for S compatibility; \code{1.5 * range} is equivalent to \code{coef}.} \item{coef}{numeric multiplication factor definying the outlier boundary, see \sQuote{Details} below.} \item{na.rm}{logical indicating how \code{\link{NA}} values should be handled; they are simply dropped when \code{na.rm = TRUE} as by default.} } \details{ The robust range is really just what \code{\link{boxplot.stats}(x, coef=coef)} returns as the whisker boundaries. This is the most extreme values \code{x[j]} still inside median plus/minus \code{coef * IQR}. } \value{ numeric vector \code{c(m,M)} with \eqn{m \le M}{m <= M} which is (not strictly) inside \code{range(x) = c(min(x),max(x))}. } \author{Martin Maechler, 1990.} \seealso{\code{\link{range}}, \code{\link{fivenum}}, \code{\link{boxplot}} and \code{\link{boxplot.stats}}. A more sophisticated robust range for (strongly) asymmetric data can be derived from the skewness adjusted boxplot statistics \code{\link[robustbase]{adjboxStats}} which is a generalization of \code{\link{boxplot.stats}}. } \examples{ stopifnot(rrange(c(1:10,1000)) == c(1,10)) } \keyword{univar} \keyword{robust} sfsmisc/man/ps.latex.Rd0000644000176200001440000001155512575757743014556 0ustar liggesusers\name{ps.latex} \alias{pdf.do} \alias{pdf.latex} \alias{ps.do} \alias{ps.latex} \title{PostScript/PDF Preview Device with Optional \sQuote{LaTeX} Touch} \usage{ pdf.do(file, paper = "default", width = -1, height = -1, onefile = FALSE, title = NULL, version = "1.4", quiet = FALSE, \dots) pdf.latex(file, height = 5 + main.space * 1.25, width = 9.5, main.space=FALSE, lab.space = main.space, paper = "special", title = NULL, lab=c(10, 10, 7), mgp.lab=c(1.6, 0.7, 0), mar=c(4, 4, 0.9, 1.1), \dots) ps.do(file, width=-1, height=-1, onefile=FALSE, horizontal=FALSE, title = NULL, \dots) ps.latex(file, height = 5 + main.space * 1.25, width = 9.5, main.space=FALSE, lab.space = main.space, paper = "special", title = NULL, lab=c(10, 10, 7), mgp.lab=c(1.6, 0.7, 0), mar=c(4, 4, 0.9, 1.1), \dots) } \arguments{ \item{file}{character giving the PostScript/PDF file name to be written.} \item{height}{device height in \emph{inches}, \code{height * 2.54} are \emph{cm}. The default is 5 plus 1.25 iff \code{main.space}.} \item{width}{device width in \emph{inches}; for this and \code{height}, see \code{\link{postscript}}.} \item{onefile, horizontal}{logicals passed to \code{\link{postscript}(..)} or \code{\link{pdf}(..)}, most probably to be left alone.} \item{title}{PostScript/PDF (not plot!) title passed to \code{\link{postscript}()} or \code{\link{pdf}()}; by default use a title with \R version and \code{file} in it.} \item{version}{a string describing the PDF version that will be required to view the output, see \code{\link{pdf}}; our (high) default ensures alpha-transparency.} \item{quiet}{logical specifying that some (informative/warning) messages should not be issued.} \item{main.space}{logical; if true, leave space for a main title (unusual for LaTeX figures!).} \item{lab.space}{logical; if true, leave space for x- and y- labels (by \emph{not} subtracting from \code{mar}).} \item{paper}{character (or missing), typically \code{"a4"} or \code{"a4r"} in non-America, see \code{\link{postscript}}. Only if this is \code{"special"} (or missing) are your choices of \code{width} and \code{height} completely honored (and this may lead to files that cannot print on A4) with resizing.} \item{lab}{integer of length 3, \code{lab[1:2]} are desired number of tick marks on x- and y- axis, see \code{\link{par}(lab=)}.} \item{mgp.lab}{three decreasing numbers determining space for axis labeling, see \code{\link{par}(mgp=)}, the default is here smaller than usual.} \item{mar}{four numbers, indicating marginal space, see \code{\link{par}(mar=)}, the default is here smaller than usual.} \item{\dots}{arguments passed to \code{\link{ps.do}()} or \code{\link{pdf.do}()} from \code{ps.latex} / \code{pdf.latex} and to \code{\link{ps.options}} from \code{ps.do}/\code{pdf.do}.} } \description{ All functions start a pseudo PostScript or Acrobat preview device, using \code{\link{postscript}} or \code{\link{pdf}}, and further registering the file name for subsequent calls to \code{\link{pdf.end}()} or \code{ps.end()}. } \details{ \code{ps.latex} and \code{pdf.latex} have an additional LaTeX %\iftex{\LaTeX}{LaTeX} flavor, and just differ by some extra \code{\link{par}} settings from the \code{*.do} siblings: E.g., after \code{\link{ps.do}(..)} is called, the graphical parameters \code{c("mar", "mgp", "lab")} are reset (to values that typically are better than the defaults for LaTeX figures). Whereas the defaults for \code{paper}, \code{width}, and \code{height} \emph{differ} between \code{\link{pdf}} and \code{\link{postscript}}, they are set such as to provide very similar functionality, for the functions \code{ps.do()} and \code{pdf.do()}; e.g., by default, both use a full plot on portrait-oriented page of the default paper, as per \code{\link{getOption}("papersize")}.\cr \code{\link{pdf.do}()} sets the default \code{paper} to \code{"special"} when both \code{width} and \code{height} are specified. } \value{ A list with components \item{old.par}{containing the old \code{par} values} \item{new.par}{containing the newly set \code{par} values} } \author{Martin Maechler} \seealso{\code{\link{ps.end}}, \code{\link{pdf}}, \code{\link{postscript}}, \code{\link{dev.print}}. } \examples{ if(interactive()) { ps.latex("ps.latex-ex.ps", main= TRUE) data(sunspots) plot(sunspots,main=paste("Sunspots Data, n=",length(sunspots)),col="red") ps.end() pdf.latex("pdf.latex-ex.pdf", main= TRUE) data(sunspots) plot(sunspots,main=paste("Sunspots Data, n=",length(sunspots)),col="red") pdf.end() ps.do("ps_do_ex.ps") example(plot.function) ps.end() pdf.do("pdf_do_ex.pdf", width=12, height=5) plot(sunspots, main="Monthly Sunspot numbers (in Zurich, then Tokyo)") pdf.end() } } \keyword{device} sfsmisc/man/mpl.Rd0000644000176200001440000000177007757505761013603 0ustar liggesusers\name{mpl} \alias{mpl} \alias{p.m} \title{Simple Matrix Plots} \description{ Do simple matrix plots, providing an easy interface to \code{\link{matplot}} by using a default x variable. } \usage{ mpl(mat, \dots) p.m(mat, \dots) } \arguments{ \item{mat}{numeric matrix.} \item{\dots}{further arguments passed to \code{\link{matplot}}, e.g., \code{type}, \code{xlab}, etc.} } \details{ \code{p.m(m)} use the first column of \code{m} as \eqn{x} variable, whereas \code{mpl(m)} uses the integers 1, 2, \ldots, \code{nrow(m)} as coordinates and \code{rownames(m)} as axis labels if possible. } \note{These were really created for playing around with curves etc, and probably should be \emph{deprecated} since in concrete examples, using \code{matplot()} directly is more appropriate. } \author{Martin Maechler} \seealso{\code{\link{matplot}}, \code{\link{plot.mts}(*, plot.type = "single")}.} \examples{ data(animals, package = "cluster") mpl(animals, type = "l") } \keyword{hplot} \keyword{array} sfsmisc/man/toLatex.numeric.Rd0000644000176200001440000000361313131443372016050 0ustar liggesusers\name{toLatex.numeric} \alias{toLatex.numeric} \title{LaTeX or Sweave friendly Formatting of Numbers} \description{ Formats real numbers, possibly in scientific notation, with a given number of digits after the decimal point. Output can be used in LaTeX math mode, e.g., for printing numbers in a table, where each number has to be printed with the same number of digits after the decimal point, even if the last digits are zeros. } \usage{ \method{toLatex}{numeric}(object, digits = format.info(object)[2], scientific = format.info(object)[3] > 0, times = "\\\\cdot", \dots) } \arguments{ \item{object}{a numeric vector.} \item{digits}{number of digits \emph{after the decimal point} (for the mantissa if \code{scientific}). The default behaves the same as \R's \code{\link{format}()}.} \item{scientific}{logical indicating if scientific notation \code{a * 10^k} should be used. The default behaves the same as \R's \code{\link{format}()}.} \item{times}{character string indicating the LaTeX symbol to be used for the \sQuote{times} sign.} \item{\dots}{unused; for compatibility with \code{\link{toLatex}}.} } \note{We use \code{digits} for \code{\link{round}}, i.e., round after the decimal point on purpose, rather than \code{\link{signif}()}icant digit rounding as used by \code{\link{print}()} or \code{\link{format}()}. } \value{ a \code{\link{character}} vector of the same length as \code{object}, containing the formatted numbers. } \author{Alain Hauser% and Martin -- E-mail ? for harvesters } \seealso{ \code{\link{pretty10exp}} which gives \code{\link{expression}}s similar to our \code{scientific=TRUE}. \code{\link{toLatex}} with other methods. } \examples{ xx <- pi * 10^(-9:9) format(xx) formatC(xx) toLatex(xx) #-> scientific = TRUE is chosen toLatex(xx, scientific=FALSE) sapply(xx, toLatex) sapply(xx, toLatex, digits = 2) } \keyword{misc} sfsmisc/man/f.robftest.Rd0000644000176200001440000000270013131443372015037 0ustar liggesusers\name{f.robftest} \alias{f.robftest} \title{Robust F-Test: Wald test for multiple coefficients of rlm() Object.} \description{ Compute a robust F-Test, i.e., a Wald test for multiple coefficients of an \code{\link[MASS]{rlm}} object. } \usage{ f.robftest(object, var = -1) } \arguments{ \item{object}{result of \code{\link[MASS]{rlm}()}.} \item{var}{variables. Either their names or their indices; the default, \code{-1} means all \emph{but} the intercept.} } \details{ This builds heavily on \code{\link[MASS]{summary.rlm}()}, the \code{\link{summary}} method for \code{\link[MASS]{rlm}} results. } \value{ An object of class \code{"htest"}, hence with the standard print methods for hypothesis tests. This is basically a list with components \item{statistic}{the F statistic, according to ...}% FIXME \item{df}{numerator and denominator degrees of freedom.} \item{data.name}{(extracted from input \code{object}.)} \item{alternative}{\code{"two.sided"}, always.} \item{p.value}{the P-value, using an F-test on \code{statistic} and \code{df[1:2]}.} } \references{ FIXME --- Need some here ! } \author{Werner Stahel, July 2000; updates by Martin Maechler.} \seealso{\code{\link[MASS]{rlm}}, \code{\link{summary.aov}}, etc.} \examples{ if(require("MASS")) { ## same data as example(rlm) data(stackloss) summary(rsl <- rlm(stack.loss ~ ., stackloss)) f.robftest(rsl) } else " forget it " } \keyword{robust} \keyword{htest} sfsmisc/man/repChar.Rd0000644000176200001440000000254514017677114014365 0ustar liggesusers\name{repChar} \alias{repChar} \alias{bl.string} \title{Make Simple String from Repeating a Character, e.g. Blank String} \description{ Simple constructors of a constant character string from one character, notably a \dQuote{blank} string of given string length. M.M. is now \sQuote{\emph{mentally deprecating}} \code{bl.string} in favor of using \code{repChar()} in all cases. With \R 3.3.0 (May 2016), the \emph{new} function \code{\link{strrep}()} was introduced; it is faster typically, and more flexible, e.g. accepting a \emph{vector} for the 2nd argument. \cr This (for now informally) deprecates all uses of \code{repChar()} and \code{bl.string()}. } \usage{ repChar(char, no) bl.string(no) } \arguments{ \item{char}{single character (or arbitrary string).} \item{no}{non-negative integer.} } \value{ One string, i.e., \code{\link{character}(1)}), for \code{bl.string} a blank string, fulfilling \code{n == nchar(bl.string(n))}. } \author{Martin Maechler, early 1990's (for \code{bl.string}).} \seealso{\code{\link{paste}}, \code{\link{character}}, \code{\link{nchar}}.} \examples{ r <- sapply(0:8, function(n) ccat(repChar(" ",n), n)) cbind(r) repChar("-", 4) repChar("_", 6) ## it may make sense to a string of more than one character: repChar("-=- ", 6) ## show the very simple function definitions: repChar bl.string } \keyword{character} sfsmisc/man/mat2tex.Rd0000644000176200001440000001106613617022536014360 0ustar liggesusers%%-- Original from Vincent Carey, see (commented) E-mail at end ! \name{mat2tex} \alias{mat2tex} \title{Produce LaTeX commands to print a matrix} \usage{ mat2tex(x, file= "mat.tex", envir = "tabular", nam.center = "l", col.center = "c", append = TRUE, digits = 3, title) } \arguments{ \item{x}{a matrix} \item{file}{names the file to which LaTeX commands should be written} \item{envir}{a string, the LaTeX environment name; default is \code{"tabular"}; useful maybe \code{"array"}, or other versions of tabular environments.} \item{nam.center}{character specifying row names should be center; default \code{"l"}.} \item{col.center}{character (vector) specifying how the columns should be centered; must have values from \code{c("l","c","r")}; defaults to \code{"c"}.} \item{append}{logical; if \code{FALSE}, will destroy the file \code{file} before writing commands to it; otherwise (by default), simply adds commands at the end of file \code{file}.} \item{digits}{integer; setting of \code{\link{options}(digits=..)} for purpose of number representation.} \item{title}{a string, possibly using LaTeX commands, which will span the columns of the LaTeX matrix} } \description{ \dQuote{Translate} an \R matrix (like object) into a LaTeX table, using \code{\\begin{tabular} ...}. } \value{ No value is returned. This function, when used correctly, only writes LaTeX commands to a file. } \author{For S: Vincent Carey \email{vjcarey@sphunix.sph.jhu.edu}, from a post on Feb.19, 1991 to S-news. Port to \R (and a bit more) by Martin Maechler \email{maechler@stat.math.ethz.ch}. } \seealso{ \code{\link[Hmisc]{latex}} in package \CRANpkg{Hmisc} is more flexible (but may surprise by its auto-printing ..). } \examples{ mex <- matrix(c(pi,pi/2,pi/4,exp(1),exp(2),exp(3)),nrow=2, byrow=TRUE, dimnames = list(c("$\\\\pi$","$e$"), c("a","b","c"))) mat2tex(mex, file = print(tf <- tempfile("mat", , ".tex")), title="$\\\\pi, e$, etc." )% double-esc -> 4 x backslash ## The last command produces the file "mat.tex" containing ##> \\begin{tabular} {| l|| c| c| c|} ##> \\multicolumn{ 4 }{c}{ $\\pi, e$, etc. } \\\\ \\hline ##> \\ & a & b & c \\\\ \\hline \\hline ##> $\pi$ & 3.14 & 1.57 & 0.785 \\\\ \\hline ##> $e$ & 2.72 & 7.39 & 20.1 \\\\ \\hline ##> \\end{tabular} ## Now you have to properly embed the contents of this file ## in a LaTeX document -- for example, you will need a ## preamble, the \\begin{document} statement, etc. ## Note that the backslash needs protection in dimnames ## or title actions. mat2tex(mex, stdout(), col.center = c("r","r","c")) } \keyword{interface} % to latex \keyword{utilities} %% %% From: vjcarey@sphunix.sph.jhu.edu (Vincent J. Carey) %% Subject: mat2tex, a report generation aid (LONG) %% To: s-news@stat.wisc.edu %% Date: Tue, 19 Feb 91 19:25:05 EST %% %% Has there been any work on "report generation" from S %% beyond the tbl() function? I have been manually %% transcribing S matrix elements to LaTeX tables %% and find this to be a tedious and error-prone process. %% Certainly there are ways of cutting and pasting window %% contents to reduce the troubles associated with digit %% keying, but this is far from foolproof, and is also %% pretty dull. %% %% Therefore I offer this function, mat2tex(), which %% produces LaTeX commands to format the entries of %% an S matrix. The function will, by default, place %% the commands in the file "mat.tex". %% %% The documentation file included is fairly explicit. The %% function does not produce a complete LaTeX program, but %% a fragment "containing" a matrix. Column and row labels %% (which may include references to special LaTeX symbols, %% provided backslash protection is maintained) are propagated %% to the LaTeX fragment. There is a provision for a matrix "title". %% %% Unadulterated output of a simple example (see the doc page %% for the input): %% %% \begin{tabular} {| l|| c| c| c|} %% \multicolumn{ 4 }{c}{ $\pi, e$, etc. } \\ \hline %% \ & a & b & c \\ \hline \hline %% $\pi$ & 3.14 & 1.57 & 0.785 \\ \hline %% $e$ & 2.72 & 7.39 & 20.1 \\ \hline %% \end{tabular} %% %% Further work needed: digit/decimal-point alignment, %% consistent boxing of the title, more arguments to allow %% sensible customization -- e.g., the user may not desire %% \hline between rows. Comments, criticism and enhancements %% are welcome. %% %% ------------------------------------------------------------------------- %% %% Vincent J. Carey %% Department of Biostatistics %% Johns Hopkins School of Public Health %% %% vjcarey@sphunix.sph.jhu.edu sfsmisc/man/primes.Rd0000644000176200001440000000552213640614355014275 0ustar liggesusers\name{primes} \alias{primes} \title{Find all Primes Less Than n} \description{ Find all prime numbers aka \sQuote{primes} less than \eqn{n}. Uses an obvious sieve method (and some care), working with \code{\link{logical}} and and \code{\link{integer}}s to be quite fast. } \usage{ primes(n, pSeq = NULL) } \arguments{ \item{n}{a (typically positive integer) number.} \item{pSeq}{optionally a vector of primes (2,3,5,...) as if from a \code{primes()} call; \bold{must} be correct. The goal is a speedup, but currently we have not found one single case, where using a non-NULL \code{pSeq} is faster.} } \details{ As the function only uses \code{\link{max}(n)}, \code{n} can also be a \emph{vector} of numbers. The famous prime number theorem states that \eqn{\pi(n)}, the \emph{number} of primes below \eqn{n} is asymptotically \eqn{n / \log(n)} in the sense that \eqn{\lim_{n \to \infty}{\pi(n) \cdot \log(n) / n \sim 1}}{lim[n -> Inf] \pi(n) * log(n) / n ~ 1}. Equivalently, the inverse of \eqn{pi()}, the \eqn{n}-th prime number \eqn{p_n} is around \eqn{n \log n}; recent results (Pierre Dusart, 1999), prove that \deqn{\log n + \log\log n - 1 < \frac{p_n}{n} < \log n + \log \log n \quad\mathrm{for } n \ge 6.}{% log n + log log n - 1 < p_n / n < log n + log log n for n >= 6.} } \value{ numeric vector of all prime numbers \eqn{\le n}{<= n}. } \author{Bill Venables (<= 2001); Martin Maechler gained another 40\% speed, carefully working with logicals and integers. } \seealso{ \code{\link{factorize}}. For large \eqn{n}, use the \CRANpkg{gmp} package and its \code{\link[gmp]{isprime}} and \code{\link[gmp]{nextprime}} functions. } \examples{ (p1 <- primes(100)) system.time(p1k <- primes(1000)) # still lightning fast stopifnot(length(p1k) == 168) \donttest{ system.time(p.e7 <- primes(1e7)) # still only 0.3 sec (2015 (i7)) stopifnot(length(p.e7) == 664579) ## The famous pi(n) := number of primes <= n: pi.n <- approxfun(p.e7, seq_along(p.e7), method = "constant") pi.n(c(10, 100, 1000)) # 4 25 168 plot(pi.n, 2, 1e7, n = 1024, log="xy", axes = FALSE, xlab = "n", ylab = quote(pi(n)), main = quote("The prime number function " ~ pi(n))) eaxis(1); eaxis(2) } ## Exploring p(n) := the n-th prime number ~=~ n * pnn(n), where ## pnn(n) := log n + log log n pnn <- function(n) { L <- log(n); L + log(L) } n <- 6:(N <- length(PR <- primes(1e5))) m.pn <- cbind(l.pn = ceiling(n*(pnn(n)-1)), pn = PR[n], u.pn = floor(n*pnn(n))) matplot(n, m.pn, type="l", ylab = quote(p[n]), main = quote(p[n] ~~ "with lower/upper bounds" ~ n*(log(n) + log(log(n)) -(1~"or"~0)))) ## (difference to the lower approximation) / n --> ~ 0.0426 (?) : plot(n, PR[n]/n - (pnn(n)-1), type = 'l', cex = 1/8, log="x", xaxt="n") eaxis(1); abline(h=0, col=adjustcolor(1, 0.5)) } \keyword{math} \keyword{arithmetic} sfsmisc/man/hatMat.Rd0000644000176200001440000000461612575757743014236 0ustar liggesusers\name{hatMat} \alias{hatMat} \title{Hat Matrix of a Smoother} \description{ Compute the hat matrix or smoother matrix, of \sQuote{any} (linear) smoother, smoothing splines, by default. } \usage{ hatMat(x, trace= FALSE, pred.sm = function(x, y, ...) predict(smooth.spline(x, y, ...), x = x)$y, \dots) } \arguments{ \item{x}{numeric vector or matrix.} \item{trace}{logical indicating if the whole hat matrix, or only its trace, i.e. the sum of the diagonal values should be computed.} \item{pred.sm}{a function of at least two arguments \code{(x,y)} which returns fitted values, i.e. \eqn{\hat{y}}{y.hat}, of length compatible to \code{x} (and \code{y}).} \item{\dots}{optionally further arguments to the smoother function \code{pred.sm}.} } \value{ The hat matrix \eqn{H} (if \code{trace = FALSE} as per default) or a number, \eqn{tr(H)}, the \emph{trace} of \eqn{H}, i.e., \eqn{\sum_i H_{ii}}{sum(i) H[i,i]}. Note that \code{dim(H) == c(n, n)} where \code{n <- length(x)} also in the case where some x values are duplicated (aka \emph{ties}). } \references{ Hastie and Tibshirani (1990). \emph{Generalized Additive Models}. Chapman \& Hall. } \author{Martin Maechler \email{maechler@stat.math.ethz.ch}} \seealso{\code{\link{smooth.spline}}, etc. Note the demo, \code{demo("hatmat-ex")}. } \examples{ require(stats) # for smooth.spline() or loess() x1 <- c(1:4, 7:12) H1 <- hatMat(x1, spar = 0.5) # default : smooth.spline() matplot(x1, H1, type = "l", main = "columns of smoother hat matrix") ## Example 'pred.sm' arguments for hatMat() : pspl <- function(x,y,...) predict(smooth.spline(x,y, ...), x = x)$y pksm <- function(x,y,...) ksmooth(sort(x),y, "normal", x.points=x, ...)$y ## Rather than ksmooth(): if(require("lokern")) pksm2 <- function(x,y,...) glkerns(x,y, x.out=x, ...)$est % pRmean <- function(x,y,...) run.mean(y, ...) % pRline <- function(x,y,...) run.line(x,y, ...)$y ## Explaining 'trace = TRUE' all.equal(sum(diag((hatMat(c(1:4, 7:12), df = 4)))), hatMat(c(1:4, 7:12), df = 4, trace = TRUE), tol = 1e-12) ## ksmooth() : Hk <- hatMat(x1, pr = pksm, bandwidth = 2) cat(sprintf("df = \%.2f\\n", sum(diag(Hk)))) image(Hk) Matrix::printSpMatrix(as(round(Hk, 2), "sparseMatrix")) ##---> see demo("hatmat-ex") for more (and larger) examples %% should test these also for x with ties } \keyword{smooth} \keyword{regression} sfsmisc/man/p.arrows.Rd0000644000176200001440000000164312575757743014570 0ustar liggesusers\name{p.arrows} \alias{p.arrows} \title{Prettified Arrows Plots} \description{ Draws arrows, like the \code{\link{arrows}} function, but with \dQuote{nice} \emph{filled} arrow heads. } \usage{ p.arrows(x1, y1, x2, y2, size = 1, width, fill = 2, ...) } \arguments{ \item{x1, y1}{coordinates of points \bold{from} which to draw.} \item{x2, y2}{coordinates of points \bold{to} which to draw.} \item{size}{symbol size as a fraction of a character height; default 1.} \item{width}{width of the arrow head; defaults to ....}%fixme (code => ??) \item{fill}{color for filling the arrow head.} \item{\dots}{further arguments passed to \code{\link{segments}()}.} } \author{Andreas Ruckstuhl, 19 May 1994; (cosmetic by MM).} \seealso{\code{\link{arrows}}.} \examples{ example(arrows, echo = FALSE) #-> x, y, s plot(x,y, main="p.arrows(.)") p.arrows(x[s], y[s], x[s+1], y[s+1], col= 1:3, fill = "dark blue") } \keyword{aplot} sfsmisc/man/quadrant.Rd0000644000176200001440000000174012575757743014632 0ustar liggesusers\name{quadrant} \alias{quadrant} \title{Give the Quadrant Number of Planar Points} \description{ Determine the quadrant of planar points, i.e. in which of the four parts cut by the x- and y- axis the points lie. Zero values (i.e. points on the axes) are treated as if \emph{positive}. } \usage{ quadrant(x, y=NULL) } \arguments{ \item{x,y}{numeric vectors of the same length, or \code{x} is an \eqn{x-y} structure and \code{y=NULL}, see \code{\link{xy.coords}}.} } \value{ numeric vector of same length as \code{x} (if that's a vector) with values in \code{1:4} indicating the quadrant number of the corresponding point. } %%\seealso{ ~~objects to See Also as \code{\link{~~fun~~}}, ~~~ } \examples{ xy <- as.matrix(expand.grid(x= -7:7, y= -7:7)); rownames(xy) <- NULL (qu <- quadrant(xy)) plot(xy, col = qu+1, main = "quadrant() number", axes = FALSE) abline(h=0, v=0, col="gray") # the x- and y- axis text(xy, lab = qu, col = qu+1, adj = c(1.4,0)) } \keyword{utilities} sfsmisc/man/p.scales.Rd0000644000176200001440000000164011131753061014472 0ustar liggesusers\name{p.scales} \alias{p.scales} \title{Conversion between plotting scales: usr, cm, symbol} \description{ Give scale conversion factors of three coordinate systems in use for traditional R graphics: use, cm, symbol. } \usage{ p.scales(unit = relsysize * 2.54 * min(pin), relsysize = 0.05) } \arguments{ \item{unit}{length of unit (or x and y units) of symbol coordinates in cm.} \item{relsysize}{same, as a proportion of the plotting area.} } \value{ A numeric 2x2 matrix, with rows named \code{x} and \code{y}, and columns, named \code{"sy2usr"} and \code{"usr2cm"} which give the scale conversion factors from \sQuote{symbol} (as given) to \sQuote{usr} coordinates and from these to \sQuote{cm}, respectively. } \author{Werner Stahel, 1990; simplification: M.Maechler, 1993, 2004} \seealso{\code{\link{par}("usr")}, of also \code{("pin")} on which this is based.} \examples{ p.scales() } \keyword{dplot} sfsmisc/man/p.ts.Rd0000644000176200001440000000552212560614001013646 0ustar liggesusers\name{p.ts} \alias{p.ts} \title{plot.ts with multi-plots and Auto-Title -- on 1 page} \description{ For longer time-series, it is sometimes important to spread the time-series plots over several subplots. p.ts(.) does this both automatically, and under manual control. Actually, this is a generalization of \code{\link{plot.ts}} (with different defaults). } \usage{ p.ts(x, nrplots = max(1, min(8, n \%/\% 400)), overlap = nk \%/\% 16, date.x = NULL, do.x.axis = !is.null(date.x), do.x.rug = FALSE, ax.format, main.tit = NULL, ylim = NULL, ylab = "", xlab = "Time", quiet = FALSE, mgp = c(1.25, .5, 0), \dots) } \arguments{ \item{x}{timeseries (possibly multivariate) or numeric vector.} \item{nrplots}{number of sub-plots. Default: in \{1..8\}, approximately \code{n/400} if possible.} \item{overlap}{by how much should subsequent plots overlap. Defaults to about 1/16 of sub-length on each side.} \item{date.x}{a time \dQuote{vector} of the same length as \code{x} and coercable to class \code{"POSIXct"} (see \link{DateTimeClasses}).} \item{do.x.axis}{logical specifying if an x axis should be drawn (i.e., tick marks and labels).} \item{do.x.rug}{logical specifying if \code{\link{rug}} of \code{date.x} values should drawn along the x axis.} \item{ax.format}{when \code{do.x.axis} is true, specify the \code{format} to be used in the call to \code{\link{axis.POSIXct}}.} \item{main.tit}{\bold{Main} title (over all plots). Defaults to name of \code{x}.} \item{ylim}{numeric(2) or NULL; if the former, specifying the y-range for the plots. Defaults to a common pretty range.} \item{ylab, xlab}{labels for y- and x-axis respectively, see description in \code{\link{plot.default}}.} \item{quiet}{logical; if \code{TRUE}, there's no reporting on each subplot.} \item{mgp}{numeric(3) to be passed to \code{\link{mult.fig}()}, see \code{\link{par}(mgp = .)}.} \item{\dots}{further graphic parameters for each \code{\link{plot.ts}(..)}.} } \section{Side Effects}{ A page of \code{nrplots} subplots is drawn on the current graphics device. } \author{Martin Maechler, \email{maechler@stat.math.ethz.ch}; July 1994 (for S).} \seealso{\code{p.ts()} calls \code{\link{mult.fig}()} for setup. Further, \code{\link{plot.ts}} and \code{\link{plot}}. } \examples{ stopifnot(require(stats)) ## stopifnot(require(datasets)) data(sunspots) p.ts(sunspots, nr=1) # == usual plot.ts(..) p.ts(sunspots) p.ts(sunspots, nr=3, col=2) data(EuStockMarkets) p.ts(EuStockMarkets[,"SMI"]) ## multivariate : p.ts(log10(EuStockMarkets), col = 2:5) ## with Date - x-axis (dense random dates): set.seed(12) x <- as.Date("2000-02-29") + cumsum(1+ rpois(1000, lambda= 2.5)) z <- cumsum(.1 + 2*rt(1000, df=3)) p.ts(z, 4, date.x = x) p.ts(z, 6, date.x = x, ax.format = "\%b \%Y", do.x.rug = TRUE) } \keyword{hplot} \keyword{ts} sfsmisc/man/mult.fig.Rd0000644000176200001440000000575513071375371014533 0ustar liggesusers\name{mult.fig} \alias{mult.fig} \title{Plot Setup for MULTiple FIGures, incl. Main Title} \description{ Easy Setup for plotting multiple figures (in a rectangular layout) on one page. It allows to specify a main title and uses \emph{smart} defaults for several \code{\link{par}} calls. } \usage{ mult.fig(nr.plots, mfrow, mfcol, marP = rep(0, 4), mgp = c(if(par("las") != 0) 2. else 1.5, 0.6, 0), mar = marP + 0.1 + c(4,4,2,1), oma = c(0,0, tit.wid, 0), main = NULL, tit.wid = if (is.null(main)) 0 else 1 + 1.5*cex.main, cex.main = par("cex.main"), line.main = cex.main - 1/2, col.main = par("col.main"), font.main = par("font.main"), \dots) } \arguments{ \item{nr.plots}{integer; the number of plot figures you'll want to draw.} \item{mfrow, mfcol}{\emph{instead} of \code{nr.plots}: integer(2) vectors giving the rectangular figure layout for \code{\link{par}(mfrow = *)}, or \code{\link{par}(mfcol=*)}, respectively. The default is to use \code{mfrow = \link{n2mfrow}(nr.plots)}.} \item{marP}{numeric(4) vector of figure margins to \emph{add} (\dQuote{\bold{P}lus}) to default \code{mar}, see below.} \item{mgp}{argument for \code{\link{par}(mpg= .)} with a smaller default than usual.} \item{mar}{argument for \code{\link{par}(mar= .)} with a smaller default than usual, using the \code{marP} argument, see above.} \item{oma}{argument for \code{\link{par}(oma= .)}, by default for adding space for the \code{main} title if necessary.} \item{main}{character. The main title to be used for the whole graphic.} \item{tit.wid}{numeric specifying the vertical width to be used for the main title; note that this is only used for the default value of \code{oma} (s. above).} \item{cex.main}{numeric; the character size to be used for the main title.} \item{line.main}{numeric; the margin line at which the title is written (via \code{\link{mtext}(main, side=3, outer=TRUE, line = line.main, ....)}).} \item{col.main, font.main}{color and font for main title, passed to \code{\link{mtext}()}, see also \code{\link{par}(*)}.} \item{\dots}{further arguments to \code{\link{mtext}} for the main title.} } \value{ A \code{\link{list}} with two components that are lists themselves, a subset of \code{\link{par}()}, \item{new.par}{the current \code{par} settings.} \item{old.par}{the \code{par} \emph{before} the call.} } \author{Martin Maechler, UW Seattle, 1990 (for \command{S}).} \seealso{\code{\link{par}}, \code{\link{layout}}.} \examples{ opl <- mult.fig(5, main= expression("Sine Functions " * sin(n * pi * x))) x <- seq(0, 1, len = 201) for (n in 1:5) plot(x, sin(n * pi * x), ylab ="", main = paste("n = ",n)) par(opl$old.par) rr <- mult.fig(mfrow=c(5,1), main= "Cosinus Funktionen", cex = 1.5, marP = - c(0, 1, 2, 0)) for (n in 1:5) plot(x, cos(n * pi * x), type = 'l', col="red", ylab ="") str(rr) par(rr$old.par) ## The *restored* par settings: str(do.call("par", as.list(names(rr$new.par)))) } \keyword{hplot} sfsmisc/man/read.org.table.Rd0000644000176200001440000000432713723455470015572 0ustar liggesusers\name{read.org.table} \title{Read.table for an Emacs Org Table} \alias{read.org.table} \description{ Read an emacs \dQuote{Org} table (in \code{file} or \code{text}) by \code{\link{read.table}()}. % FIXME: Should be easy to made to work for some of the %% Markdown formats for tables. } \usage{ read.org.table(file, header = TRUE, skip = 0, encoding = "native", fileEncoding = "", text, \dots) } \arguments{ \item{file}{a file name, a \code{\link{file}} or other connection.} \item{header}{logical indicating if the org table has header line (in the usual \code{"|"}-separated org table format).} \item{skip}{integer number of initial lines to skip.} \item{encoding}{to be used in the main \code{\link{readLines}(file, encoding=encoding)} call.} \item{fileEncoding}{if \code{file} is a file name, i.e., a \code{\link{character}} string, and \code{fileEncoding} is not the empty string, \code{file(file, "rt", encoding = fileEncoding)} will be used.} \item{text}{instead of \code{file}, a \code{\link{character}} or string (of a few lines, typically).} \item{\dots}{further arguments passed to \code{\link{read.table}}. You should \emph{not} use \code{encoding} (but possibly \code{fileEncoding}!) here, as we do not call \code{\link{read.table}} on \code{file} (but on a \code{\link{textConnection}}).} } \value{ a \code{\link{data.frame}} } \note{TODO: It should be easy to extend \code{read.org.table()} to also work for some of the proposed Markdown formats for tables. Please write to \code{\link{maintainer}("sfsmisc")} or open a github issue if you are interested. } \references{ Org-Mode \emph{Manual} on tables, \url{https://orgmode.org/manual/Tables.html} Org \emph{tutorial} for tables, \url{https://orgmode.org/worg/org-tutorials/tables.html} } \seealso{ CRAN package \CRANpkg{ascii} % \CRANpkg{ascii} % <- needs R >= 3.2.0 can \emph{write} org tables. \code{\link{read.table}} } \examples{ t1 <- " | a | var2 | C | |---+------+-----| | 2 | may | 3.4 | | 7 | feb | 4.7 | " d <- read.org.table(text = t1) d stopifnot(dim(d) == c(2, 3), identical(names(d), c("a", "var2", "C")), d[,"a"] == c(2,7)) } \keyword{file} \keyword{utilities} sfsmisc/man/plotDS.Rd0000644000176200001440000000626513020007125014167 0ustar liggesusers\name{plotDS} \alias{plotDS} \title{Plot Data and Smoother / Fitted Values} \description{ For one-dimensional nonparametric regression, plot the data and fitted values, typically a smooth function, and optionally use segments to visualize the residuals. } \usage{ plotDS(x, yd, ys, xlab = "", ylab = "", ylim = rrange(c(yd, ys)), xpd = TRUE, do.seg = TRUE, seg.p = 0.95, segP = list(lty = 2, lwd = 1, col = 2), linP = list(lty = 1, lwd = 2.5, col = 3), \dots) } \arguments{ \item{x, yd, ys}{numeric vectors all of the same length, representing \eqn{(x_i, y_i)} and fitted (smooth) values \eqn{\hat{y}_i}{y^_i}. \code{x} will be sorted increasingly if necessary, and \code{yd} and \code{ys} accordingly. Alternatively, \code{ys} can be an x-y list (as resulting from \code{\link[grDevices]{xy.coords}}) containing fitted values on a finer grid than the observations \code{x}. In that case, the observational values \code{x[]} \bold{must} be part of the larger set; \code{\link{seqXtend}()} may be applied to construct such a set of abscissa values. } \item{xlab, ylab}{x- and y- axis labels, as in \code{\link{plot.default}}.} \item{ylim}{limits of y-axis to be used; defaults to a \emph{robust} range of the values.} \item{xpd}{see \code{\link{par}(xpd=.)}; by default do allow to draw outside the plot region.} \item{do.seg}{logical indicating if residual segments should be drawn, at \code{x[i]}, from \code{yd[i]} to \code{ys[i]} (approximately, see \code{seg.p}).} \item{seg.p}{segment percentage of segments to be drawn, from \code{yd} to \code{seg.p*ys + (1-seg.p)*yd}.} \item{segP}{list with named components \code{lty, lwd, col} specifying line type, width and color for the residual segments, used only when \code{do.seg} is true.} \item{linP}{list with named components \code{lty, lwd, col} specifying line type, width and color for \dQuote{smooth curve lines}.} \item{\dots}{further arguments passed to \code{\link{plot}}.} } \author{Martin Maechler, since 1990} \note{Non-existing components in the lists \code{segP} or \code{linP} will result in the \code{\link{par}} defaults to be used. \code{plotDS()} used to be called \code{pl.ds} up to November 2007. } \seealso{\code{\link{seqXtend}()} to construct more smooth \code{ys} \dQuote{objects}. } \examples{ data(cars) x <- cars$speed yd <- cars$dist ys <- lowess(x, yd, f = .3)$y plotDS(x, yd, ys) ## More interesting : Version of example(Theoph) data(Theoph) Th4 <- subset(Theoph, Subject == 4) ## just for "checking" purposes -- permute the observations: Th4 <- Th4[sample(nrow(Th4)), ] fm1 <- nls(conc ~ SSfol(Dose, Time, lKe, lKa, lCl), data = Th4) ## Simple plotDS(Th4$Time, Th4$conc, fitted(fm1), sub = "Theophylline data - Subject 4 only", segP = list(lty=1,col=2), las = 1) ## Nicer: Draw the smoother not only at x = x[i] (observations): xsm <- unique(sort(c(Th4$Time, seq(0, 25, length = 201)))) ysm <- c(predict(fm1, newdata = list(Time = xsm))) plotDS(Th4$Time, Th4$conc, ys = list(x=xsm, y=ysm), sub = "Theophylline data - Subject 4 only", segP = list(lwd=2), las = 1) } \keyword{hplot} sfsmisc/man/TA.plot.Rd0000644000176200001440000000747013131443372014255 0ustar liggesusers\name{TA.plot} \alias{TA.plot} \title{Tukey-Anscombe Plot (Residual vs. Fitted) of a Linear Model} \description{ From a linear (or glm) model fitted, produce the so-called Tukey-Anscombe plot. Useful (optional) additions include: 0-line, lowess smooth, 2sigma lines, and automatic labeling of observations. } \usage{ TA.plot(lm.res, fit= fitted(lm.res), res= residuals(lm.res, type="pearson"), labels= NULL, main= mk.main(), xlab = "Fitted values", draw.smooth= n >= 10, show.call = TRUE, show.2sigma= TRUE, lo.iter = NULL, lo.cex= NULL, par0line = list(lty = 2, col = "gray"), parSmooth = list(lwd = 1.5, lty = 4, col = 2), parSigma = list(lwd = 1.2, lty = 3, col = 4), verbose = FALSE, \dots) } \arguments{ \item{lm.res}{Result of \code{\link{lm}(..)}, \code{\link{aov}(..)}, \code{\link{glm}(..)} or a similar object.} \item{fit}{fitted values; you probably want the default here.} \item{res}{residuals to use. Default: \bold{Weighted} ("Pearson") residuals if weights have been used for the model fit.} \item{labels}{strings to use as plotting symbols for each point. Default(\code{NULL}): extract observations' names or use its sequence number. Use, e.g., "*" to get simple \code{*} symbols. } \item{main}{main title to plot. Default: sophisticated, resulting in something like "Tukey-Anscombe Plot of : y \~ x" constructed from \code{lm.res $ call}. } \item{xlab}{x-axis label for plot.} \item{draw.smooth}{logical; if \code{TRUE}, draw a \code{lowess} smoother (with automatic smoothing fraction).} \item{show.call}{logical; if \code{TRUE}, write the "call"ing syntax with which the fit was done.} \item{show.2sigma}{logical; if \code{TRUE}, draw horizontal lines at \eqn{\pm 2\sigma}{+- 2 sigma} where \eqn{\sigma} is \code{mad(resid)}.} \item{lo.iter}{positive integer, giving the number of lowess robustness iterations. The default depends on the model and is \code{0} for non Gaussian \code{\link{glm}}'s.} \item{lo.cex}{character expansion ("cex") for lowess and other marginal texts.} \item{par0line}{a list of arguments (with reasonable defaults) to be passed to \code{\link{abline}(.)} when drawing the x-axis, i.e., the \eqn{y = 0} line.} \item{parSmooth, parSigma}{each a list of arguments (with reasonable default) for drawing the smooth curve (if \code{draw.smooth} is true), or the horizontal sigma boundaries (if \code{show.2sigma} is true) respectively.} \item{verbose}{logical indicating if some construction details should be reported (\code{\link{print}()}ed).} \item{\dots}{further graphical parameters are passed to \code{\link{n.plot}(.)}.} } \section{Side Effects}{ The above mentioned plot is produced on the current graphic device. } \author{Martin Maechler, Seminar fuer Statistik, ETH Zurich, Switzerland; \email{maechler@stat.math.ethz.ch} } \seealso{\code{\link{plot.lm}} which also does a QQ normal plot and more. } \examples{ data(stackloss) TA.plot(lm(stack.loss ~ stack.x)) example(airquality) summary(lmO <- lm(Ozone ~ ., data= airquality)) TA.plot(lmO) TA.plot(lmO, label = "O") # instead of case numbers if(FALSE) { %% from S-plus TA.plot(lm(cost ~ age+type+car.age, claims, weights=number, na.action=na.omit)) } ##--- for aov(.) : ------------- data(Gun, package = "nlme") TA.plot( aov(rounds ~ Method + Physique/Team, data = Gun)) ##--- Not so clear what it means for GLM, but: ------ if(require(rpart)) { # for the two datasets only data(solder, package = "rpart") TA.plot(glm(skips ~ ., data = solder, family = poisson), cex= .6) data(kyphosis, package = "rpart") TA.plot(glm(Kyphosis ~ poly(Age,2) + Start, data=kyphosis, family = binomial), cex=.75) # smaller title and plotting characters } } \keyword{models} \keyword{regression} sfsmisc/man/Deprecated.Rd0000644000176200001440000000176513020007125015022 0ustar liggesusers\name{Deprecated}% <<< would like "special name": don't check \arguments{} \title{Deprecated 'sfsmisc' Functions} % NOTE: ../R/Deprecated.R must be synchronized with this! % ~~~~~~~~~~~~~~~~~ \alias{pmax.sa} \alias{pmin.sa} % Move things from here to ./sfsmisc-defunct.Rd % ~~~~~~~~~~~~~~~~~~ % (and even older to ../Old_Defunct/ ) % %------ PLEASE: put \alias{.} here for EACH ! % \description{ These functions are provided for compatibility with older versions of the \pkg{sfsmisc} package only, and may be defunct as soon as of the next release. } \usage{ pmax.sa(scalar, arr) pmin.sa(scalar, arr) } \arguments{ \item{scalar}{numeric scalar.} \item{arr}{any numeric \R object, typically array.} } \details{ \code{pmax.sa(s, a)} and \code{pmin.sa(s, a)} return (more-dimensional) arrays. These have been deprecated, because \code{\link{pmax}} and \code{\link{pmin}} do so too, \bold{if} the array is used as \emph{first} argument. } \keyword{documentation} sfsmisc/man/KSd.Rd0000644000176200001440000000210107633225651013447 0ustar liggesusers\name{KSd} \alias{KSd} \title{Approximate Critical Values for Kolmogorov-Smirnov's D} \description{ Computes the critical value for Kolmogorov-Smirnov's \eqn{D_n}, for sample sizes \eqn{n \ge 10}{n >= 10} and confidence level 95\%. } \details{ Based on tables values given in the reference below. For \eqn{n\le 80}{n <= 80} uses interpolations from exact values, elsewhere uses asymptotic approximation. } \usage{ KSd(n) } \arguments{ \item{n}{the sample size, \code{n >= 10}.} } \value{ The critical value for D (two-sided) for significance level 0.05 (or confidence level 95\%). } \references{ Peter J. Bickel and Kjell A. Doksum (1977), \emph{Mathematical Statistics: Basic Ideas and Selected Topics}. Holden Day. Section 9.6 and table IX. } \author{Kjetil Halvorsen and Martin Maechler} \seealso{Is used from \code{\link{ecdf.ksCI}}.} \examples{ KSd(90) KSd(1:9)# now works op <- par(mfrow=c(2,1)) plot(KSd, 10, 150)# nice abline(v = c(75,85), col = "gray") plot(KSd, 79, 81, n = 1001)# *very* tiny discontinuity at 80 par(op) } \keyword{distribution} sfsmisc/man/rot2.Rd0000644000176200001440000000262210640133772013656 0ustar liggesusers\name{rot2} \encoding{latin1}% "^o" (degree) below \alias{rot2} \title{Rotate Planar Points by Angle} \description{ Rotate planar (xy) points by angle \code{phi} (in radians). } \usage{ rot2(xy, phi) } \arguments{ \item{xy}{numeric 2-column matrix, or coercable to one.} \item{phi}{numeric scalar, the angle in radians (i.e., \code{phi=pi} corresponds to 180 degrees) by which to rotate the points.} } \value{ A two column matrix as \code{xy}, containing the rotated points. } \author{Martin Maechler, Oct.1994} \examples{ ## Rotate three points by 60 degrees : (xy0 <- rbind(c(1,0.5), c(1,1), c(0,1))) (Txy <- rot2(xy0, phi = 60 * pi/180)) plot(xy0, col = 2, type = "b", asp = 1, xlim=c(-1,1), ylim=c(0,1.5), main = "rot2(*, pi/3) : 2d rotation by 60") points(Txy, col = 3, type = "b") O <- rep(0,2); P2 <- rbind(xy0[2,], Txy[2,]) arrows(O,O,P2[,1],P2[,2], col = "dark gray") xy0 <- .8*rbind(c(1,0), c(.5,.6), c(.7,1), c(1,1), c(.9,.8), c(1,0)) - 0.2 plot(xy0, col= 2, type="b", main= "rot2( , pi/4 * 1:7)", asp=1, xlim=c(-1,1),ylim=c(-1,1), lwd= 2, axes = FALSE, xlab="", ylab="") abline(h=0, v=0, col="thistle"); text(1.05, -.05, "x"); text(-.05,1.05, "y") for(phi in pi/4 * 0:7) do.call("arrows",c(list(0,0),rot2(xy0[2,], phi), length=0.1, col="gray40")) for(phi in pi/4 * 1:7) polygon(rot2(xy0, phi = phi), col = 1+phi/(pi/4), border=2, type = "b") } \keyword{manip} \keyword{math} sfsmisc/man/potatoes.Rd0000644000176200001440000000424710721014462014625 0ustar liggesusers\name{potatoes} \alias{potatoes} \docType{data} \title{Fisher's Potato Crop Data} \description{ Fisher's potato crop data set is of historical interest as an early example of a multi-factor block design. } \usage{data(potatoes)} \format{ A data frame with 64 observations on the following 5 variables. \describe{ \item{pos}{a factor with levels \code{1:4}.} \item{treat}{a factor with 16 levels \code{A} to \code{H} and \code{J} to \code{Q}, i.e., \code{LETTERS[1:17][-9]}.} \item{nitrogen}{a factor specifying the amount of nitrogen sulfate (\eqn{NH_4}), with the four levels \code{0,1,2,4}.} \item{potash}{a factor specifying the amount of potassium (K, \sQuote{kalium}) sulfate, with the four levels \code{0,1,2,4}.} \item{yield}{a numeric vector giving the yield of potatoes in ...}% << FIXME } } % \details{ % FIXME %% more details than the __description__ above ~~ % } %% ---- \source{ Bennett, J. H. (1972) \emph{Collected Papers of R. A. Fischer} vol.~II, 1925-31; The University of Adelaide. %% One of the blocks, in the book %% Stahel "Statist. Datenanalyse" Beisp.Kartoffelertrag (2nd ed. 251 a, 253 h) } \references{ T.Eden and R. A. Fisher (1929) Studies in Crop Variation. VI. Experiments on the Response of the Potato to Potash and Nitrogen. \emph{J. Agricultural Science} \bold{19}, 201--213. Accessible from Bennett (1972), see above. } \examples{ data(potatoes) ## See the experimental design: with(potatoes, { cat("4 blocks of experiments;", "each does every (nitrogen,potash) combination (aka 'treat'ment) once.", '', sep="\n") print(ftable(table(nitrogen, potash, treat))) print(ftable(tt <- table(pos,potash,nitrogen))) tt[cbind(pos,potash,nitrogen)] <- as.character(treat) cat("The 4 blocks pos = 1, 2, 3, 4:\n") ftable(tt) }) ## First plot: with(potatoes, interaction.plot(potash,nitrogen, response=yield)) ## ANOVAs: summary(aov(yield ~ nitrogen * potash + Error(pos), data = potatoes)) # "==>" can use simply summary(aov(yield ~ nitrogen + potash + pos, data = potatoes)) # and summary(aov(yield ~ nitrogen + potash, data = potatoes)) } \keyword{datasets} sfsmisc/man/eaxis.Rd0000644000176200001440000001724513651517202014107 0ustar liggesusers\name{eaxis} \alias{eaxis} \title{Extended / Engineering Axis for Graphics} \description{%% ---> ../R/prettylab.R An extended \code{\link[graphics]{axis}()} function which labels more prettily, in particular for log-scale axes. It makes use of \link{plotmath} or (LaTeX) \code{\link{expression}}s of the form \eqn{k \times 10^k}{k * 10^k} for labeling a log-scaled axis and when otherwise exponential formatting would be used (see \code{\link{pretty10exp}}). } \usage{ eaxis(side, at = if(log) axTicks(side, axp=axp, log=log, nintLog=nintLog) else axTicks(side, axp=axp, log=log), labels = NULL, log = NULL, use.expr = log || format.info(as.numeric(at), digits=7)[3] > 0, f.smalltcl = 3/5, at.small = NULL, small.mult = NULL, equidist.at.tol = 0.002, small.args = list(), draw.between.ticks = TRUE, between.max = 4, outer.at = TRUE, drop.1 = TRUE, sub10 = FALSE, las = 1, nintLog = max(10, par("lab")[2 - is.x]), axp = NULL, n.axp = NULL, max.at = Inf, lab.type = "plotmath", lab.sep = "cdot", \dots) } \arguments{ \item{side}{integer in 1:4, specifying side of \code{\link{axis}}.} \item{at}{numeric vector of (\dQuote{normalsized}) tick locations; by default \code{\link[graphics]{axTicks}(side, ..)}, i.e., the same as \code{\link{axis}()} would use.} \item{labels}{\code{NULL} (default), \code{\link{logical}}, \code{character} or \code{expression}, as in \code{\link{axis}()}; in addition, if \code{NA}, \code{labels = TRUE} is passed to \code{\link{axis}()}, i.e. \code{\link{pretty10exp}} is \emph{not} used. Use \code{FALSE} to suppress any labeling.} \item{log}{logical or \code{NULL} specifying if log-scale should be used; the default depends on the current plot's axis.} \item{use.expr}{logical specifying if \code{\link{pretty10exp}(.)} should be used for constructing \code{labels} when they are \code{NULL}. The default is typically good enough, but you may occasionally \emph{force} \code{use.expr = TRUE}.} \item{f.smalltcl}{factor specifying the lengths of the small ticks in proportion to the normalsized, labeled ticks.} \item{at.small}{locations of \emph{small} ticks; the default, \code{NULL}, uses \code{small.mult} and constructs \dQuote{smart} locations.} \item{small.mult}{positive integer (or \code{NULL}), used when \code{at.small} is NULL to indicate which multiples of \code{at} (typically \code{\link{axTicks}()}) should be used as \dQuote{small ticks}. The default \code{NULL} will use \code{9} in the log case and a number in 2:5 otherwise.}% depending on scale details \item{equidist.at.tol}{a small positive number, a tolerance to be used for checking equidistant \code{at} values. Used to be hardwired at \code{.001} which was seen to be too small; increase it when necessary.} \item{small.args}{optional \code{\link{list}} of further arguments to the (second) \code{\link{axis}()} call which draws the \emph{small} ticks.} \item{draw.between.ticks}{(only if \code{log} is true): logical indicating that possible (non-small) ticks between the labeled (via \code{at}) ones should be drawn as well (and possibly also used for \code{at.small} construction), see also \code{between.max}.} \item{between.max}{(only if \code{log} and \code{draw.between.ticks} are true): integer indicating ticks should be drawn (approximately) between the labeled ones.} \item{outer.at}{logical specifying that \code{at.small} should also be constructed outside the \code{at} range, but still inside the corresponding \code{\link{par}("usr")}.} \item{drop.1}{logical specifying if \eqn{1 \times}{1 *} should be dropped from labels, passed to \code{\link{pretty10exp}()}.} \item{sub10}{logical, integer (of length 1 or 2) or \code{"10"}, indicating if some \eqn{10^k} should be simplified to \dQuote{traditional} formats, see \code{\link{pretty10exp}}.} \item{nintLog}{only used in \R > 2.13.x, when \code{log} is true: approximate (lower bound on) number of intervals for log scaling.} \item{axp}{to be passed to \code{\link{axTicks}()} if \code{at} is not specified.} \item{n.axp}{to be set to \code{axp[3]} when \code{axp} and \code{at} are not specified, in order to tweak the \emph{number} of (non-small) tick marks produced from \code{\link{axTicks}(..)}, notably when \code{log} is true, set \code{n.axp} to 1, 2, or 3: \describe{ \item{1:}{will produce tick marks at \eqn{10^j} for integer \eqn{j},} \item{2:}{gives marks \eqn{k 10^j} with \eqn{k \in \{1, 5\}}{k in {1,5}},} \item{3:}{gives marks \eqn{k 10^j} with \eqn{k \in \{1, 2, 5\}}{k in {1,2,5}}} } see \code{'xaxp'} on the \code{\link{par}} help page.} \item{max.at}{maximal number of \code{at} values to be used effectively. If you don't specify \code{at} yourself carefully, it is recommended to set this to something like \code{25}, but this is not the default, for back compatibility reasons.} \item{las, \dots}{arguments passed to (the first) \code{\link{axis}} call. Note that the default \code{las = 1} differs from \code{axis}'s default \code{las = 0}.} \item{lab.type}{string, passed to \code{\link{pretty10exp}} to choose between default \code{\link{plotmath}} or LaTeX label format.} \item{lab.sep}{separator between mantissa and exponent for LaTeX labels, see \code{\link{pretty10exp}}.} } \author{Martin Maechler} \seealso{\code{\link[graphics]{axis}}, \code{\link[graphics]{axTicks}}, \code{\link{axTexpr}}, \code{\link{pretty10exp}}. } \examples{ x <- lseq(1e-10, 0.1, length = 201) plot(x, pt(x, df=3), type = "l", xaxt = "n", log = "x") eaxis(1) ## without small ticks: eaxis(3, at.small=FALSE, col="blue") ## If you like the ticks, but prefer traditional (non-"plotmath") labels: plot(x, gamma(x), type = "l", log = "x") eaxis(1, labels=NA) x <- lseq(.001, 0.1, length = 1000) plot(x, sin(1/x)*x, type = "l", xaxt = "n", log = "x") eaxis(1) eaxis(3, n.axp = 1)# -> xaxp[3] = 1: only 10^j (main) ticks ## non- log-scale : draw small ticks, but no "10^k" if not needed: x <- seq(-100, 100, length = 1000) plot(x, sin(x)/x, type = "l", xaxt = "n") eaxis(1) # default -> {1, 2, 5} * 10^j ticks eaxis(3, n.axp = 2)# -> xaxp[3] := 2 -- approximately two (main) ticks x <- seq(-1, 1, length = 1000) plot(x, sin(x)/x, type = "l", xaxt = "n") eaxis(1, small.args = list(col="blue")) x <- x/1000 plot(x, 1-sin(x)/x, type = "l", xaxt = "n", yaxt = "n") eaxis(1) eaxis(2) ## more labels than default: op <- par(lab=c(10,5,7)) plot(x, sin(x)/x, type = "l", xaxt = "n") eaxis(1) # maybe (depending on your canvas), there are too many, ## in that case, maybe use plot(x, sin(x)/x, type = "l", xaxt = "n") eaxis(1, axTicks(1)[c(TRUE,FALSE)]) # drop every 2nd label eaxis(3, labels=FALSE) ## ore use 'max.at' which thins as well: plot(x, sin(x)/x, type = "l", xaxt = "n") eaxis(1, max.at=6) par(op) ### Answering R-help "How do I show real values on a log10 histogram", 26 Mar 2013 ## the data: set.seed(1); summary(x <- rlnorm(100, m = 2, sdl = 3)) ## the plot (w/o x-axis) : r <- hist(log10(x), xaxt = "n", xlab = "x [log scale]") ## the nice axis: axt <- axTicks(1) eaxis(1, at = axt, labels = pretty10exp(10^axt, drop.1=TRUE)) ## Additionally demo'ing 'sub10' options: plot(r, xaxt="n") eaxis(1, at = axt, labels = pretty10exp(10^axt, drop.1=TRUE, sub10 = 2)) ## or plot(r, xaxt="n") eaxis(1, at = axt, labels = pretty10exp(10^axt, drop.1=TRUE, sub10 = "10")) ## or plot(r, xaxt="n") eaxis(1, at = axt, labels = pretty10exp(10^axt, drop.1=TRUE, sub10 = c(-2, 2))) } \keyword{aplot} % LocalWords: axp nintLog sfsmisc/man/p.tachoPlot.Rd0000644000176200001440000000536012575757743015210 0ustar liggesusers\name{p.tachoPlot} \alias{p.tachoPlot} \title{Draw Symbol on a Plot} \description{ Puts a symbol (pointer) on a plot at each of the specified locations. } \usage{ p.tachoPlot(x, y, z, angle=c(pi/4,3*pi/4), size, method = c("robust", "sensitive", "rank"), legend = TRUE, show.method = legend, xlab = deparse(substitute(x)), ylab = deparse(substitute(y)), xlim, ylim, \dots) } \arguments{ \item{x,y,z}{coordinates of points. Numeric vectors of the same length. Missing values (\code{NA}s) are allowed.} \item{angle}{numeric vector whose elements give the angles between the horizontal baseline and the minimum and maximum direction of the pointer measured clockwise in radians.} \item{size}{length of the pointers in cm.} \item{method}{string specifying the method to calculate the angle of the pointer. One of \code{"sensitive"}, \code{"robust"} or \code{"rank"}. Only the first two characters are necessary. The minimum and maximum direction of the pointer corresponds to min(z) and max(z) if method is \code{"sensitive"} or \code{"rank"} and to the upper and lower extreme of z if method is \code{"robust"} (see \code{boxplot} or \code{rrange} for details). The angle is proportional to z or rank(z) in case of \code{method="rank"}. } \item{legend}{logical flag: if \code{TRUE} (default), a legend giving the values of the minimum and maximum direction of the pointer is drawn.} \item{show.method}{logical flag, defaulting to \code{legend}; if true, the method name is printed.} \item{xlab,ylab}{labels for x and y axis; defaults to the \sQuote{expression} used in the function call.} \item{xlim,ylim}{numeric of length 2, the limits for the x and y axis, respectively; see \code{\link{plot.default}}.} \item{\dots}{further arguments to \code{\link{plot}}. Graphical parameters (see \code{\link{par}}) may also be supplied as arguments to this function.} } \section{Side Effects}{ A plot is created on the current graphics device. } \details{ A scatter plot of the variables x and y is plotted. The value of the third variable z is given by the direction of a pointer (similar to a tachometer). Observations whose z-coordinate is missing are marked by a dot. } \author{Christian Keller, June 1995} \seealso{\code{\link{symbols}}} \examples{ data(state) data(USArrests) p.tachoPlot(state.center $x, state.center $y, USArrests[,"UrbanPop"]) data(mtcars) par(mfrow=c(2,2)) ## see the difference between the three methods (not much differ. here!) %% hence, IMPROVE the example ! p.tachoPlot(mtcars$hp, mtcars$disp, mtcars$mpg, method="sens") p.tachoPlot(mtcars$hp, mtcars$disp, mtcars$mpg, method="rank") p.tachoPlot(mtcars$hp, mtcars$disp, mtcars$mpg, method="rob") } \keyword{hplot} sfsmisc/man/helppdf.Rd0000644000176200001440000000220014117732134014402 0ustar liggesusers\name{helppdf} \alias{helppdf} \title{help() Type="pdf" and View It} \description{ Utility to view PDF-rendered \code{\link{help}} pages; particularly useful in case they contain mathematical formulas or otherwise sophisticated formats. } \usage{ helppdf(topic, viewer = getOption("pdfviewer"), quiet = !interactive(), ...) } \arguments{ \item{topic}{the topic, passed to \code{\link{help}()}.} \item{viewer}{a pdf viewer; the default is typically what you want interactively.} \item{quiet}{\code{\link{logical}} indicating that nothing should be printed to the console and the result should be returned as \code{\link{invisible}()}.} \item{\dots}{further optional arguments passed to \code{help()}.} } \value{ Returns the full path of the pdf file produced. } \author{Martin Maechler} \seealso{ \code{\link{help}}, \code{\link{system}}. } \examples{ ## Both calls work : if(interactive()) { helppdf(Normal) helppdf("NegBinomial") } else { # batch mode od <- setwd(tempdir()) ff <- helppdf(Normal, viewer=NULL) stopifnot(file.exists(ff)) setwd(od)# revert to previous dir. } } \keyword{utilities} \keyword{print} sfsmisc/man/ellipsePoints.Rd0000644000176200001440000000503012462442610015614 0ustar liggesusers\name{ellipsePoints} \alias{ellipsePoints} \title{Compute Radially Equispaced Points on Ellipse} \description{ Compute points on (the boundary of) an ellipse which is given by elementary geometric parameters. } \usage{ ellipsePoints(a, b, alpha = 0, loc = c(0, 0), n = 201, keep.ab.order=FALSE) } \arguments{ \item{a,b}{length of half axes in (x,y) direction. Note that \eqn{(a,b)} is equivalent to \eqn{(b,a)} \emph{unless} \code{keep.ab.order=TRUE}.} \item{alpha}{angle (in degrees) giving the orientation of the ellipse, i.e., the original (x,y)-axis ellipse is rotated by \code{angle}.} \item{loc}{center (LOCation) of the ellipse.} \item{n}{number of points to generate.} \item{keep.ab.order}{logical indicating if \eqn{(a,b)} should be considered \emph{ordered}. When \code{FALSE}, as per default, the orientation of the ellipse is solely determined by \code{alpha}. Note that \code{keep.ab.order = TRUE} seems a more natural default, but \code{FALSE} is there for back-compatibility.} } \value{ A numeric matrix of dimension \code{n x 2}, each row containing the (x,y) coordinates of a point. } \author{Martin Maechler, March 2002.} \seealso{the \file{ellipse} package and \code{\link[cluster]{ellipsoidhull}} and \code{\link[cluster]{ellipsoidPoints}} in the \file{cluster} package. } \examples{ ## Simple Ellipse, centered at (0,0), x-/y- axis parallel: ep <- ellipsePoints(5,2) str(ep) plot(ep, type="n",asp=1) ; polygon(ep, col = 2) ## (a,b) = (2,5) is equivalent to (5,2) : lines(ellipsePoints(2,5), lwd=2, lty=3) ## keep.order=TRUE : Now, (2,5) are axes in x- respective y- direction: lines(ellipsePoints(2,5, keep.ab.order=TRUE), col="blue") ## rotate by 30 degrees : plot(ellipsePoints(5,2, alpha = 30), asp=1) abline(h=0,v=0,col="gray") abline(a=0,b= tan( 30 *pi/180), col=2, lty = 2) abline(a=0,b= tan(120 *pi/180), col=3, lty = 2) ## NB: use x11(type = "Xlib") for the following if you can if(dev.interactive(TRUE)) { ## Movie : rotating ellipse : nTurns <- 4 # #{full 360 deg turns} for(al in 1:(nTurns*360)) { ep <- ellipsePoints(3,6, alpha=al, loc = c(5,2)) plot(ep,type="l",xlim=c(-1,11),ylim=c(-4,8), asp=1, axes = FALSE, xlab="", ylab="") } ## Movie : rotating _filled_ ellipse {less nice to look at} for(al in 1:180) { ep <- ellipsePoints(3,6, alpha=al, loc = c(5,2)) plot(ep,type="n",xlim=c(-1,11),ylim=c(-4,8), asp=1, axes = FALSE, xlab="", ylab="") polygon(ep,col=2,border=3,lwd=2.5) } }# only if interactive } \keyword{iplot} \keyword{utilities} sfsmisc/man/plotStep.Rd0000644000176200001440000000520512560614001014572 0ustar liggesusers% Originally /u/maechler/S/GRAPHICS/plot.step.d,v 1.2 1997/05/27 10:17:27 % Copyright (c), 1991, 1997 Martin Maechler, Statistik, ETH Zurich % Martin Maechler \name{plotStep} \encoding{latin1} \alias{plotStep} \title{Plot a Step Function} \description{ Plots a step function f(x)= \eqn{\sum_i y_i 1_[ t_{i-1}, t_i ](x) }{sum(i; y[i] * Ind[t[i-1], t[i])(x))}, i.e., a piecewise constant function of one variable. With one argument, plots \bold{the} empirical cumulative distribution function. } \usage{ plotStep(ti, y, cad.lag = TRUE, verticals = !cad.lag, left.points= cad.lag, right.points= FALSE, end.points= FALSE, add = FALSE, pch = par('pch'), xlab=deparse(substitute(ti)), ylab=deparse(substitute(y)), main=NULL, \dots) } \arguments{ \item{ti}{numeric vector = \code{X[1:N]} or \code{t[0:n]}.} \item{y}{numeric vector \code{y[1:n]}; if omitted take y = k/N for empirical CDF.} \item{cad.lag}{logical: Draw 'cad.lag', i.e., \dQuote{\emph{continue droite, limite gauche}}. Default = TRUE.} \item{verticals}{logical: Draw vertical lines? Default= \code{! cad.lag}} \item{left.points}{logical: Draw left points? Default= \code{cad.lag}} \item{right.points}{logical: Draw right points? Default= \code{FALSE}} \item{end.points}{logical: Draw 2 end points? Default= \code{FALSE}} \item{add}{logical: Add to existing plot? Default= \code{FALSE}} \item{pch}{plotting character for points, see \code{\link{par}()}.} \item{xlab,ylab}{labels of x- and y-axis} \item{main}{main title; defaults to the call' if you do not want a title, use \code{main = ""}.} \item{\dots}{Any valid argument to \code{\link{plot}(..)}.} } \value{ \bold{invisibly}: List with components \code{t} and \code{y}. } \section{Side Effects}{ Calls plot(..), points(..), segments(..) appropriately and plots on current graphics device. } \author{Martin Maechler, Seminar for Statistics, ETH Zurich, \email{maechler@stat.math.ethz.ch}, 1991 ff. } \seealso{ The \code{\link{plot}} methods \code{\link{plot.ecdf}} and \code{\link{plot.stepfun}} in \R which are conceptually nicer. \code{\link{segments}(\dots, method = "constant")}. } \examples{ ##-- Draw an Empirical CDF (and see the default title ..) plotStep(rnorm(15)) plotStep(runif(25), cad.lag=FALSE) plotStep(runif(25), cad.lag=FALSE, add=TRUE, lty = 2) ui <- sort(runif(20)) plotStep(ui, ni <- cumsum(rpois(19, lambda=1.5) - 1.5), cad.lag = FALSE) plotStep(ui, ni, verticals = TRUE, right.points = TRUE) plotStep(rnorm(201), pch = '.') #- smaller points } \keyword{nonparametric} \keyword{hplot} sfsmisc/man/cum.Vert.funkt.Rd0000644000176200001440000000273011340445434015620 0ustar liggesusers\name{cum.Vert.funkt} \alias{cum.Vert.funkt} \title{Kumulative Verteilung Aufzeichnen} \description{ Kumulative Verteilung von \code{x} aufzeichnen, auf Wunsch auch Median und Quartile. This is just an old German language version of \code{\link[stats]{plot.ecdf}()} used for teaching at ETHZ. } \usage{ cum.Vert.funkt(x, Quartile = TRUE, titel = TRUE, Datum = TRUE, rang.axis = n <= 20, xlab = "", main = "", \dots) } \arguments{ \item{x}{numeric vector whose empirical distribution should be plotted.} \item{Quartile}{logical indicating if all 3 non-trivial quartiles should be drawn.} \item{titel}{logical indicating if a German title should be drawn.} \item{Datum}{logical indicating if \code{\link{p.datum}} should be added.} \item{rang.axis}{logical indicating if all the ranks should be marked at the y-axis. Defaults to true if there are not more than 20 observations.} \item{xlab, main}{x-axis label and main title; default to empty.} \item{\dots}{optional further arguments, passed to \code{\link{plotStep}}.} } \value{ the return value of \code{\link{plotStep}()} which is called internally, \emph{invisibly}. } \author{Martin Maechler et al.} \seealso{\code{\link{plotStep}} on which it is based; but you should really consider using \code{\link[stats]{plot.ecdf}()} from the \pkg{stats} package instead of this.} \examples{ cum.Vert.funkt(runif(12)) cum.Vert.funkt(runif(20)) Z <- rnorm(50) cum.Vert.funkt(Z) } \keyword{hplot} sfsmisc/man/cairoSwd.Rd0000644000176200001440000000156612347332025014547 0ustar liggesusers\name{cairoSwd} \alias{cairoSwd} \title{Cairo PDF Graphics Device useful for Sweave} \description{ Provides a graphics device for Sweave, based on \code{\link{cairo_pdf}}. The advantage of \code{cairoSwd()} compared to \code{\link{pdf}()} is its support of Unicode characters. } \usage{ cairoSwd(name, width, height, ...) } \arguments{ \item{name}{file name prefix to which \file{.pdf} will be appended.} \item{width, height}{in inches, see \code{\link{cairo_pdf}}.} \item{\dots}{further arguments, passed to \code{\link{cairo_pdf}()}} } \note{ Sweave devices need to have an argument list as above. Usage in a Sweave chunk: \preformatted{ <>= } } \author{Alain Hauser} %% \details{ %% } %% \references{ %% } \seealso{ \code{\link{pdf}}, \code{\link{cairo_pdf}}, \code{\link{Sweave}}. } %% \examples{ %% } \keyword{device} sfsmisc/man/polyn.eval.Rd0000644000176200001440000000272213246037205015057 0ustar liggesusers\name{polyn.eval} \alias{polyn.eval} \title{Evaluate Polynomials} \description{ Evaluate one or several univariate polynomials at several locations, i.e. compute \code{coef[1] + coef[2]*x + ... + coef[p+1]* x^p} (in the simplest case where \code{x} is scalar and \code{coef} a vector). } \usage{ polyn.eval(coef, x) } \arguments{ \item{coef}{numeric vector or matrix. If a vector, \code{x} can be an array and the result matches \code{x}.\cr If \code{coef} is a matrix it specifies several polynomials of the same degree as rows, \code{x} must be a vector, \code{coef[,k]} is for \eqn{x^{k-1}}{x^(k-1)} and the result is a matrix of dimension \code{length(x) * nrow(coef)}.} \item{x}{numeric vector or array. Either \code{x} or \code{coef} must be a vector.} } \details{ The stable \dQuote{Horner rule} is used for evaluation in any case. } \value{ numeric vector or array, depending on input dimensionalities, see above. } \author{Martin Maechler, ages ago.} \seealso{For much more sophisticated handling of polynomials, use the \CRANpkg{polynom} package, see, e.g., \code{\link[polynom]{predict.polynomial}}. For multivariate polynomials (and also for nice interface to the \CRANpkg{orthopolynom} package), consider the \CRANpkg{mpoly} package. } \examples{ polyn.eval(c(1,-2,1), x = 0:3)# (x - 1)^2 polyn.eval(c(0, 24, -50, 35, -10, 1), x = matrix(0:5, 2,3))# 5 zeros! (cf <- rbind(diag(3), c(1,-2,1))) polyn.eval(cf, 0:5) } \keyword{arith} sfsmisc/man/diagDA.Rd0000644000176200001440000000742613246037205014107 0ustar liggesusers\name{diagDA} \title{Diagonal Discriminant Analysis} \alias{diagDA} \alias{dDA} \alias{print.dDA} \alias{predict.dDA} \keyword{naive Bayes classifier} \description{ This function implements a simple Gaussian maximum likelihood discriminant rule, for diagonal class covariance matrices. In machine learning lingo, this is called \dQuote{Naive Bayes} (for continuous predictors). Note that naive Bayes is more general, as it models discrete predictors as multinomial, i.e., binary predictor variables as Binomial / Bernoulli. } \usage{ dDA(x, cll, pool = TRUE) \method{predict}{dDA}(object, newdata, pool = object$pool, \dots) \method{print}{dDA}(x, \dots) diagDA(ls, cll, ts, pool = TRUE) } \arguments{ \item{x,ls}{learning set data matrix, with rows corresponding to cases (e.g., mRNA samples) and columns to predictor variables (e.g., genes).} \item{cll}{class labels for learning set, must be consecutive integers.} \item{object}{object of class \code{dDA}.} \item{ts, newdata}{test set (prediction) data matrix, with rows corresponding to cases and columns to predictor variables.} \item{pool}{logical flag. If true (by default), the covariance matrices are assumed to be constant across classes and the discriminant rule is linear in the data. Otherwise (\code{pool= FALSE}), the covariance matrices may vary across classes and the discriminant rule is quadratic in the data.} \item{\dots}{further arguments passed to and from methods.} } \value{ \code{dDA()} returns an object of class \code{dDA} for which there are \code{\link{print}} and \code{\link{predict}} methods. The latter returns the same as \code{diagDA()}: \code{diagDA()} returns an integer vector of class predictions for the test set. } \references{ S. Dudoit, J. Fridlyand, and T. P. Speed. (2000) Comparison of Discrimination Methods for the Classification of Tumors Using Gene Expression Data. (Statistics, UC Berkeley, June 2000, Tech Report \#576) } \author{% grep: Sandrine Dudoit, Jane Fridlyand, and Martin Maechler Sandrine Dudoit, \email{sandrine@stat.berkeley.edu} and\cr Jane Fridlyand, \email{janef@stat.berkeley.edu} originally wrote \code{stat.diag.da()} in CRAN package \CRANpkg{sma} which was modified for speedup by Martin Maechler \email{maechler@R-project.org} who also introduced \code{dDA} etc. } \seealso{\code{\link[MASS]{lda}} and \code{\link[MASS]{qda}} from the \CRANpkg{MASS} package; \code{\link[e1071]{naiveBayes}} from \CRANpkg{e1071}. } \examples{ ## two artificial examples by Andreas Greutert: d1 <- data.frame(x = c(1, 5, 5, 5, 10, 25, 25, 25, 25, 29), y = c(4, 1, 2, 4, 4, 4, 6:8, 7)) n.plot(d1) library(cluster) (cl1P <- pam(d1,k=4)$cluster) # 4 surprising clusters with(d1, points(x+0.5, y, col = cl1P, pch =cl1P)) i1 <- c(1,3,5,6) tr1 <- d1[-i1,] cl1. <- c(1,2,1,2,1,3) cl1 <- c(2,2,1,1,1,3) plot(tr1, cex=2, col = cl1, pch = 20+cl1) (dd.<- diagDA(tr1, cl1., ts = d1[ i1,]))# ok (dd <- diagDA(tr1, cl1 , ts = d1[ i1,]))# ok, too! points(d1[ i1,], pch = 10, cex=3, col = dd) ## use new fit + predict instead : (r1 <- dDA(tr1, cl1)) (r1.<- dDA(tr1, cl1.)) stopifnot(dd == predict(r1, new = d1[ i1,]), dd.== predict(r1., new = d1[ i1,])) plot(tr1, cex=2, col = cl1, bg = cl1, pch = 20+cl1, xlim=c(1,30), ylim= c(0,10)) xy <- cbind(x= runif(500, min=1,max=30), y = runif(500, min=0, max=10)) points(xy, cex= 0.5, col = predict(r1, new = xy)) abline(v=c( mean(c(5,25)), mean(c(25,29)))) ## example where one variable xj has Var(xj) = 0: x4 <- matrix(c(2:4,7, 6,8,5,6, 7,2,3,1, 7,7,7,7), ncol=4) y <- c(2,2, 1,1) m4.1 <- dDA(x4, y, pool = FALSE) m4.2 <- dDA(x4, y, pool = TRUE) xx <- matrix(c(3,7,5,7), ncol=4) predict(m4.1, xx)## gave integer(0) previously predict(m4.2, xx) } \keyword{models} \keyword{classif} sfsmisc/man/errbar.Rd0000644000176200001440000000242413246037205014244 0ustar liggesusers\name{errbar} \encoding{latin1} \title{Scatter Plot with Error Bars} \alias{errbar} \description{ Draws a scatter plot, adding vertical \dQuote{error bars} to all the points. } \usage{ errbar(x, y, yplus, yminus, cap = 0.015, ylim = range(y,yplus,yminus), xlab= deparse(substitute(x)), ylab= deparse(substitute(y)), \dots) } \arguments{ \item{x}{vector of x values.} \item{y}{vector of y values.} \item{yplus}{vector of y values: the tops of the error bars.} \item{yminus}{vector of y values: the bottoms of the error bars.} \item{cap}{the width of the little lines at the tops and bottoms of the error bars in units of the width of the plot. Default is 0.015.} \item{ylim}{(numeric of length 2): the y-axis extents with a sensible default.} \item{xlab, ylab}{axis labels for the plot, as in \code{\link{plot.default}}.} \item{\dots}{Graphical parameters (see \code{\link{par}}) may also be supplied as arguments to this function.} } \author{Originally Charles Geyer, U.Chicago, early 1991; then Martin Mchler.} \seealso{\code{\link[Hmisc]{errbar}} in package \CRANpkg{Hmisc} is similar. %% maybe deprecate ours? FIXME } \examples{ y <- rnorm(10); d <- 1 + .1*rnorm(10) errbar(1:10, y, y + d, y - d, main="Error Bars example") } \keyword{hplot} sfsmisc/man/linesHyberb.lm.Rd0000644000176200001440000000267007624254002015646 0ustar liggesusers\name{linesHyperb.lm} \alias{linesHyperb.lm} \title{Plot Confidence or Prediction Hyperbolas around a Regression Line} \description{ Add confidence/prediction hyperbolas for \eqn{y(x_0)} to a plot with data or regression line. } \usage{ linesHyperb.lm(object, c.prob=0.95, confidence=FALSE, k=if (confidence) Inf else 1, col=2, lty=2, do.abline=TRUE) } \arguments{ \item{object}{result of \code{\link{lm}(.)}.} \item{c.prob}{coverage probability in \eqn{(0,1)}.} \item{confidence}{logical; if true, do (small) confidence band, else, realistic prediction band for the mean of \code{k} observations.} \item{k}{integer or \code{Inf}; assume \code{k} future observations; \code{k = Inf} corresponds to confidence intervals (for y).} \item{col, lty}{attributes for the \code{\link{lines}} to be drawn.} \item{do.abline}{logical; if true, the regression line is drawn as well.} } \note{ With \code{\link{predict.lm}(*, interval=)} is available, this function \code{linesHyperb.lm} is only slightly more general for its \code{k} argument. } \author{Martin Maechler, Oct 1995} \seealso{\code{\link{predict.lm}(*, interval=)} optionally computes prediction or confidence intervals.} \examples{ data(swiss) plot(Fertility ~ Education, data = swiss) # the data (lmS <- lm(Fertility ~ Education, data = swiss)) linesHyperb.lm(lmS) linesHyperb.lm(lmS, conf=TRUE, col="blue") } \keyword{regression} \keyword{aplot} sfsmisc/man/u.Datumvonheute.Rd0000644000176200001440000000252312575757743016106 0ustar liggesusers\name{u.Datumvonheute} \alias{u.Datumvonheute} \alias{C.Monatsname} \alias{C.Wochentag} \alias{C.Wochentagkurz} \alias{C.weekday} \title{Datum und Uhrzeit (auf deutsch)} \description{ Return current date and time as a string, possibly including day of the week in \emph{German}. } \usage{ u.Datumvonheute(W.tag=2, Zeit=FALSE) C.Monatsname C.Wochentag C.Wochentagkurz C.weekday } \arguments{ \item{W.tag}{logical or integer specifying you want weekday (\sQuote{Wochentag}). \code{0} or \code{FALSE} gives no, \code{1} or \code{TRUE} gives a short and \code{2} the long version of the day of the week.} \item{Zeit}{logical or integer specifying if time ("Zeit") is desired. \code{0} or \code{FALSE} gives no, \code{1} or \code{TRUE} gives a hours only and \code{2} hours and minutes.} } \value{ A string with the current date/time, in the form specified by the arguments. The \code{C.*} are \code{\link{character}} vector \dQuote{constants}, the German ones actually used by \code{u.Datumvonheute}. } \author{Caterina Savi, Martin Maechler} \seealso{\code{\link{u.date}} for a similar English version, and \code{\link{p.datum}} which plots. For English month names, etc \code{\link{month.name}}. } \examples{ u.Datumvonheute() u.Datumvonheute(W.tag=1, Zeit=TRUE) u.Datumvonheute(W.tag= FALSE, Zeit=2) } \keyword{utilities} sfsmisc/man/iterate.lin.recursion.Rd0000644000176200001440000000311112575757743017233 0ustar liggesusers\name{iterate.lin.recursion} \alias{iterate.lin.recursion} \title{Generate Sequence Iterating a Linear Recursion} \description{ Generate numeric sequences applying a linear recursion \code{nr.it} times. } \usage{ iterate.lin.recursion(x, coeff, delta = 0, nr.it) } \arguments{ \item{x}{numeric vector with \emph{initial values}, i.e., specifying the beginning of the resulting sequence; must be of length (larger or) equal to \code{length(coeff)}.} \item{coeff}{coefficient vector of the linear recursion.} \item{delta}{numeric scalar added to each term; defaults to 0. If not zero, determines the linear drift component.} \item{nr.it}{integer, number of iterations.} } \value{ numeric vector, say \code{r}, of length \code{n + nr.it}, where \code{n = length(x)}. Initialized as \code{r[1:n] = x}, the recursion is \code{r[k+1] = sum(coeff * r[(k-m+1):k])}, where \code{m = length(coeff)}. } \note{ Depending on the zeroes of the characteristic polynomial of \code{coeff}, there are three cases, of convergence, oszillation and divergence. } \author{Martin Maechler} \seealso{\code{\link{seq}} can be regarded as a trivial special case.} \examples{ ## The Fibonacci sequence: iterate.lin.recursion(0:1, c(1,1), nr = 12) ## 0 1 1 2 3 5 8 13 21 34 55 89 144 233 ## seq() as a special case: stopifnot(iterate.lin.recursion(4,1, d=2, nr=20) == seq(4, by=2, length=1+20)) ## ''Deterministic AR(2)'' : round(iterate.lin.recursion(1:4, c(-0.7, 0.9), d = 2, nr=15), dig=3) ## slowly decaying : plot(ts(iterate.lin.recursion(1:4, c(-0.9, 0.95), nr=150))) } \keyword{arith} sfsmisc/man/u.log.Rd0000644000176200001440000000216211131753061014006 0ustar liggesusers\name{u.log} \alias{u.log} \title{(Anti)Symmetric Log High-Transform} \description{ Compute \eqn{log()} only for high values and keep low ones -- antisymmetrically such that \code{u.log(x)} is (once) continuously differentiable, it computes %Fails \deqn{f(x) = \left\{\begin{array}{ll} %Fails x & for |x| \leq c \\ %Fails sign(x) c (1 + \log(|x|/c)) & for |x| > c \end{array}}{% %Fails f(x) = x for |x| <= c and sign(x)*c*(1 + log(|x|/c)) for |x| >= c.} \eqn{f(x) = x} for \eqn{|x| \le c}{|x| <= c} and \eqn{sign(x) c\cdot(1 + log(|x|/c))}{sign(x)*c*(1 + log(|x|/c))} for \eqn{|x| \ge c}{|x| >= c}. } \usage{ u.log(x, c = 1) } \arguments{ \item{x}{numeric vector to be transformed.} \item{c}{scalar, > 0} } \value{ numeric vector of same length as \code{x}. } \author{Martin Maechler, 24 Jan 1995} %\seealso{ ~~objects to SEE ALSO as \code{\link{~~fun~~}}, ~~~ } \examples{ curve(u.log, -3, 10); abline(h=0, v=0, col = "gray20", lty = 3) curve(1 + log(x), .01, add = TRUE, col= "brown") # simple log curve(u.log(x, 2), add = TRUE, col=2) curve(u.log(x, c= 0.4), add = TRUE, col=4) } \keyword{arith} sfsmisc/man/missingCh.Rd0000644000176200001440000000336712560614001014713 0ustar liggesusers\name{missingCh} \alias{missingCh} \title{Has a Formal Argument been Set or is it Missing?} \description{ \code{missingCh} can be used to test whether a value was specified as an argument to a function. Very much related to the standard \R function \code{\link{missing}}, here the argument is given by its name, a character string. As \code{missingCh()} calls \code{missing()}, do consider the caveats about the latter, see \code{\link{missing}}. } \usage{ missingCh(x, envir = parent.frame()) } \arguments{ \item{x}{a \code{\link{character}} string.} \item{envir}{a (function evaluation) \code{\link{environment}}, in which the variable named \code{x} is to be \dQuote{missing}.} } \value{ a \code{\link{logical}} indicating if the argument named \code{x} is \code{\link{missing}} in the function \dQuote{above}, typically the caller of \code{missingCh}, but see the use of \code{envir} in the \code{vapply} example. } \author{Martin Maechler} \seealso{ \code{\link{missing}} } \examples{ tst1 <- function(a, b, dd, ...) ## does not work an with argument named 'c' ! c(b = missingCh("b"), dd = missingCh("dd")) tst1(2)#-> both 'b' and 'dd' are missing tst1(,3,,3) ## b dd ## FALSE TRUE -- as 'b' is not missing but 'dd' is. Tst <- function(a,b,cc,dd,EEE, ...) vapply(c("a","b","cc","dd","EEE"), missingCh, NA, envir=environment()) Tst() ## TRUE ... TRUE -- as all are missing() Tst(1,,3) ## a b cc dd EEE ## FALSE TRUE FALSE TRUE TRUE ## ..... ..... ## as 'a' and 'cc' where not missing() ## Formal testing: stopifnot(tst1(), !tst1(,3,3), Tst(), Tst(1,,3, b=2, E="bar") == c(0,0,1,0,0)) ## maybe surprising that this ^^ becomes 'dd' and only 'cc' is missing } \keyword{programming} sfsmisc/man/p.datum.Rd0000644000176200001440000000105312575757743014360 0ustar liggesusers\name{p.datum} \alias{p.datum} \title{Plot 'Datum' (deutsch!) unten rechts} \description{ Plot the date (and time, if required) in German, at the lower right hand margin of your plot.date } \usage{ p.datum(outer = FALSE, cex = 0.75, ...) } \arguments{ \item{outer}{logical; passed to \code{\link{mtext}}.} \item{cex}{non-negative; passed to \code{\link{mtext}}.} \item{\dots}{any arguments to \code{\link{u.Datumvonheute}}.} } \seealso{\code{\link{u.date}}, \code{\link{date}}.} \examples{ plot(1) p.datum() } \keyword{hplot}%-- one or more ... sfsmisc/man/empty.dimnames.Rd0000644000176200001440000000117512560614001015714 0ustar liggesusers\name{empty.dimnames} \alias{empty.dimnames} \title{Empty Dimnames of an Array} \description{ Remove all dimension names from an array for compact printing. } \usage{ empty.dimnames(a) } \arguments{ \item{a}{an \code{\link{array}}, i.e., as special case a matrix.} } \value{ Returns \code{a} with its dimnames replaced by empty character strings. } \author{Bill Venables / Martin Maechler, Sept 1993.} \seealso{\code{\link{unname}} \emph{removes} the dimnames.} \examples{ empty.dimnames(diag(5)) # looks much nicer (a <- matrix(-9:10, 4,5)) empty.dimnames(a) # nicer, right? } \keyword{array} \keyword{print} \keyword{utilities} sfsmisc/man/relErr.Rd0000644000176200001440000000615414116672526014236 0ustar liggesusers\name{relErr} \title{Relative Error When Appropriate, Absolute Otherwise} \alias{relErrV} \alias{relErr} \description{ \describe{ \item{\code{relErrV()}:}{ Compute the signed relative error componentwise (\dQuote{vectorized}) between the \code{target} and \code{current} vectors, using the \emph{absolute} error, i.e., the difference in case the relative error is not well defined, i.e., when \code{target} is zero or infinite.} \item{\code{relErr()}:}{simply the \emph{mean} absolute value of the relative errors between \code{target} and \code{current} vectors; typically the \dQuote{same} as \code{\link{all.equal.numeric}(target, vector, tolerance=0, countEQ=TRUE)}. Currently useful only when both vectors are finite. } } } \usage{ relErrV(target, current, eps0 = .Machine$double.xmin) relErr (target, current) } \arguments{ \item{target}{numeric, possibly scalar.} \item{current}{numeric vector of \code{\link{length}()} a multiple of \code{length(target)}.} \item{eps0}{non-negative number; values \code{abs(target) < eps0} should be treated as zero (and hence \emph{absolute} instead of relative error be computed). This may be crucial when \code{target} is an \code{"mpfr"}-number vector.} } \value{ \describe{ \item{\code{relErrV()}:}{a numeric vector of the same length as \code{current}.} \item{\code{relErr()}:}{a single number.} } } \author{Martin Maechler, originally as part of \CRANpkg{Matrix} package's \file{test-tools.R}. } \seealso{ \code{\link{all.equal.numeric}()} is similar in spirit but returns \code{TRUE} or string containing the \emph{mean} relative or absolute error. } \examples{ ## relErrV() test example: showing how it works fine with {NA, Inf, 0} : eps <- 1e-4*c(-9, -8, -6, -4, 0.5, 1, 5) target <- c(-1:1, 0, 0, NA, NaN, Inf, -Inf, Inf, 0 , Inf, 1 , -3:3) current <- c(-1:1,1e-7,NaN,NA, 0 , Inf, Inf, 0, Inf, 1, Inf, -3:3+ eps) cbind(target, current, absE = current-target, relE = relErrV(target,current)) -> M ; M stopifnot(exprs = { is.logical(isFr <- is.finite(rF <- M[,"relE"])) target==current | isFr == is.finite(aF <- M[,"absE"]) identical(aF[!isFr] , rF[!isFr]) identical(numeric(), relErrV(numeric(), integer())) # length 0 {used to fail} }) tools::assertError(relErrV(1, numeric()), verbose=TRUE) # no longer allowed ## relErr() is pretty simple --- (possibly too simple, currently) relErr relErr(target, current) # NA (of course) all.equal.numeric(target, current) ## "'is.NA' value mismatch ..." ## comparison after dropping NA's : hasN <- is.na(target) | is.na(current) all.equal(target[!hasN], current[!hasN], tolerance=0) # "Mean abs. diff.: Inf" relErr(target[!hasN], current[!hasN]) # NaN (to improve?) ## comparison after only keeping cases where both are finite: finN <- is.finite(target) & is.finite(current) all.equal(target[finN], current[finN], tol=0) # "Mean abs.d.: 0.000279.." all.equal(target[finN], current[finN], tol=0, countEQ=TRUE) # " " : 0.000239.. relErr(target[finN], current[finN]) # 0.0002392929 } \keyword{arith} \keyword{utilities} sfsmisc/man/Duplicated.Rd0000644000176200001440000000372313246037205015050 0ustar liggesusers\name{Duplicated} \alias{Duplicated} \title{Counting-Generalization of duplicated()} \description{ Duplicated() generalizes the \code{\link{duplicated}} method for vectors, by returning indices of \dQuote{equivalence classes} for duplicated entries and returning \code{nomatch} (\code{NA} by default) for unique entries. Note that \code{duplicated()} is not \code{TRUE} for the first time a duplicate appears, whereas \code{Duplicated()} only marks unique entries with \code{nomatch} (\code{NA}). } \usage{ Duplicated(v, incomparables = FALSE, fromLast = FALSE, nomatch = NA_integer_) } \arguments{ \item{v}{a vector, often character, factor, or numeric.} \item{incomparables}{a vector of values that cannot be compared, passed to both \code{\link{duplicated}()} and \code{\link{match}()}. \code{FALSE} is a special value, meaning that all values can be compared, and may be the only value accepted for methods other than the default. It will be coerced internally to the same type as \code{x}.} \item{fromLast}{logical indicating if duplication should be considered from the reverse side, i.e., the last (or rightmost) of identical elements would correspond to \code{duplicated=FALSE}.} \item{nomatch}{passed to \code{\link{match}()}: the value to be returned in the case when no match is found. Note that it is coerced to \code{integer}.} } \value{ an integer vector of the same length as \code{v}. Can be used as a \code{\link{factor}}, e.g., in \code{\link{split}}, \code{\link{tapply}}, etc. } \author{Christoph Buser and Martin Maechler, Seminar fuer Statistik, ETH Zurich, Sep.2007} \seealso{\code{\link{uniqueL}} (also in this \pkg{sfsmisc} package); \code{\link{duplicated}}, \code{\link{match}}. } \examples{ x <- c(9:12, 1:4, 3:6, 0:7) data.frame(x, dup = duplicated(x), dupL= duplicated(x, fromLast=TRUE), Dup = Duplicated(x), DupL= Duplicated(x, fromLast=TRUE)) } \keyword{manip} sfsmisc/man/pretty10exp.Rd0000644000176200001440000001064213376772647015221 0ustar liggesusers\name{pretty10exp} \alias{pretty10exp} \title{Nice 10 ** k Label Expressions} \description{ Produce nice \eqn{a \times 10^k}{a * 10^k} expressions to be used instead of the scientific notation \code{"a E"}. } \usage{ pretty10exp(x, drop.1 = FALSE, sub10 = FALSE, digits = 7, digits.fuzz, lab.type = c("plotmath","latex"), lab.sep = c("cdot", "times")) } \arguments{ \item{x}{numeric vector (e.g. axis tick locations)} \item{drop.1}{logical indicating if \eqn{1 \times}{1 *} should be dropped from the resulting expressions.} \item{sub10}{logical, \code{"10"}, a non-negative integer number or an integer vector of length two, say \eqn{(k_1,k_2)}{(k1,k2)}, indicating if some \eqn{10^j} expressions for \eqn{j \in J}{j in J} should be formatted traditionally, notably e.g., \eqn{10^0 \equiv 1}{10^0 == 1}. \cr When a (non-negative) number, say \eqn{k}, \eqn{J = \{j; j \le k\}}{% J = {j; j \le k}} are all simplified, when a length--2 vector, \eqn{J = \{j; k_1 \le j \le k_2\}}{J = {j; k1 \le j \le k2}} are. Special cases: \code{sub10 = TRUE} means to use \eqn{1} instead of \eqn{10^0} and \code{sub10 = "10"} uses both \eqn{1} for \eqn{10^0} and \eqn{10} for \eqn{10^1}; these are short forms of \code{sub10 = c(0,0)} and \code{sub10 = c(0,1)} respectively. } \item{digits}{number of digits for mantissa (\eqn{a}) construction; the number of \emph{significant} digits, see \code{\link{signif}}.} \item{digits.fuzz}{the old deprecated name for \code{digits}.} \item{lab.type}{a string indicating how the result should look like. By default, (\code{\link{plotmath}}-compatible) \code{\link{expression}}s are returned. Alternatively, \code{lab.type = "plotmath"} returns LaTeX formatted strings for labels. (The latter is useful, e.g., when using the \CRANpkg{tikzDevice} package to generate LaTeX-processed figures.)} \item{lab.sep}{character separator between mantissa and exponent for LaTeX labels; it will be prepended with a backslash, i.e., \sQuote{"cdot"} will use \sQuote{"\\cdot"}} } \value{ For the default \code{lab.type = "plotmath"}, an expression of the same length as \code{x}, typically with elements of the form \code{a \%*\% 10 ^ k}. Exceptions are \code{0} which is kept simple, if \code{drop.1} is true and \eqn{a = 1}, \code{10 ^ k} is used, and if \code{sub10} is not false, \code{a \%*\% 10 ^ 0} as \code{a}, and \code{a \%*\% 10 ^ k} as as the corresponding formatted number \code{a * 10^k} independently of \code{drop.1}. Otherwise, a \code{\link{character}} vector of the same length as \code{x}. For \code{lab.type = "latex"}, currently the only alternative to the default, these strings are LaTeX (math mode) compatible strings. } \note{ If \code{sub10} is set, it will typically be a small number such as 0, 1, or 2. Setting \code{sub10 = TRUE} will be interpreted as \code{sub10 =1} where resulting exponents \eqn{k} will either be negative or \eqn{k \ge 2}{k >= 2}. } \author{Martin Maechler; Ben Bolker contributed \code{lab.type = "latex"} and \code{lab.sep}.} \seealso{\code{\link{axTexpr}} and \code{\link{eaxis}()} which build on \code{pretty10exp()}, notably the \code{eaxis()} example plots. The new \code{\link{toLatex.numeric}} method which gives very similar results with option \code{scientific = TRUE}. \cr Further, \code{\link{axis}}, \code{\link{axTicks}}. } \examples{ pretty10exp(-1:3 * 1000) pretty10exp(-1:3 * 1000, drop.1 = TRUE) pretty10exp(c(1,2,5,10,20,50,100,200) * 1e3) pretty10exp(c(1,2,5,10,20,50,100,200) * 1e3, drop.1 = TRUE) set.seed(17); lx <- rlnorm(10, m=8, s=6) pretty10exp(lx, digits = 3) pretty10exp(lx, digits = 3, sub10 = 2) pretty10exp(lx, digits = 3, lab.type="latex") pretty10exp(lx, digits = 3, lab.type="latex", lab.sep="times", sub10=2) ## use regular formatted numbers from 0.03 to 300 : pretty10exp(3*10^(-3:4), sub10 = c(-2,2)) pretty10exp(3*10^(-3:4), sub10 = c(-2,2), lab.type = "l") \dontshow{ stopifnot(identical(pretty10exp(numeric(0)), expression())) } ax <- 10^(-6:0) - 2e-16 pretty10exp(ax, drop.1=TRUE) # nice for plotting pretty10exp(ax, drop.1=TRUE, sub10=TRUE) pretty10exp(ax, drop.1=TRUE, sub10=c(-2,2)) ## in sfsmisc version <= 1.0-16, no 'digits', ## i.e., implicitly had digits := #{double precision digits} == (dig. <- .Machine$double.digits * log10(2)) # 15.95 pretty10exp(ax, drop.1=TRUE, digits= dig.) # ''ugly'' } \keyword{dplot} sfsmisc/man/tkdensity.Rd0000644000176200001440000000440012462442610015000 0ustar liggesusers\name{tkdensity} \alias{tkdensity} \title{GUI Density Estimation using Tcl/Tk} \description{ This is graphical user interface (GUI) to \code{\link{density}}, allowing for dynamic bandwidth choice and a simple kind of zooming, relying on \code{library(tcltk)}. } \usage{ tkdensity(y, n = 1024, log.bw = TRUE, showvalue = TRUE, xlim = NULL, do.rug = size < 1000, kernels = NULL, from.f = if (log.bw) -2 else 1/1000, to.f = if (log.bw) +2.2 else 2, col = 2) } \arguments{ \item{y}{numeric; the data the density of which we want.} \item{n}{integer; the number of abscissa values for \code{\link{density}} evaluation (and plotting).} \item{log.bw}{logical; if true (default), the gui scrollbar is on a \emph{log} bandwidth scale, otherwise, simple interval.} \item{showvalue}{logical; if true, the value of the current (log) bandwidth is shown on top of the scrollbar.} \item{xlim}{initial \code{xlim} for plotting, see \code{\link{plot.default}}.} \item{do.rug}{logical indicating if \code{\link{rug}(y)} should be added to each plot. This is too slow for really large sample sizes.} \item{kernels}{character vector of kernel names as allowable for the \code{kernels} argument of the standard \code{\link{density}} function.} \item{from.f, to.f}{numeric giving the left and right limit of the bandwidth scrollbar.} \item{col}{color to be used for the density curve.} } \details{ \code{library(tcltk)} must be working, i.e., Tcl/Tk must have been installed on your platform, and must have been visible during \R's configuration and/or installation. You can not only choose the bandwidth (the most important parameter), but also the kernel, and you can zoom in and out (in x-range only). } \value{ none.\cr (How could this be done? \code{tcltk} widgets run as separate processes!) } \author{Martin Maechler, building on \code{demo(tkdensity)}.} \examples{ if (dev.interactive(TRUE)) ## does really not make sense otherwise if(try(require("tcltk"))) { ## sometimes (rarely) there, but broken data(faithful) tkdensity(faithful $ eruptions) set.seed(7) if(require("nor1mix")) tkdensity(rnorMix(1000, MW.nm9), kernels = c("gaussian", "epanechnikov")) } } \keyword{hplot} \keyword{dynamic} sfsmisc/man/ecdf.ksCI.Rd0000644000176200001440000000204613131443372014517 0ustar liggesusers\name{ecdf.ksCI} \alias{ecdf.ksCI} \title{Plot Empirical Distribution Function With 95\% Confidence Curves} \description{ Plots the empirical (cumulative) distribution function (ECDF) for univariate data, together with upper and lower simultaneous 95\% confidence curves, computed via Kolmogorov-Smirnov' \eqn{D}, see \code{\link{KSd}}. } \usage{ ecdf.ksCI(x, main = NULL, sub = NULL, xlab = deparse(substitute(x)), ci.col = "red", \dots) } \arguments{ \item{x}{\code{x} numerical vector of observations.} \item{main,sub,xlab}{arguments passed to \code{\link{title}}.} \item{ci.col}{color for confidence interval lines.} \item{\dots}{optional arguments passed to \code{\link{plot.stepfun}}.} } \value{ Nothing. Used for its side effect, to produce a plot. } \references{Bickel and Doksum, see \code{\link{KSd}}. } \author{Kjetil Halvorsen} \note{Presently, will only work if \code{length(x)} > 9. } \seealso{\code{\link{ecdf}} and \code{\link{plot.stepfun}} in standard \R. } \examples{ ecdf.ksCI( rchisq(50,3) ) } \keyword{hplot} sfsmisc/man/signi.Rd0000644000176200001440000000153312575757743014124 0ustar liggesusers\name{signi} \alias{signi} \title{Rounding to Significant Digits} \description{ Rounds to significant digits similarly to \code{\link{signif}}. } \usage{ signi(x, digits = 6) } \arguments{ \item{x}{numeric vector to be rounded.} \item{digits}{number of significant digits required.} } \value{ numeric vector \dQuote{close} to \code{x}, i.e. by at least \code{digits} significant digits. } \author{Martin Maechler, in prehistoric times (i.e. before 1990).} \note{ This is really just \code{round(x, digits - trunc(log10(abs(x))))} and hence mainly of didactical use. Rather use \code{signif()} otherwise. } \seealso{\code{\link{signif}}, \code{\link{round}}.} \examples{ (x1 <- seq(-2, 4, by = 0.5)) identical(x1, signi(x1))# since 0.5 is exact in binary arithmetic (x2 <- pi - 3 + c(-5,-1,0, .1, .2, 1, 10,100)) signi(x2, 3) } \keyword{arith} sfsmisc/man/vcat.Rd0000644000176200001440000000207707563757731013752 0ustar liggesusers\name{vcat} \alias{vcat} \alias{ccat} \title{Paste Utilities -- Concatenate Strings} \description{ Con\bold{cat}enate vector elements or anything using \code{\link{paste}(*, collapse = .)}. These are simple short abbreviations I have been using in my own codes in many places. } \usage{ vcat(vec, sep = " ") ccat(...) } \arguments{ \item{vec, \dots}{any vector and other arguments to be pasted to together.} \item{sep}{the separator to use, see the \emph{Details} section.} } \details{The functions are really just defined as\cr vcat := \code{function(vec, sep = " ") paste(vec, collapse = sep)} ccat := \code{function(...) paste(..., collapse = "", sep = "")} } \value{ a character string (of length 1) with the concatenated arguments. } \author{Martin Maechler, early 1990's.} \seealso{\code{\link{paste}}, \code{\link{as.character}}, \code{\link{format}}. \code{\link{cat}()} is really for printing. } \examples{ ch <- "is" ccat("This ", ch, " it: ", 100, "\%") vv <- c(1,pi, 20.4) vcat(vv) vcat(vv, sep = ", ") } \keyword{print} \keyword{utilities} sfsmisc/man/roundfixS.Rd0000644000176200001440000000704213427266567014771 0ustar liggesusers\name{roundfixS} \alias{roundfixS} \concept{apportionment} \title{Round to Integer Keeping the Sum Fixed} \description{ Given a real numbers \eqn{y_i} with the particular property that \eqn{\sum_i y_i} is integer, find \emph{integer} numbers \eqn{x_i} which are close to \eqn{y_i} (\eqn{\left|x_i - y_i\right| < 1 \forall i}{% |x[i] - y[i]| < 1 for all i}), and have identical \dQuote{marginal} sum, \code{sum(x) == sum(y)}. As I found later, the problem is known as \dQuote{Apportionment Problem} and it is quite an old problem with several solution methods proposed historically, but only in 1982, Balinski and Young proved that there is no method that fulfills three natural desiderata. Note that the (first) three methods currently available here were all (re?)-invented by M.Maechler, without any knowledge of the litterature. At the time of writing, I have not even checked to which (if any) of the historical methods they match. } \usage{ roundfixS(x, method = c("offset-round", "round+fix", "1greedy")) } \arguments{ \item{x}{a numeric vector which \bold{must} sum to an integer} \item{method}{character string specifying the algorithm to be used.} % \item{trace}{logical or integer, enabling algorithm tracing.} } \details{ Without hindsight, it may be surprising that all three methods give identical results (in all situations and simulations considered), notably that the idea of \sQuote{mass shifting} employed in the iterative \code{"1greedy"} algorithm seems equivalent to the much simpler idea used in \code{"offset-round"}. I am pretty sure that these algorithms solve the \eqn{L_p} optimization problem, \eqn{\min_x \left\|y - x\right\|_p}{min_x ||y - x||_p}, typically for all \eqn{p \in [1,\infty]}{p in [1,Inf]} \emph{simultaneously}, but have not bothered to find a formal proof. } \value{ a numeric vector, say \code{r}, of the same length as \code{x}, but with integer values and fulfulling \code{sum(r) == sum(x)}. } \author{Martin Maechler, November 2007} \references{ Michel Balinski and H. Peyton Young (1982) \bold{Fair Representation: Meeting the Ideal of One Man, One Vote}; \url{https://en.wikipedia.org/wiki/Apportionment_paradox} \url{https://www.ams.org/samplings/feature-column/fcarc-apportionii3} } \seealso{\code{\link{round}} etc } \examples{ ## trivial example kk <- c(0,1,7) stopifnot(identical(kk, roundfixS(kk))) # failed at some point x <- c(-1.4, -1, 0.244, 0.493, 1.222, 1.222, 2, 2, 2.2, 2.444, 3.625, 3.95) sum(x) # an integer r <- roundfixS(x) stopifnot(all.equal(sum(r), sum(x))) m <- cbind(x=x, `r2i(x)` = r, resid = x - r, `|res|` = abs(x-r)) rbind(m, c(colSums(m[,1:2]), 0, sum(abs(m[,"|res|"])))) chk <- function(y) { cat("sum(y) =", format(S <- sum(y)),"\n") r2 <- roundfixS(y, method="offset") r2. <- roundfixS(y, method="round") r2_ <- roundfixS(y, method="1g") stopifnot(all.equal(sum(r2 ), S), all.equal(sum(r2.), S), all.equal(sum(r2_), S)) all(r2 == r2. & r2. == r2_) # TRUE if all give the same result } makeIntSum <- function(y) { n <- length(y) y[n] <- ceiling(y[n]) - (sum(y[-n]) \%\% 1) y } set.seed(11) y <- makeIntSum(rnorm(100)) chk(y) ## nastier example: set.seed(7) y <- makeIntSum(rpois(100, 10) + c(runif(75, min= 0, max=.2), runif(25, min=.5, max=.9))) chk(y) \dontrun{ for(i in 1:1000) stopifnot(chk(makeIntSum(rpois(100, 10) + c(runif(75, min= 0, max=.2), runif(25, min=.5, max=.9))))) } } \keyword{arith} \keyword{manip} sfsmisc/man/is.whole.Rd0000644000176200001440000000303212347335222014514 0ustar liggesusers\name{is.whole} \alias{is.whole} \title{Test Whether a Vector or Array Consists of Whole Numbers} \description{ This function tests whether a \code{numeric} or \code{complex} vector or array consists of whole numbers. The function \code{\link{is.integer}} is not appropriate for this since it tests whether the vector is of class \code{integer} (see examples). } \usage{ is.whole(x, tolerance = sqrt(.Machine$double.eps)) } \arguments{ \item{x}{\code{integer}, \code{numeric}, or \code{complex} vector or array to be tested} \item{tolerance}{maximal distance to the next whole number} } % \details{ %% ~~ If necessary, more details than the description above ~~ % } \value{ The return value has the same dimension as the argument \code{x}: if \code{x} is a vector, the function returns a \code{logical} vector of the same length; if \code{x} is a matrix or array, the function returns a \code{logical} matrix or array of the same dimensions. Each entry in the result indicates whether the corresponding entry in \code{x} is whole. } \author{Alain Hauser } \seealso{\code{\link{is.integer}}} \examples{ ## Create a random array, matrix, vector set.seed(307) a <- array(runif(24), dim = c(2, 3, 4)) a[4:8] <- 4:8 m <- matrix(runif(12), 3, 4) m[2:4] <- 2:4 v <- complex(real = seq(0.5, 1.5, by = 0.1), imaginary = seq(2.5, 3.5, by = 0.1)) ## Find whole entries is.whole(a) is.whole(m) is.whole(v) ## Numbers of class integer are always whole is.whole(dim(a)) is.whole(length(v)) } \keyword{arith} sfsmisc/man/seqXtend.Rd0000644000176200001440000000572011662507715014574 0ustar liggesusers\name{seqXtend} \alias{seqXtend} \title{Sequence Covering the Range of X, including X} \description{ Produce a sequence of unique values (sorted increasingly), \emph{containing} the initial set of values \code{x}. This can be useful for setting prediction e.g. ranges in nonparametric regression. } \usage{ seqXtend(x, length., method = c("simple", "aim", "interpolate"), from = NULL, to = NULL) } \arguments{ \item{x}{numeric vector.} \item{length.}{integer specifying \emph{approximately} the desired \code{\link{length}()} of the result.} \item{method}{string specifying the method to be used. The default, \code{"simple"} uses \code{\link{seq}(*, length.out = length.)} where \code{"aim"} aims a bit better towards the desired final length, and \code{"interpolate"} interpolates evenly \emph{inside} each interval \eqn{[x_i, x_{i+1}]}{(x[i], x[i+1])} in a way to make all the new intervalls of approximately the same length.} \item{from, to}{numbers to be passed to (the default method for) \code{\link{seq}()}, defaulting to the minimal and maximal \code{x} value, respectively.} } \note{ \code{method = "interpolate"} typically gives the best results. Calling \code{\link{roundfixS}}, it also need more computational resources than the other methods. } \value{ numeric vector of increasing values, of approximate length \code{length.} (unless \code{length. < length(unique(x))} in which case, the result is simply \code{sort(\link{unique}(x))}), containing the original values of \code{x}. From, \code{r <- seqXtend(x, *)}, the original values are at indices \code{ix <- match(x,r)}, i.e., \code{identical(x, r[ix])}. } \author{Martin Maechler} \seealso{\code{\link{seq}}; \code{\link{plotDS}} can make particularly good use of \code{seqXtend()} } \examples{ a <- c(1,2,10,12) seqXtend(a, 12)# --> simply 1:12 seqXtend(a, 12, "interp")# ditto seqXtend(a, 12, "aim")# really worse stopifnot(all.equal(seqXtend(a, 12, "interp"), 1:12)) ## for a "general" x, however, "aim" aims better than default x <- c(1.2, 2.4, 4.6, 9.9) length(print(seqXtend(x, 12))) # 14 length(print(seqXtend(x, 12, "aim"))) # 12 length(print(seqXtend(x, 12, "int"))) # 12 ## "interpolate" is really nice: xt <- seqXtend(x, 100, "interp") plot(xt, main="seqXtend(*, 100, \"interpol\")") points(match(x,xt), x, col = 2, pch = 20) # .... you don't even see that it's not equidistant # whereas the cheap method shows ... xt2 <- seqXtend(x, 100) plot(xt2, col="blue") points(match(x,xt2), x, col = 2, pch = 20) ## with "Date" objects Drng <- as.Date(c("2007-11-10", "2012-07-12")) (px <- pretty(Drng, n = 16)) # say, for the main labels ## say, a finer grid, for ticks -- should be almost equidistant n3 <- 3*length(px) summary(as.numeric(diff(seqXtend(px, n3)))) # wildly varying summary(as.numeric(diff(seqXtend(px, n3, "aim")))) # (ditto) summary(as.numeric(diff(seqXtend(px, n3, "int")))) # around 30 } \keyword{manip} \keyword{utilities} sfsmisc/man/inv.seq.Rd0000644000176200001440000000177612560614001014354 0ustar liggesusers\name{inv.seq} \alias{inv.seq} \title{Inverse seq() -- Short Expression for Index Vector} \description{ Compute a short expression for a given integer vector, typically an index, that can be expressed shortly, using \code{\link{:}} etc. } \usage{ inv.seq(i) } \arguments{ \item{i}{vector of (usually increasing) integers.} } %%\details{ %%} \value{ a \code{\link{call}} (\dQuote{the inside of an \code{\link{expression}}}) to be \code{\link{eval}()}ed to return the original \code{i}. } \author{Martin Maechler, October 1995; more elegant implementation from Tony Plate.} \seealso{\code{\link{rle}} for another kind of integer vector coding.} \examples{ (rr <- inv.seq(i1 <- c(3:12, 20:24, 27, 30:33))) eval(rr) stopifnot(eval(rr) == i1) e2 <- expression(c(20:13, 3:12, -1:-4, 27, 30:31)) (i2 <- eval(e2)) (r2 <- inv.seq(i2)) stopifnot(all.equal(r2, e2[[1]])) ## Had {mapply()} bug in this example: ii <- c(1:3, 6:9, 11:16) stopifnot(identical(ii, eval(inv.seq(ii)))) } \keyword{arith} \keyword{utilities} sfsmisc/man/p.profileTraces.Rd0000644000176200001440000000310412575757743016047 0ustar liggesusers\name{p.profileTraces} \encoding{latin1} \alias{p.profileTraces} \title{Plot a profile.nls Object With Profile Traces} \description{ Displays a series of plots of the profile t function and the likelihood profile traces for the parameters in a nonlinear regression model that has been fitted with \code{\link{nls}} and profiled with \code{\link{profile.nls}}. } \usage{ p.profileTraces(x, cex = 1, subtitle = paste("t-Profiles and traces of ", deparse(attr(x,"summary")$formula))) } \arguments{ \item{x}{an object of class \code{"profile.nls"}, typically resulting from \code{profile(\link[stats]{nls}(.))}, see \code{\link[stats]{profile.nls}}.} \item{cex}{character expansion, see \code{\link{par}(cex =)}.} \item{subtitle}{a subtitle to set for the plot. The default now includes the \code{\link{nls}()} formula used.} } %- \details{ % ......... %- } \author{Andreas Ruckstuhl, \R port by Isabelle Flckiger and Marcel Wolbers} \note{the \pkg{stats}-internal \code{stats:::plot.profile.nls} plot method just does \dQuote{the diagonals}. } \seealso{\code{\link{profile}}, and \code{\link{nls}} (which has unexported \code{profile} and \code{stats:::plot.profile.nls} methods). } \examples{ require(stats) data(Puromycin) Treat <- Puromycin[Puromycin$state == "treated", ] fm <- nls(rate ~ T1*conc/(T2+conc), data=Treat, start = list(T1=207,T2=0.06)) (pr <- profile(fm)) # quite a few things.. op <- par(mfcol=1:2) plot(pr) # -> 2 'standard' plots par(op) ## ours: p.profileTraces(pr) } \keyword{hplot} \keyword{nonlinear} sfsmisc/man/u.sys.Rd0000644000176200001440000000250712562441251014052 0ustar liggesusers\name{u.sys} \title{'Portable' System function (R / S-plus)} \alias{u.sys} \alias{Sys.ps.cmd}% was in unix/Sys.ps.Rd \description{ \code{u.sys()} is a convenient wrapper (of \code{system()}) to call to the underlying operating system. The main purpose has been to provide a function with identical UI both in S-PLUS and \R. MM thinks you shouldn't use this anymore, usually. \code{Sys.ps.cmd()} returns the \samp{ps} (\sQuote{\bold{p}rocess \bold{s}tatus}) OS command name (as \code{\link{character}} string), and is typically usable on unix alikes only.% Windows with 'Rtools' installed ?? } \usage{ u.sys(\dots, intern = TRUE) Sys.ps.cmd() } \arguments{ \item{\dots}{any number of strings -- which will be \code{\link{paste}()}d together and passed to \code{system}.} \item{intern}{logical -- note that the default is \emph{reversed} from the one in \code{\link{system}()}.} } \author{Martin Maechler} \seealso{\code{\link{system}}, really!; on non-Windows, \code{Sys.ps()} which makes use of \code{Sys.ps.cmd()}. } \examples{ u.sys # shows how simply the function is defined : \dontrun{ function (..., intern = TRUE) system(paste(..., sep = ""), intern = intern) } # All *running* processes of user [sometimes only R]: try ( u.sys(Sys.ps.cmd(), "ur") ) } \keyword{utilities} \keyword{environment}% System, not R sfsmisc/man/funEnv.Rd0000644000176200001440000000346313131443222014225 0ustar liggesusers\name{funEnv} \alias{funEnv} \title{List-like Environment of Functions (and More)} \description{ Construct a \dQuote{list}, really an \code{\link{environment}} typically of functions and optionally other \R objects, where the \code{\link{function}}s and \code{\link{formula}}s all all share the same environment. Consequently, the functions may call each other. On technical level, this is just a simple wrapper around \code{\link{list2env}()}. } \usage{ funEnv(..., envir = NULL, parent = parent.frame(), hash = (...length() > 100), size = max(29L, ...length())) } \arguments{ \item{...}{an arbitrary \emph{named} \dQuote{list} of \R objects, typically including several \code{\link{function}}s.} \item{envir}{an \code{\link{environment}} or \code{NULL}.} \item{parent}{(for the case \code{envir = NULL}): a parent frame aka enclosing environment, see \code{\link{new.env}} and \code{\link{list2env}}.} \item{hash, size}{(for the case \code{envir = NULL}): \code{hash} a logical indicating if the created environment should use hashing, and (\code{size}) the hash size, see \code{\link{list2env}}.} } \value{ an \code{\link{environment}}, say \code{E}, containing the objects from \code{...} (plus those in \code{envir}), and all function objects' \code{\link{environment}()} is E. } %% \references{ %% } \author{Martin Maechler} \seealso{ \code{\link{list2env}}, \code{\link{environment}} } \examples{ ee <- funEnv(f = function(x) g(2*(x+1)), g = function(y) hh(y+1), hh = function(u) u^2, info = "Some Information (not a function)") ls(ee) # here the same as names(ee) ## Check that it works: i.e., that "f sees g" and "g sees hh": stopifnot(all.equal(ee$f(pi), (2*pi+3)^2)) ee$f(0:4) # [1] 9 25 49 81 121 } \keyword{programming} \keyword{data} sfsmisc/man/p.hboxp.Rd0000644000176200001440000000207012410524270014335 0ustar liggesusers\name{p.hboxp} \alias{p.hboxp} \title{Add a Horizontal Boxplot to the Current Plot} \description{ Add a horizontal boxplot to the current plot. This is mainly an auxiliary function for \code{\link{histBxp}}, since \code{\link{boxplot}(*, horizontal = TRUE, add = TRUE)} is usually much preferable to this. } \usage{ p.hboxp(x, y.lo, y.hi, boxcol = 3, medcol = 2, medlwd = 5, whisklty = 2, staplelty = 1) } \arguments{ \item{x}{univariate data set.} \item{y.lo, y.hi}{minimal and maximal \emph{user} coordinates \bold{or} \code{y.lo = c(ylo,hyi)}.} \item{boxcol, medcol}{color of the box and the median line.} \item{medlwd}{line width of median line.} \item{whisklty, staplelty}{line types of the whisker and the staple, the latter being used for the outmost non-outliers.} } \details{ .... } \author{Martin Maechler building on code from Markus and Christian Keller.} \seealso{\code{\link{boxplot}(**, horizontal = TRUE, add= TRUE)}.} \examples{ %% FIXME: add! ## ==> See code in 'histBxp' (.) and example(histBxp) ! ## } \keyword{aplot} sfsmisc/man/histBxp.Rd0000644000176200001440000001047613246037205014416 0ustar liggesusers\name{histBxp} \encoding{latin1} \alias{histBxp} \title{Plot a Histogram and a Boxplot} \description{ Creates a histogram and a horizontal boxplot on the current graphics device. } \usage{ histBxp(x, nclass, breaks, probability=FALSE, include.lowest=TRUE, xlab = deparse(substitute(x)), \dots, width=0.2, boxcol=3, medcol=2, medlwd=5, whisklty=2, staplelty=1) } \arguments{ \item{x}{numeric vector of data for histogram. Missing values (\code{NA}s) are allowed.} \item{nclass}{ recommendation for the number of classes (i.e., bars) the histogram should have. The default is a number proportional to the logarithm of the length of \code{x}. } \item{breaks}{ vector of the break points for the bars of the histogram. The count in the i-th bar is \code{sum(breaks[i] < x <= breaks[i+1])} except that if \code{include.lowest} is \code{TRUE} (the default), the first bar also includes points equal to \code{breaks[1]}. If omitted, evenly-spaced break points are determined from \code{nclass} and the extremes of the data. } \item{probability}{ logical flag: if \code{TRUE}, the histogram will be scaled as a probability density; the sum of the bar heights times bar widths will equal \code{1}. If \code{FALSE}, the heights of the bars will be counts. } \item{include.lowest}{ If \code{TRUE} (the default), the lowest bar will include data points equal to the lowest break, otherwise it will act like the other bars (see the description of the \code{breaks} argument). } \item{xlab}{character or expression for x axis labeling.} \item{\dots}{additional arguments to \code{\link{barplot}}. The \code{\link{hist}} function uses the function \code{barplot} to do the actual plotting; consequently, arguments to the \code{barplot} function that control shading, etc., can also be given to \code{hist}. See the \code{barplot} documentation for arguments \code{angle}, \code{density}, \code{col}, and \code{inside}. Do not use the \code{space} or \code{histo} arguments. } \item{width}{ width of the box relative to the height of the histogram. DEFAULT is \code{0.2}.} \item{boxcol}{color of filled box. The default is \code{3}.} \item{medcol}{ the color of the median line. The special value, \code{NA}, indicates the current plotting color (\code{par("col")}). The default is \code{2}. If \code{boxcol=0} and \code{medcol} is not explicitly specified this is set to the current plotting color (\code{par("col")}). } \item{medlwd}{ median line width. The special value \code{NA}, is used to indicate the current line width (\code{par("lwd")}). The default is \code{5}. } \item{whisklty}{ whisker line type. The special value \code{NA} indicates the current line type (\code{par("lty")}). The default is \code{2} (dotted line).} \item{staplelty}{ staple (whisker end cap) line type. The special value \code{NA} indicates the current line type (\code{par("lty")}). The default is \code{1} (solid line). Graphical parameters (see \code{\link{par}}) may also be supplied as arguments to this function. In addition, the high-level graphics arguments described under \code{par} and the arguments to \code{title} may be supplied to this function.} } \details{ If \code{include.lowest} is \code{FALSE} the bottom breakpoint must be strictly less than the minimum of the data, otherwise (the default) it must be less than or equal to the minimum of the data. The top breakpoint must be greater than or equal to the maximum of the data. This function has been called \code{hist.bxp()} for 17 years; in 2012, the increasingly strong CRAN policies required a new name (which could not be confused with an S3 method name). } \author{S-Plus: Markus Keller, Christian Keller; port to \R in 1990's: Martin Mchler.} \seealso{\code{\link{hist}}, \code{\link{barplot}}, \code{\link{boxplot}}, \code{\link{rug}} and \code{\link[Hmisc]{scat1d}} in the \CRANpkg{Hmisc} package. } \examples{ lab <- "50 samples from a t distribution with 5 d.f." mult.fig(2*3, main = "Hist() + Rug() and histBxp(*)") for(i in 1:3) { my.sample <- rt(50, 5) hist(my.sample, main=lab); rug(my.sample)# for 50 obs., this is ok, too.. histBxp(my.sample, main=lab) } } \keyword{hplot} sfsmisc/man/lseq.Rd0000644000176200001440000000125110205460113013716 0ustar liggesusers\name{lseq} \alias{lseq} \title{Generate Sequences, Equidistant on Log Scale} \description{ Generate sequences which are equidistant on a log-scale. } \usage{ lseq(from, to, length) } \arguments{ \item{from}{starting value of sequence.} \item{to}{end value of the sequence.} \item{length}{desired length of the sequence.} } \value{ a \code{\link{numeric}} vector of length \code{length}. } \seealso{\code{\link{seq}}.%% ~/R/D/r-devel/R/src/library/base/man/seq.Rd } \examples{ (x <- lseq(1, 990, length= 21)) plot(x, x^4, type = "b", col = 2, log = "xy") if(with(R.version, major >= 2 && minor >= 1)) plot(x, exp(x), type = "b", col = 2, log = "xy") } \keyword{manip} sfsmisc/man/factorize.Rd0000644000176200001440000000310213246037205014747 0ustar liggesusers\name{factorize} \alias{factorize} \title{Prime Factorization of Integers} \description{ Compute the prime factorization(s) of integer(s) \code{n}. % ## Purpose: Prime factorization of integer(s) 'n' % ## ------------------------------------------------------------------------- % ## Arguments: n vector of integers to factorize (into prime numbers) % ## --> needs 'prime.sieve' % ## >> Better would be: Define class 'primefactors' and "multiply" method % ## then use this function recursively only "small" factors % ## ------------------------------------------------------------------------- } \usage{ factorize(n, verbose = FALSE) } \arguments{ \item{n}{vector of integers to factorize.} \item{verbose}{logical indicating if some progress information should be printed.} } \details{ works via \code{\link{primes}}, currently in a cheap way, sub-optimal for large composite \eqn{n}. %% FIXME: ALSO, %% % ## >> Better would be: Define class 'primefactors' and "multiply" method } \value{ A named \code{\link{list}} of the same length as \code{n}, each element a 2-column matrix with column \code{"p"} the prime factors and column~\code{"m"} their respective exponents (or multiplities), i.e., for a prime number \code{n}, the resulting matrix is \code{cbind(p = n, m = 1)}. } \author{Martin Maechler, Jan. 1996.} \seealso{ \code{\link{primes}}. For factorization of moderately or really large numbers, see the \CRANpkg{gmp} package, and its \code{\link[gmp]{factorize}()}. } \examples{ factorize(47) factorize(seq(101, 120, by=2)) } \keyword{math} sfsmisc/man/sessionInfoX.Rd0000644000176200001440000001025614032027330015410 0ustar liggesusers\name{sessionInfoX}% sessionInfo help is ~/R/D/r-devel/R/src/library/utils/man/sessionInfo.Rd \title{Extended Information About the Current R Session} \alias{isRshared} \alias{sessionInfoX} \alias{print.sessionInfoX} \description{ Collect (and print) information about the current \R session and environment, using \code{\link{sessionInfo}()} and more mostly low-level and platform dependent information. \code{isRshared()} is a utility called from \code{sessionInfoX()}. } \usage{ sessionInfoX(pkgs = NULL, list.libP = FALSE, extraR.env = TRUE) \method{print}{sessionInfoX}(x, locale = TRUE, RLIBS = TRUE, Renv = TRUE, \dots) isRshared(platform = .Platform) } \arguments{ \item{pkgs}{\code{NULL} (default), \code{TRUE} or a \code{\link{character}} vector of \R package names, whose \code{\link{packageDescription}()}s are wanted. No packages by default, \code{TRUE} takes all currently loaded pkgs.} \item{list.libP}{a logical indicating if for all \code{\link{.libPaths}} entries, the files should be listed via \code{\link{list.files}}.} \item{extraR.env}{logical indicating if \emph{all} environment variables should be recorded which start with \code{"R_"} or \code{"_R_"}.} %% print(): \item{x}{typically the result of \code{sessionInfoX()}.} \item{locale}{logical, passed to \code{\link{print.sessionInfo}()} indicating if the locale information should be printed.} \item{RLIBS}{logical indicating if the information about R_LIBS should be printed.} \item{Renv}{logical indicating if the information about R environment variables should be printed.} \item{\dots}{passed to \code{\link{print}} methods.} %% isRshared(): \item{platform}{a \code{\link{list}} \dQuote{like} \code{\link{.Platform}}.} } %% \details{ %% } \value{For \code{isRshared()}, a \code{\link{logical}} indicating if \R has been installed as \dQuote{shared}, i.e., linked to \file{libR*} shared library. For \code{sessionInfoX()}, an object of S3 class \code{"sessionInfoX"}, a \code{\link{list}} with components (there may be more, experimental and not yet listed here): \item{sInfo}{simply the value of \code{\link{sessionInfo}()}.} \item{sysInf}{the value of \code{\link{Sys.info}()}.} \item{capabilities}{the value of \code{\link{capabilities}()}.} \item{extSoft}{for \R 3.2.0 and newer, the value of \code{\link{extSoftVersion}()}.} \item{grSoft}{for \R 3.2.0 and newer, the value of \code{\link{grSoftVersion}()}.} \item{tclVersion}{for \R 3.2.0 and newer and when \pkg{tcltk} is loaded, the Tcl version (\code{\link[tcltk]{tclVersion}()}).} \item{LAPACK}{for \R 3.0.3 and newer, the value of \code{\link{La_version}()}.} \item{pcre}{for \R 3.1.3 and newer, the value of \code{\link{pcre_config}()}.} \item{pkgDescr}{If \code{pkgs} was non-empty, a named \code{\link{list}} of \code{\link{packageDescription}()}s for each entry in \code{pkgs}.} \item{libPath}{the value of \code{\link{.libPaths}()}.} \item{RLIBS}{a \code{\link{character}} vector of entries from \code{\link{Sys.getenv}("R_LIBS")}, typically very similar to the \code{libPaths} component.} \item{n.RLIBS}{simply a \code{\link{normalizePath}()}ed version of \code{RLIBS}.} \item{R.env}{a named character vector with the \dQuote{important} \R environment variables \code{R_ENVIRON}, \code{R_PROFILE}, \code{R_CHECK_ENVIRON}.} \item{xR.env}{if \code{extraR.env} was true, a named character vector of \dQuote{all R related} environment variables, as specified in \code{extraR.env}'s description above.} \item{shared}{(not available on Windows, where it is conceptually always true:) \code{\link{logical}} indicating if the version of \R is \dQuote{shared}.} %%i.e., ... <<< FIXME: explain more %% FIXME: unfinished } \author{Martin Maechler, December 2015 ff.} \seealso{ \code{\link{sessionInfo}}, \code{\link{.libPaths}}, \code{\link{R.version}}, \code{\link{Sys.getenv}}. } \examples{ six0 <- sessionInfoX() six0$shared # useful (for some, e.g., MM) on Unix alikes sixN <- sessionInfoX("nlme", list.libP = TRUE) sixN # -> print() method for "sessionInfoX" names(sixN) str(sixN, max = 1)# outline of lower-level structure str(sixN$pkgDescr) # list with one component "nlme" } \keyword{misc} sfsmisc/man/compresid2way.Rd0000644000176200001440000000702311131753061015553 0ustar liggesusers\name{compresid2way} \alias{compresid2way} \title{Plot Components + Residuals for Two Factors} \description{ For an analysis of variance or regression with (at least) two factors: Plot components + residuals for two factors according to Tukey's \dQuote{forget-it plot}. Try it! } \usage{ compresid2way(aov, data=NULL, fac=1:2, label = TRUE, numlabel = FALSE, xlab=NULL, ylab=NULL, main=NULL, col=c(2,3,4,4), lty=c(1,1,2,4), pch=c(1,2)) } \arguments{ \item{aov}{either an \code{\link{aov}} object with a formula of the form % \code{y \~{} a + b}, where \code{a} and \code{b} are factors, \code{y ~ a + b}, where \code{a} and \code{b} are factors, or such a formula.} \item{data}{data frame containing \code{a} and \code{b}.} \item{fac}{the two factors used for plotting. Either column numbers or names for argument \code{data}.} \item{label}{logical indicating if levels of factors should be shown in the plot.} \item{numlabel}{logical indicating if effects of factors will be shown in the plot.} \item{xlab,ylab,main}{the usual \code{\link{title}} components, here with a non-trivial default constructed from \code{aov} and the component factors used.} \item{col,lty,pch}{colors, line types, plotting characters to be used for plotting [1] positive residuals, [2] negative residuals, [3] grid, [4] labels. If \code{pch} is sufficiently long, it will be used as the list of individual symbols for plotting the y values.} } \details{For a two-way analysis of variance, the plot shows the additive components of the fits for the two factors by the intersections of a grid, along with the residuals. The observed values of the target variable are identical to the vertical coordinate. The application of the function has been extended to cover more complicated models. The components of the fit for two factors are shown as just described, and the residuals are added. The result is a \dQuote{component plus residual} plot for two factors in one display. } \value{Invisibly, a list with components \item{compy}{data.frame containing the component effects of the two factors, and combined effects plus residual} \item{coef}{coefficients: Intercept and effects of the factors} } \references{ F. Mosteller and J. W. Tukey (1977) \emph{Data Analysis and Regression: A Second Course in Statistics}. Addison-Wesley, Reading, Mass., p. 176. John W. Tukey (1977) \emph{Exploratory Data Analysis}. Addison-Wesley, Reading, Mass., p. 381. } \author{Werner Stahel \email{stahel@stat.math.ethz.ch}} \seealso{\code{\link{interaction.plot}}} \examples{ ## From Venables and Ripley (2002) p.165. N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0) P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0) K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0) yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0) npk <- data.frame(block=gl(6,4), N=factor(N), P=factor(P), K=factor(K), yield=yield) npk.cr <- compresid2way(yield ~ N+P+K, data=npk, fac=c("P","K")) ## Fisher's 1926 data on potatoe yield data(potatoes) pot.aov <- aov(yield ~ nitrogen+potash+pos, data=potatoes) compresid2way(pot.aov, pch=as.character(potatoes$pos)) compresid2way(yield~nitrogen+potash, data=subset(potatoes, pos == 2)) ## 2 x 3 design : data(warpbreaks) summary(fm1 <- aov(breaks ~ wool + tension, data = warpbreaks)) compresid2way(fm1) } \keyword{hplot} sfsmisc/man/n.code.Rd0000644000176200001440000000232112575757743014155 0ustar liggesusers\name{n.code} \alias{n.code} \alias{code2n} \title{Convert "Round" Integers to Short Strings and Back} \description{ \code{n.code} convert \dQuote{round integers} to short character strings. This is useful to build up variable names in simulations, e.g. \code{code2n} is the \emph{inverse} function of \code{n.code()}. } \usage{ n.code(n, ndig = 1, dec.codes = c("", "d", "c", "k")) code2n(ncod, ndig = 1, dec.codes = c("", "d", "c", "k")) } \arguments{ \item{n}{integer vector.} \item{ncod}{character vector, typically resulting from \code{n.code}.} \item{ndig}{integer giving number of digits before the coding character.} \item{dec.codes}{character code for 1, 10, 100, 1000 (etc).} } % \details{ % ~~ If necessary, more details than the __description__ above ~~ % } \value{ \code{n.code(n)} returns a \code{\link{character}} vector of the same length as \code{n}. \code{code2n(ncod)} returns a \code{\link{integer}} vector of the same length as \code{ncod}. Usually, \code{code2n(n.code(n)) == n}. } \author{Martin Maechler} %\seealso{ ..} \examples{ n10 <- c(10,20,90, 100,500, 2000,10000) (c10 <- n.code(n10))#-> "1d" "2d" "9d" "1c" .. stopifnot(code2n(c10) == n10) } \keyword{utilities} sfsmisc/man/rot13.Rd0000644000176200001440000000255512415203120013730 0ustar liggesusers\name{rotn} \alias{rotn} \title{Generalized Rot13 Character Translation (Rotation)} \description{ Compute generalized \sQuote{rot13} character translations or \dQuote{rotations} In the distant past, considered as poor man's encryption, such rotations are way too poor nowadays and provided mainly for didactical reasons. } \usage{ rotn(ch, n = 13) } \arguments{ \item{ch}{a \code{\link{character}} vector; often a string (of length 1).} \item{n}{an integer in \eqn{\{1\dots26\}}{{1...26}}; the default is particularly useful.} } \value{ a character as \code{ch}, but with each character (which belongs to \code{\link{letters}} or \code{\link{LETTERS}} \dQuote{rotated} by \code{n} (positions in the alphabet). } \author{Martin Maechler} \details{ Note that the default \code{n = 13} makes \code{rotn} into a function that is its own inverse. Written after having searched for it and found \code{seqinr::rot13()} which was generalized and rendered more transparently to my eyes. } \seealso{ \code{\link{rot2}}, a completely different rotation (namely in the plane aka \eqn{R^2}). } \examples{ rotn(c("ABC", "a","b","c"), 1) rotn(c("ABC", "a","b","c"), 2) rotn(c("ABC", "a","b","c"), 26) # rotation by 26 does not change much (ch <- paste("Hello", c("World!", "you too"))) rotn(ch) rotn( rotn(ch ) ) # rotn(*, 13) is its own inverse } \keyword{manip}sfsmisc/man/ps.end.Rd0000644000176200001440000000413113617022536014156 0ustar liggesusers\name{ps.end} \alias{ps.end} \alias{pdf.end} \title{Close PostScript or Acrobat Graphics Device opened by 'ps.do' / 'pdf.do'} \usage{ ps.end(call.gv= NULL, command = getOption("eps_view"), debug = getOption("verbose")) pdf.end(call.viewer= NULL, command = getOption("pdfviewer"), debug = getOption("verbose")) } \arguments{ \item{call.gv,call.viewer}{logical, indicating if the postscript or acrobat reader (e.g., ghostview or \code{acroread} or the command given by \code{command}) should be called. By default, find out if the viewer is already runing on this file and only call it if needed.} \item{command}{character, giving a system command for PostScript previewing. By default, \code{getOption("eps_view")} is set to\cr \code{gv -watch -geometry -0+0 -magstep -2 -media BBox -noantialias} which assumes \code{gv} (aka \emph{ghostview}) to be in your OS path.} \item{debug}{logical; if \code{TRUE} print information during execution.} } \description{ Closes the PostScript or PDF file (\code{\link{postscript}},\code{\link{pdf}}), openend by a previous \code{\link{ps.do}} (or \code{\link{pdf.latex}}, or \dots) call, using \code{\link{dev.off}}, and additionally opens a previewer for that file, \emph{unless} the previewer is already up. This almost provides an \sQuote{interactive} device (like \code{\link{x11}}) for \code{\link{postscript}} or \code{\link{pdf}}. } \details{ Depends on Unix tools, such as \command{ps}. } \author{Martin Maechler} \seealso{\code{\link{postscript}}, \code{\link{postscript}} \code{\link{pdf.do}}, \code{\link{ps.do}}, %--> ./ps.latex.Rd \dots } \examples{ if(interactive() \dontshow{ || Sys.getenv("USER") == "maechler" } ) { myPS <- tempfile("ex", fileext = ".ps") ps.do(myPS) data(sunspots) plot(sunspots) ps.end() tempfile("ex-sun", fileext = ".pdf") -> myPDF pdf.latex(myPDF) plot(sunspots) pdf.end(call. = FALSE) # basically the same as dev.off() } ps.latex(tempfile("ex2", fileext = ".eps")) plot(sunspots) ps.end(call.gv = FALSE) # basically the same as dev.off() } \keyword{device} sfsmisc/man/u.assign0.Rd0000644000176200001440000000151712575757743014624 0ustar liggesusers\name{u.assign0} \alias{u.assign0} \alias{u.get0} \title{'Portable' assign / get functions (R / S-plus) for 'Frame 0'} \description{ \R does not have S' concept of \code{frame = 0}, aka \sQuote{session frame}. These two function were an attempt to provide a portable way for working with frame 0, particularly when porting code \emph{from} S. They have been \bold{deprecated} since August 2013. } \usage{ u.assign0(x, value, immediate = FALSE) u.get0(x) } \arguments{ \item{x}{character string giving the \emph{name} of the object.} \item{value}{any \R object which is to be assigned.} \item{immediate}{logical, for S compatibility. No use in \R.} } \author{Martin Maechler} \note{Really don't use these anymore...} \seealso{\code{\link{get}}, \code{\link{assign}}.} % \keyword{utilities} \keyword{environment}% System, not R sfsmisc/man/p.res.2fact.Rd0000644000176200001440000000373412346606342015025 0ustar liggesusers\name{p.res.2fact} \alias{p.res.2fact} \title{Plot Numeric (e.g. Residuals) vs 2 Factors Using Boxplots} \description{ Plots a numeric \dQuote{residual like} variable against two factor covariates, using boxplots. } \usage{ p.res.2fact(x, y, z, restricted, notch = FALSE, xlab = NULL, ylab = NULL, main = NULL) } \arguments{ \item{x,y}{two factors or numeric vectors giving the levels of factors.} \item{z}{numeric vector of same length as \code{x} and \code{y}, typically residuals.} \item{restricted}{positive value which truncates the size. The corresponding symbols are marked by stars.} \item{notch}{logical indicating if the boxplots should be notched, see \code{\link{boxplot}(*,notch)}.} \item{xlab,ylab}{axis labels, see \code{\link{plot.default}}, per default the actual argument expressions.} \item{main}{main title passed to \code{plot}, defaulting to the deparsed \code{z} argument.} } \details{ if values \emph{are} restricted, this make use of the auxiliar function \code{\link{u.boxplot.x}}. } \author{Lorenz Gygax \email{logyg@wild.unizh.ch} and Martin Maechler, Jan.95; starting from \code{\link{p.res.2x}()}. } \seealso{\code{\link{p.res.2x}}, \code{\link{boxplot}}, \code{\link{plot.lm}}, \code{\link{TA.plot}}. } \examples{ I <- 8; J <- 3; K <- 20 xx <- factor(rep(rep(1:I, rep(K,I)),J)) yy <- factor(rep(1:J, rep(I*K,J))) zz <- rt(I*J*K, df=5) #-- Student t with 5 d.f. p.res.2fact(xx,yy,zz, restr= 4, main= "i.i.d. t <- 5 random |.| <= 4") mtext("p.res.2fact(xx,yy,zz, restr= 4, ..)", line=1, adj=1, outer=TRUE, cex=1) ## Real data data(warpbreaks) (fm1 <- lm(breaks ~ wool*tension, data = warpbreaks)) ## call via formula method of p.res.2x(): p.res.2x(~ ., fm1) # is shorter than, but equivalent to ## p.res.2x(~ wool + tension, fm1) ## or the direct ## with(warpbreaks, p.res.2fact(wool, tension, residuals(fm1))) ## ## whereas this is "transposed": p.res.2x(~ tension+wool, fm1) } \keyword{hplot} \keyword{regression} sfsmisc/man/D1D2.Rd0000644000176200001440000000652410142471470013424 0ustar liggesusers% This is also sym.linked into % Martin's WpDensity package /u/maechler/R/Pkgs/WpDensity/ \name{D1D2} \alias{D1D2} \title{Numerical Derivatives of (x,y) Data via Smoothing Splines} \description{ Compute numerical derivatives of \eqn{f()} given observations \code{(x,y)}, using cubic smoothing splines with GCV, see \code{\link[stats]{smooth.spline}}. In other words, estimate \eqn{f'()} and/or \eqn{f''()} for the model \deqn{Y_i = f(x_i) + E_i, \ \ i = 1,\dots n,} } \usage{ D1D2(x, y, xout = x, spar.offset = 0.1384, deriv = 1:2, spl.spar = NULL) } \arguments{ \item{x,y}{numeric vectors of same length, supposedly from a model \code{y ~ f(x)}.} \item{xout}{abscissa values at which to evaluate the derivatives.} \item{spar.offset}{numeric fudge added to the smoothing parameter, see \code{spl.par} below.} \item{deriv}{integer in \code{1:2} indicating which derivatives are to be computed.} \item{spl.spar}{direct smoothing parameter for \code{smooth.spline}. If it is \code{NULL} (as per default), the smoothing parameter used will be \code{spar.offset + sp$spar}, where \code{sp$spar} is the GCV estimated smoothing parameter, see \code{\link{smooth.spline}}.} } \details{ It is well known that for derivative estimation, the optimal smoothing parameter is larger (more smoothing) than for the function itself. \code{spar.offset} is really just a \emph{fudge} offset added to the smoothing parameter. Note that in \R's implementation of \code{\link{smooth.spline}}, \code{spar} is really on the \eqn{\log\lambda} scale. When \code{deriv = 1:2} (as per default), both derivatives are estimated with the \emph{same} smoothing parameter which is suboptimal for the single functions individually. Another possibility is to call \code{D1D2(*, deriv = k)} twice with \code{k = 1} and \code{k = 2} and use a \emph{larger} smoothing parameter for the second derivative. } \value{ a list with several components, \item{x}{the abscissae values at which the derivative(s) are evaluated.} \item{D1}{if \code{deriv} contains 1, estimated values of \eqn{f'(x_i)} where \eqn{x_i} are the values from \code{xout}.} \item{D2}{if \code{deriv} contains 2, estimated values of \eqn{f''(x_i)}.} \item{spar}{the \bold{s}moothing \bold{par}ameter used in the (final) \code{smooth.spline} call.} \item{df}{the equivalent \bold{d}egrees of \bold{f}reedom in that \code{smooth.spline} call.} } \author{Martin Maechler, in 1992 (for S).} \seealso{\code{\link{D2ss}} which calls \code{smooth.spline} twice, first on \code{y}, then on the \eqn{f'(x_i)} values; \code{\link[stats]{smooth.spline}} on which it relies completely. } \examples{ set.seed(8840) x <- runif(100, 0,10) y <- sin(x) + rnorm(100)/4 op <- par(mfrow = c(2,1)) plot(x,y) lines(ss <- smooth.spline(x,y), col = 4) str(ss[c("df", "spar")]) if(is.R()) plot(cos, 0, 10, ylim = c(-1.5,1.5), lwd=2) else { # Splus xx <- seq(0,10, len=201); plot(xx, cos(xx), type = 'l', ylim = c(-1.5,1.5)) } title(expression("Estimating f'() : " * frac(d,dx) * sin(x) == cos(x))) offs <- c(-0.1, 0, 0.1, 0.2, 0.3) i <- 1 for(off in offs) { d12 <- D1D2(x,y, spar.offset = off) lines(d12$x, d12$D1, col = i <- i+1) } legend(2,1.6, c("true cos()",paste("sp.off. = ", format(offs))), lwd=1, col = 1:(1+length(offs)), cex = 0.8, bg = NA) par(op) } \keyword{smooth} sfsmisc/man/loessDemo.Rd0000644000176200001440000000717113131443372014724 0ustar liggesusers\name{loessDemo} \title{Graphical Interactive Demo of loess()} \alias{loessDemo} \description{ A graphical and interactive demonstration and visualization of how \code{\link{loess}} works. By clicking on the graphic, the user determines the current estimation window which is visualized together with the weights. } \usage{ loessDemo(x, y, span = 1/2, degree = 1, family = c("gaussian", "symmetric"), nearest = FALSE, nout = 501, xlim = numeric(0), ylim = numeric(0), strictlim = TRUE, verbose = TRUE, inch.sym = 0.25, pch = 4, shade = TRUE, w.symbols = TRUE, sym.col = "blue", w.col = "light blue", line.col = "steelblue") } \arguments{ \item{x,y}{numeric vectors of the same length; the demo is about \code{\link{loess}(y ~ x)}.} \item{span}{the smoothing parameter \eqn{\alpha}.} \item{degree}{the degree of the polynomials to be used; must be in \eqn{{0,1,2}}.} \item{family}{if \code{"gaussian"} fitting is by least-squares, and if \code{"symmetric"} a re-descending M estimator is used with Tukey's biweight function. Can be abbreviated.} \item{nearest}{logical indicating how \eqn{x_0} should be determined, the value at which \eqn{\hat{f}(x_0)}{f^(x_0)} is computed. If \code{nearest} is true, the closest \emph{data} value is taken. } \item{nout}{the number of points at which to evaluate, i.e, determining \eqn{u_i}, \eqn{i = 1,2, \dots, \mathtt{nout}}, at which \eqn{\hat{f}(u_i)}{f^(u_i)} is computed.} \item{xlim}{x-range; to extend or determine (iff \code{strictlim} is true) the \eqn{x}-range for plotting.} \item{ylim}{y-range; to extend or determine (iff \code{strictlim} is true) the \eqn{y}-range for plotting.} \item{strictlim}{logical determining if \code{xlim} and \code{ylim} should be strict limits (as e.g., in \code{\link{plot.default}}), or just a suggestion to \emph{extend} the data-dependent ranges.} \item{verbose}{logical ......} \item{inch.sym}{symbol size in inches of the maximal weight circle symbol.} \item{pch}{plotting character, see \code{\link{points}}.} \item{shade}{logical; if true, \code{\link{polygon}(.., density=..)} will be used to shade off the regions where the weights are zero.} \item{w.symbols}{logical indicating if the non-zero weights should be visualized by circles with radius proportional to \code{inch.sym} and \eqn{\sqrt{w}} where \eqn{w} are the weights.} \item{sym.col, w.col, line.col}{colors for the symbols, weights and lines, respectively.} } %% \value{ %% } \author{%%for grep: Greg Snow, ... Henrik Aa. Nielsen .. As function \code{loess.demo()}, written and posted to S-news, on 27 Sep 2001, by Greg Snow, Brigham Young University, % gls@byu.edu it was modified by Henrik Aa. Nielsen, IMM, DTU, % han@imm.dtu.dk and subsequently spiffed up for \R by Martin Maechler. } \seealso{ \code{\link{loess}}. } \examples{ if(dev.interactive()) { if(requireNamespace("lattice")) { data("ethanol", package = "lattice") attach(ethanol) loessDemo(E,NOx, span=.25) loessDemo(E,NOx, span=.25, family = "symmetric") loessDemo(E,NOx, degree=0)# Tricube Kernel estimate }% if (. lattice .) ## Artificial Example with one outlier n2 <- 50; x <- 1:(1+2*n2) fx <- (x/10 - 5)^2 y <- fx + 4*rnorm(x) y[n2+1] <- 1e4 loessDemo(x,y, span=1/3, ylim= c(0,1000))# not robust !! loessDemo(x,y, span=1/3, family = "symm") loessDemo(x,y, span=1/3, family = "symm", w.symb = FALSE, ylim = c(0,40)) loessDemo(x,y, span=1/3, family = "symm", ylim = c(0,40)) ## but see warnings() --- there's a "fixup" }% only if interactive } \keyword{loess} \keyword{dynamic} \keyword{hplot} sfsmisc/man/nearcor.Rd0000644000176200001440000001071713246037205014424 0ustar liggesusers% Copyright (2007) Jens Oehlschlgel % GPL licence, no warranty, use at your own risk % Copyright (2007-2010) Martin Maechler \name{nearcor} \alias{nearcor} \encoding{latin1} \title{Find the Nearest Proper Correlation Matrix} \description{ This function \dQuote{smoothes} an improper correlation matrix as it can result from \code{\link{cor}} with \code{use="pairwise.complete.obs"} or \code{\link[polycor]{hetcor}}. It is \emph{deprecated} now, in favor of \code{\link[Matrix]{nearPD}()} from package \CRANpkg{Matrix}.% 2013-01-16 } \usage{ nearcor(R, eig.tol = 1e-06, conv.tol = 1e-07, posd.tol = 1e-08, maxits = 100, verbose = FALSE) } \arguments{ \item{R}{a square symmetric approximate correlation matrix} \item{eig.tol}{defines relative positiveness of eigenvalues compared to largest, default=1.0e-6.} \item{conv.tol}{convergence tolerance for algorithm, default=1.0e-7 } \item{posd.tol}{tolerance for enforcing positive definiteness, default=1.0e-8} \item{maxits}{maximum number of iterations} \item{verbose}{logical specifying if convergence monitoring should be verbose.} } \details{ This implements the algorithm of Higham (2002), then forces symmetry, then forces positive definiteness using code from \code{\link[sfsmisc]{posdefify}}. This implementation does not make use of direct LAPACK access for tuning purposes as in the MATLAB code of Lucas (2001). The algorithm of Knol DL and ten Berge (1989) (not implemented here) is more general in (1) that it allows contraints to fix some rows (and columns) of the matrix and (2) to force the smallest eigenvalue to have a certain value. } \value{ A \code{\link{list}}, with components \item{cor}{resulting correlation matrix} \item{fnorm}{Froebenius norm of difference of input and output} \item{iterations}{number of iterations used} \item{converged}{logical} } \references{See those in \code{\link[sfsmisc]{posdefify}}. } \author{ Jens Oehlschlgel } \seealso{the slightly more flexible \code{\link[Matrix]{nearPD}} which also returns a \emph{classed} matrix (class \code{dpoMatrix}). For new code, \code{nearPD()} is really preferred to \code{nearcor()}, which hence is considered deprecated. \code{\link[polycor]{hetcor}}, \code{\link{eigen}}; \code{\link[sfsmisc]{posdefify}} for a simpler algorithm. } \examples{ cat("pr is the example matrix used in Knol DL, ten Berge (1989)\n") pr <- matrix(c(1, 0.477, 0.644, 0.478, 0.651, 0.826, 0.477, 1, 0.516, 0.233, 0.682, 0.75, 0.644, 0.516, 1, 0.599, 0.581, 0.742, 0.478, 0.233, 0.599, 1, 0.741, 0.8, 0.651, 0.682, 0.581, 0.741, 1, 0.798, 0.826, 0.75, 0.742, 0.8, 0.798, 1), nrow = 6, ncol = 6) ncr <- nearcor(pr) nr <- ncr$cor \dontshow{ stopifnot(all.equal(nr[lower.tri(nr)], c(0.487968018215891, 0.642651880010905, 0.490638670907082, 0.64409905308119, 0.808711184549399, 0.514114729435273, 0.250668810831206, 0.672351311297071, 0.725832055882792, 0.596827778712155, 0.582191779051908, 0.744963163381413, 0.729882058012398, 0.772150225146827, 0.813191720191943))) } plot(pr[lower.tri(pr)], nr[lower.tri(nr)]); abline(0,1, lty=2) round(cbind(eigen(pr)$values, eigen(nr)$values), 8) cat("The following will fail:\n") try(factanal(cov=pr, factors=2)) cat("and this should work\n") try(factanal(cov=nr, factors=2)) if(require("polycor")) { n <- 400 x <- rnorm(n) y <- rnorm(n) x1 <- (x + rnorm(n))/2 x2 <- (x + rnorm(n))/2 x3 <- (x + rnorm(n))/2 x4 <- (x + rnorm(n))/2 y1 <- (y + rnorm(n))/2 y2 <- (y + rnorm(n))/2 y3 <- (y + rnorm(n))/2 y4 <- (y + rnorm(n))/2 dat <- data.frame(x1, x2, x3, x4, y1, y2, y3, y4) x1 <- ordered(as.integer(x1 > 0)) x2 <- ordered(as.integer(x2 > 0)) x3 <- ordered(as.integer(x3 > 1)) x4 <- ordered(as.integer(x4 > -1)) y1 <- ordered(as.integer(y1 > 0)) y2 <- ordered(as.integer(y2 > 0)) y3 <- ordered(as.integer(y3 > 1)) y4 <- ordered(as.integer(y4 > -1)) odat <- data.frame(x1, x2, x3, x4, y1, y2, y3, y4) xcor <- cor(dat) pcor <- cor(data.matrix(odat)) # cor() no longer works for factors hcor <- hetcor(odat, ML=TRUE, std.err=FALSE)$correlations ncor <- nearcor(hcor)$cor try(factanal(covmat=xcor, factors=2, n.obs=n)) try(factanal(covmat=pcor, factors=2, n.obs=n)) try(factanal(covmat=hcor, factors=2, n.obs=n)) try(factanal(covmat=ncor, factors=2, n.obs=n)) } } \keyword{algebra} \keyword{array} sfsmisc/man/axTexpr.Rd0000644000176200001440000000430612575757743014447 0ustar liggesusers\name{axTexpr} \alias{axTexpr} \title{Axis Ticks Expressions in Nice 10 ** k Form} \description{ Produce nice \eqn{a \times 10^k}{a * 10^k} expressions for \code{\link{axis}} labeling instead of the scientific notation \code{"a E"}. } \usage{ axTexpr(side, at = axTicks(side, axp = axp, usr = usr, log = log), axp = NULL, usr = NULL, log = NULL, drop.1 = FALSE) } \arguments{ \item{side}{integer in 1:4 specifying the axis side, as for \code{\link{axis}}.} \item{at}{numeric vector; with identical default as in \code{\link{axTicks}()}.} \item{axp, usr, log}{as for \code{\link{axTicks}()}.} \item{drop.1}{logical indicating if \eqn{1 \times}{1 *} should be dropped from the resulting expressions.} } \details{ This is just a utility with the same arguments as \code{\link{axTicks}}, a wrapper \code{\link{pretty10exp}(at, *)}. } \value{ an expression of the same length as \code{x}, with elements of the form \code{a \%*\% 10 ^ k}. } \author{Martin Maechler} \seealso{\code{\link{pretty10exp}}; \code{\link{eaxis}}, \code{\link{axis}}, \code{\link{axTicks}}. } \examples{ x <- 1e7*(-10:50) y <- dnorm(x, m=10e7, s=20e7) plot(x,y)## not really nice, the following is better: ## For horizontal y-axis labels, need more space: op <- par(mar= .1+ c(5,5,4,1)) plot(x,y, axes= FALSE, frame=TRUE) aX <- axTicks(1); axis(1, at=aX, label= axTexpr(1, aX)) ## horizontal labels on y-axis: aY <- axTicks(2); axis(2, at=aY, label= axTexpr(2, aY), las=2) par(op) ### -- only 'x' and using log-scale there: plot(x,y, xaxt= "n", log = "x") aX <- axTicks(1); axis(1, at=aX, label= axTexpr(1, aX)) ## Now an "engineer's version" ( more ticks; only label "10 ^ k" ) : axp <- par("xaxp") #-> powers of 10 *inside* 'usr' axp[3] <- 1 # such that only 10^. are labeled aX <- axTicks(1, axp = axp) xu <- 10 ^ par("usr")[1:2] e10 <- c(-1,1) + round(log10(axp[1:2])) ## exponents of 10 *outside* 'usr' v <- c(outer(1:9, e10[1]:e10[2], function(x,E) x * 10 ^ E)) v <- v[xu[1] <= v & v <= xu[2]] plot(x,y, xaxt= "n", log = "x", main = "engineer's version of x - axis") axis(1, at = aX, label = axTexpr(1, aX, drop.1=TRUE)) # 'default' axis(1, at = v, label = FALSE, tcl = 2/3 * par("tcl")) } \keyword{dplot} sfsmisc/man/col01scale.Rd0000644000176200001440000000144010000534352014700 0ustar liggesusers\name{col01scale} \alias{col01scale} \alias{colcenter} \title{Matrix Scaling Utilities} \description{ \code{col01scale} and \code{colcenter} (re)scale the columns of a matrix. These are simple one-line utilities, mainly with a didactical purpose. } \usage{ colcenter (mat) col01scale(mat, scale.func = function(x) diff(range(x)), location.func = mean) } \arguments{ \item{mat}{numeric matrix, to rescaled.} \item{scale.func, location.func}{two functions mapping a numeric vector to a single number.} } \value{ a matrix with the same attributes as the input \code{mat}. } \author{Martin Maechler} \seealso{The standard \R function \code{\link{scale}()}.} \examples{ ## See the simple function definitions: colcenter ## simply one line col01scale# almost as simple } \keyword{array} sfsmisc/man/sfsmisc-defunct.Rd0000644000176200001440000000224213020007125016046 0ustar liggesusers\name{sfsmisc-defunct} \title{Defunct Functions in Package \pkg{sfsmisc}} %------ NOTE: ../R/Defunct.R must be synchronized with this! % ~~~~~~~~~~~ \alias{sfsmisc-defunct} %------ PLEASE: put \alias{.} here for EACH ! % Move things from here to ../Old_Defunct/ % ~~~~~~~~~~~~~~~ \alias{list2mat} \alias{pl.ds} \alias{p.pllines} \description{ The functions or variables listed here are no longer part of package \pkg{sfsmisc} as they are not needed (any more). } \usage{ ## Defunct in 2016-12 --> to be sfsmisc 1.1-1 list2mat(x, check = TRUE) p.pllines(x,y,group,lty=c(1,3,2,4),\dots) ## deprecated from 2007 to 2013; defunct since 2014-01: pl.ds() ##-- is replaced by plotDS() } \details{ \code{list2mat(x)} was usually the same as \code{sapply(x, c)} (where the latter does not construct column names where \code{x} has no names). \code{p.pllines} is now defunct because basic \R graphics (but not S-PLUS) provide its functionality directly: Use \code{plot(x,y, lty = group, type = 'l', ...)}. \code{pl.ds} has been renamed to \code{\link{plotDS}()} in 2007. } \seealso{ \code{\link{Defunct}} } \keyword{internal} sfsmisc/man/D2ss.Rd0000644000176200001440000001000610142471531013571 0ustar liggesusers\name{D2ss} \alias{D2ss} \alias{D1ss} \alias{D1tr} \title{Numerical Derivatives of (x,y) Data (via Smoothing Splines)} \description{ Compute the numerical first or 2nd derivatives of \eqn{f()} given observations \code{(x[i], y ~= f(x[i]))}. \code{D1tr} is the \emph{\bold{tr}ivial} discrete first derivative using simple difference ratios, whereas \code{D1ss} and \code{D2ss} use cubic smoothing splines (see \code{\link[stats]{smooth.spline}}) to estimate first or second derivatives, respectively. \code{D2ss} first uses \code{smooth.spline} for the first derivative \eqn{f'()} and then applies the same to the predicted values \eqn{\hat f'(t_i)}{f'^(t[i])} (where \eqn{t_i}{t[i]} are the values of \code{xout}) to find \eqn{\hat f''(t_i)}{f''^(t[i])}. } \usage{ D1tr(y, x = 1) D1ss(x, y, xout = x, spar.offset = 0.1384, spl.spar=NULL) D2ss(x, y, xout = x, spar.offset = 0.1384, spl.spar=NULL) } \arguments{ \item{x,y}{numeric vectors of same length, supposedly from a model \code{y ~ f(x)}. For \code{D1tr()}, \code{x} can have length one and then gets the meaning of \eqn{h = \Delta x}.} \item{xout}{abscissa values at which to evaluate the derivatives.} \item{spar.offset}{numeric fudge added to the smoothing parameter(s), see \code{spl.par} below. Note that the current default is there for historical reasons only, and we often would recommend to use \code{spar.offset = 0} instead.} \item{spl.spar}{direct smoothing parameter(s) for \code{smooth.spline}. If it is \code{NULL} (as per default), the smoothing parameter used will be \code{spar.offset + sp$spar}, where \code{sp$spar} is the GCV estimated smoothing parameter for \emph{both} smooths, see \code{\link{smooth.spline}}.} } \details{ It is well known that for derivative estimation, the optimal smoothing parameter is larger (more smoothing needed) than for the function itself. \code{spar.offset} is really just a \emph{fudge} offset added to the smoothing parameters. Note that in \R's implementation of \code{\link{smooth.spline}}, \code{spar} is really on the \eqn{\log\lambda} scale. % % When \code{deriv = 1:2} (as per default), both derivatives are % estimated with the \emph{same} smoothing parameter which is suboptimal % for the single functions individually. Another possibility is to call % \code{D1D2(*, deriv = k)} twice with \code{k = 1} and \code{k = 2} and % use a \emph{larger} smoothing parameter for the second derivative. } \value{ \code{D1tr()} and \code{D1ss()} return a numeric vector of the length of \code{y} or \code{xout}, respectively. \code{D2ss()} returns a list with components \item{x}{the abscissae values (= \code{xout}) at which the derivative(s) are evaluated.} \item{y}{estimated values of \eqn{f''(x_i)}.} \item{spl.spar}{numeric vector of length 2, contain the \code{spar} arguments to the two \code{smooth.spline} calls.} \item{spar.offset}{as specified on input (maybe rep()eated to length 2).} } \author{Martin Maechler, in 1992 (for S).} \seealso{\code{\link{D1D2}} which directly uses the 2nd derivative of the smoothing spline; \code{\link{smooth.spline}}. } \examples{ ## First Derivative --- spar.off = 0 ok "asymptotically" (?) set.seed(330) mult.fig(12) for(i in 1:12) { x <- runif(500, 0,10); y <- sin(x) + rnorm(500)/4 f1 <- D1ss(x=x,y=y, spar.off=0.0) plot(x,f1, ylim = range(c(-1,1,f1))) curve(cos(x), col=3, add= TRUE) } set.seed(8840) x <- runif(100, 0,10) y <- sin(x) + rnorm(100)/4 op <- par(mfrow = c(2,1)) plot(x,y) lines(ss <- smooth.spline(x,y), col = 4) str(ss[c("df", "spar")]) xx <- seq(0,10, len=201) plot(xx, -sin(xx), type = 'l', ylim = c(-1.5,1.5)) title(expression("Estimating f''() : " * frac(d^2,dx^2) * sin(x) == -sin(x))) offs <- c(0.05, 0.1, 0.1348, 0.2) i <- 1 for(off in offs) { d12 <- D2ss(x,y, spar.offset = off) lines(d12, col = i <- i+1) } legend(2,1.6, c("true : -sin(x)",paste("sp.off. = ", format(offs))), lwd=1, col = 1:(1+length(offs)), cex = 0.8, bg = NA) par(op) } \keyword{smooth} sfsmisc/man/last.Rd0000644000176200001440000000246113246037205013733 0ustar liggesusers\name{last} \encoding{latin1} \alias{last} \title{Get Last Elements of a Vector} \description{ Extract the last elements of a vector. } \usage{ last(x, length.out = 1, na.rm = FALSE) } \arguments{ \item{x}{any vector.} \item{length.out}{integer indicating how many element are desired. If positive, return the \code{length.out} last elements of \code{x}; if negative, the last \code{length.out} elements are \emph{dropped}. } \item{na.rm}{logical indicating if the last non-missing value (if any) shall be returned. By default (it is \code{FALSE} and) the last elements (whatever its values) are returned.} } \value{ a vector of length \code{abs(length.out)} of \emph{last} values from \code{x}. } \author{Werner Stahel (\email{stahel@stat.math.ethz.ch}), and independently, Philippe Grosjean (\email{phgrosjean@sciviews.org}), Frdric Ibanez (\email{ibanez@obs-vlfr.fr}).} \note{ This function may eventually be deprecated for the standard \R function \code{\link{tail}()}. Useful for the \code{\link[pastecs]{turnogram}()} function in package \CRANpkg{pastecs}. } \seealso{\code{\link[pastecs]{first}}, \code{\link[pastecs]{turnogram}} } \examples{ a <- c(NA, 1, 2, NA, 3, 4, NA) last(a) last(a, na.rm=TRUE) last(a, length = 2) last(a, length = -3) } \keyword{ manip } sfsmisc/TODO0000644000176200001440000000471714017671432012427 0ustar liggesusers##-*- org -*- * TODO *formally* deprecate repChar() and bl.string() in favor of R (>= 3.3.0) strrep() * TODO more to sessionInfoX(); chk openBLAS etc, see more moreSessionInfo() in robustbase, ~/R/Pkgs/robustbase/inst/xtraR/platform-sessionInfo.R * TODO finish and export pkgLibs() R/unix/package-props.R * TODO New utilities for MASS::boxcox() "diagnostics", notably histogram nicely labeled ** --> ~/R/MM/Pkg-ex/microbenchmark/seq-mb.R ** Maybe ask Brian about willingness to improve: boxcox(*, plotit=TRUE) looks nice, ** but the estimate + conf.interval computations are inside the plotting, not available as numbers * TODO Better ylim for boxplot(), see, ~/R/MM/Pkg-ex/microbenchmark/simple-ex.R * TODO mat2tex() is really not flexible enough; and there are better functions in other packages, e.g. latex in 'Hmisc' --> deprecate this! [2005-04] * TODO str_data() could become more flexible (class = "."; also (optionally) return class + dim()/length(); see 'TODO' in [[R/str_data.R]] * TODO is.whole() [[R/misc-goodies.R]] conflicts with gmp::is.whole() -- as it has a 'tolerance' * TODO move some demo/*.R to vignettes/*.Rmd -- notably the prime-numbers (for those, see also below) * TODO clean up R/prime-numbers-fn.R -- move all non-exported functions to ** TODO (a new file) ./inst/primes-extra-fns.R ** TODO and source() that from ./demo/prime-numbers.R !! * Reverse Dep. status: 2014-06-16 http://stat.ethz.ch/CRAN/web/packages/sfsmisc/ ** Reverse depends: ascrda, catIrt, distr, ICEbox, lordif, modiscloud, plfm, polycor, random.polychor.pa ** Reverse imports: CDM, Demerelate, FrF2, lokern, mcmcplots, ReliabilityTheory, simsalapar, sirt, TAM * TODO Improve ps.end(): should return something useful ==> new ./tests/psend-ex.R which tests that 2 x {ps.do() ... ps.end()} *does* work properly * TODO eaxis() [ ./R/prettylab.R ] : ** TODO allow log2-scale and "2^..." labelling --- or log_k and 'k^..' ** TODO this is a range where the *defaults* of eaxis are completely bad --> but really it is because axTicks(*, log=TRUE) can be bad: curve(qgamma(1e-100, x, lower.tail=FALSE), 1e-110, 1e-70, log="xy", col=2, axes=FALSE) eaxis(1);eaxis(2) * TODO Work on R/approx2.R, for now [[approx2.R]] -- implement remaining "vectorized" part * DONE 2017-08-xx: in [[DESCRIPTION]], use Authors@R with Werner, Andreas, .., Alain, .. * DONE 2008-10-22: Copied boxplot.matrix() to R-devel (2.9.0 to be) Remove this from 'sfsmisc' eventually. sfsmisc/DESCRIPTION0000644000176200001440000001040714120063352013425 0ustar liggesusersPackage: sfsmisc Title: Utilities from 'Seminar fuer Statistik' ETH Zurich Version: 1.1-12 VersionNote: Last CRAN: 1.1-11 on 2021-04-03 Date: 2021-09-10 Authors@R: c(person("Martin","Maechler", role=c("aut","cre"), email="maechler@stat.math.ethz.ch", comment = c(ORCID = "0000-0002-8685-9910")) , person("Werner", "Stahel", role = "ctb", comment = "Functions: compresid2way(), f.robftest(), last(), p.scales(), p.dnorm()") , person("Andreas", "Ruckstuhl", role = "ctb", comment = "Functions: p.arrows(), p.profileTraces(), p.res.2x()") , person("Christian", "Keller", role = "ctb", comment = "Functions: histBxp(), p.tachoPlot()") , person("Kjetil", "Halvorsen", role = "ctb", comment = "Functions: KSd(), ecdf.ksCI()") , person("Alain", "Hauser", role = "ctb", comment = "Functions: cairoSwd(), is.whole(), toLatex.numeric()*") , person("Christoph", "Buser", role = "ctb", comment = "to function Duplicated()") , person("Lorenz", "Gygax", role = "ctb", comment = "to function p.res.2fact()") , person("Bill", "Venables", role = "ctb", comment = "Functions: empty.dimnames(), primes()") , person("Tony", "Plate", role = "ctb", comment = "to inv.seq()") # minor contributors: , person("Isabelle", "Flckiger", role = "ctb") , person("Marcel", "Wolbers", role = "ctb") , person("Markus", "Keller", role = "ctb") , person("Sandrine", "Dudoit", role = "ctb") , person("Jane", "Fridlyand", role = "ctb") , person("Greg", "Snow", role = "ctb", comment = "to loessDemo()") , person("Henrik Aa.", "Nielsen", role = "ctb", comment = "to loessDemo()") , person("Vincent", "Carey", role = "ctb") , person("Ben", "Bolker", role = "ctb") , person("Philippe", "Grosjean", role = "ctb") , person("Frdric", "Ibanez", role = "ctb") , person("Caterina", "Savi", role = "ctb") , person("Charles", "Geyer", role = "ctb") , person("Jens", "Oehlschlgel", role = "ctb") ) Maintainer: Martin Maechler Description: Useful utilities ['goodies'] from Seminar fuer Statistik ETH Zurich, some of which were ported from S-plus in the 1990s. For graphics, have pretty (Log-scale) axes, an enhanced Tukey-Anscombe plot, combining histogram and boxplot, 2d-residual plots, a 'tachoPlot()', pretty arrows, etc. For robustness, have a robust F test and robust range(). For system support, notably on Linux, provides 'Sys.*()' functions with more access to system and CPU information. Finally, miscellaneous utilities such as simple efficient prime numbers, integer codes, Duplicated(), toLatex.numeric() and is.whole(). Depends: R (>= 3.3.0) Imports: grDevices, methods, utils, stats, tools Suggests: datasets, tcltk, cluster, lattice, MASS, Matrix, nlme, lokern Enhances: mgcv, rpart, nor1mix, polycor, sm, tikzDevice, e1071, Hmisc, gmp, pastecs, polynom, robustbase EnhancesNote: 2nd line: packages mentioned in Rd xrefs Encoding: latin1 ByteCompile: yes License: GPL (>= 2) URL: https://github.com/mmaechler/sfsmisc BugReports: https://github.com/mmaechler/sfsmisc/issues NeedsCompilation: no Packaged: 2021-09-13 20:40:15 UTC; maechler Author: Martin Maechler [aut, cre] (), Werner Stahel [ctb] (Functions: compresid2way(), f.robftest(), last(), p.scales(), p.dnorm()), Andreas Ruckstuhl [ctb] (Functions: p.arrows(), p.profileTraces(), p.res.2x()), Christian Keller [ctb] (Functions: histBxp(), p.tachoPlot()), Kjetil Halvorsen [ctb] (Functions: KSd(), ecdf.ksCI()), Alain Hauser [ctb] (Functions: cairoSwd(), is.whole(), toLatex.numeric()*), Christoph Buser [ctb] (to function Duplicated()), Lorenz Gygax [ctb] (to function p.res.2fact()), Bill Venables [ctb] (Functions: empty.dimnames(), primes()), Tony Plate [ctb] (to inv.seq()), Isabelle Flckiger [ctb], Marcel Wolbers [ctb], Markus Keller [ctb], Sandrine Dudoit [ctb], Jane Fridlyand [ctb], Greg Snow [ctb] (to loessDemo()), Henrik Aa. Nielsen [ctb] (to loessDemo()), Vincent Carey [ctb], Ben Bolker [ctb], Philippe Grosjean [ctb], Frdric Ibanez [ctb], Caterina Savi [ctb], Charles Geyer [ctb], Jens Oehlschlgel [ctb] Repository: CRAN Date/Publication: 2021-09-14 09:10:02 UTC sfsmisc/tests/0000755000176200001440000000000014117733424013071 5ustar liggesuserssfsmisc/tests/p.R0000644000176200001440000000032010126004731013432 0ustar liggesusers#### Plots etc library(sfsmisc) ## A time-series with start and end *not* at year boundary: data(EuStockMarkets) SMI <- EuStockMarkets[, "SMI"] p.ts(SMI)# gave warning (and was 'wrong' but "only" visually) sfsmisc/tests/posdef.R0000644000176200001440000000344314032027146014471 0ustar liggesuserslibrary(sfsmisc) options(digits=9) set.seed(12) m <- matrix(round(rnorm(25),2), 5, 5); m <- 1+ m + t(m); diag(m) <- diag(m) + 4 (mp <- posdefify(m)) (mp. <- posdefify(m, method = "allEV")) stopifnot(eigen(mp, only.val=TRUE)$values > 0, eigen(mp., only.val=TRUE)$values > 0, all.equal(diag(m), diag(mp), tol= 1e-15), all.equal(diag(m), diag(mp.),tol= 1e-15), T) ## nearcor() pr <- matrix(c(1, 0.477, 0.644, 0.478, 0.651, 0.826, 0.477, 1, 0.516, 0.233, 0.682, 0.75, 0.644, 0.516, 1, 0.599, 0.581, 0.742, 0.478, 0.233, 0.599, 1, 0.741, 0.8, 0.651, 0.682, 0.581, 0.741, 1, 0.798, 0.826, 0.75, 0.742, 0.8, 0.798, 1), nrow = 6, ncol = 6) nc. <- nearcor(pr, conv.tol = 1e-7) # default, 11 iter. ncr <- nearcor(pr, conv.tol = 1e-15) # 27-28 iterations (because of conv.tol)! ncr0 <- nearcor(pr, conv.tol = 1e-15, posd.tol = 0)# -> no posdefify step parts <- setdiff(names(nc.), "iterations") ## IGNORE_RDIFF_BEGIN str(ncr) if(ncr$iterations != 28) { cat(sprintf("On this platform, the number of iterations (for tol 1e-15) is not 28, but %d;\n", ncr$iterations)) cat("sessionInfoX() :\n") print(sessionInfoX()) } ## IGNORE_RDIFF_END str(ncr0[parts])# looks identical (with few digits accuracy) nr <- ncr$cor stopifnot(exprs = { nc.$iterations == 11 all.equal(nr[lower.tri(nr)], c(0.48796803265083, 0.64265188295401, 0.49063868812228, 0.64409905497094, 0.80871120142824, 0.51411473401472, 0.25066882763262, 0.67235131534931, 0.72583206922437, 0.59682778611131, 0.58219178154582, 0.7449631866236, 0.72988206459063, 0.77215024062758, 0.81319175546212), tol = 1e-12) all.equal(ncr, ncr0, tolerance = 6e-6)# seen 6.6676e-7 }) sfsmisc/tests/eaxis.R0000644000176200001440000000065213376772552014343 0ustar liggesuserslibrary(sfsmisc) expo <- -3:4 stopifnot(exprs = { all.equal(pretty10exp(10^expo, drop.1=TRUE, sub10 = c(-2, 2)), expression(10^-3, 0.01, 0.1, 1, 10, 100, 10^3, 10^4)) identical(pretty10exp(10^expo, drop.1=TRUE, sub10 = c(-2, 2), lab.type="latex"), c("$10^{-3}$", "0.01", "0.1", "1", "10", "100", "$10^{3}$", "$10^{4}$")) ## gave exponential format for "latex" case. }) sfsmisc/tests/dDA.R0000644000176200001440000000454213446512436013653 0ustar liggesuserslibrary(sfsmisc) ###--------------- "Iris Example for ever" ---------------------------- data(iris) cl.true <- as.integer(iris[,"Species"]) n <- length(cl.true) stopifnot(cl.true == rep(1:3, each = 50)) m.iris <- data.matrix(iris[, 1:4]) .proctime00 <- proc.time() ## Self Prediction: Not too good (2+4 and 3+3 misclass.) table(diagDA(m.iris, cl.true, m.iris), cl.true) table(diagDA(m.iris, cl.true, m.iris, pool=FALSE), cl.true) ## Crossvalidation: The same example as knn() & knn1() from "class" : data(iris3) train <- rbind(iris3[1:25,,1], iris3[1:25,,2], iris3[1:25,,3]) test <- rbind(iris3[26:50,,1], iris3[26:50,,2], iris3[26:50,,3]) cl <- rep(1:3, each = 25) pcl <- diagDA(train, cl, test) table(pcl, cl)## 0 + 1 + 2 misclassified ## knn ( k=1) has 0 + 1 + 3 ## knn ( *, k=3) has 0 + 2 + 3 ==> ``diagDA() is best ..'' stopifnot(pcl == diagDA(train,cl, test, pool = FALSE)) # i.e. quadratic identical here ### Test 'NA' in predict dat.fr RNGversion("3.5.0")# -- so w/ sample() still stays unchanged: set.seed(753) itr <- sample(n, 0.9 * n) lrn <- m.iris[ itr,] tst <- m.iris[-itr,] dd <- dDA(lrn, cl.true[itr]) pd0 <- predict(dd, tst) i.NA <- c(3:5,7,11) j.NA <- sample(1:ncol(tst), size=length(i.NA), replace=TRUE) tst[cbind(i.NA, j.NA)] <- NA pdd <- predict(dd, tst) pcl <- diagDA(lrn, cl.true[itr], tst) stopifnot(length(pdd) == nrow(tst), identical(pdd, pcl), pdd[-i.NA] == pd0[-i.NA], which(is.na(pdd)) == i.NA) ## Now do some (randomized) CV : ## for each observation, count how often it's misclassified M <- 200 set.seed(234) missCl <- integer(n) for(m in 1:M) { itr <- sample(n, 0.9 * n) lrn <- m.iris[ itr,] tst <- m.iris[-itr,] pcl <- diagDA(lrn, cl.true[itr], tst) stopifnot(pcl == predict(dDA(lrn, cl.true[itr]), tst)) missCl <- missCl + as.integer(pcl != cl.true[ - itr]) } missCl ; mean(missCl) / M ## The "same" with 'pool=FALSE' : missCl <- integer(n) for(m in 1:M) { itr <- sample(n, 0.9 * n) lrn <- m.iris[ itr,] tst <- m.iris[-itr,] pcl <- diagDA(lrn, cl.true[itr], tst, pool=FALSE) stopifnot(pcl == predict(dDA(lrn, cl.true[itr], pool=FALSE), tst)) missCl <- missCl + as.integer(pcl != cl.true[ - itr]) } missCl ; mean(missCl) / M ## here somewhat worse than linear cat('Time elapsed: ', proc.time() - .proctime00,'\n') sfsmisc/tests/misc.R0000644000176200001440000000273213174067641014156 0ustar liggesusersrequire("sfsmisc") options(warn=2) AsciiToInt(LETTERS) # gave '.. embedded nul ..' warning ## just for fun -- typically shows "iso-latin1 charset cat(chars8bit(1:255),"\"\n") ## Checking the new 'ndigits' default argument for digitsBase(): ee <- 0:30 for(base in 2:64) stopifnot((be <- base^ee) > 0, any(ok <- be < 2^52), ee == floor(1e-9+ log(be, base)), 0 == as.integer(digitsBase(0, base=base)), # failed be[ok] == as.integer(digitsBase(be[ok], base=base))) ## failed, e.g. for 3^5, in sfsmisc <= 1.0-22 ## Tests for is.whole (taken from the examples) set.seed(307) a <- array(runif(24), dim = c(2, 3, 4)) a[4:8] <- 4:8 m <- matrix(runif(12), 3, 4) m[2:4] <- 2:4 v <- complex(real = seq(0.5, 1.5, by = 0.1), imaginary = seq(2.5, 3.5, by = 0.1)) ## Find whole entries stopifnot(identical(is.whole(a), a == round(a)), identical(is.whole(m), m == round(m)), which(is.whole(v)) == 6) ## Numbers of class integer are always whole stopifnot(is.whole(dim(a)), is.whole(length(v)), is.whole(-1L)) ## From: Liping Seng ## Subject: Bug with integrate.xy()? ## Date: Wed, 7 Jun 2017 12:24:12 +0000 ## MM simplified set.seed(1776) y <- rnorm(200) fit <- density(y, bw = 0.3773427, n=1024, kernel="epanechnikov") integrate.xy(fit$x, fit$y, min(fit$x), 1.7927854, xtol=3.16228e-7) ## Fixed (2017-06-08) ## Error in seq.default(a, length = max(0, b - a - 1)) : ## 'length.out' must be a non-negative number sfsmisc/tests/posdef.Rout.save0000644000176200001440000000731414032027146016157 0ustar liggesusers R Under development (unstable) (2020-02-04 r77771) -- "Unsuffered Consequences" Copyright (C) 2020 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. > library(sfsmisc) > > options(digits=9) > > set.seed(12) > m <- matrix(round(rnorm(25),2), 5, 5); m <- 1+ m + t(m); diag(m) <- diag(m) + 4 > (mp <- posdefify(m)) [,1] [,2] [,3] [,4] [,5] [1,] 2.040000000 1.559508625 -0.887340889 -0.408171836 -0.245682172 [2,] 1.559508625 4.360000000 -0.533157355 1.705637933 2.344838314 [3,] -0.887340889 -0.533157355 3.440000000 1.195027865 1.353283301 [4,] -0.408171836 1.705637933 1.195027865 6.020000000 0.577514304 [5,] -0.245682172 2.344838314 1.353283301 0.577514304 2.940000000 > (mp. <- posdefify(m, method = "allEV")) [,1] [,2] [,3] [,4] [,5] [1,] 2.040000000 1.378740895 -0.424598775 -0.386773282 -0.434470464 [2,] 1.378740895 4.360000000 -0.613091776 1.507019105 2.225434128 [3,] -0.424598775 -0.613091776 3.440000000 0.940298040 1.156766185 [4,] -0.386773282 1.507019105 0.940298040 6.020000000 0.277226191 [5,] -0.434470464 2.225434128 1.156766185 0.277226191 2.940000000 > > stopifnot(eigen(mp, only.val=TRUE)$values > 0, + eigen(mp., only.val=TRUE)$values > 0, + all.equal(diag(m), diag(mp), tol= 1e-15), + all.equal(diag(m), diag(mp.),tol= 1e-15), + T) > > ## nearcor() > pr <- matrix(c(1, 0.477, 0.644, 0.478, 0.651, 0.826, + 0.477, 1, 0.516, 0.233, 0.682, 0.75, + 0.644, 0.516, 1, 0.599, 0.581, 0.742, + 0.478, 0.233, 0.599, 1, 0.741, 0.8, + 0.651, 0.682, 0.581, 0.741, 1, 0.798, + 0.826, 0.75, 0.742, 0.8, 0.798, 1), + nrow = 6, ncol = 6) > > nc. <- nearcor(pr, conv.tol = 1e-7) # default, 11 iter. > ncr <- nearcor(pr, conv.tol = 1e-15) # 27-28 iterations (because of conv.tol)! > ncr0 <- nearcor(pr, conv.tol = 1e-15, posd.tol = 0)# -> no posdefify step > parts <- setdiff(names(nc.), "iterations") > ## IGNORE_RDIFF_BEGIN > str(ncr) List of 4 $ cor : num [1:6, 1:6] 1 0.488 0.643 0.491 0.644 ... $ fnorm : num 0.0744 $ iterations: num 28 $ converged : logi TRUE - attr(*, "class")= chr "nearcor" > if(ncr$iterations != 28) { + cat(sprintf("On this platform, the number of iterations (for tol 1e-15) is not 28, but %d;\n", + ncr$iterations)) + cat("sessionInfoX() :\n") + print(sessionInfoX()) + } > ## IGNORE_RDIFF_END > str(ncr0[parts])# looks identical (with few digits accuracy) List of 3 $ cor : num [1:6, 1:6] 1 0.488 0.643 0.491 0.644 ... $ fnorm : num 0.0744 $ converged: logi TRUE > nr <- ncr$cor > > stopifnot(exprs = { + nc.$iterations == 11 + all.equal(nr[lower.tri(nr)], + c(0.48796803265083, 0.64265188295401, 0.49063868812228, 0.64409905497094, + 0.80871120142824, 0.51411473401472, 0.25066882763262, 0.67235131534931, + 0.72583206922437, 0.59682778611131, 0.58219178154582, 0.7449631866236, + 0.72988206459063, 0.77215024062758, 0.81319175546212), tol = 1e-12) + all.equal(ncr, ncr0, tolerance = 6e-6)# seen 6.6676e-7 + }) > > proc.time() user system elapsed 0.144 0.041 0.239 sfsmisc/tests/dDA.Rout.save0000644000176200001440000001101213460302530015312 0ustar liggesusers R Under development (unstable) (2019-04-24 r76419) -- "Unsuffered Consequences" Copyright (C) 2019 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. > library(sfsmisc) > > ###--------------- "Iris Example for ever" ---------------------------- > data(iris) > cl.true <- as.integer(iris[,"Species"]) > n <- length(cl.true) > stopifnot(cl.true == rep(1:3, each = 50)) > m.iris <- data.matrix(iris[, 1:4]) > > .proctime00 <- proc.time() > > ## Self Prediction: Not too good (2+4 and 3+3 misclass.) > table(diagDA(m.iris, cl.true, m.iris), cl.true) cl.true 1 2 3 1 50 0 0 2 0 48 4 3 0 2 46 > table(diagDA(m.iris, cl.true, m.iris, pool=FALSE), cl.true) cl.true 1 2 3 1 50 0 0 2 0 47 3 3 0 3 47 > > ## Crossvalidation: The same example as knn() & knn1() from "class" : > data(iris3) > train <- rbind(iris3[1:25,,1], iris3[1:25,,2], iris3[1:25,,3]) > test <- rbind(iris3[26:50,,1], iris3[26:50,,2], iris3[26:50,,3]) > cl <- rep(1:3, each = 25) > > pcl <- diagDA(train, cl, test) > table(pcl, cl)## 0 + 1 + 2 misclassified cl pcl 1 2 3 1 25 0 0 2 0 24 2 3 0 1 23 > ## knn ( k=1) has 0 + 1 + 3 > ## knn ( *, k=3) has 0 + 2 + 3 ==> ``diagDA() is best ..'' > > stopifnot(pcl == diagDA(train,cl, test, pool = FALSE)) > # i.e. quadratic identical here > > ### Test 'NA' in predict dat.fr > RNGversion("3.5.0")# -- so w/ sample() still stays unchanged: Warning message: In RNGkind("Mersenne-Twister", "Inversion", "Rounding") : non-uniform 'Rounding' sampler used > set.seed(753) > itr <- sample(n, 0.9 * n) > lrn <- m.iris[ itr,] > tst <- m.iris[-itr,] > dd <- dDA(lrn, cl.true[itr]) > pd0 <- predict(dd, tst) > > i.NA <- c(3:5,7,11) > j.NA <- sample(1:ncol(tst), size=length(i.NA), replace=TRUE) > tst[cbind(i.NA, j.NA)] <- NA > pdd <- predict(dd, tst) > pcl <- diagDA(lrn, cl.true[itr], tst) > stopifnot(length(pdd) == nrow(tst), + identical(pdd, pcl), + pdd[-i.NA] == pd0[-i.NA], + which(is.na(pdd)) == i.NA) > > ## Now do some (randomized) CV : > ## for each observation, count how often it's misclassified > M <- 200 > set.seed(234) > missCl <- integer(n) > for(m in 1:M) { + itr <- sample(n, 0.9 * n) + lrn <- m.iris[ itr,] + tst <- m.iris[-itr,] + pcl <- diagDA(lrn, cl.true[itr], tst) + stopifnot(pcl == predict(dDA(lrn, cl.true[itr]), tst)) + missCl <- missCl + as.integer(pcl != cl.true[ - itr]) + } > missCl ; mean(missCl) / M [1] 0 0 2 1 2 3 7 15 12 13 5 16 18 14 5 0 0 2 1 2 3 7 15 12 13 [26] 5 16 18 14 5 0 0 2 1 2 3 7 15 12 13 5 16 18 14 5 0 0 2 1 2 [51] 3 7 15 12 13 5 16 18 14 5 0 0 2 1 2 3 7 15 12 13 5 16 18 14 5 [76] 0 0 2 1 2 3 7 15 12 13 5 16 18 14 5 0 0 2 1 2 3 7 15 12 13 [101] 5 16 18 14 5 0 0 2 1 2 3 7 15 12 13 5 16 18 14 5 0 0 2 1 2 [126] 3 7 15 12 13 5 16 18 14 5 0 0 2 1 2 3 7 15 12 13 5 16 18 14 5 [1] 0.03766667 > > ## The "same" with 'pool=FALSE' : > missCl <- integer(n) > for(m in 1:M) { + itr <- sample(n, 0.9 * n) + lrn <- m.iris[ itr,] + tst <- m.iris[-itr,] + pcl <- diagDA(lrn, cl.true[itr], tst, pool=FALSE) + stopifnot(pcl == predict(dDA(lrn, cl.true[itr], pool=FALSE), tst)) + missCl <- missCl + as.integer(pcl != cl.true[ - itr]) + } > missCl ; mean(missCl) / M ## here somewhat worse than linear [1] 1 2 1 3 9 11 13 8 14 12 12 11 14 15 7 1 2 1 3 9 11 13 8 14 12 [26] 12 11 14 15 7 1 2 1 3 9 11 13 8 14 12 12 11 14 15 7 1 2 1 3 9 [51] 11 13 8 14 12 12 11 14 15 7 1 2 1 3 9 11 13 8 14 12 12 11 14 15 7 [76] 1 2 1 3 9 11 13 8 14 12 12 11 14 15 7 1 2 1 3 9 11 13 8 14 12 [101] 12 11 14 15 7 1 2 1 3 9 11 13 8 14 12 12 11 14 15 7 1 2 1 3 9 [126] 11 13 8 14 12 12 11 14 15 7 1 2 1 3 9 11 13 8 14 12 12 11 14 15 7 [1] 0.04433333 > > cat('Time elapsed: ', proc.time() - .proctime00,'\n') Time elapsed: 0.424 0.072 0.5 0 0 > > > proc.time() user system elapsed 0.546 0.091 0.630 sfsmisc/tests/p.Rout.save0000644000176200001440000000206310126004731015125 0ustar liggesusers R : Copyright 2004, The R Foundation for Statistical Computing Version 2.0.0 beta (2004-09-27), ISBN 3-900051-07-0 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 a HTML browser interface to help. Type 'q()' to quit R. > #### Plots etc > library(sfsmisc) > > ## A time-series with start and end *not* at year boundary: > data(EuStockMarkets) > SMI <- EuStockMarkets[, "SMI"] > > p.ts(SMI)# gave warning (and was 'wrong' but "only" visually) 1 -- start{0}= (1991, 130); end{493}= (1992.86, 140.343) 2 -- start{435}= (1992.64, 139.126); end{958}= (1994.61, 150.098) 3 -- start{900}= (1994.39, 148.881); end{1423}= (1996.36, 159.853) 4 -- start{1365}= (1996.14, 158.636); end{1859}= (1998, 169) > sfsmisc/R/0000755000176200001440000000000014117733457012136 5ustar liggesuserssfsmisc/R/diagDA.R0000644000176200001440000001472311553046557013400 0ustar liggesusersdiagDA <- function(ls, cll, ts, pool= TRUE) { ## Purpose: Diagonal (Linear or Quadratic) Discriminant Analysis ## ---------------------------------------------------------------------- ## Arguments: --> ?diagDA (i.e. ../man/diagDA.Rd ) ## ---------------------------------------------------------------------- ## Authors: Sandrine Dudoit, sandrine@stat.berkeley.edu ## Jane Fridlyand, janef@stat.berkeley.edu ## as function stat.diag.da() in package "sma" ## ## Modification (API and speed): Martin Maechler, Date: 19 Nov 2003, 15:34 ### ---------------------- Fit Model ------------------------------ ls <- data.matrix(ls) n <- nrow(ls) p <- ncol(ls) cl0 <- as.integer(min(cll, na.rm=TRUE) - 1) cll <- as.integer(cll) - cl0 ## cll now in 1:K inaC <- is.na(cll) clL <- cll[!inaC] K <- max(clL) if(K != length(unique(clL))) stop(sQuote("cll")," did not contain *consecutive* integers") nk <- integer(K) m <- v <- matrix(0,p,K) colVars <- function(x, means = colMeans(x, na.rm = na.rm), na.rm=FALSE) { x <- sweep(x, 2, means) colSums(x*x, na.rm = na.rm) / (nrow(x) - 1) } sum.na <- function(x) sum(x, na.rm=TRUE) ## Class means and variances for(k in 1:K) { which <- (cll == k) nk[k] <- sum.na(which) lsk <- ls[which, , drop = FALSE] m[,k] <- colMeans(lsk, na.rm = TRUE) if(nk[k] > 1) v[,k] <- colVars (lsk, na.rm = TRUE, means = m[,k]) ## else 0 } ### ---------------------- Predict from Model ----------------------------- ts <- data.matrix(ts) if(p != ncol(ts)) stop("test set matrix must have same columns as learning one") ## any NA's in test set currently must give NA predictions ts <- na.exclude(ts) nt <- nrow(ts) disc <- matrix(0, nt,K) if(pool) { ## LDA ## Pooled estimates of variances vp <- rowSums(rep(nk - 1, each=p) * v) / (n - K) ## == apply(v, 1, function(z) sum.na((nk-1)*z))/(n-K) if(any(i0 <- vp == 0)) vp[i0] <- 1e-7 * min(vp[!i0]) ivp <- rep(1/vp, each = nt) # to use in loop for(k in 1:K) { y <- ts - rep(m[,k], each=nt) disc[,k] <- rowSums(y*y * ivp) ## == apply(ts, 1, function(z) sum.na((z-m[,k])^2/vp)) } } else { ## QDA if(FALSE) { ## not yet quite : fails ../tests/dDA.R -- FIXME for(k in 1:K) { ts <- ts - rep(m[,k], each=nt) disc[,k] <- rowSums((ts*ts) / rep(v[,k], each=nt)) + sum(log(v[,k])) } } else { for(k in 1:K) { disc[,k] <- apply(ts,1, function(z) sum((z-m[,k])^2/v[,k])) + sum.na(log(v[,k])) } } } ## predictions pred <- cl0 + apply(disc, 1, which.min) if(inherits(attr(ts,"na.action"), "exclude")) # had missings in `ts' pred <- napredict(omit = attr(ts,"na.action"), pred) pred } ## Cleaner: One function to estimate; one to predict : ## ------- (my tests give a time-penalty 5% for doing things two steps) dDA <- function(x, cll, pool= TRUE) { ## Purpose: Diagonal (Linear or Quadratic) Discriminant Analysis x <- data.matrix(x) n <- nrow(x) p <- ncol(x) cl0 <- as.integer(min(cll, na.rm=TRUE) - 1) cll <- as.integer(cll) - cl0 ## cll now in 1:K inaC <- is.na(cll) clL <- cll[!inaC] K <- max(clL) if(K != length(unique(clL))) stop(sQuote("cll")," did not contain *consecutive* integers") nk <- integer(K) m <- v <- matrix(0,p,K) colVars <- function(x, means = colMeans(x, na.rm = na.rm), na.rm=FALSE) { x <- sweep(x, 2, means) colSums(x*x, na.rm = na.rm) / (nrow(x) - 1) } sum.na <- function(x) sum(x, na.rm=TRUE) ## Class means and variances for(k in 1:K) { which <- (cll == k) nk[k] <- sum.na(which) lsk <- x[which, , drop = FALSE] m[,k] <- colMeans(lsk, na.rm = TRUE) if(nk[k] > 1) v[,k] <- colVars (lsk, na.rm = TRUE, means = m[,k]) ## else 0 } structure(list(call = match.call(), cl0 = cl0, n=n, p=p, K=K, means=m, vars=v, nk=nk, pool=pool), class = "dDA") } print.dDA <- function(x, ...) { cat(if(x$pool)"Linear (pooled var)" else "Quadratic (no pooling)", "Diagonal Discriminant Analysis,\n ", deparse(x$call),"\n") with(x, cat(" (n= ",n,") x (p= ",p,") data in K=",K," classes of [", paste(nk, collapse=", "),"] observations each\n", sep="")) cat("\n") invisible(x) } predict.dDA <- function(object, newdata, pool = object$pool, ...) { newdata <- data.matrix(newdata) n <- object$n p <- object$p K <- object$K ## means and vars are (p x K) matrices: mu <- object$means Vr <- object$vars if(p != ncol(newdata)) stop("test set matrix must have same columns as learning one") ## any NA's in test set currently must give NA predictions newdata <- na.exclude(newdata) nt <- nrow(newdata) disc <- matrix(0, nt,K) if(pool) { ## LDA ## Pooled estimates of variances vp <- rowSums(Vr * rep(object$nk - 1, each=p)) / (n - K) ## == apply(Vr, 1, function(z) sum.na((nk-1)*z))/(n-K) if(any(i0 <- vp == 0)) vp[i0] <- 1e-7 * min(vp[!i0]) ivp <- rep(1/vp, each = nt) # to use in loop for(k in 1:K) { y <- newdata - rep(mu[,k], each=nt) disc[,k] <- rowSums(y*y * ivp) ## == apply(newdata, 1, function(z) sum.na((z-mu[,k])^2/vp)) } } else { ## QDA sum.na <- function(x) sum(x, na.rm=TRUE) ## zero - variances are not acceptable later if(any(i0 <- Vr == 0)) { if(all(i0)) stop("all variances are 0 -- cannot predict") Vr[i0] <- 1e-7 * min(Vr[!i0]) } if(FALSE) { ## not yet quite : fails ../tests/dDA.R -- FIXME for(k in 1:K) { y <- newdata - rep(mu[,k], each=nt) disc[,k] <- rowSums((y*y) / rep(Vr[,k], each=nt)) + sum(log(Vr[,k])) } } else { for(k in 1:K) { disc[,k] <- apply(newdata,1, function(z) sum((z-mu[,k])^2/Vr[,k])) + sum.na(log(Vr[,k])) } } } ## predictions pred <- object$cl0 + apply(disc, 1, which.min) if(inherits(attr(newdata,"na.action"), "exclude")) { ## had missings in `newdata' pred <- napredict(omit = attr(newdata,"na.action"), pred) } ## ^^^^^^^^^ typically stats:::napredict.exclude() pred } sfsmisc/R/rot13.R0000644000176200001440000000050312415203120013201 0ustar liggesusers##' Generalized rot13 --> ../man/rot13.Rd rotn <- function (ch, n = 13) { ch <- as.character(ch) # or error stopifnot(0 <= n, n <= 26) i <- c(if(n < 26) (n+1):26, seq_len(n)) chartr(old = paste(c(letters, LETTERS ), collapse=""), new = paste(c(letters[i],LETTERS[i]), collapse=""), x = ch) } sfsmisc/R/Duplicated.R0000644000176200001440000000160411102561403014315 0ustar liggesusers## From: Christoph Buser ## To: maechler@.... ## Subject: Duplicated ## Date: Tue, 25 Sep 2007 14:29:46 +0200 ### Changes and more arguments: entirely by MM Duplicated <- function(v, incomparables = FALSE, fromLast = FALSE, nomatch = NA_integer_) { ## Purpose: A counting-generalization of duplicated() ## ---------------------------------------------------------------------- ## Arguments: a numeric vector ## ---------------------------------------------------------------------- ## Author: Martin Maechler & Christoph Buser, Date: Sep 2007 uv <- unique(nv <- na.omit(v)) ## easier (but less general?): uv <- unique(nv <- v[!is.na(v)]) fv <- factor(nv, levels = uv) dup <- duplicated(as.integer(fv), incomparables = incomparables, fromLast = fromLast) match(v, nv[dup], incomparables = incomparables, nomatch = nomatch) } sfsmisc/R/relErr.R0000644000176200001440000000304714116665241013512 0ustar liggesusers## The relative error typically returned by all.equal.numeric(), ## "kept as simple as possible" relErr <- function(target, current) { ## make this work, also for 'Matrix' ==> no mean() .. n <- length(current) if(length(target) < n) # (as we don't use mean()) target <- rep(target, length.out = n) sum(abs(target - current)) / sum(abs(target)) } ## Componentwise aka "Vectorized" relative error: ## Must not be NA/NaN unless one of the components is ==> deal with {0, Inf, NA} relErrV <- function(target, current, eps0 = .Machine$double.xmin) { n <- length(target <- as.vector(target)) ## assert( is multiple of ) : lc <- length(current) if(!n) { if(!lc) return(numeric()) # everything length 0 else stop("length(target) == 0 differing from length(current)") } else if(!lc) stop("length(current) == 0 differing from length(target)") ## else n, lc > 0 if(lc %% n) stop("length(current) must be a multiple of length(target)") R <- if(lc != n) # explicitly recycle target[rep(seq_len(n), length.out=lc)] else target # (possibly "mpfr") R[] <- 0 ## use *absolute* error when target is zero {and deal with NAs}: t0 <- abs(target) < eps0 & !(na.t <- is.na(target)) R[t0] <- current[t0] ## absolute error also when it is infinite, as (-Inf, Inf) would give NaN: dInf <- is.infinite(E <- current - target) R[dInf] <- E[dInf] useRE <- !dInf & !t0 & (na.t | is.na(current) | (current != target)) R[useRE] <- (current/target)[useRE] - 1 R } sfsmisc/R/tkdensity.R0000644000176200001440000001330012662652577014302 0ustar liggesusers### demo(tkdensity) ## is at ### /u/maechler/R/D/r-devel/Linux-inst/library/tcltk/demo/tkdensity.R tkdensity <- function(y, n = 1024, log.bw = TRUE, showvalue = TRUE, xlim = NULL, do.rug = size < 1000, kernels = NULL, from.f = if(log.bw) -2 else 1/1000, to.f = if(log.bw) +2.2 else 2, col = 2) { ## Purpose: as density() but with scrollbar - bandwidth selection ## ----------------------------------------------------------------------- ## Author: Martin Maechler, Date: 8 Nov 2000, 19:00 requireNamespace("tcltk") || stop("tcltk support is absent") tclVar <- tcltk::tclVar tclvalue <- tcltk::tclvalue tkframe <- tcltk::tkframe tkpack <- tcltk::tkpack tklabel <- tcltk::tklabel tkscale <- tcltk::tkscale nbw <- xZ <- xM <- NA_real_ # so '<<-' keeps them here dFun <- density.default all.kerns <- eval(formals(dFun)$kernel) kernels <- if(is.null(kernels)) all.kerns else match.arg(kernels, all.kerns, several.ok = TRUE) ynam <- deparse(substitute(y)) size <- length(y) sd.y <- sqrt(var(y)) ## Use Silverman's Rule of Thumb initially : hi <- sd.y if ((lo <- min(hi, IQR(y)/1.34)) == 0) (lo <- hi) || (lo <- abs(y[1])) || (lo <- 1) bw <- bw0 <- 0.9 * lo * size^(-0.2) if(log.bw) lbw <- lbw0 <- log10(bw0) ry <- range(y) xlim <- if(is.null(xlim)) ry + c(-2,2)* bw0 else as.numeric(xlim) xlmid <- xm0 <- mean(xlim) xr0 <- diff(xlim) ## Initialize Tcl variables: xZoom <- tclVar(100)# % xlmid <- tclVar(xlmid) if(log.bw) Lbw <- tclVar(log10(bw)) else bw <- tclVar(bw) kernel <- tclVar("gaussian") ## Tvar <- function(v) as.numeric(tclvalue(substitute(v))) replot <- function(...) { if (is.null(y)) return() # too early... b <- if(log.bw) 10 ^ (lbw <<- as.numeric(tclvalue(Lbw))) else nbw <<- as.numeric(tclvalue(bw)) ##Dbg cat("b = ", formatC(b),"\n") k <- tclvalue(kernel) # *is* char ##Dbg cat("tclvalue(kernel)"); str(k) xZ <<- as.numeric(tclvalue(xZoom)) xM <<- as.numeric(tclvalue(xlmid)) ## "codetools, please do believe that we do use 'b', 'k', 'xlim' !": if(0 > 1) b <- xlim + b + k xr.half <- (xr0 / 2) * 100 / xZ xlim <- xM + c(-xr.half, xr.half) eval(substitute(plot(density(y, bw = b, kernel = k, n = n), main = paste("density(",ynam, ", bw = ",format(b, dig = 3), ", kernel = \"", k, "\")", sep=""), xlim = xlim, col = col))) if(do.rug) rug(y) ## points(y,rep(0,size), col = 3) } replot.maybe <- function(...) if ((log.bw && !identical(lbw, as.numeric(tclvalue(Lbw)))) || (!log.bw && !identical(nbw, as.numeric(tclvalue(bw)))) || !identical(xZ, as.numeric(tclvalue(xZoom))) || !identical(xM, as.numeric(tclvalue(xlmid))) ) replot() base <- tcltk::tktoplevel() tcltk::tkwm.title(base, paste("Tk Density(",ynam,")")) base.frame <- tkframe(base, borderwidth = 2) bw.frame <- tkframe(base.frame, relief = "groove", borderwidth = 3) kern.frame <- tkframe(base.frame, relief = "groove", borderwidth = 2) x.frame <- tkframe(base.frame) xr.frame <- tkframe(x.frame) xmid.frame <- tkframe(x.frame) tkpack(xr.frame, xmid.frame, side = "left", anchor = "s") q.but <- tcltk::tkbutton(base, text = "Quit", command = function() { par(op) ## see par() below ! tcltk::tkdestroy(base) }) tkpack(base.frame, bw.frame, kern.frame, x.frame, q.but) ## Bandwith Frame : tkpack(tklabel (bw.frame, text = if(log.bw)"log10(Bandwidth)" else "Bandwidth")) tkpack(tkscale (bw.frame, command = replot.maybe, from = if(log.bw) lbw0 + (from.f) else bw0 * from.f, to = if(log.bw) lbw0 + (to.f) else bw0 * to.f, showvalue = showvalue, variable = if(log.bw) Lbw else bw, resolution = if(log.bw) lbw0/20 else bw0/4 * from.f, length = 200, orient = "horiz")) ## Kernel Frame : tkpack(tklabel(kern.frame, text = "Kernel")) for (k.name in kernels) tkpack(tcltk::tkradiobutton(kern.frame, command = replot, text = k.name, value = k.name, variable=kernel), anchor = "w") ## [x Zoom] Frame : tkpack(tklabel (xr.frame, text = "x zoom [%]")) tkpack(tkscale (xr.frame, command = replot.maybe, from = 5,# = 1/20 to = 500,# = * 5 showvalue = TRUE, variable = xZoom, length = 80, orient = "horiz")) ## [x Pan] Frame : tkpack(tklabel (xmid.frame, text = "x pan")) tkpack(tkscale (xmid.frame, command = replot.maybe, from = xm0 - xr0, to = xm0 + xr0, showvalue = FALSE, variable = xlmid, resolution = xr0/2000, length = 80, orient = "horiz")) if((op <- par("ask")) || prod(par("mfrow")) > 1) op <- par(ask = FALSE, mfrow = c(1,1)) ## on.exit(par(op)) is *NOT* sufficient; do it only when quitting tk !! ##Dbg cat("Before calling `replot()' : \n") replot() ## Returning doesn't work!! ##return(tclvar[c("bw", "kernel")]) } ###--- ## tkpack() : ##- .Tcl(.Tcl.args(...)) : ##- [tcl] unknown or ambiguous option "": must be \ ## -after, -anchor, -before, -expand, -fill, -in, ## -ipadx, -ipady, -padx, -pady, or -side. sfsmisc/R/p.goodies.R0000644000176200001440000002065713136043020014136 0ustar liggesusers#### Original is /u/sfs/S/p.goodies.S [v 1.12 1999/05/06 10:17:00 sfs Exp ] #### ### p.goodies.S ---- SfS- S(plus) - Funktionen, welche ### ---------------- mit 'p.' (fr "Plot") beginnen [alte SfS-Tradition ..] ### == = ### ### see also "/u/sfs/S/u.goodies.S" ### "/u/sfs/S/f.goodies.S" ### "/u/sfs/S/misc-goodies.S" ### ### ********************** ### INHALT von p.goodies.S (bitte jeweils ergaenzen): ### ********************** ### p.clear Bildschirm "putzen" ### p.datum Deutsches Datum "unten rechts" ### p.dchisq \ ### p.dgamma > Dichten plotten ### p.dnorm / ### p.pairs 'pairs' mit mehr Moeglichkeiten ### p.pllines ### p.lm.hyperb --> ./linesHyberb.lm.R ### p.scales ### p.two.forget ### p.two.res ### p.profileTraces Profil-Spuren fuer Nichtlineare Regression ### p.hboxp Horizontale Boxplots ### p.arrows Nicer arrows(): FILLED arrow heads ### ### ========================================================================== p.datum <- function(outer = FALSE, cex = 0.75, ...) mtext(u.Datumvonheute(...), 4, cex = cex, adj = 0, outer = outer, las = 0) ## =========================================================================== ## curve(.. xlim..) only satisfactory from R version 1.2 on .. p.dchisq <- function(nu, h0.col = "light gray", ...) { x <- NULL # against codetools' FP warning curve(dchisq(x, nu), xlim= qchisq(c(1e-5,.999), nu), ylab = paste("dchisq(x, nu=",format(nu),")"), ...) abline(h=0, col = h0.col) } p.dgamma <- function(shape, h0.col = "light gray", ...) { x <- NULL # against codetools' FP warning curve(dgamma(x, shape), xlim= qgamma(c(1e-5,.999), shape), ylab = paste("dgamma(x, shape=",format(shape),")"), ...) abline(h=0, col = h0.col) } p.dnorm <- function(mu = 0, s = 1, h0.col = "light gray", ms.lines = TRUE, ms.col = "gray", ...) { f <- function(x) dnorm(x, mu, s) curve(f, xlim = qnorm(c(1e-5, 0.999), mu, s), ylab = substitute(phi(x, mu == m, sigma == ss), list(m=format(mu), ss=format(s))), ...) abline(h=0, col = h0.col) if(ms.lines) { segments(mu,0, mu, f(mu), col=ms.col) f.ms <- f(mu-s) arrows(mu-s, f.ms, mu+s, f.ms, length= 1/8, code= 3, col=ms.col) text(mu+c(-s/2,s/2), f.ms, expression(-sigma, +sigma), adj=c(.5,0)) } } p.m <- function(mat, ...) matplot(mat[, 1], mat[, -1, drop = FALSE], ...) ## =========================================================================== p.scales <- function(unit = relsysize * 2.54 * min(pin), relsysize = 0.05) { ## Fn.name: p.scales ## Purpose: Conversion between plot scales: usr, cm, symbol ## Author: W. Stahel , Date: May/90; updated: M.Mae. 9/93 ## ---------------------------------------------------------------- ## Arguments: ## unit: length of unit (or x and y units) of symbol coordinates in cm ## relsysize: same, as a proportion of the plotting area ## ---------------------------------------------------------------- usr <- par("usr") pin <- par("pin") usr2cm <- (2.54 * pin)/(usr[c(2, 4)] - usr[c(1, 3)]) names(usr2cm) <- c("x", "y") cbind(sy2usr = unit/usr2cm, usr2cm = usr2cm) } p.profileTraces <- function(x, cex=1, subtitle=paste("t-Profiles and traces of ", deparse(attr(x,"summary")$formula))) { nx <- names(x) np <- length(x) opar <- par(oma = c(2, 2, 1.5, 0), mfrow = c(np, np), mar = c(2,4, 0, 0) + 0.2) on.exit(par(opar)) for (i in 1:np) { for (j in 1:i) { if (i == j) { ## Diagonale : Profil t-Funktionen if (!is.null(this.comp <- x[[i]])) { xx <- this.comp$par[, nx[i]] tau <- this.comp[[1]] plot(spline(xx, tau), xlab = "", ylab = "", type = "l", las = 1, mgp = c(3, 0.8, 0), cex = 0.5 * cex) points(xx[tau == 0], 0, pch = 3) pusr <- par("usr") ## "at = " muss anders sein R & SPlus if(is.R()) { ## mtext(outer = TRUE, at= ): mtext(side = 1, line = 0.8, at = -1/(2*np)+i/np, text = nx[j] , outer = TRUE, cex = cex) mtext(side = 2, line = 0.8, at = 1+1/(2*np)-i/np, text = nx[i], outer = TRUE, cex = cex) } else { mtext(side = 1, line = 0.8, at = mean(pusr[1:2]), text = nx[j] , outer = TRUE, cex = cex) mtext(side = 2, line = 0.8, at = mean(pusr[3:4]), text = nx[i], outer = TRUE, cex = cex) } } } else { ## j < i : Likelihood Profilspuren if ((!is.null(x.comp <- x[[j]])) & (!is.null(y.comp <- x[[i]]))) { xx <- x.comp$par[, nx[j]] xy <- x.comp$par[, nx[i]] yx <- y.comp$par[, nx[j]] yy <- y.comp$par[, nx[i]] plot(xx, xy, xlab = "", ylab = "", las = 1, mgp = c(3, 0.8, 0), type = "n", xlim = range(c(xx, yx)), ylim = range(c(xy, yy)), cex = 0.5 * cex) lines(xx, xy, col = 2) lines(yx, yy, col = 3) } } } if (i < np) # frame()s: S-plus braucht hufig eines mehr : for (k in 1:(np - i + if(is.R()) 0 else 1)) frame() } mtext(side = 3, line = 0.2, text = subtitle, outer = TRUE, cex = 1.2 * cex) } ## Test Beispiel : ## --> /u/sfs/ueb/fortgeschrittene/loesungen/loes-rg.truthennen.R ## mainly auxiliary of histBxp() [in ./misc-goodies.R ] : p.hboxp <- function(x, y.lo, y.hi, boxcol = 3, medcol = 2, medlwd = 5, whisklty = 2, staplelty = 1) { if(missing(y.hi) && length(y.lo) == 2) { y.hi <- y.lo[2]; y.lo <- y.lo[1] } ## should test y.lo < y.hi, both to be numbers... ##--- 2nd set of Defaults (by setting the args to NA) : if(is.na(medcol)) medcol <- par("col") if(is.na(medlwd)) medlwd <- par("lwd") if(is.na(whisklty)) whisklty <- par("lty") if(is.na(staplelty)) staplelty <- par("lty") # b <- boxplot(x, plot = FALSE) st <- c(b$stats)## names(st) <- c("max","Q3","med","Q1","min") ##-------- drawing the boxplot -------------- ## coordinates : m <- (y.hi + y.lo)/2 llhh <- c(y.lo, y.lo, y.hi, y.hi) ## drawing the box polygon(c(st[4], st[2], st[2], st[4]), llhh, col = ifelse(boxcol == 0, par("col"), boxcol), lty = 1, density = ifelse(boxcol == 0, 0, -1)) # ## Median lines(rep.int(st[3], 2), c(y.lo, y.hi), col = ifelse(boxcol == 0 && missing(medcol), par("col"), medcol), lwd = medlwd, lty = 1) # ## Border of the box lines(c(st[4], st[2], st[2], st[4]), llhh, col = ifelse(boxcol == 0, par("col"), boxcol), lty = 1) # ## Whiskers lines(c(st[1:2], NA, st[4:5]), rep.int(m, 5), lty = whisklty) # ## Staples k <- .01 * diff(range(x)) lines(st[1]+ c(-k, 0, 0, -k), llhh, lty = staplelty) lines(st[5]+ c( k, 0, 0, k), llhh, lty = staplelty)# ## Outliers for(out in b$out) lines(rep.int(out, 2), c(y.lo, y.hi), lty = staplelty) } p.arrows <- function(x1, y1, x2, y2, size=1, width = (sqrt(5)-1)/4/cin, fill = 2, ...) { ## Purpose: Nicer arrows(): FILLED arrow heads ## ------------------------------------------------------------------------- ## Arguments: size: symbol size as a fraction of a character height ## width: width of the Arrow Head ## ...: further arguments for the segment routine ## Author: Andreas Ruckstuhl, Date: 19 May 94; Cosmetic by MM: June'98 ## ------------------------------------------------------------------------- cin <- size*par("cin")[2] ## vertical symbol size in inches uin <- if(is.R()) 1/xyinch() else par("uin") ## inches per usr unit segments(x1, y1, x2, y2, ...) ## Create coordinate of a polygon for a ``unit arrow head'': x <- sqrt(seq(0, cin^2, length=floor(35*cin)+2)) delta <- 0.005/2.54 # ? 2.54cm = 1 in x.arr <- c(-x, -rev(x)) wx2 <- width* x^2 y.arr <- c(- wx2 - delta, rev(wx2) + delta) ## Polar(x.., y..): deg.arr <- c(atan2(y.arr, x.arr), NA)# - NA to 'break' long polygon r.arr <- c(sqrt(x.arr^2 + y.arr^2), NA) ## Draw Arrow Head at (x2,y2) theta <- atan2((y2-y1)*uin[2], (x2-x1)*uin[1]) lx <- length(x1) Rep <- rep.int(length(deg.arr), lx) x2 <- rep.int(x2, Rep) y2 <- rep.int(y2, Rep) theta <- rep.int(theta, Rep) + rep.int(deg.arr, lx) r.arr <- rep.int(r.arr, lx) polygon(x2+ r.arr*cos(theta)/uin[1], y2+ r.arr*sin(theta)/uin[2], col= fill) } sfsmisc/R/unix/0000755000176200001440000000000014020761347013111 5ustar liggesuserssfsmisc/R/unix/Sys.ps.R0000644000176200001440000001622413136043020014424 0ustar liggesusers#### Martin Maechler, Aug.2000, originally in /u/maechler/R/MISC/ps.R ### --> ../../man/unix/Sys.ps.Rd to see more comments ## I would really like builtin Sys.ps() for these ### Sys.ps.cmd() ---> now moved to ../R/ ## These only apply to "System V" compatible `ps', not to BSD ones .Sys.ps.fields <- list(POSIX = c("args", "comm", "time", "etime", "nice", "pcpu", "pid", "pgid", "ppid", "group", "rgroup", "user", "ruser", "tty", "vsz"), ## Now the extras, not in above POSIX: SunOS = c( "addr", "pri", "c", "rgid", "class", "rss", "f", "ruid", "fname", "s", "gid", "sid", "opri", "stime", "osz", "uid", "pmem", "wchan"), Linux =## These are Linux (RH 6.2):"Docu" at end .. c("%cpu", "%mem", "alarm", "blocked", "bsdstart", "bsdtime", "c", "caught", "cmd", "command", "cputime", "drs", "dsiz", "egid", "egroup", "eip", "esp", "euid", "euser", "f", "fgid", "fgroup", "flag", "flags", "fname", "fsgid", "fsgroup", "fsuid", "fsuser", "fuid", "fuser", "gid", "ignored", "intpri", "lim", "longtname", "lstart", "m_drs", "m_trs", "maj_flt", "majflt", "min_flt", "minflt", "ni", "nwchan", "opri", "pagein", "pending", "pgrp", "pmem", "pri", "rgid", "rss", "rssize", "rsz", "ruid", "s", "sess", "session", "sgi_p", "sgi_rss", "sgid", "sgroup", "sid", "sig", "sig_block", "sig_catch", "sig_ignore", "sig_pend", "sigcatch", "sigignore", "sigmask", "stackp", "start", "start_stack", "start_time", "stat", "state", "stime", "suid", "suser", "svgid", "svgroup", "svuid", "svuser", "sz", "timeout", "tmout", "tname", "tpgid", "trs", "trss", "tsiz", "tt", "tty4", "tty8", "ucomm", "uid", "uid_hack", "uname", "vsize", "wchan") ) ## Note that proc.time() gives part of that info better ## command == cmd == args gives "command + arguments : too long .Sys.ps.multifields <- c("command", "cmd","args", "lstart") Sys.ps <- function(process = Sys.getpid(), fields = c("pid", "pcpu", "time", "vsz", "comm"), usefile = length(fields) > 10, ps.cmd = Sys.ps.cmd(), verbose = getOption("verbose"), warn.multi = verbose || any(fields != "ALL")) { if(!is.null(tp <- attr(ps.cmd,"type")) && tp == "BSD") stop("this function cannot work with BSD kind of `ps'.") ps.opt <- { if(is.numeric(process) && process == round(process)) paste("-p",process) # PID else if(process == "ALL") { warning("`process = \"ALL\"' not yet working properly") "-e" # all process } else if(is.character(process) && length(process) == 1) paste("-C",process) # Command name else stop(paste("invalid `process':",format(process))) } if(length(ps.opt) > 1) warning("Multiple processes : not yet working ...") Sys.ps.fields <- c(.Sys.ps.fields $ POSIX, if(any(ii <- Sys.info()["sysname"] == names(.Sys.ps.fields))) .Sys.ps.fields[ii][[1]]) if(identical(fields, "ALL")) i.field <- TRUE else { i.field <- pmatch(fields, Sys.ps.fields) # allow abbreviated ones if(any(ina <- is.na(i.field))) { warning(paste("Dropping invalid field names", fields[ina])) i.field <- i.field[!ina] } } fields <- Sys.ps.fields[i.field] imult <- !is.na(match(fields, .Sys.ps.multifields)) if(any(imult) && length(fields) > 1) { if(warn.multi) warning(paste("Not using `multi fields' ", paste(fields[imult],collapse=","))) fields <- fields[!imult] imult <- FALSE } ## Don't use "-w" with cmd/args, or command : gives space in between ## Must use "--width" (GNU ps only) when there are many fields ... ## Need temporary file & scan since system cannot get very long ## lines ... if(usefile) ofile <- tempfile("R.Sys.ps") cmd <- paste(ps.cmd, ps.opt, "-o", paste(fields, collapse=","), if(usefile) paste(" >", ofile)) if(verbose) cat("Now calling\n\t",cmd,"\n") lines <- system(cmd, intern = !usefile) if(usefile) { if(lines) warning(paste("system() returned non-0 :",lines)) lines <- scan(ofile, what = "", sep="\n", quiet = TRUE)## incl header } if(length(lines) <= 1) stop(paste("call returned less than two lines:", lines, sep="\n")) r <- sub("^ ","", gsub("[ ]+"," ", lines)) ## SP & TAB if(length(fields) == 1) { if(length(r) == 2) return(structure(r[2], names = fields)) else warning(paste("Funny result with one `fields': length(r)=", length(r))) } ## else { ll <- strsplit(r, " ") d.len <- diff(lenl <- sapply(ll, length)) if(lenl[1] == length(fields)) ## use fields! ll[[1]] <- fields else warning(paste("Number returned headers =", lenl[1], " != ", "#{fields} =", length(fields))) if(d.len) { # names and result differ warning(paste("Lengths differ:", paste(lenl, collapse=","))) } r <- c(ll[[2]], rep(NA, max(0,-d.len))) names(r) <- if( d.len > 0) c(ll[[1]], rep(".x.",d.len)) else ll[[1]][1:lenl[2]] r ##} } Sys.sizes <- function(process = Sys.getpid(), ps.cmd = Sys.ps.cmd()) { ## For both Solaris and GNU(Linux); GNU/Linux additionally has dsize if(!is.null(tp <- attr(ps.cmd,"type")) && tp == "BSD") { ## a *real* hack [needed for Linux 2.0 or SunOS 4.x ..] r <- system(paste(ps.cmd,"m",process), intern = TRUE)[1:2] # 2 lines r <- strsplit(r," *") hd <- r[[1]]; hd <- hd[hd != "" & hd != "COMMAND"] i <- match(c("RSS","DRS"), hd) r <- structure(r[[2]][i], names = hd[i]) } else { ## proper "System V like" ps : r <- Sys.ps(process, c("rss","vsz")) } storage.mode(r) <- "integer" r } if(Sys.info()[["sysname"]] == "Linux") { ##----- Linux-only ---- Sys.procinfo <- function(procfile) { l2 <- strsplit(readLines(procfile),"[ \t]*:[ \t]*") r <- sapply(l2[sapply(l2, length) == 2], function(c2)structure(c2[2], names= c2[1])) attr(r,"Name") <- procfile names(r) <- make.names(names(r), unique = TRUE) # <- so the result can be name-indexed! class(r) <- "simple.list" r } } else { ## non-Linux "unix" -- including MacOS X "Darwin" Sys.procinfo <- function(procfile) { stop("Sys.procinfo() is not yet implemented for non-Linux unix-alikes") } } Sys.cpuinfo <- function() Sys.procinfo("/proc/cpuinfo") Sys.meminfo <- function() Sys.procinfo("/proc/meminfo") Sys.MIPS <- function() as.numeric(Sys.cpuinfo()["bogomips"]) Sys.memGB <- function(kind = "MemTotal") { mm <- drop(read.dcf("/proc/meminfo", fields=kind)) if(any(is.na(mm))) stop("Non-existing 'kind': ", names(mm)[is.na(mm)][1]) if(!all(grepl(" kB$", mm))) stop("Memory info ", dQuote(kind), " is not returned in 'kB' aka kiloBytes") ## return memory in giga bytes as.numeric(sub(" kB$", "", mm)) / (1000 * 1024) } sfsmisc/R/unix/package-props.R0000644000176200001440000000227613723455470016005 0ustar liggesuserspkgLibs <- function(pkg, cmd = if(Sys.info()[["sysname"]] == "Darwin") "otool -L" else "ldd") { stopifnot(is.character(pkg)) lapply(setNames(pkg, nm = vapply(pkg, function(p) system.file(package = p), " ")), function(p) { libD <- Filter(dir.exists, file.path(system.file(package = p), "libs")) # possibly empty if(length(libD)) { libs <- list.files(libD, full.names=TRUE) lapply(setNames(libs, basename(libs)), function(so) sub("^[ \t]*", "", system(paste(cmd, so), intern=TRUE))) ##__TODO_ strsplit() into (2--)3 parts: ## "libgcc_s.so.1 => /usr/lib64/libgcc_s.so.1 (0x00007fe7ad090000)" } # else NULL }) } if(FALSE) { ip <- installed.packages() # can only look at installed pkgs str(ip) pkgs <- intersect(c("sfsmisc", "MASS", "Matrix", "nlme", "Rmpfr", "pcalg", "V8", "lme4", "round"), ip) pkgs pl <- pkgLibs(pkgs) # needs system("ldd" ..) to work pl str(pl) } sfsmisc/R/ellipse.R0000644000176200001440000000225611102534404013701 0ustar liggesusersellipsePoints <- function(a,b, alpha = 0, loc = c(0,0), n = 201, keep.ab.order = FALSE) { ## Purpose: ellipse points,radially equispaced, given geometric par.s ## ------------------------------------------------------------------------- ## Arguments: a, b : length of half axes in (x,y) direction ## alpha: angle (in degrees) for rotation ## loc : center of ellipse ## n : number of points ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 19 Mar 2002 stopifnot(is.numeric(a), is.numeric(b)) reorder <- a < b && keep.ab.order B <- min(a,b) A <- max(a,b) ## B <= A d2 <- (A-B)*(A+B) ## = A^2 - B^2 phi <- 2*pi*seq(0,1, len = n) sp <- sin(phi) cp <- cos(phi) r <- a*b / sqrt(B^2 + d2 * sp^2) xy <- r * if(reorder) cbind(sp, cp) else cbind(cp, sp) ## xy are the ellipse points for alpha = 0 and loc = (0,0) al <- alpha * pi/180 ca <- cos(al) sa <- sin(al) xy %*% rbind(c(ca, sa), c(-sa, ca)) + cbind(rep(loc[1],n), rep(loc[2],n)) } sfsmisc/R/zzz.R0000644000176200001440000000422413376731510013112 0ustar liggesusers## .onLoad <- function(lib, pkg) ## { ## } ##' return 'x' unless it is NULL where you'd use 'orElse' `%||%` <- function(x, orElse) if(!is.null(x)) x else orElse ## if(!exists("rep_len", mode = "function")) # old R version ## rep_len <- function(x, length.out) rep(x, length.out=length.out) if(getRversion() < "3.5") { ## if(!is.function(.BaseNamespaceEnv$...length)) # ...length() only in R >= 3.5.0 ## This substitute is kludgy by using parent.env() -- but it works (sometimes) ## in funEnv() -- see ../R/misc-goodies.R ...length <- function() eval(quote(length(list(...))), envir = parent.frame()) isTRUE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && x isFALSE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && !x } .set.eps_view <- function() { ## This assumes "gv" in your path --- ideally this would be configured! if(!is.character(getOption("eps_view")) && .Platform $ OS.type == "unix") { SYS <- function(cmd) system(cmd, intern=TRUE, ignore.stderr=TRUE) ## doesRespond <- function(cmd) length(SYS(cmd)) > 0 doesRespond <- function(cmd) ## should be portable (thanks BDR): all(system(paste(cmd,"> /dev/null")) != c(1,256)*127) if(doesRespond("gv -h")) { ## 'gv' cmd <- "gv -watch -geometry -0+0 -magstep -2 -media BBox -noantialias" hyphens <- SYS(paste("gv -h | fgrep watch | head -1", "| sed 's/watch.*//; s/^[\\s ]*//'")) if(length(hyphens) && hyphens == "--") cmd <- sub(" --geometry", " -geometry", sub(" --magstep ", " --scale=", sub(" --media ", " --media=", gsub(" -([a-z])", " --\\1", cmd)))) } else if (doesRespond("ggv --version")) { ## try 'ggv' cmd <- "ggv --geometry -0+0" } else if (doesRespond("evince --version")) { ## try 'evince' cmd <- "evince" # no geometry options } else if (doesRespond("kghostview --version")) { ## try 'kghostview' cmd <- "kghostview --geometry -0+0" } else { warning("no valid postscript previewer found; consider setting\n", " options(\"eps_view\"= \"....\") yourself") cmd <- "replace_with_postscript_previewer" } options("eps_view" = cmd) } } sfsmisc/R/rrange.R0000644000176200001440000000071110470665074013533 0ustar liggesusersrrange <- function(x, range = 1, coef = 1.5, na.rm = TRUE) { ## Purpose: `Robust RANGE', ===> ?rrange ## Author: Martin Maechler, 1990 if(!missing(range)) { if(!missing(coef)) stop("Must use either 'range' or 'coef'") coef <- 1.5 * range } if(!na.rm && any(is.na(x))) return(0+ c(NA,NA))# numeric NA ## S: (boxplot(..., plot = FALSE)$stats)[c(5, 1)] boxplot.stats(x, coef = coef, do.conf= FALSE, do.out= FALSE)$stats[c(1,5)] } sfsmisc/R/integratexy.R0000644000176200001440000000504413116205767014623 0ustar liggesusers## This is also sym.linked into ## Martin's WpDensity package /u/maechler/R/Pkgs/WpDensity/ integrate.xy <- function(x,fx, a,b, use.spline = TRUE, xtol = 2e-8) { if(is.list(x)) { fx <- x$y; x <- x$x if(length(x) == 0) stop("list 'x' has no valid $x component") } if((n <- length(x)) != length(fx)) stop("'fx' must have same length as 'x'") if(is.unsorted(x)) { i <- sort.list(x); x <- x[i]; fx <- fx[i] } if(any(i <- duplicated(x))) { n <- length(x <- x[!i]) ## we might have to check that the same fx[] are duplicated ## otherwise either give an error or take the mean() of those... fx <- fx[!i] } if(any(diff(x) == 0)) stop("bug in 'duplicated()' killed me: have still multiple x[]!") if(missing(a)) a <- x[1] else if(any(a < x[1])) stop("'a' must NOT be smaller than min(x)") if(missing(b)) b <- x[n] else if(any(b > x[n])) stop("'b' must NOT be larger than max(x)") if(length(a) != 1 && length(b) != 1 && length(a) != length(b)) stop("'a' and 'b' must have length 1 or same length !") else { k <- max(length(a),length(b)) if(any(b < a)) stop("'b' must be elementwise >= 'a'") } if(use.spline) { xy <- spline(x,fx, n = max(1024, 3*n)) ##-- Work around spline(.) BUG: (ex.: range(spline(1:20,1:20,n=95))) if(xy$x[length(xy$x)] < x[n]) { if(TRUE) cat("working around spline(.) BUG --- hmm, really?\n\n") xy$x <- c(xy$x, x[n]) xy$y <- c(xy$y, fx[n]) } ## END if work around ---- x <- xy$x; fx <- xy$y n <- length(x) } ab <- unique(c(a,b)) BB <- abs(outer(x,ab,"-")) < (xtol * max(b - a)) if(any(j <- 0 == colSums(BB))) { # the j-th element(s) of ab are not in x[] y <- approx(x,fx, xout = ab[j])$y x <- c(ab[j],x) i <- sort.list(x) x <- x[i]; fx <- c(y,fx)[i]; n <- length(x) } ##--- now we could use 'Simpson's formula IFF the x[i] are equispaced... -- ##--- Since this may well be wrong, just use 'trapezoid formula': dig0 <- floor(-log10(xtol)) # f.match <- function(x,table,dig) match(signif(x,dig), signif(table,dig)) ## was (S+) f.match <- function(x,table) match(as.single(x), as.single(table)) d <- dig0; while(anyNA(ai <- f.match(a,x, d))) d <- d - 1/8 ; ai <- rep_len(ai, k) d <- dig0; while(anyNA(bi <- f.match(b,x, d))) d <- d - 1/8 ; bi <- rep_len(bi, k) dfx <- fx[-c(1,n)] * diff(x,lag = 2) r <- numeric(k) for (i in 1:k) { a <- ai[i]; b <- bi[i] r[i] <- (x[a+1] - x[a])*fx[a] + (x[b] - x[b-1])*fx[b] + sum(dfx[seq(a, length = max(0,b-a-1))]) } r/2 } sfsmisc/R/prettylab.R0000644000176200001440000002177013651517202014264 0ustar liggesusers#### Pretty Labels for "plotmath" axes -- Main function: eaxis() ### --> these are from ~/R/MM/GRAPHICS/axis-prettylab.R ### Help files: ../man/pretty10exp.Rd ../man/axTexpr.Rd ../man/eaxis.Rd ### -------------- ---------- -------- pretty10exp <- function(x, drop.1 = FALSE, sub10 = FALSE, digits = 7, digits.fuzz, lab.type = c("plotmath", "latex"), lab.sep = c("cdot", "times")) { ## Purpose: produce "a 10^k" label expressions instead of "a e" ## ---------------------------------------------------------------------- ## Arguments: x: numeric vector (e.g. axis tick locations) ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 7 May 2004; 24 Jan 2006 if(!missing(digits.fuzz)) { message("'digits.fuzz' is deprecated; use 'digits' instead") digits <- digits.fuzz } lab.type <- match.arg(lab.type) lab.sep <- match.arg(lab.sep) eT <- floor(log10(abs(x)) + 10^-digits) # x == 0 case is dealt with below mT <- signif(x / 10^eT, digits) # m[antissa] ss <- vector("list", length(x)) if(sub.10 <- !isFALSE(sub10)) { sub10 <- if(isTRUE(sub10)) c(0L,0L) else if(identical(sub10, "10")) 0:1 else as.integer(sub10) noE <- if(length(sub10) == 1) { if(sub10 < 0) stop("'sub10' must not be negative if a single number") eT <= sub10 } else if(length(sub10) == 2) { stopifnot(sub10[1] <= sub10[2]) sub10[1] <= eT & eT <= sub10[2] } else stop("invalid 'sub10'") ## for noE's, mt := value (instead of mantissa): mT[noE] <- mT[noE] * 10^eT[noE] } if (lab.type == "plotmath") { for(i in seq(along = x)) ss[[i]] <- if(x[i] == 0) quote(0) else if(sub.10 && noE[i] ) substitute( A, list(A = mT[i])) else if(drop.1 && mT[i] == 1) substitute( 10^E, list(E = eT[i])) else if(drop.1 && mT[i] == -1) substitute(-10^E, list(E = eT[i])) else substitute(A %*% 10^E, list(A = mT[i], E = eT[i])) do.call("expression", ss) } else { ## lab.type=="latex" ## TO DO: allow format specifier?? mTf <- formatC(mT, width=1) eTf <- formatC(eT, width=1) for(i in seq(along = x)) ss[[i]] <- if(x[i] == 0) "" else if(sub.10 && noE[i] ) mTf[i] else if(drop.1 && mT[i] == 1) sprintf("$10^{%s}$", eTf[i]) else if(drop.1 && mT[i] == -1) sprintf("$-10^{%s}$",eTf[i]) else sprintf("$%s \\%s 10^{%s}$", mTf[i], lab.sep, eTf[i]) unlist(ss) } } axTexpr <- function(side, at = axTicks(side, axp=axp, usr=usr, log=log), axp = NULL, usr = NULL, log = NULL, drop.1 = FALSE) { ## Purpose: Do "a 10^k" labeling instead of "a e" ## ------------------------------------------------- ## Arguments: as for axTicks() pretty10exp(at, drop.1) } ### TODO: ### ### My axis(.) function with at least two options ("engineering/not") ### Really wanted: allow xaxt = "p" (pretty) or "P" (pretty, "Engineer") ### FIXME(2): max.at is only needed because axTicks() is sometimes too large ### FIXME(3): ?? axisTicks() instead of axTicks(): ## set.seed(1);x <- runif(100,-0.18, 1.13) ## par(mar=.1+c(5,4,2,4)); plot(x,axes=FALSE) ## eaxis(4) # ugly ## eaxis(2, at=axisTicks(par("usr")[3:4],log=FALSE)) # much better eaxis <- function(side, at = if(log) axTicks(side, axp=axp, log=log, nintLog=nintLog) else axTicks(side, axp=axp, log=log), labels = NULL, log = NULL, ## use expression (plotmath/latex) if 'log' or exponential format: use.expr = log || format.info(as.numeric(at), digits=7)[3] > 0, f.smalltcl = 3/5, at.small = NULL, small.mult = NULL, equidist.at.tol = 0.002, small.args = list(), draw.between.ticks = TRUE, between.max = 4, outer.at = TRUE, drop.1 = TRUE, sub10 = FALSE, las = 1, nintLog = max(10, par("lab")[2L - is.x]), axp = NULL, n.axp = NULL, max.at = Inf, lab.type="plotmath", lab.sep="cdot", ...) { ## Purpose: "E"xtended, "E"ngineer-like (log-)axis ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 13 Oct 2007 ## first part: same as graphics::axTicks() [also by MM] : is.x <- side%%2 == 1 XY <- function(ch) paste0(if (is.x) "x" else "y", ch) if(is.null(log)) log <- par(XY("log")) if(is.null(axp)) { axp <- par(XY("axp")) if(!is.null(n.axp)) { if(is.numeric(n.axp) && length(n.axp) == 1 && n.axp == as.integer(n.axp)) axp[3] <- n.axp else stop(gettextf( "'n.axp' must be an integer to be used as '%s', see ?par and there 'xaxp'", XY("axp")), domain=NA) } } if(is.finite(max.at <- round(max.at))) { ## "thin the 'at' values if(max.at < 1) stop("'max.at' must be >= 1") at <- quantile(at, (0:max.at)/max.at, names = FALSE, type = 3) ## <-- ensure that order statistics are used if(!log && is.null(at.small) && { d <- diff(at) any(abs(diff(d)) > equidist.at.tol * mean(d)) }) # at is not equidistant : at.small <- FALSE } if(is.null(labels)) labels <- if(use.expr) { pretty10exp(at, drop.1=drop.1, sub10=sub10, lab.type=lab.type, lab.sep=lab.sep) } else if(lab.type == "latex") paste("$", at, "$", sep="") else TRUE else if(length(labels) == 1 && is.na(labels)) # no 'plotmath' labels <- TRUE axis(side, at = at, labels = labels, las=las, ...) if(log) { if(any(at <= 0)) stop("invalid 'log=TRUE' for at <= 0: not a true log scale plot?") l1 <- (lat <- log10(at)) %% 1 ## the 10^k ones l.int <- l1 < 1e-5 | l1 > 1 - 1e-5 if(draw.between.ticks && all(l.int)) { ## all lat are integer ## check if have "thinned" but still want to draw ticks if(any(diff(lat <- sort(round(lat, 5))) > 1)) { nl <- length(lat0 <- lat) ## extend 'at' (new must contain the previous!) lat <- lat[1]:lat[nl] if(length(lat) > between.max*nl) { ## too many: thin them! lat <- unique(round(seqXtend(lat0, between.max*nl, "interpolate"))) if(is.null(at.small) && median(diff(lat)) > 1.5) ## no small ticks, if large are mostly not 10^(k1..k2) at.small <- FALSE } at <- 10^lat axis(side, at = at, labels = FALSE, las=las, ...) } } } if(is.null(at.small)) { ## create smart default, using small.mult at.small <- if(log) { if(!all(l.int)) at <- at[l.int] if(is.null(small.mult)) small.mult <- 9 if(length(at)) outer(2:small.mult, c(if(outer.at) at[1]/10, at)) } else { ## assumes that 'at' is equidistant d <- diff(at <- sort(at)) if(any(abs(diff(d)) > equidist.at.tol * (dd <- mean(d)))) FALSE ## 'at' is not equidistant" else { if(is.null(small.mult)) { ## look at 'dd' , e.g. in {5, 50, 0.05, 0.02 ..} d. <- dd / 10^floor(log10(dd)) small.mult <- { if(d. %% 5 == 0) 5 else if(d. %% 4 == 0) 4 else if(d. %% 2 == 0) 2 else if(d. %% 3 == 0) 3 else if(d. %% 0.5 == 0) 5 else 2 } } outer(seq_len(small.mult-1)/small.mult * dd, c(if(outer.at) at[1]-dd, at), "+") } } ## if(outer.at) { # make sure 'at.small' remain inside "usr" p.u <- sort(par("usr")[if(is.x) 1:2 else 3:4]) if(log) p.u <- 10^p.u at.small <- at.small[p.u[1] <= at.small & at.small <= p.u[2]] } } if(is.numeric(at.small) && any(is.finite(at.small))) ## can use NA or FALSE to suppress ## axis(side, at = at.small, .....) do.call(axis, c(list(side, at = at.small, labels = FALSE, tcl = f.smalltcl * par("tcl")), small.args)) } ## @author Alain Hauser ## @date 2014-02-12 originally toLatex.numeric <- function(object, digits = format.info(object)[2], scientific = format.info(object)[3] > 0, times = "\\cdot", ...) { sround <- function(x, digits) sprintf("%0.*f", digits, x) if(scientific) { ## Strings in scientific format -- isn't regex a funny thing? ;-) # res <- as.character(pretty10exp(object, digits = digits + 1)) # res <- sub("%\\*%", gsub("\\\\", "\\\\\\\\", times), res) # sub("10\\^(.*)$", "10^{\\1}", res) ## Original version without pretty10exp and regex: eT <- floor(log10(abs(object)) + 10^(-digits-1)) sprintf("%s %s 10^{%d}", sround(object/10^eT, digits), times, eT) } else { ## Actual output strings sround(object, digits) } } sfsmisc/R/Ftest-rlm.R0000644000176200001440000000417212452535573014141 0ustar liggesusers##- From: Werner Stahel ##- To: holzer@stat.math.ethz.ch, maechler@stat.math.ethz.ch ##- Subject: robuster F-test ##- Date: Fri, 14 Jul 2000 17:01:55 +0200 (CEST) f.robftest <- function(object, var = -1) { ## Purpose: robust F-test: Wald test for several coefficients of ## an rlm object ## ------------------------------------------------------------------------- ## Arguments: ## object result of rlm(...) ## var variables. Either their names or their indices ## Default: all *but* the intercept ## ------------------------------------------------------------------------- ## Author: Werner Stahel, Date: 14 Jul 2000; MM, 2000-07-14 if (!inherits(object, "rlm")) stop("f.robftest() only works for 'rlm' objects") ## determine and check coefficients to be tested cf <- object$coef iind <- if(is.character(var)) match(var,names(cf)) else seq(length(cf))[var] wrong <- is.na(iind) | iind > length(cf) | iind < 1 if (any(wrong)) stop(paste("variable ",var[wrong]," not found")) cf <- cf[iind] if (0 == (t.nv <- length(cf))) stop("no variables to be tested") ## covariance matrix of estimated coefficients: calls summary.rlm(): stopifnot(requireNamespace("MASS")) t.r <- summary(object, method="XtWX") ## Nota BENE: vcov() calls vcov.lm() which uses $sigma instead of $stddev ! t.cov <- t.r$cov.unscaled[iind,iind] * t.r$stddev ^ 2 ## Instead of c(cf %*% solve(t.cov) %*% cf)/t.nv ## quite a bit more efficient (for larger p): x' A^-1 x : t.f <- sum(cf * solve(t.cov, cf))/t.nv df <- c(t.nv, t.r$df[2]) ## MM: Return an object of class "htest" ---> nice print.*() method ! structure(list(statistic = c(F = t.f), df = df, data.name = paste("from", deparse(object$call)), method = "robust F-test (as if non-random weights)", alternative = "two.sided", null.value = {c0 <- cf; c0[] <- 0; c0}, p.value = pf(t.f, df[1], df[2], lower.tail = FALSE)), class = "htest") } sfsmisc/R/printTable.R0000644000176200001440000000556311567630345014374 0ustar liggesusers printTable2 <- function(table2, digits = 3) { ##-- 2-weg Kontingenztafel mit allem zusammen ... -- ruft catCon(.) auf ##-- Urspruneglich fuer NDK-Uebungen 1992 ##-- Verbessert und Fehler korrigiert! : M.Maechler, Feb.1993 d <- dim(table2) if(length(d) != 2) stop("Argument muss numerische Matrix sein: Die (2-Weg) Kontingenz Tafel") N <- sum(table2) cat("\nKontingenz-Tafel mit Randsummen:\n") print(margin2table(table2), digits=0) cat("\nGemeinsame Verteilung mit Randverteilungen:\n") I <- d[1]; J <- d[2]; df <- (I-1)*(J-1) r <- margin2table(table2/N) print(r, digits) joint <- r[1:I, 1:J] xrand <- r[I+1, 1:J] yrand <- r[1:I, J+1] condy <- joint/yrand condx <- t(t(joint)/xrand) cat("Bedingte Verteilung gegen y:\n"); print(round(condy,digits)); cat("\n") cat("Bedingte Verteilung gegen x:\n"); print(round(condx,digits)); cat("\n") exp.ind <- N * outer(yrand,xrand)#- Expected under INDEPendence: n * p_i * p_j cat("Freiheitsgrade: df =",df,"\n") cat("Chi^2 - Annahmebereich: [0,", round(qchisq(0.95,df),1), "] (alpha=0.05)\n\n\n", sep = "") test.chisq <- sum((as.matrix(table2)-exp.ind)^2/exp.ind) cat("Testwerte unter der Unabhaengigkeitshypothese:\n") cat(" Test mit Chi^2: ",format(round(test.chisq,2)), " (P-Wert: ",round(1-pchisq(test.chisq,df),4),")\n",sep = "") is.pos <- table2 != 0 test.deviance <- 2*sum(table2[is.pos]*log(table2[is.pos]/exp.ind[is.pos])) cat(" Test mit Devianz: ",format(round(test.deviance,2)), " (P-Wert: ",round(1-pchisq(test.deviance,df),4),")\n\n",sep = "") invisible(list(p.condx = condx, p.condy = condy, expected.indep = exp.ind, df = df, chisq.test = test.chisq, deviance = test.deviance)) } ### The original catCon() function did compute and print; ### now separated : margin2table <- function(x, totName = "sum", name.if.empty=FALSE) { x <- as.matrix(x) if(name.if.empty) x <- empty.dimnames(x) r <- rowSums(x) r <- rbind(cbind(x, r), c(colSums(x), sum(r))) dimnames(r) <- if(!is.null(dnx <- dimnames(x))) { dn <- list(if(!is.null(dnx[[1]])) c(dnx[[1]], totName), if(!is.null(dnx[[2]])) c(dnx[[2]], totName)) names(dn) <- names(dnx) dn } ## else NULL class(r) <- c("margin2table", "table") r } print.margin2table <- function(x, digits = 3, quote = FALSE, right = TRUE, ...) { if(is.null(d <- dim(x)) || length(d <- d - 1) !=2) stop("'x' is not a matrix") N <- d[1]; M <- d[2] cx <- format(round(x, digits))[c(1:N,N+1,N+1), c(1:M,M+1,M+1)] cx[N+1,] <- "--"; if(!is.null(rownames(cx))) rownames(cx)[N+1] <- "--" cx[,M+1] <- "|" ; if(!is.null(colnames(cx))) colnames(cx)[M+1] <- "|" ## TODO: think of implementing zero.print = "." -- as in print.table() ## TODO(2): improve that in print.table(), ## (e.g. replace "0.0" or "0e0" by ". "; "00.0" by " . ") print(cx, quote=quote, right=right, ...) invisible(x) } sfsmisc/R/u.goodies.R0000644000176200001440000000633212562441251014147 0ustar liggesusers####--- Utilities ----------------- ## Was in ./unix/ -- but is called from pdf.end() / ps.end() which are here: ./ps.goodies.R Sys.ps.cmd <- function() { sys <- (si <- Sys.info())[["sysname"]] if(sys == "Linux") { s.rel <- si[["release"]] ## 2013-7: Kurt sees s.rel <- "3.9-1-amd64" rel <- c(as.integer(strsplit(s.rel,"[[:punct:]]")[[1]][1:2]) %*% c(1000,1)) if(is.na(rel)) rel <- 3000 if(rel >= 2006) "/bin/ps w" ## Linux kernel >= 2.6 (this is true for Ubuntu!) else if(rel >= 2002) "/bin/ps --width 1000" ## Linux >= 2.2 else structure("/bin/ps w",type="BSD") } else if(sys == "SunOS") "/usr/bin/ps" else { warning("Unknown OS [Operating System]; 'ps' may not be compatible") "ps" } } u.sys <- function(..., intern=TRUE) system(paste0(...), intern=intern) u.date <- function(short = FALSE) format(Sys.time(), paste0("%d/%h/%Y", if(!short) ", %H:%M")) ## Unix-only: u.sys("date '+%d/%h/%Y", if(!short) ", %H:%M", "'") u.Datumvonheute <- function(W.tag = 2, Zeit = FALSE) { ## Ziel: Deutsches (kurzes) Datum (als string) ## ## ==> ?u.Datumvonheute [online help] ## Unix-only: dat <- as.numeric(system("date '+%w %d %m %Y %H %M' | tr ' ' '\n'",TRUE)) dat <- as.integer(strsplit(format(Sys.time(),"%w %d %m %Y %H %M"), " ")[[1]]) ## 1 2 3 4 5 6 DMY <- paste0(dat[2], ". ", C.Monatsname[dat[3]], " ", dat[4]) r <- if (W.tag) { #-- wollen Wochentag W <- ifelse(dat[1]==0, 7, dat[1]) if (W.tag==2) Wtag <- C.Wochentag[W] else Wtag <- C.Wochentagkurz[W] paste(Wtag, DMY, sep=", ") } else DMY if(Zeit) { paste(r, if (Zeit==2) paste(dat[5:6], collapse=":") else dat[5], sep="; ") } else r } C.Monatsname <- c("Januar", "Februar", "Maerz", "April", "Mai", "Juni", "Juli", "August", "September", "Oktober", "November", "Dezember") C.Wochentag <- c("Montag", "Dienstag", "Mittwoch", "Donnerstag", "Freitag", "Samstag", "Sonntag") C.Wochentagkurz <- c("Mon", "Die", "Mit", "Don", "Fre", "Sam", "Son") C.weekday <- c("Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun") ## Months: we had ## C.monthname === month.name in R ## C.monthshort === month.abb in R ##>>> Please: Forget the following !! it is ===== S function date() !! ##>>> "u.datum"<- function() unix("date") u.datumdecode <- function(d, YMDHMnames = c("Jahr", "Monat", "Tag", "Std", "Min")) { ## Ziel: Daten der Form 8710230920 aufspalten in Jahr, Monat, Tag, Std, Min ## ---------------------------------------------------------------------- ## Bemerkungen: Dies scheint mir nicht das richtige Konzept. ## Wenn man numerische Datuemer will, soll man doch julianische ## Daten verwenden !! Dann hat man auch eine richtige Zeit-Skala ## Diese Funktionen sind in library(examples) und (verbessert) in ## /u/maechler/s/date.Data !! (Martin Maechler) ##======================================================================= if(length(YMDHMnames) != 5 || !is.character(YMDHMnames)) stop("invalid `YMDHMnames': must be character(5)") n <- length(d) z <- matrix(NA, n, 5, dimnames = list(names(d), YMDHMnames)) for(j in 5:1) { h <- d %/% 100 z[, j] <- d - 100 * h d <- h } drop(z)# vector if `d' was a scalar (length 1) } sfsmisc/R/missingCh.R0000644000176200001440000000024512420226555014175 0ustar liggesusersmissingCh <- function(x, envir = parent.frame()) { stopifnot(is.character(x)) eval(substitute(missing(VAR), list(VAR=as.name(x))), envir = envir) } sfsmisc/R/ps.goodies.R0000644000176200001440000002505713617216205014333 0ustar liggesusers#### PostScript Goodies fr R --- `a la /u/sfs/S/ps.goodies.S #### #### ## hidden in the name space -- FIXME? maybe more useful ?? --- dev.latex <- function(file, DEV, height= 5+ main.space*1.25, width= 9.5, main.space = FALSE, lab.space = main.space, paper = "special", title = NULL, lab = c(10, 10, 7), mgp.lab = c(1.6, 0.7, 0), mar = c(4, 4, 0.9, 1.1), ...) { ## Purpose: Setup for 1 LaTeX-includable picture SAVING on white space ! ## Calls ps.do(.) ; par(.) [ old par in global 'o.p']; USE ps.end() ! ## ------------------------------------------------------------------------- ## Arguments: height & width in INCHES. (5, 9.5) is 'horizontal look' ## title: to be used in PostScript (-> for gv/ghostview !) ## main.space & lab.space: if T, leave space for 'main' & 'x/ylab' ## lab : for par(.); (10,10,7): use more axis 'labels' .. ## mgp.lab & mar : for par(.): these are values for 'lab.space=T' ## Note: FIRST fiddle with 'main.sp.', 'lab.sp.' before 'mgp.lab' and 'mar'! ## ------------------------------------------------------------------------- ## EXAMPLE:for(m in c(T,F)){str(ps.latex("q.ps",main=m));acf(hstart);ps.end()} ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: Sep 94; Sept. 95 ## Cannot use missing(.) here, as all arg.s *are* specified ## from the calling pdf.latex() etc .. frms <- formals() lab.def <- identical(lab, eval(frms[["lab"]])) mar.def <- identical(mar, eval(frms[["mar"]])) mgp.lab.def <- identical(mgp.lab, eval(frms[["mgp.lab"]])) if(!lab.def && !(length(lab)==3 && is.numeric(lab) && all(lab >=0))) stop("'lab' must be numeric vector >= 0, of length 3") if(!mgp.lab.def && !(length(mgp.lab)==3 && is.numeric(mgp.lab) && all(mgp.lab >=0) && all(diff(mgp.lab)<=0))) stop("'mgp.lab' must be non-increasing numeric vector >= 0, of length 3") if(!mar.def && !(length(mar)==4 && is.numeric(mar) && all(mar >=0))) stop("'mar' must be non-negative numeric vector of length 4") DEV(file=file, height=height, width=width, paper=paper, title = title, ...) ##= ## Now: just do the proper par(...) calls : mar.main.Extra <- c(0,0, 3.2,0) mar.nolab.Minus <- c(1,1, 0.3,0) if(main.space && mar.def) mar <- mar + mar.main.Extra if(!lab.space) { mar <- mar - mar.nolab.Minus if(main.space) warning("'main.space' is TRUE, but 'lab.space' is FALSE ...") } o.p <- par(mar = mar, mgp= mgp.lab) o.p <- c(o.p, par(lab=lab)) # need 2 step for bug ? ## "frame 0 / GlobalEnv assignment deprecated: u.assign0("o.par.psl", o.p) invisible(list(old.par=o.p, new.par= par(c("mar","mgp","lab")))) } ps.latex <- function(file, height= 5+ main.space*1.25, width= 9.5, main.space = FALSE, lab.space = main.space, paper = "special", title = NULL, lab = c(10, 10, 7), mgp.lab = c(1.6, 0.7, 0), mar = c(4, 4, 0.9, 1.1), ...) { dev.latex(DEV = ps.do, file=file, height=height, width=width, main.space=main.space, lab.space=lab.space, paper=paper, title=title, lab=lab, mgp.lab=mgp.lab, mar=mar, ...) } pdf.latex <- function(file, height= 5+ main.space*1.25, width= 9.5, main.space = FALSE, lab.space = main.space, paper = "special", title = NULL, lab = c(10, 10, 7), mgp.lab = c(1.6, 0.7, 0), mar = c(4, 4, 0.9, 1.1), ...) { dev.latex(DEV = pdf.do, file=file, height=height, width=width, main.space=main.space, lab.space=lab.space, paper=paper, title=title, lab=lab, mgp.lab=mgp.lab, mar=mar, ...) } ps.do <- local({ myfile <- NULL function(file, width = -1, height = -1, onefile = FALSE, horizontal = FALSE, title = NULL, ...) { ## Purpose: "Ghostview" device driver. --- to be "closed" by ps.end(..) -- ## ------------------------------------------------------------------------- ## Arguments: file, width, height : file name and dims in inch; 1 in:=2.54 cm ## onefile = F <==> Encapsulated PS (Splus default: T, simple PS) ## -- new Args: combining former ps.do(.) and ps.col(.) : ## ... : passed to ps.options ## ------------------------------------------------------------------------- ## Author: Martin Maechler, 1992-1995 ## ## --->>>>>> CONSIDER 'ps.latex' instead for pictures ! myfile <<- file ## if(length(l... <- list(...))) { ## ## This does NOT work : pso are the *NEW*, not the *former* ones! ## oldop <- ps.options()[names(l...)] ## ps.options(...) ## on.exit( do.call("ps.options", oldop) ) #- reset ps.options ! ## } if(is.null(title)) title <- paste("R", paste(R.version[c("major", "minor")], collapse = "."), "plot:", basename(file)) postscript(file = file, width = width, height = height, horizontal=horizontal, onefile = onefile, title = title, print.it = FALSE, ...) }## ps.do() })## local(..) ps.end <- function(call.gv = NULL, command = getOption("eps_view"), debug = getOption("verbose")) { ## Purpose: A "ghostview" device driver (almost). ## Author: Martin Maechler, Date: May 26 1992, 15:32 ## ---------------------------------------------------------------- ## Arguments: call.gv: If TRUE, call ghostview. ## Default: Find out if ghostview already runs on this file, ## If yes, do not call it again. ## MUST be called after ps.do(..) or ps.latex() ! ## Example: ps.end(com = "ghostview --media a4") ## ---------------------------------------------------------------- ## Only if postscript is running !! -- if( names(dev.cur()) == "postscript") dev.off() if(.Platform $ OS.type == "unix") { .set.eps_view() } else { ## OS.type != "unix" --- i.e. Windows : warning("using ps, ghostview,...is currently not implemented for non-Unix") return(FALSE) } ..ps.file <- environment(ps.do)$myfile if (is.null(call.gv)) { f <- u.sys(Sys.ps.cmd(), " | grep '", command, "' | grep -v grep") if(debug) { cat("ps.end(): f:\n");print(f) } call.gv <- length(f) == 0 if(!call.gv) { ##--- STILL does NOT work ##--- if you work with two different pictures simultaneously for(i in 1:length(f)) { #-- only NOT call if THIS ps.file .. -- ## find command in 'ps' output line (sub/gsub have no 'fixed=TRUE') ic <- regexpr(command, f[i], fixed=TRUE) ## only keep the file name fil <- substr(f[i], ic + attr(ic,"match.length") + 1, 1e4) cat("ps.end(): fil:",fil,"\n") call.gv <- length(fil) < 1 || all(..ps.file != fil) if(!call.gv) break #-- don't call ghostview since it runs this file.. } } } else if(identical(call.gv, FALSE)) fil <- "" if (call.gv) { fil <- ..ps.file u.sys(command, " ", fil, "&", intern=FALSE) } else cat("\n >> switch to", sub(" .*", '', command), "(postscript viewer) window -- updated automagically!\n\n") invisible(fil) } ###--- Using pdf() instead of postscript() --- otherwise "same" : pdf.do <- local({ myfile <- NULL function(file, paper = "default", width = -1, height = -1, onefile = FALSE, title = NULL, version = "1.4", quiet=FALSE, ...) { ## Purpose: "PDF + view" device driver. --- to be "closed" by pdf.end(..) -- ## ------------------------------------------------------------------------- ## Arguments: file, width, height : file name and dims in inch; 1 in:=2.54 cm ## onefile = FALSE <==> "Encapsulated" ## ... : passed to pdf.options ## ------------------------------------------------------------------------- ## Author: Martin Maechler, April 26, 2007 {built on much older ps.do()} ## if(length(l... <- list(...))) { ## ## ps.options also used for pdf -- in some way ## oldop <- ps.options()[names(l...)] ## ps.options(...) ## on.exit( do.call("ps.options", oldop) ) #- reset ps.options ! ## } myfile <<- file if(missing(paper) && !missing(width) && !missing(height)) { if(!quiet) message("as 'width' and 'height' are specified, setting 'paper = \"special\"") paper <- "special" } if(is.null(title)) title <- paste("R", paste(R.version[c("major", "minor")], collapse = "."), "plot:", basename(file)) ## default for 'paper' is now 'missing' pdf(file = file, version = version, paper = paper, width = width, height = height, onefile = onefile, title = title, ...) }## pdf.do() })## local(..) pdf.end <- function(call.viewer = NULL, command = getOption("pdfviewer"), debug = getOption("verbose")) { ## Purpose: A "ghostview" device driver (almost). ## Author: Martin Maechler, Date: April 26, 2007 ## ---------------------------------------------------------------- ## Arguments: call.viewer: If TRUE, call ghostview. ## Default: Find out if ghostview already runs on this file, ## If yes, do not call it again. ## MUST be called after pdf.do(..) or pdf.latex() ! ## Example: pdf.end(com = "acroread") ## ---------------------------------------------------------------- ## Only if postscript is running !! -- if( names(dev.cur()) == "pdf") dev.off() if(.Platform $ OS.type != "unix") { warning("using ps (process status) is currently not implemented for non-Unix") return(FALSE) } ..pdf.file <- environment(pdf.do)$myfile if (is.null(call.viewer)) { cmd <- basename(command) f <- u.sys(Sys.ps.cmd(), " | grep '", cmd, "' | grep -v grep") if(debug) { cat("pdf.end(): f:\n");print(f) } call.viewer <- length(f) == 0 if(!call.viewer) { ##--- STILL does NOT work ##--- if you work with two different pictures simultaneously for(i in 1:length(f)) { #-- only NOT call if THIS pdf.file .. -- ## find command in 'ps' output line (sub/gsub have no 'fixed=TRUE') ic <- regexpr(cmd, f[i], fixed=TRUE) ## only keep the file name fil <- substr(f[i], ic + attr(ic,"match.length") + 1, 1e4) cat("pdf.end(): fil:",fil,"\n") call.viewer <- length(fil) < 1 || all(..pdf.file != fil) if(!call.viewer) break #-- don't call ghostview since it runs this file.. } } } else if(identical(call.viewer, FALSE)) fil <- "" if (call.viewer) { fil <- ..pdf.file u.sys(command, " ", fil, "&", intern=FALSE) } else { msg <- if(length(grep("acroread", command))) " acroread -- and refresh via C-w M-f 1 !" else " PDF viewer window and maybe refresh!" cat("\n >> switch to", msg,"\n\n") } invisible(fil) } ## Alain Hauser --> ../man/cairoSwd.Rd cairoSwd <- function(name, width, height, ...) cairo_pdf(filename = paste(name, "pdf", sep = "."), width = width, height = height) sfsmisc/R/loessDemo.R0000644000176200001440000001042412620116104014171 0ustar liggesusersloessDemo <- function(x, y, span = 1/2, degree = 1, family = c("gaussian", "symmetric"), nearest = FALSE, nout = 501, xlim = numeric(0), ylim = numeric(0), strictlim=TRUE, verbose = TRUE, inch.sym = 0.25, pch = 4, shade = TRUE, w.symbols = TRUE, sym.col = "blue", w.col = "light blue", line.col = "steelblue") { ## function to demonstrate the locally weighted regression function loess ## written and posted to S-news, Thu, 27 Sep 2001 07:48 ### Dr. Greg Snow ## Brigham Young University, Department of Statistics ## gls@byu.edu ## Modified by Henrik Aa. Nielsen, IMM, DTU (han@imm.dtu.dk) ## spiffed up (R only), by M.Mächler, SfS ETH Zurich family <- match.arg(family) ## drop NA's and sort: miss.xy <- is.na(x) | is.na(y) x <- x[!miss.xy] y <- y[!miss.xy] ix <- order(x) x <- x[ix] y <- y[ix] degree <- as.integer(degree) if(length(degree) != 1 || is.na(degree) || degree < 0 || 2 < degree) stop("'degree' must be in {0,1,2}") fit.D <- loess(y ~ x, degree = degree, span = span, family = family, control = loess.control(surface = "direct")) fit.I <- loess(y ~ x, degree = degree, span = span, family = family) xx <- seq(min(x), max(x), len = nout) est <- list(x = xx, y = predict(fit.I, newdata = data.frame(x = xx))) xl <- if(strictlim && is.numeric(xlim) && length(xlim) == 2) xlim else { xl <- range(x, est$x, xlim) xl <- xl + c(-1, 1) * 0.03 * diff(xl) } yl <- if(strictlim && is.numeric(ylim) && length(ylim) == 2) { dy <- 0.05 * diff(ylim) ylim } else { yl <- range(y, est$y, ylim, fitted(fit.D)) dy <- 0.05 * diff(yl) yl + c(-1, 1) * dy } ## room below for weights dy <- 4*dy yl[1] <- yl[1] - dy stit <- paste("span = ", span,"; degree = ", degree) if(family != "gaussian") stit <- paste(stit,". family = \"", family,'"',sep="") fitPlot <- function(x, y, w, est, fit.D, xl, yl) { pU <- par("usr") plot(x, y, pch = pch, xlim = xl, ylim = yl, sub = stit) if(!is.null(w)) { w <- w/max(w) # in [0,1] wP <- w > 1e-5 nw <- length(xw <- x[wP]) if(w.symbols) symbols(xw, y[wP], circles = sqrt(w[wP]), inches = inch.sym, add = TRUE, fg = sym.col) # scale [0,1] to yl[1] + [0, dy] : y0 <- pU[3] wy <- y0 + (dy+yl[1]-y0) * w[wP] polygon(c(xw[1], xw, xw[nw]), c(y0, wy, y0), col = w.col) segments(xw, rep(y0,nw), xw, wy, col=sym.col) } lines(x, fitted(fit.D), col = 2, lwd = 2) mtext("Exact estimate with linear interpolation between x-values ('surface = \"direct\")", col = 2, adj = 0.5, line = 0.5) lines(est, col = 3, lwd = 2) mtext("Estimate obtained using the default interpolation scheme", col = 3, adj = 0.5, line = 2) pU } fitPlot(x, y, w=NULL, est, fit.D, xl, yl) repeat { if(verbose) cat("click left for x0 to predict -- click right to stop ") x0 <- locator(1)$x if(verbose) cat("\n") if(length(x0) < 1)## right clicking leaves loop break if(nearest) x0 <- unique(x[abs(x - x0) == min(abs(x - x0))]) if(verbose) cat("x0 =", x0, "\n") Dx <- abs(x - x0) d <- if(span < 1) sort(Dx)[as.integer(span * length(x))] else max(Dx) * sqrt(span) w <- rep(0, length(x)) s <- Dx <= d w[s] <- (1 - (Dx[s]/d)^3)^3 # tricube weights pU <- fitPlot(x, y, w, est, fit.D, xl, yl) ## ======= == if(degree > 0L) { ## is '1' or '2 if(degree == 1) abline(lm(y ~ x, weights = w), col = line.col) else ## (degree == 2) # predict(lm( ~ poly()) fails! lines(xx, predict(lm(y ~ x + I(x^2), weights = w), data.frame(x=xx)), col = line.col, err = -1) } else { ## degree == 0 ##lines(x, fitted(lm(y ~ 1, weights = w)), col = line.col, err = -1) abline(a = sum(w*y)/sum(w), b = 0, col = line.col) } abline(v = x0, col = line.col, lty = 3, lwd = 0.2) axis(1, at= x0, labels = formatC(x0, digits=3), col.axis = line.col) if((x1 <- x0 - d) > xl[1]) { abline(v = x1, col = line.col, lty = 2) if(shade) polygon(c(pU[1],x1,x1,pU[1]), pU[c(3,3, 4,4)], density = 5) } if((x1 <- x0 + d) < xl[2]) { abline(v = x1, col = line.col, lty = 2) if(shade) polygon(c(x1, pU[c(2,2)],x1), pU[c(3,3, 4,4)], density = 5, angle = -45) } } } sfsmisc/R/huber.R0000644000176200001440000000021710377014647013363 0ustar liggesusers#### NOTA BENE: New version of huberM() is only in 'robustbase' !!! #### -------- ---------------------------------------- sfsmisc/R/twoway-r-plot.R0000644000176200001440000000742012326161235015016 0ustar liggesuserscompresid2way <- function(aov, data=NULL, fac=1:2, label = TRUE, numlabel = FALSE, xlab=NULL, ylab=NULL, main=NULL, col=c(2,3,4,4),lty=c(1,1,2,4), pch=c(1,2)) { ## Zweck: forget-it-plot Autor: Stahel Datum: Dez 89 ## Arguments: ## aov either a aov object with a formula of the form ## y ~ a + b , where a and b are factors ## or such a formula ## data data frame containing a and b ## fac the two factors used for plotting ## label show levels of factors in the plot ## numlabel show effects of factors in the plot ## col,lty,pch colors, line types, plotting characters to be used ## [1] positive residuals ## [2] negative residuals ## [3] grid ## [4] labels if (inherits(aov,"aov")) { lform <- formula(aov) if (is.null(data)) { datanm <- as.character(aov$call)[3] if (is.na(datanm)) stop("no data found") data <- eval(parse(text=datanm)) } } else { if (!is.data.frame(data)) stop("unsuitable argument data") lform <- aov aov <- aov(lform,data) } lmm <- model.frame(aov) fac <- if (is.numeric(fac)) fac+1 else match(fac,names(lmm)) if (any(is.na(fac))) stop("factor(s) not found") if (!all(vapply(lmm[,fac], is.factor, NA))) stop("variables are not both factors") ## coefficients, components of the fit lcf <- dummy.coef(aov) lic <- lcf[["(Intercept)"]] if (is.na(lic)) lic <- 0 lia <- fac[1] lib <- fac[2] lfa <- lmm[,lia] lfb <- lmm[,lib] lcfa <- lcf[[lia]] lcfb <- lcf[[lib]] lmna <- min(lcfa) lmnb <- min(lcfb) lcfa <- lcfa-lmna lcfb <- lcfb-lmnb lic <- lic+lmna+lmnb lefa <- lcfa[lfa] lefb <- lcfb[lfb] lfit <- lic+lefa+lefb lfnames <- names(lmm)[c(lia,lib)] lyname <- names(lmm)[1] ly <- lfit+resid(aov) ## prepare plot lx <- lefb-lefa if (is.null(main)) main <- format(lform) if (is.null(ylab)) ylab <- lyname if (is.null(xlab)) xlab <- paste("-",paste(lfnames,collapse = " + ")) lty <- rep(lty,length = 4) if (length(pch) <= 1) pch <- rep(c(pch,pch,1),length = 2) lrgy <- range(c(lfit, ly)) lrgx <- range(lx) lht <- 0.05 * diff(lrgy) lwd <- 0.05 * diff(lrgx) plot(lrgx+lwd*c(-1,1), lrgy+lwd*c(-1,1), type = "n", xlab = "", ylab = ylab) mtext(main, 3, 1, cex = par("cex.main"), col = par("col.main"), font = par("font.main")) mtext(xlab,1, par("mgp")[1], at = 0) ## residuals li <- ly > lfit if (any(li)) { lpch <- if (length(pch) >= length(li)) pch[li] else pch[1] segments(lx[li], lfit[li], lx[li], ly[li], lty = lty[1], col = col[1]) points(lx[li], ly[li], col = col[1], pch = lpch) } li <- !li if (any(li)) { lpch <- if (length(pch) >= length(li)) pch[li] else pch[2] segments(lx[li], lfit[li], lx[li], ly[li], lty = lty[2], col = col[2]) points(lx[li], ly[li], col = col[2], pch = lpch) } ## grid lmxa <- max(lcfa) segments(lcfb, lic + lcfb, lcfb - lmxa, lic + lmxa + lcfb, lty = lty[3], col = col[3]) lmxb <- max(lcfb) segments( - lcfa, lic + lcfa, lmxb - lcfa, lic + lmxb + lcfa, lty = lty[3], col = col[3]) ## labels if(label) text(c(lcfb - lmxa - lwd, lmxb - lcfa + lwd), c(lmxa + lcfb, lmxb + lcfa) + lic + lht, c(levels(lfb), levels(lfa)), col = col[4]) if(numlabel) { ldg <- - min(0, floor(log10(max(abs(lrgy)))) - 3) text(c(lcfb + lwd, - lcfa - lwd), lic + c(lcfb, lcfa) - lht, round(c(lcfb, lcfa), ldg), col = col[4]) } lcf <- list(lic,lcfa,lcfb) names(lcf) <- c("(Intercept)",lfnames) lcompy <- data.frame(ly,lefa,lefb) names(lcompy) <- c(paste("part",lyname,sep = "."), paste("eff",lfnames,sep = ".")) invisible(list(compy = lcompy,coef = lcf)) } sfsmisc/R/prime-numbers-fn.R0000644000176200001440000003000312662652577015451 0ustar liggesusers####---- Prime numbers, factorization, etc. --- "illustatration of programming" ####---- Function definitions -------- ## for examples, see "../demo/prime-numbers.R" ### MM: Currently only export primes() and factorize() ---- TODO: CLEAN UP! ## NOTA BENE: ## --------- ## I found out [R 1.9.x, July 2004], that the primes() function ## Bill Venables' "conf.design" package (== primes.() below) is almost an ordner of ## magnitude faster than the primes.*() or prime.sieve() ones further below : ## but read on: I'm improving it a bit: primes. <- function(n) { ## By Bill Venables <= 2001 ## Find all primes less than n (or max(n) if length(n) > 1). ## Uses an obvious sieve method. Nothing flash. ## if ((M2 <- max(n)) <= 1) return(numeric(0)) x <- 1:M2 x[1] <- 0 p <- 1 M <- floor(sqrt(M2)) while((p <- p + 1) <= M) if(x[p] != 0) x[seq(p^2, n, p)] <- 0 x[x > 0] } ##' New 'pSeq' is still (almost ?) always **slower** than pSeq = NULL !!!! primes <- function(n, pSeq = NULL) { ## Find all primes less than n (or max(n) if length(n) > 1). ## Uses an obvious sieve method. Nothing flash. ## ## By Bill Venables <= 2001 ## MM: work with logical(), keep to integer --> another 40% speedier for R ## --- 2016-01: replacing seq() by seq.int() in loop got another 20% !! if ((M2 <- max(n)) <= 1) return(integer(0)) n <- as.integer(M2) if(is.null(pSeq)) { P <- rep.int(TRUE, n) P[1] <- FALSE } else { ## assume pSeq = c(2, 3, 5, ..., P_max) ## stopifnot(pSeq[1:2] == 2:3, !is.unsorted(pSeq)) if(!is.integer(pSeq)) pSeq <- as.integer(pSeq) maxP1 <- pSeq[length(pSeq)] + 1L if(maxP1 >= n) return(pSeq) ## else (maxP1 := max(pSeq) + 1) < n P <- logical(maxP1) # all FALSE P[pSeq] <- TRUE P <- c(P, rep.int(TRUE, n - maxP1)) } M <- as.integer(sqrt(M2)) ## p <- 1:1 ## while((p <- p + 1:1) <= M) for(p in seq_len(M)) if(P[p])# p is prime, sieve with it P[seq.int(p*p, n, p)] <- FALSE seq_len(n)[P] } ## much slower than primes (even after improvement Jan.2016) prime.sieve <- function(maxP = pM*pM, p2et = c(2,3,5)) { ## Purpose: Produce ALL prime numbers from 2, 3.., using 2,3,5,7,... ## ------------------------------------------------------------------------- ## Arguments: maxP : want primes up to maxP ## p2et: primes c(2,3,5,..., pM); ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 26 Jan 96, 15:08 if(any(p2et[1:2] != 2:3) || is.unsorted(p2et <- as.integer(p2et))) stop("argument 'p2et' must contain SORTED primes 2,3,..") k <- length(p2et) pM <- p2et[k] if(maxP <= pM+1L) p2et #- no need to compute more else if((maxP <- as.integer(maxP)) > pM*pM) prime.sieve(maxP, prime.sieve(pM*pM, p2et)) else { #-- pM < maxP <= pM^2 r <- seq.int(from = pM+2L, to = maxP, by = 2L) for(pr in p2et[p2et <= sqrt(maxP)]) if(0 == length(r <- r[r %% pr != 0])) break c(p2et,r) } } factorize <- function(n, verbose = FALSE) { ## Purpose: Prime factorization of integer(s) 'n' ## ------------------------------------------------------------------------- ## Arguments: n vector of integers to factorize (into prime numbers) ## --> needs a primes() function [originally prime.sieve] ## >> Better would be: Define class 'primefactors' and "multiply" method ## then use this function recursively only "small" factors ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 26--30 Jan 96 n <- if(all(n < .Machine$integer.max)) as.integer(n) else { warning("factorizing large int ( > maximal integer )") round(n) } N <- length(n) M <- as.integer(sqrt(max(n))) #-- check up to this prime number ##-- for M > 100 to 200: should DIVIDE first and then go on .. ##-- Here, I am just (too) lazy: pr <- primes(M) # was: prime.sieve(maxP = M) ## k <- length(pr) nDp <- outer(pr, n, FUN = function(p,n) n %% p == 0) ## which are divisible? ## dim(nDp) = (k,N) ; ## Divide those that are divisible : ## quot <- matrix(n,k,N,byrow=T)[nDp] %/% matrix(pr,k,N)[nDp] ## quot <- rep(n,rep(k,N))[nDp] %/% rep(pr,N)[nDp] res <- vector("list",length = N) names(res) <- n for(i in 1:N) { ## factorize n[i] nn <- n[i] if(any(Dp <- nDp[,i])) { #- Dp: which primes are factors nP <- length(pfac <- pr[Dp]) # all the small prime factors if(verbose) cat(nn," ") } else { # nn is a prime res[[i]] <- cbind(p = nn, m = 1L) if(verbose) cat("direct prime", nn, "\n") next # i } m.pr <- rep(1L, nP)# multiplicities Ppf <- prod(pfac) while(1 < (nn <- nn %/% Ppf)) { #-- have multiple or only bigger factors Dp <- nn %% pfac == 0 if(any(Dp)) { # have more smaller factors m.pr[Dp] <- m.pr[Dp] + 1L Ppf <- prod(pfac[Dp]) } else { #-- the remainder is a bigger prime pfac <- c(pfac,nn) m.pr <- c(m.pr, 1L) break # out of while(.) } } res[[i]] <- cbind(p = pfac, m = m.pr) } # end for(i ..) res } test.factorize <- function(res) { ## Purpose: Test prime factorization ## ------------------------------------------------------------------------- ## Arguments: result of factorize ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 29 Jan 96, 10:29 n <- as.numeric(names(res))# as.integer() may fail for *large* ones n == vapply(res, function(pf) prod(pf[,"p"] ^ pf[,"m"]), 1.) } ##- From: Bill Venables ##- Date: Thu, 10 Sep 1998 21:02:20 +0930 ##- To: mona kanaan ##- Cc: s-news@wubios.wustl.edu ##- Subject: Re: [S] factors (divisors ) of an integer ##- ##- > Dear all, ##- > I wonder whether there is an already built in Splus function to find ##- > the divisors of a given integer, if so could you please point it out to ##- > me. ##- > Or if someone has already written such a function, could you ##- > please pass it over, if possible. ##- > ##- > ##- > The function I am looking for works sth like this ##- > ##- > N <- 6 ##- > DN <- DIV(N) ##- > DN ##- > 1 2 3 6 ##- > ##- > Thanks a lot, ##- > Mona ##- ##- This turns out to be a pretty little programming exercise. ##- Here's a vectorized version, even, although it only returns the ##- *prime* divisors, not all the devisors. That a supplmentary ##- exercise... factorizeBV <- function(n) { if(!is.numeric(n)) stop("cannot factorize non-numeric arguments") if(length(n) > 1) { l <- list() for(i in seq(along = n)) l[[i]] <- Recall(n[i]) return(l) } if(n != round(n) || n < 2) return(n) tab <- 2:n fac <- numeric(0) while(n > 1) { while(n %% tab[1] == 0) { fac <- c(fac, tab[1]) n <- n/tab[1] } tab <- tab[tab <= n] omit <- tab[1] * c(1, tab[tab <= n/tab[1]]) tab <- tab[ - match(omit, tab, nomatch = 0)] } fac } ##- From: mona kanaan ##- Date: Fri, 11 Sep 1998 08:52:59 +0100 (BST) ##- To: "'S-News'" ##- Subject: [S] Summary: Factors (divisors) of an inreger ##- Thanks a lot, for everybody who replied to my query. ##- Here is a summary of what was passed on. ##- The first two codes due to Bill Venables and Bill Dunlap give the Prime ##- divisors of an integer(this is what i was actually looking for), the last ##- code gives all divisors but is not efficient for "large" ##- integers (this is what i was trying to avoid). ##- ##- Thanks again ##- Mona ## .... Bill Venables solution [see above !] ........ ##- ----------------------------------------------------------------- ##- ----------------------------------------------------------------- ##- Bill Dunlap ##- ##- I use the following factors(), which uses the enclosed primes(): ## ## MM: mv'ed all examples to file ... (now ../demo/prime-numbers.R ) factors <- function(x) { factor1 <- function(y, max.factor, .Primes) { .Primes <- if(missing(.Primes)) primes.t(max.factor) else primes.t(max.factor, .Primes) f <- numeric(0) while(y > 1) { ## note: 1 has no factors according to this which <- y %% .Primes == 0 if(sum(which) == 0) { f <- c(f, y) break } else f <- c(f, .Primes[which]) y <- y/prod(.Primes[which]) } val <- sort(f) if(length(val) && any(big <- val > max.factor^2)) { if(sum(big) != 1) stop("internal error: sum(big)!=1") val <- sort(c(val[!big], Recall(val[big], min(ceiling(sqrt(val[big])), max.factor^2), .Primes))) } val } val <- lapply(x, factor1, 43) names(val) <- as.character(x) val } ## MM: this version (Bill Dunlap's maybe slightly modified ?) is ## -- *much* slower than primes() above ! primes.t <- function(n, .Primes = c(2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43)) { ## primes() function using table if(is.unsorted(.Primes)) stop("'.Primes' must be increasing") nP <- length(.Primes <- as.integer(.Primes)) maxP <- .Primes[nP] stopifnot(.Primes[1:3] == c(2,3,5), maxP > 30, maxP %% 2 == 1, maxP %% c(3,5) != 0) if(maxP < n) { ## compute longer .Primes by sieve .Primes <- seq(from = 2, to = n) for(i in 1:length(.Primes)) { composite <- .Primes %% .Primes[i] == 0 composite[i] <- FALSE if(all(!composite)) break .Primes <- .Primes[!composite] if(i >= length(.Primes)) break } } .Primes[.Primes <= n] } ##- factors.simple() is easier to understand and is faster on small numbers ##- but can work very slowly on large numbers with lots of small factors ##- (like numbers arising in combinatorics). factors.simple <- function(x) { factor1 <- function(y, .Primes) { f <- numeric(0) while(y > 1) { ## note 1 has no factors according to this which <- y %% .Primes == 0 if(sum(which) == 0) { f <- c(f, y) break } else f <- c(f, .Primes[which]) y <- y/prod(.Primes[which]) } sort(f) } val <- lapply(x, factor1, primes(ceiling(sqrt(max(x))))) names(val) <- as.character(x) val } ##---------------------------------------------------------------------------- ##---------------------------------------------------------------------------- ##---------------------------------------------------------------------------- ## ## Guido Schwarzer ,Gardar Johannesson, Remy vande Ven, Henrik Aalborg-Nielsen DIV <- function(N) { N.seq <- 1:N N.seq[(N %% N.seq) == 0] } ##- From: "Frank E Harrell Jr" ##- To: "s-news" ##- Subject: [S] An improved factorize() ##- Date: Sat, 12 Sep 1998 22:34:05 -0400 ##- ##- Here is a modification of Michael Bramley's (bramley.m@pg.com) factorize ##- function with memory usage of approx. the square root of the original. divisors <- function(n) { ## Frank E Harrell Jr -- called this "factorize()" p <- n/(z <- 1:ceiling(sqrt(n))) z <- z[trunc(p) == p] unique(c(z, rev(n/z))) } ##- From: Paul A Tukey ##- Date: Wed, 16 Sep 1998 18:27:15 -0400 (EDT) ##- To: fharrell@virginia.edu, lifer@fuse.net, s-news@wubios.wustl.edu ##- Subject: Re: [S] Prime divisors ##- This discussion has been fun. ##- Seems to me we've been gradually heading toward ##- computing the prime factorization of a number. ##- That is, a collection of prime numbers (with possible ##- duplication) whose product is the given number. ##- A recursive layer on top of Frank Harrell's factorize() does ##- it -- but the code below uses a slightly shortened version ##- of factorize() that only returns the smallest divisor > 1. fac <- function(n) { p <- n/(z <- 1:floor(sqrt(n))) z <- z[trunc(p) == p] c(z, rev(n/z))[2] } pfac <- function(n, nn = 0) { if(nn == 0) pfac(n, fac(n)) else if(n <= nn) nn else c(nn, pfac(n/nn)) } ##- Note that prod(pfac(n)) == n. ##- Now I'm sure someone can write a more elegant version. ##- Also, recursion is probably neither memory-efficient ##- nor CPU-efficient in Splus. ##- -- Paul Tukey ##- Bellcore sfsmisc/R/Deprecated.R0000644000176200001440000000063714032027415014311 0ustar liggesusers###--> Synchronize with ../man/Deprecated.Rd !! ###--> move things from here as defunct to ./Defunct.R ### ========= ## Deprecation of these, as of 2016-12-01 : pmax.sa <- function(scalar, arr) { warning("pmax.sa(s,a) is deprecated; use pmax(a,s) instead") } pmin.sa <- function(scalar, arr) { warning("pmin.sa(s,a) is deprecated; use pmin(a,s) instead") } sfsmisc/R/pkgDesc.R0000644000176200001440000000077213775420073013643 0ustar liggesusers##' A slightly more convenient version of packageDescription() ##' 1. returns named character vector; no other attributes pkgDesc <- function (pkg, lib.loc = NULL, fields = NULL, ...) { pd <- packageDescription(pkg, lib.loc=lib.loc, fields=fields, drop=FALSE, ...) file <- attr(pd, "file") structure(class = "Dlist", c(unlist(pd), c(file=file))) } ##' useful: e.g. as sapply( pkgs, pkgBuilt) pkgBuilt <- function(pkg, lib.loc = NULL, ...) pkgDesc(pkg, lib.loc=lib.loc, fields = "Built", ...) sfsmisc/R/pd-matrix.R0000644000176200001440000000312211613747655014167 0ustar liggesusers ## testing code is currently in ## /u/maechler/R/MM/MISC/posdefify.R ## TODO: probaby add 'rescale.kind = c("diag", "trace")' ## ---- they would differ only when some EV's were negative ### Higham's code by Ravi posdefify <- function(m, method = c("someEVadd", "allEVadd"), symmetric = TRUE, eigen.m = eigen(m, symmetric= symmetric), eps.ev = 1e-7) { ## Purpose: From a matrix m, make a "close" positive definite one ## ------------------------------------------------------------------------- ## Arguments: m: numeric matrix (n x n), usually symmetric ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 19 Dec 1997; 7 Jul 2004 stopifnot(is.numeric(m) && is.matrix(m)) method <- match.arg(method) n <- length(lam <- eigen.m $values) Eps <- eps.ev * abs(lam[1])# lam[1] is largest EV; "small" is *relative* ## lam[n] is the SMALLEST eigenvalue if(lam[n] < Eps) { # fix up small or negative values switch(method, "someEVadd" = lam[lam < Eps] <- Eps, "allEVadd" = lam <- lam + Eps-lam[n] ) Q <- eigen.m $vectors o.diag <- diag(m)# original one - for rescaling m <- Q %*% (lam * t(Q)) ## == Q %*% diag(lam) %*% t(Q) ## rescale to the original diagonal values ## D <- sqrt(o.diag/diag(m)) ## where they are >= Eps : D <- sqrt(pmax(Eps,o.diag)/diag(m)) m[] <- D * m * rep(D, each = n) ## == diag(D) %*% m %*% diag(D) } m } sfsmisc/R/linesHyberb.lm.R0000644000176200001440000000175207624253452015140 0ustar liggesuserslinesHyperb.lm <- function(object, c.prob = .95, confidence = FALSE, k = if(confidence) Inf else 1, col = 2, lty = 2, do.abline = TRUE) { n <- length(Res <- residuals(object)) df <- object $ df.resid s2 <- sum(Res^2)/df s <- sqrt(s2) if(is.null(R <- object $ R)) ## in R R <- qr.R(object $ qr) Xm <- R[1,2]/R[1,1] # = mean(x_i) : (X'X)[1,] = (R'R)[1,] = [n sum_{x_i}] ##-- S_{xx} = sum_i{(x_i - mean(x_i))^2} : you can prove this: (R'R) = ... S.xx <- R[2,2]^2 ux <- par("usr")[1:2] d.xs <- data.frame(x = xs <- seq(ux[1],ux[2], length = 100)) names(d.xs) <- attr(object$terms,"term.labels") #-- proper x-variable name ys <- predict(object, new = d.xs) pred.err <- qt(1-(1-c.prob)/2, df) * s * sqrt(1/k + 1/n + (xs-Xm)^2/S.xx) o.p <- par(err=-1) on.exit(par(o.p)) if(do.abline) abline(object) lines(xs, ys - pred.err, col=col, lty=lty) lines(xs, ys + pred.err, col=col, lty=lty) } sfsmisc/R/p.tachoPlot.R0000644000176200001440000000646207155210621014447 0ustar liggesusersp.tachoPlot <- function(x, y, z, angle= c(pi/4,3*pi/4), size, method= c("robust", "sensitive", "rank"), legend = TRUE, show.method= legend, xlab= deparse(substitute(x)), ylab= deparse(substitute(y)), xlim, ylim, ...) { ## Purpose: Puts a symbol (pointer) on a plot at each of the ## specified locations. ## ------------------------------------------------------------------------- ## Arguments: see on-line help (?p.tachoPlot) ## ------------------------------------------------------------------------- ## Author: Christian Keller, Date: 16 Jun 95, 18:35 if(length(angle) != 2) stop("length of angle must be 2") if(angle[1]<=0 | angle[1]>=pi/2) stop("angle[1] should be between 0 and pi/2") if(angle[2]<=pi/2 | angle[2]>=pi) stop("angle[2] should be between pi/2 and pi") method <- match.arg(method) xlab ; ylab ## eval substitute(.) now ii <- !is.na(x) & !is.na(y) x <- x[ii]; y <- y[ii]; z <- z[ii] if(method=="sensitive"){ Min <- min(z, na.rm=TRUE) Max <- max(z, na.rm=TRUE) b <- (z-Min)/(Max-Min) } else if(method=="robust"){ Range <- rrange(z) Min <- Range[1] Max <- Range[2] b <- pmin(pmax(z-Min,0),Max-Min)/(Max-Min) } else if(method=="rank"){ Min <- min(z, na.rm=TRUE) Max <- max(z, na.rm=TRUE) Rank <- replace(rep(NA,length(z)), !is.na(z), rank(z[!is.na(z)])) b <- (Rank-1)/(sum(!is.na(z))-1) } else stop("unknown method (impossible)") ## -- range of the Plot range.x <- range(x) range.y <- range(y) pcm <- par("pin") * 2.54 if(missing(size)) size <- min(pcm)/20 else { if(length(size) != 1) stop("length of size must be 1") } size <- size/2 sx <- size*max(c(abs(cos(pi-angle[1])),abs(cos(pi-angle[2])))) sy <- size*max(c(abs(sin(pi-angle[1])),abs(sin(pi-angle[2])))) fx <- sx*diff(range.x)/(pcm[1]-2*size) fy <- sy*diff(range.y)/(pcm[2]-2*size) if(missing(xlim)) xlim <- range.x + c(-1,1)*fx if(missing(ylim)) ylim <- range.y + c(-1,1)*fy plot(x, y, pch=".", xlim=xlim, ylim=ylim, xlab=xlab, ylab=ylab, ...) ## -- calculate angles alpha <- angle[1] + (angle[2]-angle[1])*b usr <- par("usr") xd <- size*cos(pi-alpha)*diff(usr[1:2])/pcm[1] yd <- size*sin(pi-alpha)*diff(usr[3:4])/pcm[2] ## -- draw symbols if(method == "robust"){ out <- zMax segments((x+xd)[!out],(y+yd)[!out], (x-xd)[!out], (y-yd)[!out], lty=1) if(any(out,na.rm=TRUE)) { segments((x+xd)[out],(y+yd)[out], (x-xd)[out], (y-yd)[out], lty=2,col=2) } } else{ segments(x+xd, y+yd, x-xd, y-yd, lty=1) } if(legend){## -- draw legend cxy <- par("cxy") x1 <- min(pcm)/20*cos(pi-angle[1])*diff(usr[1:2])/pcm[1] x2 <- min(pcm)/20*cos(pi-angle[2])*diff(usr[1:2])/pcm[1] y1 <- min(pcm)/20*sin(pi-angle[1])*diff(usr[3:4])/pcm[2] y2 <- min(pcm)/20*sin(pi-angle[2])*diff(usr[3:4])/pcm[2] x <- usr[2] - 3*cxy[1] - x2 y <- cxy[2] + usr[4] lines(c(x+x1,x,x+x2), c(y+y1,y,y+y2), lty=1, xpd=TRUE) text(x+x2, y, labels=formatC(Max), adj=0, cex=0.8*par("cex"), xpd=TRUE) text(x+x1, y, labels=formatC(Min), adj=1, cex=0.8*par("cex"), xpd=TRUE) } if(show.method) ## -- print method name mtext(paste("method =",method),line=0, adj=1, cex=0.8*par("cex")) invisible() } sfsmisc/R/KS-confint.R0000644000176200001440000000420312356064445014230 0ustar liggesusers### Fixme: In the following, computing and plotting should be separated ###--> ./ecdf.R plot.ecdf() should get conf.type and conf.int argument!! ### Also, I've posted a pre-version of this: ## Date: Mon, 22 Oct 2001 19:15:35 +0200 ## From: Martin Maechler ## Subject: [R] Re: conf.int. for ecdfs {was "Two questions"} ## To: cblouin@is2.dal.ca ## Cc: Kjetil Halvorsen , r-help@stat.math.ethz.ch ### Note -- this is related to the pkstwo() function inside ks.test() ### ==== in stats : ~/R/D/r-devel/R/src/library/stats/R/ks.test.R ecdf.ksCI <- function(x, main = NULL, sub = NULL, xlab = deparse(substitute(x)), ci.col = "red", ...) { force(xlab) if(is.null(main)) main <- paste0("ecdf(",deparse(substitute(x)),") + 95% K.S. bands") n <- length(x) if(is.null(sub)) sub <- paste("n = ", n) ec <- ecdf(x) xx <- get("x", envir=environment(ec))# = sort(x) yy <- get("y", envir=environment(ec)) D <- KSd(n) yyu <- pmin(yy + D, 1) yyl <- pmax(yy - D, 0) ecu <- stepfun(xx, c(yyu, 1) ) ecl <- stepfun(xx, c(yyl, yyl[n]) ) ## Plots -- all calling plot.stepfun plot(ec, main = main, sub = sub, xlab = xlab, ...) plot(ecu, add=TRUE, verticals=TRUE, do.points=FALSE, col.hor= ci.col, col.vert= ci.col, ...) plot(ecl, add=TRUE, verticals=TRUE, do.points=FALSE, col.hor= ci.col, col.vert= ci.col, ...) } KSd <- function(n) { ## `approx.ksD()' ## approximations for the critical level for Kolmogorov-Smirnov statistic D, ## for confidence level 0.95. Taken from Bickel & Doksum, table IX, p.483 ## and Lienert G.A.(1975) who attributes to Miller,L.H.(1956), JASA ifelse(n > 80, 1.358/( sqrt(n) + .12 + .11/sqrt(n)),## Bickel&Doksum, table IX,p.483 splinefun(c(1:9, 10, 15, 10 * 2:8),# from Lienert c(.975, .84189, .70760, .62394, .56328,# 1:5 .51926, .48342, .45427, .43001, .40925,# 6:10 .33760, .29408, .24170, .21012,# 15,20,30,40 .18841, .17231, .15975, .14960)) (n)) } sfsmisc/R/Defunct.R0000644000176200001440000000403614033651664013650 0ustar liggesusers### Functions moved from ./Deprecated.R ### ~~~~~~~~~~~~~~~ ###--- remove things from here to ../Old_Defunct/ex-Deprecated.R ### ==== == ============================== ###___ add on top ___ ## Deprecation of these on 2013-08-03, defunct since 2021-04-03 u.assign0 <- function(x, value, immediate = FALSE) ## Purpose: Simple function with identical UI for both R & S ## Author: Martin Maechler, Date: 7 Jul 1999 stop("u.assign0(..) is deprecated, use assign(.., , envir = .GlobalEnv)\n", " {if you really must; that is deprecated in packages as well}") u.get0 <- function(x) stop("u.get0(x) is deprecated, use get(x, envir = .GlobalEnv)") ## Deprecated in 2005; defunctified 2016-12-01 : list2mat <- function(x, check = TRUE) { ## Purpose: list -> matrix ## ------------------------------------------------------------------------- ## Arguments: x a list whose first 2 el. MUST be equal length vectors ## check: if T, check if lengths are ok. F: "quick & dirty" ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 19 May 93, 09:46 stop("list2mat(x) has been deprecated in 2005 and is defunct now. Use sapply(x, c) or vapply(..) instead!") } pl.ds <- function(...) { stop("pl.ds() has been renamed to plotDS() and is defunct now.\n", "Please change your code to use the new name") plotDS(...) } p.pllines <- function(x,y,group,lty=c(1,3,2,4),...) { ## Purpose: lines according to group ## ------------------------------------------------------------------------- ## Arguments: ## ------------------------------------------------------------------------- ## Author: Werner Stahel, Date: 21 Jun 93, 15:45 stop("p.pllines() is defunct: in R, use", "plot(x,y, lty=group, type='l', ...)") plot(x,y,type="n",...) ngr <- max(group) for (gg in 1:ngr) { ii <- group==gg & !is.na(x) & !is.na(y) if(sum(ii)) lines(x[ii],y[ii],lty=lty[1+(gg-1)%%length(lty)]) } } sfsmisc/R/p.res.2x.formula.R0000644000176200001440000000502112346574250015276 0ustar liggesusersif(FALSE) ##: This is not yet ready for prime time ## NOTE we have had p.res.2x(x,y,z, ...) forever in --> ./p.res.2x.WSt.R ## --- ~~~~~~~~~ ------- ~~~~~~~~~~~~~~~ p.res.2x.formula <- ## Change the name ; no 'lm' ## take graphics:::mosaicplot.formula() as example function(formula = ~., data, restricted = NULL, size = 1, slwd = 1, scol = 2, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, ...) { ## Purpose: plot residuals vs. two x's ## Author: ARu , Date: 11/Jun/91 ## Aenderungen: MMae, 30/Jan/92, Dez.94 / WSt ## -------------------------------------------------------------------------- ## Arguments: ## formula formula defining the variables zu be used, either ## z ~ x + y ## ~ x + y in this case, data must inherit from lm , ## and the residuals of data will be used as z . ## data a data.frame or an lm or aov object. ## In the latter case, g.rex2x will look for the data ## that was used to fit the model. ## restricted absolute value which truncates the size. ## The corresponding symbols are marked by stars. ## size the symbols are scaled so that 'size' is the size of ## the largest symbol in cm. ## slwd, scol line width and color to be used for the symbols ## ... additional arguments for the S-function 'plot' ## EXAMPLE : ## g.res2x(zz~.,data=data.frame(xx=rep(1:10,7),yy=rep(1:7, rep(10,7)), ## zz=rnorm(70)), restr = 2, main = "i.i.d. N(0,1) random residuals") ## -------------------------------------------------------------------------- formula <- as.formula(formula) if (inherits(data,"lm")) { t.d <- get(as.character(data$call[3])) if (length(formula) < 3) { formula <- update.formula(formula,residuals~.) t.d <- f.merge1(t.d,resid(data),namefrom = "residuals") } } else t.d <- data if (!is.data.frame(t.d)) { if(is.matrix(data)) data <- as.data.frame(data) else stop("data is not a data frame or 'lm' object") } t.d <- na.omit(model.frame(formula, t.d)) z <- t.d[,1] x <- as.numeric(t.d[,2]) y <- as.numeric(t.d[,3]) if(is.null(xlab)) xlab <- names(t.d)[2] if(is.null(ylab)) ylab <- names(t.d)[3] p.res.2x.numeric(x,y,z, restricted=restricted, size=size, slwd=slwd, scol=scol, xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, ...) } sfsmisc/R/misc-goodies.R0000644000176200001440000011642314116737223014644 0ustar liggesusers#### misc-goodies.R #### ~~~~~~~~~~~~~~ SfS - R - goodies that are NOT in #### "/u/sfs/R/SfS/R/u.goodies.R" #### "/u/sfs/R/SfS/R/p.goodies.R" ###--- Original: From 'S' in /u/sfs/S/misc-goodies.S ###--- ======== But start doing *less* here ! ###================================================================== ### Functions <<<<<<<< Please use a few subsections like "Plotting"... ###================================================================== ### ___Note___ we have some of these headers __MESS__ ### But we leave it because of RCS {rather dismantle everything into 4-6 pieces ##-#### Vector, Matrix (or higher Array) stuff ######## ##-### -------------------------------------- ######## last <- function(x, length.out = 1, na.rm = FALSE) { ## Purpose: last element(s) of a vector ## Author: Werner Stahel, Date: Tue Jan 21 17:29:42 1992 ## ---------------------------------------------------------------- ## Arguments: ## x: vector ## length.out: if positive, return the length.out last elements of x, ## if negative, the last length.out elements are dropped ## ---------------------------------------------------------------- if (na.rm) x <- x[!is.na(x)] n <- length(x) x[sign(length.out)*(n-abs(length.out)+1):n] } empty.dimnames <- function(a) { ## 'Remove' all dimension names from an array for compact printing. n <- length(da <- dim(a)) if(n == 0) return(a) dimnames(a) <- lapply(1:n, function(i) rep.int("", da[i])) a } ##-#### Plot / Devices related stuff ######## ##-### ----------------------------- ######## ##-### >>>>> "p.goodies.S" or "ps.goodies.S" ######## errbar <- function(x, y, yplus, yminus, cap = 0.015, ylim = range(y, yplus, yminus), xlab = deparse(substitute(x)), ylab = deparse(substitute(y)), ... ) { ## Purpose: Makes a plot with error bars ## Authors: Charles Geyer, Statistics, U. Chicago, geyer@galton.uchicago.edu ## Martin Maechler, Date: 11 Apr 91 and Mar 27 1992, 12:32 ## ---------------------------------------------------------------- ## Arguments: --- see help(..) page ---> ?errbar ## ----------------------------------------======= plot( x, y, ylim=ylim, xlab=xlab, ylab=ylab, ... ) xcoord <- par()$usr[1:2] segments( x, yminus, x, yplus ) smidge <- cap * ( xcoord[2] - xcoord[1] ) / 2 segments( x - smidge, yminus, x + smidge, yminus ) segments( x - smidge, yplus, x + smidge, yplus ) } ## C.Monatsname , etc.. sind jetzt bei der zugehoerigen Funktion ## u.Datumvonheute in /u/sfs/S/u.goodies.S cum.Vert.funkt <- function(x, Quartile = TRUE, titel = TRUE, Datum = TRUE, rang.axis = n <= 20, xlab = "", main = "", ...) { ## Ziel: Kumulative Verteilung von x aufzeichnen, auf Wunsch auch Median ## und Quartile op <- par(xaxs = "r", yaxs = "r", las = 1)# the default anyway on.exit(par(op)) r <- plotStep(x, xlab = xlab, main = main, ...) #### FIXME : stepfun() / ecdf() instead n <- length(x) if(rang.axis) axis(4, at = (0:n)/n, labels = 0:n, pos = par("usr")[1])#, las = 1) if(titel) mtext("Kumulative Verteilungsfunktion", 3, line = 0.5) if(Quartile) for(i in 1:3) abline(h = i/4, lty = 2) if(Datum) p.datum() invisible(r) } ## This was "plot.step()" but that's in conflict with S3 methods plotStep <- function(ti, y, cad.lag = TRUE, verticals = !cad.lag, left.points = cad.lag, right.points = FALSE, end.points = FALSE, add = FALSE, pch = par('pch'), xlab = deparse(substitute(ti)), ylab = deparse(substitute(y)), main = NULL, ...) #####- FIXME ----------- use stepfun(), plot.stepfun() etc !!! ---------------- { ## Purpose: plot step-function f(x)= sum{ y[i] * 1_[ t[i-1], t[i] ] (x) } ## ------------------------------------------------------------------------- ## Arguments: for missing 'y', do empirical CDF; ==> ON-LINE Help "?plot.step" ## ------------------------------------------------------------------------- ## Author: Martin Maechler, 1990, U.Washington, Seattle; improved -- Dec.1993 ## ## EXAMPLE: ##-- Plot empirical cdf Fn(x) for a small n: ## xx <- runif(20); plot.step(xx); plot.step( xx, cad.lag = F ) ## plot.step( runif(20), add=T, cad.lag=F) xlab ylab if(missing(y)) { if(is.vector(ti) && is.numeric(ti)) { # -- Do empirical CDF -- nt <- length(ti) ti <- sort(ti) dt <- (ti[nt] - ti[1])/20 ti <- c(ti[1] - dt, ti, ti[nt] + dt) n <- nt + 1 y <- (0:nt)/nt } else { xy <- xy.coords(ti,NULL,NULL,NULL) ti <- c(xy$x[1], xy$x) y <- xy$y n <- length(y) } } else { n <- length(y) if(length(ti) != (n + 1)) stop("length(ti) MUST == length(y) + 1") } if(length(ti) != (n + 1) || length(y) != n) stop("NEVER CALLED! --length(ti) MUST == length(y) + 1") if(missing(main)) main <- deparse(sys.call()) n1 <- n+1 ##-- horizontal segments: if (add) segments(ti[-n1], y, ti[-1], y, ...) else { plot(ti, c(y[1],y), type = 'n', xlab = xlab, ylab = ylab, main = main, ...) segments(ti[-n1], y, ti[-1], y) } if(left.points) points(ti[-n1],y, pch = pch) if(right.points) points(ti[-1], y, pch = pch) ##-- col=0 <==> "erase" : if(! end.points) points(ti[c(1,n1)], y[c(1,n)], pch = pch, col = 0) if(verticals) { if (add) segments(ti[2:n], y[-n], ti[2:n], y[-1], ...) else segments(ti[2:n], y[-n], ti[2:n], y[-1]) } invisible(list(t = ti, y = y)) } histBxp <- function(x, nclass, breaks, probability = FALSE, include.lowest = TRUE, xlab = deparse(substitute(x)), ..., width = 0.2, boxcol = 3, medcol = 2, medlwd = 5, whisklty = 2, staplelty = 1) { ## Purpose: Plot a histogram and a boxplot ## ------------------------------------------------------------------------- ## Arguments: ---> see help(hist.bxp) ! ## ------------------------------------------------------------------------- ## Authors: Christian Keller, Date: 10 Nov 95, (Martin Maechler, Jan 96) ## calls p.hboxp(.) ! ## determine the height of the plot h <- if(missing(breaks)){ if(missing(nclass)) hist(x, include.lowest = include.lowest, plot = FALSE) else hist(x, nclass = nclass, include.lowest = include.lowest, plot = FALSE) } else hist(x, breaks = breaks, include.lowest = include.lowest, plot = FALSE) ymax <- max(h$counts) ymin <- - ymax * width # range: (-w,1)*ymax instead of (0,1)*ymax ##------- drawing the histogram ------------- hist(x, breaks = h$breaks, probability = probability, include.lowest = include.lowest, plot = TRUE, xlab = xlab, ylim = c(ymin, ymax), axes = FALSE, ...) axis(1) axis(2, at = pretty(c(0,ymax), n = 5), srt = 90) ## ph, 8.5.00: n instead of nint abline(h = 0) # ##-------- drawing the boxplot -------------- ##-- scale a range scale.r <- function(x1,x2, fact = 1.1) (x1+x2)/2 + c(-fact,fact) * (x2-x1)/2 ##-- since 4% extra space above x-axis (just below ymin): ##- cat("par$usr[3:4]:", par("usr")[3:4], ##- " ymin -.04 *(ymax-ymin)",ymin -.04 *(ymax-ymin),"\n") ##-- NOTE: Always have (seemingly): par("usr")[3] == ymin -.04 *(ymax-ymin) ##-O- ORIGINAL VERSION (Keller & Keller) : ##-O- p.hboxp(x, ymin, -.04 *(ymax-ymin), ##-O- boxcol=boxcol, medcol=medcol, ##-O- medlwd=medlwd, whisklty=whisklty, staplelty=staplelty) ##---- This is much better for width <=.1 or so... ##-- but you should leave some white space -> scale down ##-- The scaling factor is really a KLUDGE but works for a wide range! p.hboxp(x, scale.r(par("usr")[3], 0, ## ph, 8.5.00: changed f=.9 to f=.8 f = .8 - max(0, .15 - width)*(1+(par("mfg")[3] >= 3))), boxcol = boxcol, medcol = medcol, medlwd = medlwd, whisklty = whisklty, staplelty = staplelty) } ##-#### Print & Strings ######## ##-### =============== ######## ccat <- ## character 'concat' function(...) paste0(..., collapse = "") vcat <- ## (numeric) vector 'concat' function(vec, sep = " ") paste(vec, collapse = sep) paste.vec <- function(name, digits = options()$digits) { ## Purpose: Utility for "showing vectors" ## ------------------------------------------------------------------------- ## Example: x <- 1:4; paste.vec(x) ##-> "x = 1 2 3 4" paste(paste(deparse(substitute(name))), "=", paste(format(name, digits = digits), collapse = " ")) } signi <- function(x, digits = 6) round(x, digits - trunc(log10(abs(x)))) ##' NB: Since ~ R 3.3.0 (May 2016), use base R's "new" strrep(x, times) instead repChar <- function(char, no) paste(rep.int(char, no), collapse = "") ## correct, but slower than the next one: bl.string <- function(no) repChar(" ", no) ## faster: bl.string <- function(no) sprintf("%*s", no, "") ### symnum : standard R function !! wrapFormula <- function(f, data, wrapString = "s(*)") { ## Purpose: Mainly: Construct a useful gam() formula from "Y ~ ." ## ---------------------------------------------------------------------- ## Arguments: f : the initial formula; typically something like "Y ~ ." ## data: data.frame to which the formula applies ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 22 May 2007, 18:03 form <- formula(terms(f, data = data)) if(length(form) != 3) stop("invalid formula; need something like 'Y ~ .'") wrapS <- strsplit(wrapString, "\\*")[[1]] stopifnot(length(wrapS) == 2) cc <- gsub("([^+ ]+)", paste0(wrapS[1], "\\1", wrapS[2]), format(form[[3]])) form[[3]] <- parse(text = cc, srcfile = NULL)[[1]] form } ##' Capture Output and print first and last parts, eliding middle parts. ##' Particularly useful for teaching purposes, and e.g., in Sweave ##' ##' @title Capture output and Write / Print First and Last Parts ##' @param EXPR the (literal) expression the output is to be captured ##' @param first integer: how many lines should be printed at beginning ##' @param last integer: how many lines should be printed at the end. ##' @param middle numeric (or NA logical): ##' @param i.middle index start of middle part ##' @param dotdots string to be used for elided lines ##' @param n.dots number of \code{dotdots} ....{FIXME} ##' @return return value of \code{\link{capture.output}(EXPR)} ##' @author Martin Maechler ## -> ../man/capture-n-write.Rd capture.and.write <- function(EXPR, first, last = 2, middle = NA, i.middle, dotdots = " ....... ", n.dots = 2) { co <- capture.output(EXPR) writeLines(head(co, first)) catDots <- function(M) cat(rep.int(paste0(dotdots,"\n"), M), sep="") catDots(n.dots) if(is.numeric(middle)) { stopifnot(length(middle) == 1, middle >= 0, middle == round(middle)) i0 <- first+2 if(missing(i.middle)) { i.middle <- max(i0, length(co) %/% 2 - middle %/% 2) } else { ## !missing(i.middle) if(i.middle < i0) stop("'i.middle' is too small, should be at least ", i0) } writeLines(co[i.middle-1 + seq_len(middle)]) catDots(n.dots) } writeLines(tail(co, last)) invisible(co) } ##-#### "Calculus" Mathematical stuff ######## ##-### ----------------------------- ######## polyn.eval <- function(coef, x) { ## Purpose: compute coef[1] + coef[2]*x + ... + coef[p+1]* x^p ## if coef is vector, x can be any array; result : of same dim. as x ## if coef is matrix, x must be vector; dim(result) = len(x) * nrow(coef) ## coef = matrix: evaluate SEVERAL polynomials (of same degree) ## ---- contains coefficient-vectors as ROWS ==> coef[,i] <-> x^{i-1} ## Author: Martin Maechler if(is.null(dim(coef))) { lc <- length(coef) if (lc == 0) 0 else { r <- coef[lc] if (lc > 1) for (i in (lc-1):1) r <- coef[i] + r*x r } } else { #-- coef is MATRIX -- dc <- dim(coef) lc <- dc[2]; dc <- dc[1] n <- length(x) if (lc == 0) matrix(0, n, dc) else { r <- matrix(coef[,lc], n, dc, byrow = TRUE) if (lc > 1) for (i in (lc-1):1) r <- r*x + matrix(coef[,i], n, dc, byrow = TRUE) r } } } ## negative x .. may make sense in some cases,.... but not yet : ##digitsBase <- function(x, base = 2, ndigits = 1 + floor(log(max(abs(x)),base))) digitsBase <- function(x, base = 2, ndigits = 1 + floor(1e-9 + log(max(x,1), base))) { ## Purpose: Give the vector A of the base-_base_ representation of _n_: ## ------- n = sum_{k=0}^M A_{M-k} base ^ k , where M = length(a) - 1 ## Value: MATRIX M where M[,i] corresponds to x[i] ## Author: Martin Maechler, Date: Dec 4, 1991 ## ---------------------------------------------------------------- ## ----> help(digitsBase) ! ## ------------------------------ if(any(x < 0)) stop("'x' must be non-negative integers") if(any(x != trunc(x))) stop("'x' must be integer-valued") r <- matrix(0, nrow = ndigits, ncol = length(x)) if(ndigits >= 1) for (i in ndigits:1) { r[i,] <- x %% base if (i > 1) x <- x %/% base } class(r) <- "basedInt" attr(r, "base") <- base r } bi2int <- function(xlist, base) vapply(xlist, function(u) polyn.eval(rev(u), base), numeric(1)) as.intBase <- function(x, base = 2) { xl <- if(is.character(x)) lapply(strsplit(x,""), as.integer) else if(is.numeric(x) && is.matrix(x)) tapply(x, col(x), c) else if(!is.list(x)) stop("'x' must be character, list or a digitsBase() like matrix") bi2int(xl, base) } as.integer.basedInt <- function(x, ...) as.intBase(x, base = attr(x, "base")) print.basedInt <- function (x, ...) { cat(sprintf("Class 'basedInt'(base = %d) [1:%d]\n", attr(x,"base"), ncol(x))) cx <- x attr(cx,"base") <- NULL print(unclass(cx), ...) invisible(x) } sHalton <- function(n.max, n.min = 1, base = 2, leap = 1) { ## Purpose: Halton sequence H(k,b) for k=n.min:n.max -- for Quasi Monte Carlo ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 29 Jul 2004, 21:34 stopifnot((leap <- as.integer(leap)) >= 1) ## now do this via digitsBase(), later go directly nd <- as.integer(1 + log(n.max, base)) dB <- digitsBase(if(leap == 1) n.min:n.max else seq(n.min, n.max, by=leap), base = base, ndigits = nd) colSums(dB/base^(nd:1)) } QUnif <- function(n, min = 0, max = 1, n.min = 1, p, leap = 1, silent = FALSE) { ## Purpose: p-dimensional ''Quasi Random'' sample in [min,max]^p ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 29 Jul 2004, 21:43 ## Example: plot(QUnif(1000, 2), cex=.6, pch=20, xaxs='i', yaxs='i') stopifnot(1 <= (n <- as.integer(n)), length(n) == 1, 1 <= (p <- as.integer(p)), length(p) == 1, length(min) == p || length(min) == 1, length(max) == p || length(max) == 1, 1 <= (n.min <- as.integer(n.min)), 1 <= (leap <- as.integer(leap)), (n.max <- n.min + (n - 1:1)*leap) < .Machine$integer.max) pr. <- c(2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83, 89,97,101,103,107,109,113,127,131,137,139,149,151,157,163,167,173, 179,181,191, 193,197,199,211,223,227,229,233,239,241,251,257,263, 269,271,277,281,283,293,307,311,313,317,331,337,347,349,353,359, 367,373,379,383,389,397,401,409,419,421,431,433,439,443,449,457) if(length(pr.) < p) { if(!silent) message("enlarging internal prime table for \"large\" p=",p) Lp <- log(p) pr. <- primes(p*(Lp + log(Lp))) ## using p_n/n < log n + log log n } pr <- pr.[1:p] if(leap > 1 && any(leap == pr) && length(pr.) >= p+1) # take a non-leap pr pr <- c(pr[leap != pr], pr.[p+1]) max <- rep.int(max, p) min <- rep.int(min, p) dU <- max - min r <- matrix(0., n, p) for(j in 1:p) r[,j] <- min[j] + dU[j] * sHalton(n.max, n.min, base = pr[j], leap = leap) r } chars8bit <- function(i = 1:255) { ## Purpose: Compute a character vector from its "ASCII" codes. ## We seem to have to use this complicated way thru text and parse. ## Author: Martin Maechler, Original date: Wed Dec 4, 1991 ## this is an improved version of make.ASCII() from ~/S/Good-string.S ! ## ---------------------------------------------------------------- i <- as.integer(i) if(any(i < 0 | i > 255)) stop("'i' must be in 0:255") if(any(i == 0)) warning("\\000 (= 'nul') is no longer allowed in R strings") i8 <- apply(digitsBase(i, base = 8), 2, paste, collapse="") c8 <- paste0('"\\', i8, '"') eval(parse(text = paste0("c(",paste(c8, collapse=","),")"))) } strcodes <- function(x, table = chars8bit(1:255)) { ## Purpose: R (code) implementation of old S's ichar() ## ---------------------------------------------------------------------- ## Arguments: x: character vector ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 23 Oct 2003, 12:42 lapply(strsplit(x, ""), match, table = table) } ## S-PLUS has AsciiToInt() officially, and ichar() in library(examples): AsciiToInt <- ichar <- function(strings) unname(unlist(strcodes(strings))) helppdf <- function(topic, viewer = getOption("pdfviewer"), quiet = !interactive(), ...) { if(!tryCatch(is.character(topic) && length(topic) == 1L, error = function(e) FALSE)) topic <- deparse1(substitute(topic)) hh <- help(topic, help_type = "pdf", ...) pdfile <- with(attributes(hh), paste(topic, type, sep=".")) ## almost all rendering & pdf creation happens here: print(hh, msg=!quiet)# utils:::print.help_files_with_topic() |--> .show_help_on_topic_offline() if(length(viewer)) system(paste(viewer, pdfile), wait = FALSE) ans <- file.path(getwd(), pdfile) if(quiet) invisible(ans) else ans } ##-#### "Miscellaneous" (not any other category) ######## ##-### ============= ------------------------- ######## uniqueL <- function(x, isuniq = !duplicated(x), need.sort = is.unsorted(x)) { ## return list(ix, uniq) ## such that all(x == uniq[ix]) and (of course) uniq == x[isuniq] if(need.sort) { xs <- sort(x, index.return = TRUE) ixS <- xs $ ix isuniq <- isuniq[ixS] x <- xs$x } ix <- as.integer(cumsum(isuniq)) if(need.sort) ix <- ix[sort.list(ixS)] list(ix = ix, xU = x[isuniq]) } ##' Constructor of a "list" (really an environment) of functions (and more) ##' which all *share* the same environment in which they exist ##' --> ../man/funEnv.Rd ##' ~~~~~~~~~~~~~~~~ funEnv <- function(..., envir = NULL, parent = parent.frame(), hash = (...length() > 100), size = max(29L, ...length())) { e <- list2env(list(...), envir=envir, parent=parent, hash=hash, size=size) for(n in names(e)) ## iff function or formula, set environment to 'e': if(is.function(e[[n]]) || (is.call(e[[n]]) && inherits(e[[n]], "formula"))) environment(e[[n]]) <- e e } is.whole <- function(x, tolerance = sqrt(.Machine$double.eps)) { ## Tests if a numeric scalar (or vector, matrix or array) is a whole ## number; returns an boolean object of the same dimension as x, each entry ## indicating whether the corresponding entry in x is whole. is.whole.scalar <- if (is.integer(x)) { function(x) TRUE } else if (is.numeric(x)) { function(x) isTRUE(all.equal(x, round(x), tolerance = tolerance)) } else if (is.complex(x)) { function(x) isTRUE(all.equal(Re(x), round(Re(x)), tolerance = tolerance)) && isTRUE(all.equal(Im(x), round(Im(x)), tolerance = tolerance)) } else stop("Input must be of type integer, numeric or complex.") if (is.null(dim(x))) vapply(x, is.whole.scalar, NA) else apply(x, seq_along(dim(x)), is.whole.scalar) } ##' ##' @title Generate Random Date/Time Sequences ##' @param n number of entries to generate ##' @param min, max character strings or \R objects inheriting from \code{"POSIXt"}. ##' @return vector ##' @author Martin Maechler ## ## __ NOT YET EXPORTED ## FIXME: consider 'mean = Sys.time(), delta.tim = "1 month"' ## ----- ==> min = mean - as.difftime(delta.tim), ## max = mean - as.difftime(delta.tim) ## now <- Sys.time(); del <- as.difftime(100, units="weeks") ## rDatetime(100, now-del, now+del) rDatetime <- function(n, min = "1900-01-01", max = "2100-12-31") { if(is.character(min) || inherits(min, "POSIXt")) min <- as.POSIXct(min) else stop("'min' must be string (coercable to \"POSIXct\") or \"POSIXt\" object") if(is.character(max) || inherits(max, "POSIXt")) max <- as.POSIXct(max) else stop("'max' must be string (coercable to \"POSIXct\") or \"POSIXt\" object") stopifnot(length(min) == 1, length(max) == 1) structure(runif(n, as.numeric(min), as.numeric(max)), class = c("POSIXct", "POSIXt"), tzone = "") } ### ### autoreg(), mean.cor() etc ... not yet ### ### if we take them, use different file !! ####========== This is from /u/maechler/S/Good.S ============= ####========== --------------------------------- ============= ##-#### Plot / Devices related stuff ######## ##-### ----------------------------- ######## mpl <- function(mat, ...) { matplot(1:nrow(mat), mat, xaxt = 'n',...) if(0 == length(dn <- dimnames(mat)[[1]])) axis(1) else axis(1, at = 1:nrow(mat), labels = dn) } roundfixS <- function(x, method = c("offset-round", "round+fix", "1greedy")) { ## Purpose: y := r2i(x) with integer y *and* sum(y) == sum(x) ## Author: Martin Maechler, 28 Nov 2007 n <- length(x) x0 <- floor(x) e <- x - x0 ## == (x %% 1) in [0, 1) S. <- sum(e) stopifnot(all.equal(S., (S <- round(S.)))) method <- match.arg(method) ## The problem is equivalent to transforming ## e[] \in [0,1) into f[] \in {0,1}, with sum(e) == sum(f) ## Goal: transform e[] into f[] gradually, by "shifting" mass ## such that the sum() remains constant switch(method, "offset-round" = { ## This is going to be equivalent to ## r := round(x + f) with the correct f \in [-1/2, 1/2], or ## r == floor(x + f + 1/2) = floor(x + g), g \in [0, 1] ## ## Need sum(floor(e + g)) = S; ## since sum(floor(e)) == 0, sum(floor(e+1)) == n, ## we just need to floor(.) the S smallest, and ceiling(.) the others if(S > 0) { r <- numeric(n) # all 0; set to 1 those corresponding to large e: r[sort.list(e, decreasing=TRUE)[1:S]] <- 1 x0 + r } else x }, ## end{offset-round} "round+fix" = { r <- round(e) if((del <- S - sum(r)) != 0) { # need to add +/- 1 to 'del' entries s <- sign(del) ## +1 or -1: add +1 only to r < x entries, aD <- abs(del) ## and -1 only to r > x entries, ## those with the "worst" rounding are made a bit worse if(del > 0) { iCand <- e > r dx <- (e - r)[iCand] # > 0 } else { ## del < 0 iCand <- e < r dx <- (e - x)[iCand] # > 0 } ii <- sort.list(dx, decreasing = TRUE)[1:aD] r[iCand][ii] <- r[iCand][ii] + s } return(x0 + r) }, ## end{round+fix} "1greedy" = { ii <- e != 0 while(any(ii)) { ci <- cumsum(ii) # used to revert u[ii] subsetting m <- length(e. <- e[ii]) ie <- sort.list(e.) # both ends are relevant left <- e.[ie[1]] < 1 - e.[ie[m]] iThis <- if(left) 1 else m iother <- if(left) m else 1 J <- which.max(ci == ie[iThis]) ## which(.)[1] but faster I <- which.max(ci == ie[iother]) r <- x[J] x[J] <- k <- if(left) floor(r) else ceiling(r) mass <- r - k # if(left) > 0 else < 0 if(m <= 2) { # short cut and evade rounding error if(m == 1) { # should happen **rarely** if(!(min(abs(mass), abs(1-mass)) < 1e-10)) warning('m==1 in "1greedy" w/ mass not close to {0,1}') } else { ## m==2 x[I] <- round(x[I] + mass) } break ## ii <- FALSE } else { ## m >= 3 e[J] <- if(left) 0 else 1 ii[J] <- FALSE ## and move it's mass to the other end: e.new <- e[I] + mass if(e.new > 1) stop("e[I] would be > 1 -- internal error") else if(e.new < 0) stop("e[I] would be < 0 -- internal error") x[I] <- x[I] + mass e[I] <- e.new } ## m >= 3 } ## end{while} x }) # end{switch} }## roundfixS seqXtend <- function(x, length., method = c("simple","aim","interpolate"), from = NULL, to = NULL) { ## Purpose: produce a seq(.) covering the range of 'x' and INCLUDING x ## Author: Martin Maechler, Date: 28 Nov 2007 =======> ../man/seqXtend.Rd x <- unique(sort(x)) n <- length(x) method <- match.arg(method) if(length. > n) { if((from_is1 <- is.null(from))) from <- x[1] if((from_isL <- is.null(to))) to <- x[n] if(method == "interpolate") { if(!from_is1) { if(from > x[1]) stop("'from' > min(x) not allowed for method ", method) x <- c(from, x) } if(!from_isL) { if(to < x[n]) stop("'to' < max(x) not allowed for method ", method) x <- c(x, to) } n <- length(x) dx <- x[-1] - x[-n] ## == diff(x) w <- as.numeric(x[n] - x[1]) ## == sum(dx); ## as.n..(.) -> works with "Date" etc nn <- length. - n ## need 'nn' new points in 'n - 1' intervals ## how many in each? ## Want them approximately equidistant, ie. of width ~= w / (nn + 1) ## but do this smartly such that dx[i] / (k1[i] + 1) {= stepsize in interval i} ## is approximately constant k1 <- (nn + n-1) * dx / w - 1 ## ==> sum(k1) == nn ## now "round" the k1[] such that sum(.) remains == nn k <- roundfixS(k1) ## keep the right border, drop the left seqI <- function(i) seq(x[i], x[i+1], length.out=k[i]+2)[-1] l.seq <- lapply(1:(n-1), seqI) ## do.call(c, *), e.g. for new (R-devel 4.1.x) c.Date() [KH]: c(x[1], if(is.object(x)) do.call(c, l.seq) else unlist(l.seq)) } else { nn <- switch(method, "simple" = length., "aim" = length. - n + from_is1 + from_isL) ## a more sophisticated 'method' would have to use iteration, *or* ## interpolate between the 'x' values instead ## which might be considered to be too far from seq() unique(sort(c(x, seq(from, to, length.out = nn)))) } } else x }## {seqXtnd} plotDS <- function(x, yd, ys, xlab = "", ylab = "", ylim = rrange(c(yd, ys)), xpd = TRUE, do.seg = TRUE, seg.p = .95, segP = list(lty = 2, lwd = 1, col = 2), linP = list(lty = 1, lwd = 2.5, col = 3), ...) { ## Purpose: Plot Data & Smooth ## ------------------------------------------------------------------------- ## Arguments: do.seg: logical, plot "residual segments" iff T (= default). ## ------------------------------------------------------------------------- ## Author: Martin Maechler, 1990-1994 ## 2007: allow ys to be a (xs,ys)-xycoords structure, where {x[] \in xs[]} if((hasMoreSmooth <- !is.numeric(ys))) { ysl <- xy.coords(ys) ixs <- match(x, ysl$x) if(any(is.na(ixs))) stop("'x' inside the 'ys' structure must contain all the observational 'x'") ys <- ysl$y[ixs] } if(is.unsorted(x)) { i <- sort.list(x) x <- x[i] yd <- yd[i] ys <- ys[i] } addDefaults <- function(listArg) { ## trick such that user can call 'segP = list(col = "pink")' : nam <- deparse(substitute(listArg)) P <- as.list(formals(sys.function(sys.parent()))[[nam]])[-1] # w/o "list" for(n in names(listArg)) P[[n]] <- listArg[[n]] P } plot(x, yd, xlab = xlab, ylab = ylab, ylim = ylim, ...) #pch = pch, if(!missing(linP)) linP <- addDefaults(linP) if(hasMoreSmooth) lines(ysl, xpd = xpd, lty = linP$lty, lwd = linP$lwd, col = linP$col) else lines(x, ys, xpd = xpd, lty = linP$lty, lwd = linP$lwd, col = linP$col) if(do.seg) { if(!missing(segP)) segP <- addDefaults(segP) segments(x, seg.p*ys + (1-seg.p)*yd, x, yd, xpd = xpd, lty = segP$lty, lwd = segP$lwd, col = segP$col) } invisible() } ##-#### Matrix (or higher Array) stuff ######## ##-### ------------------------------ ######## colcenter <- function(mat) sweep(mat,2, apply(mat,2,mean)) col01scale <- function(mat, scale.func = function(x) diff(range(x)), location.func = mean) { ##-- See also 'scale' (std. S func) -- mat <- sweep(mat,2, apply(mat,2, location.func)) sweep( mat, 2, apply(mat,2, scale.func), "/") } ## diag.ex <- function(n) --- now renamed : diagX <- function(n) { ## Purpose: Returns "the other diagonal" matrix ## Author: Martin Maechler, Date: Tue Jan 14 1992; Nov.2002 ## ---------------------------------------------------------------- ## Arguments: n: integer dimension of matrix ## ---------------------------------------------------------------- m <- numeric(n * n) m[1L+ (n-1L)* seq_len(n)] <- 1 dim(m) <- c(n,n) m } xy.grid <- function(x,y) { ## Purpose: Produce the grid used by persp, contour, .. as N x 2 matrix nx <- length(x) ny <- length(y) cbind(rep.int(x,rep.int(ny,nx)), rep.int(y,nx)) } rot2 <- function(xy, phi) { ## Purpose: rotate xy-points by angle 'phi' (in radians) ## ------------------------------------------------------------------------- ## Arguments: xy : n x 2 matrix; phi: angle (in [0, 2pi]) ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 26 Oct 94, 22:16 co <- cos(phi); s <- sin(phi) xy %*% t( matrix(c(co,s, -s, co), 2,2) ) } tapplySimpl <- function(X, INDEX, FUN, ...) { ## Purpose: Nicer result for tapply(..) when Function returns ## vector AND there is >= 2 "INDEX", i.e., categories. ## ------------------------------------------------------------------------- ## Arguments: as for tapply, ## FUN: Must return [named, if possible] FIXED length vector ## [num/char] EVEN for NULL and NA ! ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 14 Jun 93, 17:34 rl <- tapply(X, INDEX, FUN, ..., simplify = TRUE) if (is.list(rl)) { #-- when >=2 indices AND length(FUN(x)) > 1 --- if(any(Nas <- unlist(lapply(rl, is.null)))) rl[Nas] <- list(FUN(NULL)) array(unlist(rl), dim = c(length(rl[[1]]), dim(rl)), dimnames = c(list(names(rl[[1]])), dimnames(rl)) ) } else rl } ##-#### "Calculus" Mathematical stuff ######## ##-### ----------------------------- ######## u.log <- function(x, c = 1) { ## Purpose: log(.) only for high x- values ... identity for low ones ## This f(x) is continuously differentiable (once). ## f(x) = x for |x| <= c ## f(x) = sign(x)*c*(1 + log(|x|/c)) for |x| >= c ## ------------------------------------------------------------------------- ## Arguments: x: numeric vector; c: scalar > 0 ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 24 Jan 95, 17:28 if(!is.numeric(c)|| c < 0) stop("'c' must be positive number") r <- x to.log <- abs(x) > c ; x <- x[to.log] r[to.log] <- sign(x) * c * (1 + log(abs(x/c))) r } xy.unique.x <- function(x, y, w, fun.mean = mean, ...) { ## Purpose: given 'smoother data' (x_i, y_i) [and maybe weight w_i] ## with multiple x_i, use unique x's, replacing y's by their mean ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 8 Mar 93, 16:36 ##--*--*--*--*--*--*--*--*--*-- x,y,w treatment --*--*--*--*--*--*--*--*-- if(missing(x)) x <- time(y) else if(missing(y)) { if(is.list(x)) { if(any(is.na(match(c("x", "y"), names(x))))) stop("cannot find x and y in list") y <- x$y; x <- x$x; if(!is.null(x$w)) w <- x$w } else if(is.complex(x)) { y <- Im(x); x <- Re(x) } else if(is.matrix(x) && ncol(x) == 2) { y <- x[, 2]; x <- x[, 1] } else if(is.matrix(x) && ncol(x) == 3) { y <- x[, 2]; w <- x[, 3]; x <- x[, 1] } else { y <- x; x <- time(x) } } n <- length(x) if(n != length(y)) stop("lengths of x and y must match") if(missing(w)) w <- rep.int(1,n) else if(n != length(w)) stop("lengths of x and w must match") ##--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*--*-- gr <- match(x, ux <- unique(x, ...)) cbind(x = ux, y = tapply(y, gr, FUN = fun.mean), w = tapply(w, gr, FUN = sum)) } ##-#### Non-calculus ("Discrete") Mathematical stuff ######## ##-### -------------------------------------------- ######## lseq <- function(from, to, length) { ## Purpose: seq(.) : equidistant on log scale ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 3 Feb 2005, 08:34 stopifnot(from > 0) exp(seq(log(from), log(to), length.out = length)) } inv.seq <- function(i) { ## Purpose: 'Inverse seq': Return a short expression for the 'index' 'i' ## -------------------------------------------------------------------- ## Arguments: i: vector of (usually increasing) integers. ## -------------------------------------------------------------------- ## Author: Martin Maechler, Date: 3 Oct 95, 18:08 ## -------------------------------------------------------------------- ## EXAMPLES: cat(rr <- inv.seq(c(3:12, 20:24, 27, 30:33)),"\n"); eval(rr) ## r2 <- inv.seq(c(20:13, 3:12, -1:-4, 27, 30:31)); eval(r2); r2 li <- length(i <- as.integer(i)) if(li == 0) return(expression(NULL)) else if(li == 1) return(as.expression(i)) ##-- now have: length(i) >= 2 di1 <- abs(diff(i)) == 1 #-- those are just simple sequences n1:n2 ! i <- i + 0 # coercion to "double", so result has no 'L' appended integers. s1 <- i[!c(FALSE,di1)] # beginnings s2 <- i[!c(di1,FALSE)] # endings mkseq <- function(i, j) if (i==j) i else call(':', i, j) as.call(c(list(as.name('c')), mapply(s1, s2, FUN=mkseq, SIMPLIFY=FALSE, USE.NAMES=FALSE))) } iterate.lin.recursion <- function(x, coeff, delta = 0, nr.it) { r <- c(x, numeric(nr.it)) n <- length(x) ic <- length(coeff):1 for(i in 1:nr.it) r[n + i] <- delta + c(coeff %*% r[n + i - ic]) r } quadrant <- function(x,y=NULL) { xy <- xy.coords(x,y); x <- xy$x; y <- xy$y Sgn <- function(u) ifelse(u >= 0, 1, -1) y <- Sgn(y); 2 - y + (y != Sgn(x)) } n.code <- function(n, ndig = 1, dec.codes = c("","d","c","k")) { ##-- convert "round integers" to short char.strings ##-- useful to build-up variable names in simulations ##-- e.g., nd <- length(dec.codes) e10 <- pmin(floor(log10(n) + 1e-12), nd - 1) if (any(e10 < 0)) { e10 <- pmax(0, e10) ; warning("some 'n' too small") } ## IDEA: Things like ## ---- n.code(c(2000,1e4,5e4,6e5,7e6,8e7), ## dec. = c("","d","c","k","-","-","M")) ## could work; (not quite yet, see ex. above) ##- if(any(id <- is.na(dec.codes) | dec.codes == "-")) { ##- ## then use previous code for these (things like "20k", "300k") ##- ## sequentially from the left: ##- for(k in which(id)) { ##- dec.codes[k] <- dec.codes[k - 1] ##- ii <- 1+e10 == k ##- e10[ii] <- e10[ii] - 1 ##- } ##- } paste0(round(n/ 10^(e10 + 1 - ndig)), dec.codes[1 + e10]) } code2n <- function(ncod, ndig = 1, dec.codes = c("","d","c","k")) { ## The inverse function to n.code le <- nchar(ncod) cod <- substring(ncod, le, le) as.integer(substring(ncod, 1, le-1)) * 10^(match(cod, dec.codes)-1) } nr.sign.chg <- function(y) { ## Purpose: Compute number of sign changes in sequence ## Be careful with y[i] that were 0 !! y <- sign(c(y)) y <- y[y != 0] sum(y[-1] != y[-length(y)]) } unif <- function(n, round.dig = 1 + trunc(log10(n))) { ## Purpose: Give regular points on [-c,c] with mean 0 and variance ~= 1 if(n %% 2 == 0) { if(n > 0) round((2 * 1:n - (n + 1)) * sqrt(3/(n * (n + 1))), round.dig) } else { m <- n %/% 2 #--> m+1 = (n+1)/2 ( - m:m) * round(sqrt(6/((m + 1) * n)), round.dig) } } prt.DEBUG <- function(..., LEVEL = 1) { stop("prt.DEBUG() is defunct: use a 'verbose' argument or options(verbose=.) instead") ## if (exists("DEBUG", where = 1) && DEBUG >= LEVEL )# ## ## ## cat(paste0("in '", sys.call(sys.nframe()-1)[1], "':"), ..., "\n") } ##' @title Read an Emacs Org Table by read.table() ## --> ../man/read.org.table.Rd read.org.table <- function(file, header = TRUE, skip = 0, encoding = "native", fileEncoding = "", text, ...) { ## file - text handling --- cut'n'paste from read.table()'s header if (missing(file) && !missing(text)) { file <- textConnection(text, encoding = "UTF-8") on.exit(close(file)) } if(is.character(file)) { file <- if(nzchar(fileEncoding)) file(file, "rt", encoding = fileEncoding) else file(file, "rt") on.exit(close(file)) } if(!inherits(file, "connection")) stop("'file' must be a character string or connection") if(!isOpen(file, "rt")) { open(file, "rt") on.exit(close(file)) } if(skip > 0L) readLines(file, skip) ll <- readLines(file, encoding=encoding) close(file); on.exit() ## drop |--------+---------+--------+--| : if(length(i <- grep("---+\\+--", ll[1:3]))) ll <- ll[-i] ## drop beginning and ending "|" : ll <- sub("^ *\\|", "", sub("\\| *$", "", ll)) if(header) { ## assume header in first 2 lines ii <- if(nchar(ll[1]) < 2) 2 else 1 ## header line hl <- ll[ii] ## drop header line(s) ll <- ll[-seq_len(ii)] ## split the header lines into column names col.names <- sub("^ +", "", sub(" +$", "", strsplit(hl, " *\\| *") [[1L]])) } ## drop empty lines at end only while(grepl("^ *$", tail(ll, 1L))) ll <- ll[-length(ll)] f.ll <- textConnection(ll)# , encoding = "UTF-8" is *NOT* good on.exit(close(f.ll)) read.table(f.ll, header=FALSE, sep = "|", col.names = col.names, ...) # , encoding = "UTF-8" *not* good } sfsmisc/R/TA.plot.R0000644000176200001440000001223113446400714013530 0ustar liggesusersn.plot <- function(x, y=NULL, nam = NULL, abbr = n >= 20 || max(nchar(nam))>=8, xlab = NULL, ylab = NULL, log = "", cex = par("cex"), col = par("col"), ...) { ## Purpose: "Name Plot"; Names (or numbers) instead of points in plot(..) ## --> help(n.plot) ! if(inherits(x,"formula")) # is(x, "formula") stop("formula not yet supported") ## this is like plot.default(): xlabel <- if (!missing(x)) deparse(substitute(x)) ylabel <- if (!missing(y)) deparse(substitute(y)) xy <- xy.coords(x, y, xlabel, ylabel, log) xlab <- xlab %||% xy$xlab ylab <- ylab %||% xy$ylab plot(xy, type = 'n', xlab = xlab, ylab = ylab, log = log, ...) n <- length(x) ## Use "any names", otherwise take 1,2,.. : nam <- nam %||% rownames(x) %||% names(x) %||% names(y) %||% as.character(seq_len(n)) if(abbr) nam <- abbreviate(nam, minlength=1) text(xy, labels=nam, cex=cex, col=col) invisible(nam) } TA.plot <- function(lm.res, fit = fitted(lm.res), res = residuals(lm.res, type = "pearson"), labels = NULL, main = mk.main(), xlab = "Fitted values", draw.smooth = n >= 10, show.call = TRUE, show.2sigma = TRUE, lo.iter = NULL, lo.cex = NULL, par0line = list(lty = 2, col = "gray"), parSmooth = list(lwd = 1.5, lty = 4, col = 2), parSigma = list(lwd = 1.2, lty = 3, col = 4), verbose = FALSE, ...) { ## Purpose: Produce a Tukey-Anscombe plot of a linear model fit ## Note that residuals and fitted are UN-correlated (IFF intercept..) ## ------------------------------------------------------------------------- ## Arguments: lm.res = RESult of lm(..) ## res : (weighted) residuals by default, ## labels = 'symbols' for point, default(NULL): extract names or use seq.nr ## use '*' to get simple '*' symbols. ## ## --- see on-line help by "?TA.plot" !! ## ------------------------------------------------------------------------- ## Uses : n.plot(.) ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: Dec 92 / Nov.93; for R: 1999/2000 if(missing(main)) { call <- getCall(lm.res) if(is.call(call[["formula"]]) && any(c("lm", "aov") == call[[1]])) call <- call[["formula"]] else { #-- only formula part; no extra 'data =' if (length(call) >= 3 && !is.na(m.f <- match("formula", names(call)))) { call <- call[c(1, m.f)] names(call)[2] <- "" } } mk.main <- function() { cal <- call ## if(is.R()) call else get("call", frame = sys.parent()) if(is.null(cal)) "Tukey-Anscombe plot of ???" else { nc <- nchar(ccal <- deparse(cal, width.cutoff = 200)[1]) if(verbose) cat("|cal|=", length(cal), "; nchar(ccal) =", nc,": '", ccal, "'\n", sep="") if(nc > 36) warning("TA.plot: 'main' title is long; consider using cex.main = 0.8", call. = FALSE) ##-- now should even go further: ##-- E.g. if nc > 50, use cex = .8 in the call to n.plot below paste(if(nc < 13) "Tukey-Anscombe plot of : " else if(nc < 24) "T.A. plot of: " else "TA-pl:", ccal) } } } if("ylab" %in% names(list(...))) { n.plot(fit, res, nam = labels, xlab = xlab, main = main, ...) } else { yl <- "Residuals" ## FIXME $weights, $resid -- not portable (e.g., to lmer obj!) ==> use extractors? if(is.list(lm.res) && !is.null(lm.res$weights) && is.numeric(res0 <- lm.res$resid) && any(abs(res0 - res) > 1e-6*mad(res))) yl <- paste("WEIGHTED", yl) n.plot(fit, res, nam = labels, xlab = xlab, ylab = yl, main = main, ...) } if(show.call) mtext(deparse(match.call()), side = 3, line = 0.5, cex = 0.6, adj=1) do.call("abline", c(list(h= 0), par0line)) p.mgp <- par("mgp")[1:2] #-- line numbers of margin text: xlab & label if(missing(lo.cex)) lo.cex <- max(.2, min(0.8*par("mex"), .9*-diff(p.mgp))/par("mfg")[4]) m.line <- if(par("mfg")[4]==1) .2+ p.mgp[1] else max(p.mgp[1] - .2*lo.cex, sum(p.mgp)/2) if(show.2sigma) { s2 <- c(-2,2) * mad(res, center=0) rr <- range(res) if(s2[1] < rr[1] || s2[2] > rr[2]) mtext(paste("2 sigma = ", format(s2[2])), side= 1, line= m.line, adj = 0, cex= lo.cex) ##abline(h= s2, lwd=1.8, lty=3, col=4) do.call("abline", c(list(h= s2), parSigma)) } n <- length(res) if(draw.smooth) { if(!is.list(parSmooth)) stop("`parSmooth' must be a list") ##-- lo.iter: idea of Werner Stahel: no robustness for 'glm' residuals if (is.null(lo.iter)) lo.iter <- if(inherits(lm.res, "glm") && family(lm.res)$family[1] != "Gaussian") 0 else 3 f <- max(0.2, 1.25 * n^-.2) #'-- Martin's very empirical formula... rlow <- lowess(fit, res, f = f, iter = lo.iter) do.call("lines",c(rlow, parSmooth)) mtext(paste("-.-.-.- : lowess smooth (f =", format(round(f,2)), if(lo.iter!=3) paste(", it=", lo.iter), ")"), side = 1, line = m.line, cex = lo.cex, adj = 1) } ##- "Correlation:", formatC(cor(fit,res), dig=3), ## mtext(paste(" -- Rank corr.:", formatC(cor(rank(fit),rank(res)), dig=3)) ) invisible() } sfsmisc/R/sourceAttach.R0000644000176200001440000000117113246276146014705 0ustar liggesusers##' @title "Source + Attach" an R source file ##' @author Martin Maechler, 29 Jul 2011 sourceAttach <- function(file, pos = 2, name = paste(abbreviate(gsub(fsep, "", dirname(file)), 12, method="both.sides"), basename(file), sep=fsep), keep.source = getOption("keep.source.pkgs"), warn.conflicts = TRUE) { ENV <- new.env() sys.source(file, envir = ENV, keep.source = keep.source)# also checks file fsep <- .Platform$file.sep # for default 'name' : ## mini-obfuscation: this *IS* a legitimate use of attach()! A <- attach A(ENV, pos=pos, name=name, warn.conflicts=warn.conflicts) } sfsmisc/R/hatMat.R0000644000176200001440000000173113746476427013511 0ustar liggesusershatMat <- function(x, trace = FALSE, pred.sm = function(x,y,...) predict(smooth.spline(x,y, ...), x = x)$y, ...) { ## Purpose: Return Hat matrix of a smoother -- very general (but slow) ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 7 Mar 2001, 11:12 stopifnot(is.logical(trace), length(trace) == 1) n <- NROW(x) if(is.unsorted(x) && !missing(pred.sm)) warning("'x' is not sorted increasingly:\n ", " this may be inefficient and lead to wrong results") y <- pred.sm(x, numeric(n), ...) if(!is.numeric(y) || length(y) !=n) stop("`pred.sm' does not return a numeric length n vector") H <- if(trace) 0 else matrix(as.numeric(NA), n,n) for (i in 1:n) { y <- numeric(n) ; y[i] <- 1 # y := e_i ; (e_i)_j = 1_[i=j] y <- pred.sm(x, y, ...) if(trace) H <- H + y[i] else H[,i] <- y } H } sfsmisc/R/D1D2.R0000644000176200001440000001122110142471407012674 0ustar liggesusers## This is also sym.linked into ## Martin's WpDensity package /u/maechler/R/Pkgs/WpDensity/ ###------- Numerical Derivatives ------------------------------------------ ### Test Programs and examples for those two are in ### --> "/u/maechler/S/NUMERICS/D1-tst.S" ### ### For 'optimal' 2nd Deriv.: d2.est(..) ### --> "/u/maechler/S/NUMERICS/diff2.S" "/u/maechler/S/NUMERICS/diff2-user.S" D1tr <- function(y, x = 1) { ## Purpose: discrete trivial estimate of 1st derivative. ## ------------------------------------------------------------------------- ## Arguments: x is optional ## ------------------------------------------------------------------------- ##--> See also D1.naive in ~/S/D1-tst.S (and the (smoothing) one: 'D1') ! ## Author: Martin Maechler, ~ 1990 n <- length(y) if(length(x) == 1) c(y[2] - y[1], 0.5 * (y[-(1:2)] - y[-((n-1):n)]), y[n] - y[n-1])/x else { if(n != length(x)) stop("lengths of 'x' & 'y' must equal") if(is.unsorted(x)) stop("'x' must be sorted !") c(y[2] - y[1], 0.5 * (y[-(1:2)] - y[-((n-1):n)]), y[n] - y[n-1]) / c(x[2] - x[1], 0.5 * (x[-(1:2)] - x[-((n-1):n)]), x[n] - x[n-1]) } } D1ss <- function(x, y, xout = x, spar.offset = 0.1384, spl.spar=NULL) { ## Purpose: Numerical first derivatives of f() for y_i = f(x_i) + e_i. ## Find f'(xout) -- using smoothing splines with GCV' ## Author: Martin Maechler, Date: 6 Sep 92, 00:04 ## ------------------------------------------------------------------------- ## Arguments: x = { x_i } MUST be sorted increasingly // y = { y_i } ## ------------------------------------------------------------------------- sp <- if(is.null(spl.spar)) { sp <- smooth.spline(x,y) smooth.spline(x,y, spar = sp$ spar + spar.offset) } else smooth.spline(x,y, spar = spl.spar) predict(sp, xout, deriv = 1) $ y } D2ss <- function(x, y, xout = x, spar.offset = 0.1384, spl.spar=NULL) { ## Purpose: Numerical 2nd derivative of f() for y_i = f(x_i) + e_i. ## Find f''(xout) -- using smoothing splines (with GCV) -- DOUBLY: ## f --ss-> f' --ss-> f'' ## ------------------------------------------------------------------------- ## Arguments: x = { x_i } MUST be sorted increasingly // y = { y_i } ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 29 Jan 1997, 17:55 -- for S-plus ## ------------------------------------------------------------------------- use.fudge <- is.null(spl.spar) if(use.fudge) { ##-- use GCV * 'spar.offset' --- if(is.null(spar.offset)) stop("must specify 'spl.spar' OR 'spar.offset'!") lf <- length(spar.offset) if(!is.numeric(spar.offset) || lf == 0 || lf > 2) stop("'spar.offset' must be numeric(1 or 2) !") if(lf == 1) spar.offset <- rep(spar.offset, 2) sp <- smooth.spline(x,y) sp <- smooth.spline(x,y, spar = spar.offset[1] + sp $ spar) spl.spar <- numeric(2); spl.spar[1] <- sp $ spar } else { lf <- length(spl.spar) if(!is.numeric(spl.spar) || lf == 0 || lf > 2) stop("'spl.spar' must be numeric(1 or 2) !") if(lf == 1) spl.spar <- rep(spl.spar, 2) sp <- smooth.spline(x,y, spar = spl.spar[1]) } D1 <- predict(sp, x, deriv = 1) $ y #-- 1st derivative ... if(use.fudge) { ##-- use GCV * 'spar.offset' --- sp <- smooth.spline(x, D1) sp <- smooth.spline(x, D1, spar = spar.offset[2] + sp $ spar) spl.spar[2] <- sp $ spar } else { sp <- smooth.spline(x, D1, spar = spl.spar[2]) } if(is.unsorted(xout)) xout <- sort(xout) list(x=xout, y = predict(sp, xout, deriv = 1) $ y, spl.spar = spl.spar, spar.offset = spar.offset) } D1D2 <- function(x, y, xout = x, spar.offset = 0.1384, deriv = 1:2, spl.spar=NULL) { ## Purpose: Numerical first derivatives of f() for y_i = f(x_i) + e_i. ## Find f'(xout) & f''(xout) -- using smoothing splines with GCV' ## Author: Martin Maechler, Date: 23 Sep 1992, 9:40ith GCV' ## Author: Martin Maechler, Date: 23 Sep 1992, 9:40 ## ------------------------------------------------------------------------- ## Arguments: x = { x_i } MUST be sorted increasingly // y = { y_i } ## ------------------------------------------------------------------------- if(is.unsorted(xout)) xout <- sort(xout) sp <- if(is.null(spl.spar)) { sp <- smooth.spline(x,y) smooth.spline(x,y, spar = sp$ spar + spar.offset) } else smooth.spline(x,y, spar = spl.spar) c(list(x = xout, D1 = if(any(deriv==1)) predict(sp, xout, deriv = 1) $ y, D2 = if(any(deriv==2)) predict(sp, xout, deriv = 2) $ y), sp[c("spar", "df")]) } sfsmisc/R/p.ts.R0000644000176200001440000001003513567454430013143 0ustar liggesusersp.ts <- function(x, nrplots = max(1, min(8, n%/%400)), overlap = nk %/% 16, date.x = NULL, do.x.axis = !is.null(date.x), do.x.rug = FALSE, ax.format, main.tit = NULL, ylim = NULL, ylab = "", xlab = "Time", quiet = FALSE, mgp = c(1.25, .5, 0), ...) { ## Purpose: plot.ts with multi-plots + Auto-Title -- currently all on 1 page ## ------------------------------------------------------------------------- ## Arguments: x : timeseries [ts,rts,its,cts] or numeric vector ## nrplots: number of sub-plots [DEFAULT: in {1..8}, ~= n/400] ## overlap: how much should subsequent plots overlap [DEFAULT:..] ## ## Depends on mult.fig() ## ## ---> help page ?p.ts ## ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 1 Jul 1994; 18 Dec 1998. if(is.null(main.tit)) main.tit <- paste(deparse(substitute(x))) isMat <- is.matrix(x) n <- if(isMat) nrow(x) else length(x) has.date.x <- !is.null(date.x) if(do.x.axis && !has.date.x) stop("'do.x.axis' is true, but 'date.x' is NULL") if(has.date.x) { if(n != length(date.x)) stop("'date.x' must be date vector of the same length as series") if(do.x.axis) date.x <- as.POSIXct(date.x) # work, or give error now if(is.unsorted(date.x, na.rm=TRUE)) { i <- order(date.x) x <- if(isMat) x[i,] else x[i] date.x <- date.x[i] } xaxt <- "n" } else xaxt <- par("xaxt") if(nrplots == 1) { if(has.date.x) { plot(date.x, x, ..., ylim = ylim, type = 'l', main = main.tit, xlab = xlab, ylab = ylab, xaxt = xaxt) if(do.x.axis) axis.POSIXct(1, x = date.x, format = ax.format) } else plot.ts(x, ..., ylim = ylim, main = main.tit, xlab = xlab, ylab = ylab, xaxt = xaxt) } else if(nrplots <= 0) return(nrplots) else { # nrplots >= 2 : if(n <= 1) stop("`x' must have at least two points!") if(!is.ts(x)) x <- as.ts(x) ##- do.dates <- inherits(x, "cts") ##- if(do.dates) x <- as.rts(x)# dates() as below fails [S+ 3.4] ## NB: end() and start() are of length 1 _or_ 2 (!) scal <- (end(x) - (t1 <- start(x))) / (n-1) nk <- n %/% nrplots if(is.null(ylim)) ylim <- range(pretty(range(x, na.rm = TRUE))) if(!quiet) Form <- function(x) paste0("(",paste(formatC(x, digits=6, width=1), collapse=", "), ")") pp <- mult.fig(mfrow=c(nrplots,1), main = main.tit, mgp = mgp, marP = c(-1,-1,-2,0)) on.exit(par(pp $ old.par)) for(i in 1:nrplots) { i0 <- as.integer(max(0, (-overlap + (i-1)*nk)-1) ) in1 <- as.integer(min(n, i*nk + overlap)-1 ) st <- t1 + scal*i0 ##; if(do.dates) st <- dates(st) en <- t1 + scal*in1 ##; if(do.dates) en <- dates(en) if(!quiet) cat(sprintf("%2d -- start{%d}= %s; end{%d}= %s\n", i, i0,Form(st), in1, Form(en))) if(has.date.x) { plot(date.x[1+ i0:in1], window(x, start= st, end = en), ..., ylim = ylim, type = 'l', xlab = xlab, ylab = ylab, xaxt = xaxt) if(do.x.axis) { if(!quiet) { cat("summary(date.x):\n"); print(summary(date.x[1+ i0:in1])) } axis.POSIXct(1, x = date.x[1+ i0:in1], format = ax.format) ## (I've lost my improved version of this which had 'nYrs = 12' if(do.x.rug) ## this can be ugly rug(date.x[1+ i0:in1]) } } else plot(window(x, start= st, end = en), ylim = ylim, xlab = xlab, ylab = ylab, xaxt = xaxt, ..., plot.type= "single")# plot.type : for plot.mts only, } } } sfsmisc/R/sessionInfo-ext.R0000644000176200001440000001236314116665241015355 0ustar liggesusersisRshared <- function(platform = .Platform) { platform$ OS.type == "windows" || { ## works on Linux; what about others, notably Mac ? ldd.s <- try(Rcmd(paste("ldd", R.home("bin/exec/R"), "| head -5"), stdout=TRUE)) ## If in doubt (error etc), assume ## R executable to be linked to libR.{so,dylib} , i.e., "shared" : inherits(ldd.s, "try-error") || is.null(ldd.s) || anyNA(ldd.s) || any(grepl(paste0("^.?libR", platform$dynlib.ext), ldd.s)) } } sessionInfoX <- function(pkgs=NULL, list.libP = FALSE, extraR.env = TRUE) { ## return an object; then print() via method lP <- .libPaths() # *is* normalized in the sense of normalizePath() nRL <- normalizePath(RLIBS <- strsplit(Sys.getenv("R_LIBS"), ":")[[1]]) si <- sessionInfo() ## typically the "same" [ setequal(.,.) ] as loadedNamespaces() : sessionPkgs <- c(si[["basePkgs"]], unlist(lapply(si[c("otherPkgs", "loadedOnly")], names), use.names=FALSE)) if(isTRUE(pkgs)) pkgs <- sessionPkgs else if(!is.null(pkgs)) stopifnot(is.character(pkgs), length(pkgs) > 0) Rver <- package_version(si$R.version) structure(class = "sessionInfoX", list(sInfo = si, sysInf = Sys.info(), capabilities = capabilities(), extSoft = if(Rver >= "3.2.0") extSoftVersion(), grSoft = if(Rver >= "3.2.0") grSoftVersion(), tclVersion=if(Rver >= "3.2.0" && "tcltk" %in% sessionPkgs) tcltk::tclVersion(), LAPACK = if(Rver >= "3.0.3") La_version(), pcre = if(Rver >= "3.1.3") pcre_config(), isRshared = isRshared(), pkgDescr = if(!is.null(pkgs)) sapply(pkgs, packageDescription, simplify=FALSE), libPath = lP, .Library = .Library, RLIBS = RLIBS, n.RLIBS = nRL, list.libP = if(list.libP) sapply(lP, list.files, simplify=FALSE), R.env = Sys.getenv(c("R_ENVIRON", "R_PROFILE", "R_CHECK_ENVIRON")), xR.env = if(extraR.env) local({ ss <- Sys.getenv() ss[grepl("^_?R_", names(ss))] }))) } print.sessionInfoX <- function(x, locale = TRUE, RLIBS = TRUE, Renv = TRUE, ...) { cat("Extended sessionInfo():", "-----------------------", sep="\n")# does add a final '\n' if(!is.null(pkgD <- x$pkgDescr)) { cat("specific packageDescription()s:\n") print(pkgD, ...) cat("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n") } cat("Capabilities:\n") print(symnum(x$capabilities, symbols = c("-", "X")), ...) cat("Sys.info:\n") print(structure(x$sysInf[c("nodename", "user")], class="Dlist"), ...) cat("\n") if(!is.null(x$LAPACK)) cat("LAPACK version:", x$LAPACK, "\n") if(!is.null(x$extSoft)) { cat("External software (versions):\n") print(structure(x$extSoft, class="Dlist"), ...) } if(!is.null(x$grSoft)) { cat("Graphical software (versions):\n") print(structure(x$grSoft, class="Dlist"), ...) } if(!is.null(x$tclVersion)) cat("Tcl version:", x$tclVersion, "\n") if(!is.null(x$pcre)) cat("\nPCRE (regex) config.:", sub("^c", "", deparse(x$pcre, width.cutoff=99)), "\n") cat("R executable linked against libR.* ['is R shared']:", x$isRshared, "\n") cat("\n") if(RLIBS) { cat("R_LIBS:\n") cbind(x$RLIBS) xtr.lp <- setdiff(x$libPath, union(normalizePath(x$.Library), x$n.RLIBS)) if(length(xtr.lp)) { cat("libPath [.libPaths()] contents in addition to R_LIBS and .Library:\n") print(xtr.lp) } else cat("libPath contains not more than RLIBS and .Library (normalized)\n") if(length(xx <- setdiff(x$n.RLIBS, x$libPath))) { ## typically empty cat("** RLIBS has entries not in .libPaths():\n") print(xx) } } if(Renv) { cat("Main R env. variables", if(!is.null(x$xR.env)) " (for more, inspect the 'xR.env' component)", ":\n", sep="") print(cbind(x$R.env), ...) } cat("---------------- standard sessionInfo():\n") print(x$sInf, locale=locale, ...) invisible(x) } shortRversion <- function(Rv = R.version, Rst = Rv$status, Rvstring = if(!is.null(s <- Rv$version.string)) ## in R 0.90.1 had no $version.string s else R.version.string, date = Rst != "", spaces = TRUE) { pat <- paste0("\\(", if(date) "([^)]+)" else "[0-9]{4}-[0-9]{2}-[0-9]{2} *(.+)", "\\)$") r <- if(Rst == "Under development (unstable)") ## "R Under development (unstable) (2017-10-16 r73554)" paste("R devel", sub(paste0(".*",pat), "\\1", Rvstring)) else if(tolower(Rst) %in% c("patched", "alpha", "beta", "rc")) ## "R version 3.4.2 Patched (2017-10-12 r73556)" sub(pat, "\\1", sub(" version", "", Rvstring)) else if(Rst == "") # "R version 3.2.5 (2016-04-14)" (regular release) gsub(if(date) "[()]" else " \\(.*", "", sub(" version", "", Rvstring)) else stop("invalid R.version $ status: ", sQuote(Rst)) if(spaces) r else gsub(" ", "_", sub("^R ", "R-", r)) } sfsmisc/R/plotCI.R0000644000176200001440000000000010377024760013433 0ustar liggesuserssfsmisc/R/mat2tex.R0000644000176200001440000000442713376731215013650 0ustar liggesusers### Port to R and a few small improvements: ### Copyright 2000 Martin Maechler, ETH Zurich mat2tex <- function(x, file = "mat.tex", envir = "tabular", nam.center = "l", col.center = "c", append = TRUE, digits = 3, title) { if(length(d.x <- dim(x)) != 2) stop("'x' must be a matrix like object with dim(x) of length 2") if(any(d.x <= 0)) stop("'dim(x)' must be positive") nr.x <- d.x[1] nc.x <- d.x[2] c2ind <- (1:nc.x)[-1] # possibly empty ## determine if there are labels to be processed dn.x <- dimnames(x) if(has.rowlabs <- !is.null(dn.x[[1]])) rowlabs <- dn.x[[1]] if(has.collabs <- !is.null(dn.x[[2]])) collabs <- dn.x[[2]] ## produce column specification stopifnot(any(nam.center == c("l","r","c"))) stopifnot(all(col.center %in% c("l","r","c"))) col.center <- rep(col.center, length = nc.x) colspec <- "{|" if(has.rowlabs) colspec <- paste(colspec, nam.center, "||") colspec <- paste0(colspec, paste(col.center, "|", collapse=""), "}") cat(paste(sprintf("\\begin{%s}", envir), colspec, " \n"), file=file, append=append) span <- nc.x + if(has.rowlabs) 1 else 0 cat(if(!missing(title)) paste("\\multicolumn{", span, "}{c}{", title, "} \\\\"), "\\hline \n", file = file, append = TRUE) ## output column labels if needed if(has.collabs) { collabline <- " " if(has.rowlabs) collabline <- paste(collabline, " \\ &") collabline <- paste(collabline, collabs[1]) for(i in c2ind) collabline <- paste(collabline, "&", collabs[i]) collabline <- paste(collabline, "\\\\ \\hline \\hline") cat(collabline, "\n", file = file, append = TRUE) } ## output matrix entries op <- options(digits = digits); on.exit(op) for(i in 1:nr.x) { thisline <- if(has.rowlabs) paste(rowlabs[i], "&", format(x[i, 1])) else format(x[i, 1]) for(j in c2ind) thisline <- paste(thisline, "&", format(x[i, j])) thisline <- paste(thisline, "\\\\ \\hline") cat(paste(thisline, "\n"), file = file, append = TRUE) } cat(paste0("\\end{", envir, "}\n"), file = file, append = TRUE) } sfsmisc/R/nearcor.R0000644000176200001440000000507011725135240013700 0ustar liggesusers#### Copyright (2007) Jens Oehlschlgel #### GPL licence, no warranty, use at your own risk ### NOTA BENE: nearPD() in package Matrix is a new version, slightly more elegant ### ^^^^^^^^ also using Matrix-builtin functionality nearcor <- function( # Computes the nearest correlation matrix to an approximate correlation matrix, i.e. not positive semidefinite. R # n-by-n approx correlation matrix , eig.tol = 1.0e-6 # defines relative positiveness of eigenvalues compared to largest , conv.tol = 1.0e-7 # convergence tolerance for algorithm , posd.tol = 1.0e-8 # tolerance for enforcing positive definiteness , maxits = 100 # maximum number of iterations allowed , verbose = FALSE # set to TRUE to verbose convergence # RETURNS list of class nearcor with components cor, iterations, converged ){ if (!(is.numeric(R) && is.matrix(R) && identical(R,t(R)))) stop('Error: Input matrix R must be square and symmetric') # Inf norm inorm <- function(x)max(rowSums(abs(x))) # Froebenius norm fnorm <- function(x)sqrt(sum(diag(t(x) %*% x))) n <- ncol(R) U <- matrix(0, n, n) Y <- R iter <- 0 while (TRUE){ T <- Y - U # PROJECT ONTO PSD MATRICES e <- eigen(Y, symmetric=TRUE) Q <- e$vectors d <- e$values D <- diag(d) # create mask from relative positive eigenvalues p <- (d>eig.tol*d[1]); # use p mask to only compute 'positive' part X <- Q[,p,drop=FALSE] %*% D[p,p,drop=FALSE] %*% t(Q[,p,drop=FALSE]) # UPDATE DYKSTRA'S CORRECTION U <- X - T # PROJECT ONTO UNIT DIAG MATRICES X <- (X + t(X))/2 diag(X) <- 1 conv <- inorm(Y-X) / inorm(Y) iter <- iter + 1 if (verbose) cat("iter=", iter, " conv=", conv, "\n", sep="") if (conv <= conv.tol){ converged <- TRUE break }else if (iter==maxits){ warning(paste("nearcor did not converge in", iter, "iterations")) converged <- FALSE break } Y <- X } X <- (X + t(X))/2 # begin from posdefify(sfsmisc) e <- eigen(X, symmetric = TRUE) d <- e$values Eps <- posd.tol * abs(d[1]) if (d[n] < Eps) { d[d < Eps] <- Eps Q <- e$vectors o.diag <- diag(X) X <- Q %*% (d * t(Q)) D <- sqrt(pmax(Eps, o.diag)/diag(X)) X[] <- D * X * rep(D, each = n) ## force symmetry X <- (X + t(X))/2 } # end from posdefify(sfsmisc) diag(X) <- 1 ret <- list(cor=X, fnorm=fnorm(R-X), iterations=iter, converged=converged) class(ret) <- "nearcor" ret } sfsmisc/R/p.res.2x.WSt.R0000644000176200001440000001634412346606152014355 0ustar liggesusers#### was part of ./p.goodies.R ### Exports : ### p.res.2x Werner Stahels Plot; z.B Residuen gegen 2 x-Var. ### p.res.2fact Aehnliche Idee: Residuen gegen 2 Faktoren (boxplots) ## p.wstPlot <- function(...) ## { ## warning("\n\n*** p.wstPlot(.) heisst neu p.res.2x(.)\n** Diese verwenden!\n") ## p.res.2x(...) ## } p.res.2x <- function(x, ...) UseMethod("p.res.2x") p.res.2x.default <- function(x, y, z, restricted = NULL, size = 1, slwd = 1, scol = 2:3, xlab = NULL, ylab = NULL, main = NULL, xlim = range(x), ylim = range(y), ...) { ## Purpose: Stahels Residuen-Plot ## Author: ARu , Date: 11/Jun/91 ## Aenderungen: MMae, 30/Jan/92, Dez.94 --> help(p.res.2x) if(is.null(xlab)) xlab <- deparse(substitute(x)) if(is.null(ylab)) ylab <- deparse(substitute(y)) if(is.null(main)) main <- deparse(substitute(z)) ok <- !(is.na(x) | is.na(y) | is.na(z)) x <- x[ok]; y <- y[ok]; z <- z[ok] ## ##--- restrict z values: --- az <- abs(z) has.restr <- if(is.null(restricted)) FALSE else any(restr <- az > restricted) if(has.restr) { z[z > restricted] <- restricted z[z < - restricted] <- - restricted } ##--- fix plot region: --- pcm <- par("pin") * 2.54 #damit in cm ##--- damit im Plot das Symbol wirklich die Groesse size hat: size <- size/(2 * sqrt(2)) fx <- (size * diff(xlim))/(pcm[1] - 2 * size)/2 fy <- (size * diff(ylim))/(pcm[2] - 2 * size)/2 ##-- plot(x, y, xlim = xlim + c(-1,1)* fx, ylim = ylim + c(-1,1)* fy, pch = ".", xlab = xlab, ylab = ylab, main = main, ...) ##--- draw symbols: --- z <- z/max(az, na.rm = TRUE) usr <- par("usr") sxz <- diff(usr[1:2])/pcm[1] * size * z syz <- abs(diff(usr[3:4])/pcm[2] * size * z) if(length(scol) == 2) scol <- scol[1 + as.integer(z < 0)] segments(x - sxz, y - syz, x + sxz, y + syz, lwd = slwd, col = scol) ##--- mark restricted observations: --- if(has.restr) { points((x - sxz)[restr], (y - syz)[restr], pch = 8, mkh = 1/40) points((x + sxz)[restr], (y + syz)[restr], pch = 8, mkh = 1/40) } invisible() } ## graphics:::mosaicplot.formula as an example p.res.2x.formula <- function(x = ~., data, main = deparse(substitute(data)), xlab = NULL, ylab = NULL, ...) { ## Purpose: plot residuals vs. two x's ## Author: ARu , Date: 11/Jun/91 ## Aenderungen: MMae, 30/Jan/92, Dez.94 / WSt ## -------------------------------------------------------------------------- ## Arguments: ## x formula defining the variables zu be used, either ## z ~ x + y ## ~ x + y in this case, data must inherit from lm , ## and the residuals of data will be used as z . ## data a data.frame or an lm or aov object. ## In the latter case, p.res.2x will look for the data ## that was used to fit the model. ## restricted absolute value which truncates the size. ## The corresponding symbols are marked by stars. ## size the symbols are scaled so that 'size' is the size of ## the largest symbol in cm. ## slwd, scol line width and color to be used for the symbols ## ... additional arguments for the S-function 'plot' ## EXAMPLE : ## g.res2x(zz~.,data=data.frame(xx=rep(1:10,7),yy=rep(1:7, rep(10,7)), ## zz=rnorm(70)), restr = 2, main = "i.i.d. N(0,1) random residuals") ## -------------------------------------------------------------------------- if(miss.main <- missing(main)) force(main) formula <- as.formula(x) t.d <- if(inherits(data, "lm")) { if(miss.main) main <- paste0("residuals(", main, ")") if(!is.data.frame(t.d <- data$model)) { ## try to look for the data that was used to fit the model. cl <- data$call i <- if("data" %in% names(cl)) "data" else 3 # try .. t.d <- get(as.character(cl[[i]])) } if (length(formula) < 3) { if(identical(format(formula), "~.")) formula <- formula(data) formula <- update.formula(formula, residuals ~ .) ## formula <- substitute(residuals ~ RHS, list(RHS = formula[[2]])) cbind(t.d, residuals = residuals(data)) } else t.d } else data if (!is.data.frame(t.d)) { if(is.matrix(data)) data <- as.data.frame(data) else stop("data is not a data frame or 'lm' object with 'model' or existing data") } t.d <- na.omit(model.frame(formula, t.d)) z <- t.d[,1] x <- t.d[,2]; if(is.null(xlab)) xlab <- names(t.d)[2] y <- t.d[,3]; if(is.null(ylab)) ylab <- names(t.d)[3] if(is.factor(x) && is.factor(y)) p.res.2fact(x, y, z, main=main, xlab=xlab, ylab=ylab, ...) else { x <- as.numeric(t.d[,2]) y <- as.numeric(t.d[,3]) p.res.2x.default(x,y,z, main=main, xlab=xlab, ylab=ylab, ...) } } p.res.2fact <- function(x, y, z, restricted, notch = FALSE, xlab = NULL, ylab = NULL, main = NULL) { if(is.null(xlab)) xlab <- deparse(substitute(x)) if(is.null(ylab)) ylab <- deparse(substitute(y)) if(is.null(main)) main <- deparse(substitute(z)) ok <- !(is.na(x) | is.na(y) | is.na(z)) x <- x[ok]; y <- y[ok]; z <- z[ok] x <- as.factor(x) y <- as.factor(y) lx <- levels(x); ly <- levels(y) ##--- restrict z values: --- if(missing(restricted)) restr <- FALSE else { if(!is.numeric(restricted) || restricted <= 0) stop("'restricted' must be POSITIVE !") if(any(restr <- abs(z) > restricted)) { zorig <- z z[z > restricted] <- restricted z[z < -restricted] <- - restricted } } rz <- range(z) op <- par(mfrow = c(length(ly), 1), oma = c(5,6,6,0), mar = .1 + c(2,4,0,1)) on.exit(par(op)) for (yv in rev(ly)) { Ind <- y == yv plot (x[Ind], z[Ind], ylim = rz, xlab = "", ylab = yv, notch = notch) abline(h = 0, lty = 3, lwd = 0) if(any(II <- restr & Ind)) { ## boxplot creates a coord.system with x = [-4, 104] jx <- as.numeric(x[II]) #-- in 1:length(lx).. cat("..Cut z=",format(zorig[II])," at ", xlab,"=",x[II],", ", ylab, "=",yv,"\n") points( u.boxplot.x(length(lx),jx) , z[II]*1.02, pch = 8, mkh = 1/25) } } mtext (xlab, side = 1, line = 1, outer = TRUE, cex = 1.3) mtext (ylab, side = 2, line = 3, outer = TRUE, cex = 1.3) mtext (main, side = 3, line = 2, cex = 1.5, outer = TRUE) if(any(restr)) message(sum(restr), " restricted observation(s)") invisible() } ## Not sure if I want this (as global function). ## I had eliminated it long ago (from "SfS") but it's used above: u.boxplot.x <- function(n, j = 1:n, fullrange = 100) { ## Purpose: Return the j-th x-coordinates in an 'n' side-by-side boxplot ## ------------------------------------------------------------------------- ## Arguments: n : number of boxplots; j: indices of boxplots ## fullrange: x-coords as 'uniform' in [0,fullrange] (f.=100, Splus 3.1,3.2) ## ------------------------------------------------------------------------- ## Author: Martin Maechler, Date: 19 Jan 95, 17:57 cn <- fullrange/(3*n*(n+1)) Dn <- cn*(3*n+2) ## Delta_{n} an <- cn*(2*n+1) ## a_{n} ## x(j) = an + (j-1)*Dn : an + (j-1)*Dn } sfsmisc/R/str_data.R0000644000176200001440000000446512623620111014051 0ustar liggesusers str_data <- function(pkgs, filterFUN, ...) { ## Purpose: str(.) of all datasets in a package ## ---------------------------------------------------------------------- ## Arguments: pkgs : character vector of names of R packages ## ... : potential further arguments to be passed to str() ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 17 Jun 2005, 09:04 stopifnot(is.character(pkgs)) ans <- as.list(pkgs); names(ans) <- pkgs if(hasFilter <- !missing(filterFUN)) { stopifnot(is.function(filterFUN)) filtName <- deparse(substitute(filterFUN)) } for(pkg in pkgs) { cat("\nAll data sets in R package '",pkg,"' ", if(hasFilter) paste0(" filtered by ", paste(filtName, collapse=" "),"()"), ":\n--------------------------"," ", rep("=", nchar(pkg)), "\n\n", sep='') dd <- data(package = pkg) items <- unique( dd$results[,"Item"] ) # unique(): bug in data(), R <= 3.2.2 ## not those that are part of "another" (multi-object) one: if(length(i <- grep(".*\\(.*\\)$", items)) > 0) items <- items[- i] its <- vector("list", length=length(items)); names(its) <- items ## ## TODO Gabor's wishes (2005-03-25): ## 1) allow filtering on class(), ## 2) sorting according to size -- that needs 2 passes through... ## MM: [optionally?] *return* class; also *return* dim(), length() dat.env <- new.env() for(n in items) { data(list = n, package = pkg, envir = dat.env) nm0 <- ls(envir = dat.env, all.names=TRUE)## all objects created from above data(.) nms <- if(hasFilter) nm0[vapply(nm0, function(n) filterFUN(get(n, envir = dat.env)), TRUE)] else nm0 if(length(nms)) { cat(n, ": ") if(length(nms) == 1) { ## one data set == normal case if(nms != n) cat(nms, ": ") ob <- get(nms, envir = dat.env) str(ob, ...) } else { ## more than one data set cat("\n") for(nn in nms) { cat(" ", nn, ": ") str(get(nn, envir=dat.env), indent.str = paste(" ", ''), ...) } } cat("--------------\n") its[[n]] <- nms } else { if(!hasFilter) warning(gettextf("no objects found from data(\"%s\")", n)) its[n] <- NULL # delete that list entry } rm(list = nm0, envir = dat.env) } ans[[pkg]] <- its } invisible(ans) } sfsmisc/R/mult.fig.R0000644000176200001440000000323612773531415014006 0ustar liggesusersmult.fig <- function(nr.plots, mfrow, mfcol, marP = rep(0, 4), mgp = c(if(par("las") != 0) 2. else 1.5, 0.6, 0), mar = marP + 0.1 + c(4,4,2,1), oma = c(0,0, tit.wid, 0), main = NULL, tit.wid = if (is.null(main)) 0 else 1 + 1.5*cex.main, cex.main = par("cex.main"), line.main = cex.main - 1/2, col.main = par("col.main"), font.main = par("font.main"), ...) { ## Purpose: 'MULTiple FIGures' incl. title and other good defaults ## ------------------------------------------------------------------------- ## Arguments: -- Either ONE of the first 3 arguments -- ### =========> help(mult.fig) ## ------------------------------------------------------------------------- ## Author: Martin Maechler, 1990 (UW, Seattle) -- 1995 ## ------------------------------------------------------------------------- use.row <- missing(mfcol) if (use.row) if (missing(mfrow)) { if (missing(nr.plots)) stop("must either specify 'nr.plots', 'mfrow' or 'mfcol' !") else mfrow <- n2mfrow (nr.plots) } old.par <- if(use.row) par(mfrow = mfrow, oma = oma, mar = mar, mgp= mgp) else par(mfcol = mfcol, oma = oma, mar = mar, mgp= mgp) ##---- now go ahead : if(!is.R()) frame() if (!is.null(main)) {# Do title *before* first plot! if(is.R()) plot.new() mtext(main, side = 3, outer = TRUE, line = line.main, cex = cex.main, font = font.main, col = col.main, ...) if(is.R()) par(new=TRUE)# reverse `plot.new()' above } invisible(list(new.par = par(c("mfrow","mfcol","oma","mar","mgp")), old.par = old.par)) } sfsmisc/R/glob2rx.R0000644000176200001440000000135012241131615013617 0ustar liggesusersif(getRversion() < "2.2") ## R 2.2.0 and later contain this in 'utils' glob2rx <- function(pattern, trim.head = FALSE, trim.tail = TRUE) { ## Purpose: Change "ls" aka "wildcard" aka "globbing" _pattern_ to ## Regular Expression (as in grep, perl, emacs, ...) ## ------------------------------------------------------------------------- ## Author: Martin Maechler ETH Zurich, ~ 1991 ## New version using [g]sub() : 2004 p <- gsub('\\.','\\\\.', paste0('^', pattern, '$')) p <- gsub('\\?', '.', gsub('\\*', '.*', p)) ## these are trimming '.*$' and '^.*' - in most cases only for esthetics if(trim.tail) p <- sub("\\.\\*\\$$", '', p) if(trim.head) p <- sub("\\^\\.\\*", '', p) p } sfsmisc/MD50000644000176200001440000001773514120063352012242 0ustar liggesusers7bb47683902b645cdaadccb6f3b40b87 *DESCRIPTION 066ea8172ac3ac511ae2c38d688231c5 *NAMESPACE 8afd533b4259c17ed53c20efe8f699d7 *R/D1D2.R cb8954e48878fe777c0d9243716e20b5 *R/Defunct.R 10253db1554bb10dce38cc9d9c1e4050 *R/Deprecated.R 2faf7fdfe633f527dea219910e888a2b *R/Duplicated.R bcf3db2731b901cc6e501f3d13cf6eba *R/Ftest-rlm.R 3757b9510f3471b5dfc9ba2834c8a632 *R/KS-confint.R 08aa9b366144e32a2160243816befb59 *R/TA.plot.R 35220955505c3ac9e6548be35871362b *R/diagDA.R 91ea7964ab5ecac601bf38e69ca45ae1 *R/ellipse.R f05c0bbec8bd887ae30b60859f23d825 *R/glob2rx.R 0dcbc519140f02a3abc64232bc84fb55 *R/hatMat.R 7ae63a44db92d439094ec6de8fff76bb *R/huber.R 8eb07c22307d4020dabd2554fea86c55 *R/integratexy.R b4a9d17e432ff9b979425f62582d49c6 *R/linesHyberb.lm.R a48c705692ea66ef396a718062987788 *R/loessDemo.R f3dcd4c4dc32070242d73573ed7fd8e8 *R/mat2tex.R 9f7fad1d246dcba33c4ffc0d4b5b4fdf *R/misc-goodies.R ad4627d9c2d46aa969ca7361abbd33c0 *R/missingCh.R 53d3ae56bf1986a12d8b70c50c05ddb8 *R/mult.fig.R bc1b64f3982e7219ffa337c6020f816e *R/nearcor.R 13f7b4407e395f4b7b547c35cf036a6a *R/p.goodies.R 3720ed20d9d2b6c04158c17bc5bc5ee8 *R/p.res.2x.WSt.R d0cb50e45537e34eef3a8915f3c2df37 *R/p.res.2x.formula.R 9afd1506d2d741d04f243e9b35706d24 *R/p.tachoPlot.R 09bab35ec23faa9a5d18c62dccbb33d2 *R/p.ts.R c3dbae94f06bc46451e1367e6782e35c *R/pd-matrix.R 9501a2f53226623a9a6070a21ddfc50d *R/pkgDesc.R d41d8cd98f00b204e9800998ecf8427e *R/plotCI.R 694114e73422c322b15ac73b681572cb *R/prettylab.R 7e49e6fed6eb866899dcff83ce8c4058 *R/prime-numbers-fn.R 579103392ad91392e2aea09f5d967909 *R/printTable.R d71992445124578d8b4af1530e423cd2 *R/ps.goodies.R aec685ea8ccf7d67271beced44e88bd2 *R/relErr.R 87b45273be3601faf5c40d852b08e152 *R/rot13.R 11a6ed2caf724846b43282bef7b56c10 *R/rrange.R 3e16c7e3718219aba773d3e169df1d31 *R/sessionInfo-ext.R fc45293bdb8acc5c249e9f533e84181a *R/sourceAttach.R 9157d8065f07a8a3c048553cbe1cb5e0 *R/str_data.R 8a24f77bf447231bbd8c436a40dc14ef *R/tkdensity.R 92ef1cc410fab9f832703185c1cb0827 *R/twoway-r-plot.R 2c7dd1c656423473d9a8e993d1dfd035 *R/u.goodies.R 02d8ebd96cdf27d80387e7b25257f6e2 *R/unix/Sys.ps.R b2ada1549f4d55d8a786835c3ab9eea9 *R/unix/package-props.R 4c6d22be483c03e4af942e0041b03260 *R/zzz.R 5aa594d45d25b7e7ef9f145a8072cff0 *README.md dc18da56aa4208975f2546e9b68d9e41 *TODO 24c4be0aa52face72313592ef90cf899 *data/potatoes.rda 3162005b7c7bcef9a60f61223ee381aa *demo/00Index f9218ba6ed399a453f42f7104605783b *demo/hatmat-ex.R c90bddd957b7fd59ad0ec2fbc069ed5b *demo/pretty-lab.R 1cfe5644e4ebaf2f16906018b6a9be8d *demo/prime-numbers.R 4d314a8c0c266297365a8fa808c12e30 *inst/ChangeLog 685ef058243925990ef87c5b4dfffe55 *inst/NEWS.Rd 4ed7f6c581c6aa69e70a24f3159b9c12 *man/AsciiToInt.Rd 9cabb0a929659d2fd8bd6fe39116e8af *man/D1D2.Rd 4778c6d3e74920fc8f277e79f5092bc1 *man/D2ss.Rd 6539612fd8fbe186385ae3d303e525d1 *man/Deprecated.Rd d16dad87f8c00165d842345b7573df7e *man/Duplicated.Rd f4ea7840b26cc4f113a878867055b915 *man/KSd.Rd fddde42e537fd46697621fed8f817f73 *man/QUnif.Rd 37f424efdf61e9f0078a74d7b59bb70d *man/TA.plot.Rd d103f8ace017a9e94763249c91416e65 *man/axTexpr.Rd e11463f8a85b1ec729fa88edb8117f52 *man/cairoSwd.Rd 2b262f3ea5da111df612742e5d5907d6 *man/capture-n-write.Rd c32625326c3ad34c095abb66e9b839c7 *man/col01scale.Rd edad636e43c3a9687547909f1ec117d4 *man/compresid2way.Rd e30198b92a39a77ec6569ad3e99f3a5b *man/cum.Vert.funkt.Rd 2e0e01ccbd9834ce96db6ec3fc46ba0a *man/diagDA.Rd 82aa7de273908725619762b73e8e268d *man/diagX.Rd 7283e1fadc13034367d813c3a405b846 *man/digitsBase.Rd 6f32c3f2b67c487e7d9493085267667e *man/eaxis.Rd e8fdce6877d53de12c3b9b27b132ff5e *man/ecdf.ksCI.Rd 939f600e0d0acb65adbabc05759e5380 *man/ellipsePoints.Rd 098c821a13e368c63219154298501bb3 *man/empty.dimnames.Rd 1939bc6ec9aae941abb2b14037044254 *man/errbar.Rd be982550f60b22d311e40f08ac3c36bb *man/f.robftest.Rd e1b212b3e0afcd4bae38bfa5e9ae8497 *man/factorize.Rd 974208bd088b1d79595b3083c9e23318 *man/funEnv.Rd 0ae00c51dc7e08c30c394cba19a4a52d *man/hatMat.Rd 130bdec125e0c34779a44ae0d5e7abdd *man/helppdf.Rd 1d667547b960fcbeeb36201a56f8c6e8 *man/histBxp.Rd 8152fbae8c8c8a7d0f01567b248d9b4e *man/integrate.xy.Rd f5a1b593e29d536987373ae72f497197 *man/inv.seq.Rd f82f08573df90f601b1a59758d88cd30 *man/is.whole.Rd 8cc8f0928dcdd19d1bf1e924f616f3b7 *man/iterate.lin.recursion.Rd 8029732cbc7bfd58d6ea5b6f83f4b2fa *man/last.Rd a17165f1928e3efe1a2c05edde235652 *man/linesHyberb.lm.Rd 459290d53c3435026c98a12bb072b497 *man/loessDemo.Rd decfa636a77108a710aba7f4bc36e23d *man/lseq.Rd 93de4f2be93577e5fd9827cadcdb913f *man/mat2tex.Rd 5873be6b49f0fc4a15403f83f73a9656 *man/missingCh.Rd 2354c1ba3878c02499591992e6343cb5 *man/mpl.Rd 28216bd8986545b68d9b2864c1463e15 *man/mult.fig.Rd 01ac9b09b78f3a002ef13ec2a7cddc7f *man/n.code.Rd 1b59a0f1c4740ad78500d195cb0aa37d *man/n.plot.Rd 7df44536e6020f379bfd0618583b9121 *man/nearcor.Rd 63139976748a77241ff080e800279928 *man/nr.sign.chg.Rd 0fb19621eb65c1e0f28f8019733fd359 *man/p.arrows.Rd bde004dd9e970ec7b8b6b2261078908e *man/p.datum.Rd d2f5e8d2dd849bfa59803733ecb4180e *man/p.dnorm.Rd c5fec55fa6c8cb765f26b3b6a93f45dd *man/p.hboxp.Rd 540c3505da5ee5c0983a84d7a57be607 *man/p.profileTraces.Rd f5f94c0b8d8248d216f393d2c4f4d01b *man/p.res.2fact.Rd 86332a7c818ccd70034b4e1ba647cfaa *man/p.res.2x.Rd b0f106196081b0eeb1e1ae8f4c4590ad *man/p.scales.Rd bb8a9dd6fe567286f3747c1dcf639dad *man/p.tachoPlot.Rd cd418d8d300dbde09a1346425d1932c9 *man/p.ts.Rd 6c0ccb8210f8f0b09bc36b4ce60d5220 *man/paste.vec.Rd 6aa2db0194c163f352f175b54db80fb1 *man/pkgDesc.Rd a4bf6c3ebaf4a67c378e3b03f8d6c79c *man/plotDS.Rd 0f8a0b40f8e1bf7e75ac5d2e61d33faf *man/plotStep.Rd aca71df255d8679dfd8890db6ef361e1 *man/polyn.eval.Rd 89c085b0d9db0b114cbd3eaa9a5df3fc *man/posdefify.Rd e6f3999639e01408aabf962f3a595f6c *man/potatoes.Rd 5f9f8f48d63f7569db4dda304b8aba78 *man/pretty10exp.Rd 8105b00a9a43cf5fe29958a2327e0b16 *man/primes.Rd 4c478f18f6cdf79a2814836ae4363fc7 *man/printTable2.Rd ce4d70e480ae39799ab528d90d5de6c8 *man/prt.DEBUG.Rd ec00b18388638da9806a566465d6e5e0 *man/ps.end.Rd 65f23aff7a86d1c3039348c20c99c238 *man/ps.latex.Rd 09cdba33a2a6a9c02566de87ab750e4f *man/quadrant.Rd 50137cb25c3fbb06b2259cf87a033a6e *man/read.org.table.Rd 695315da17053b0a9461832c2cf1f484 *man/relErr.Rd 7fb1f1fd5d83125f0699563c6d0dbb2f *man/repChar.Rd e67d5425ab7ff233223712a92e150d9c *man/rot13.Rd 9eb4b1c5c27e9cda929a144d7f5cc59b *man/rot2.Rd 08e77090f993273040f59e25a4eec79f *man/roundfixS.Rd 2b242ddffbdc912f66501d1944aba8e2 *man/rrange.Rd 13219b81885b1869bb54ee8160d968f9 *man/seqXtend.Rd bf4b568640fa09d77d4ebee56ed883b4 *man/sessionInfoX.Rd ab412268eaa1dc6f3dfd06d883c9d183 *man/sfsmisc-defunct.Rd dc21d6584c6fc06d163d941912f0c66b *man/shortRversion.Rd 2872bc2847f68b1d01aff5966ed71ea8 *man/signi.Rd aa9fa49a5740239ecf3468467956a3e8 *man/sourceAttach.Rd 2658a2f34a55896efac98469172f2012 *man/str_data.Rd 8daffacd134142a2fffb3691eba6f9a2 *man/tapplySimpl.Rd 9fd3e3bd1cb05ea34dbd503774a6d557 *man/tkdensity.Rd cc5417d31ecd64777d09124645e5dcfa *man/toLatex.numeric.Rd 41dbd15b8b65775ea1c8f2b10ae4d064 *man/u.Datumvonheute.Rd 4b4e1b7f34c404258dcad9577c5ea218 *man/u.assign0.Rd 5655b7f3a36b440a890aea93df0883cd *man/u.boxplot.x.Rd e065504c7e7e95e8ee84040cb6cf2796 *man/u.date.Rd 16e689ce58368eab7014c2053f396051 *man/u.datumdecode.Rd a2514a8ae496c191deb921da1b285f7b *man/u.log.Rd ed0a0387325d6fef9df166209efa273e *man/u.sys.Rd b2fe80d0e0ce5047170efde9d7d90dad *man/unif.Rd a47d6a51a729bc2649a128b9a82ba953 *man/uniqueL.Rd 966d8d71d643c54234330ad5f8271914 *man/unix/Sys.cpuinfo.Rd da64aa2c4ed2bf470a71c67fb257358d *man/unix/Sys.ps.Rd 0cff9c548278d10c7cc062f495335c13 *man/unix/pkgLibs.Rd 9a55a48b31382a23af157cd6e72471e3 *man/vcat.Rd a359fd5f303430e840db40a8d88c0e07 *man/wrapFormula.Rd 823cdd617db69384a2c649a41f70a62e *man/xy.grid.Rd 1acc56972f51bf6e8ede412dc3f54dda *man/xy.unique.x.Rd 7eaa71a28dd5fc44c5eeb9fed0a1af17 *tests/dDA.R eef165e671105c305aa07c2324a4fdc6 *tests/dDA.Rout.save 7d55edfad6b694797b4378d3452ff318 *tests/eaxis.R 12b30fde79917ae63e0d98887eaa915d *tests/misc.R 0d1474c2a9ea1b0c12a4b5bd21afa273 *tests/p.R a43879df91dd2e235443b2d27d017aac *tests/p.Rout.save 339af5a2f5c2f9b9da3543ca0eeee87b *tests/posdef.R edc74ea7e43caeea38820d50bc829454 *tests/posdef.Rout.save sfsmisc/inst/0000755000176200001440000000000014117733424012704 5ustar liggesuserssfsmisc/inst/ChangeLog0000644000176200001440000007424512452530121014457 0ustar liggesusers2015-01-05 Martin Maechler * R/prettylab.R (pretty10exp): extended 'sub10' possibilities 2014-07-05 Martin Maechler * DESCRIPTION (Version): 1.0-27, released to CRAN on 2015 <<<<<<< * R/KS-confint.R (ecdf.ksCI): '...' now also passed to first of three plot() calls to plot.stepfun(). 2014-07-01 Martin Maechler * R/prettylab.R (eaxis): sub10 (=FALSE) can be set for pretty10exp() 2014-06-15 Martin Maechler * R/prettylab.R (toLatex.numeric): times="\\cdot" .. from Alain * R/misc-goodies.R (is.whole): new from Alain (May 12). 2014-06-13 Martin Maechler * R/p.res.2x.WSt.R (p.res.2x.formula): new, method for p.res.2x() which is now generic * man/p.res.2fact.Rd: p.res.2x(~., ) now can work 2014-05-02 Martin Maechler * R/prettylab.R (pretty10exp): new 'lab.type' (and 'lab.sep') from Ben Bolker 2014-04-24 Martin Maechler * R/misc-goodies.R (bi2int): new utility, called in as.intBase() * man/digitsBase.Rd: add the IP "n <-> a" example w/ base=256 2014-04-23 Martin Maechler * DESCRIPTION (Version): 1.0-26, released to CRAN on 2014-06-16 * R/prettylab.R (pretty10exp): new 'sub10' option * R/prettylab.R (toLatex.numeric): new, original from Alain 2013-10-14 Martin Maechler * DESCRIPTION (Version): 1.0-25, released to CRAN on 2014-01-24. * R/unix/Sys.ps.R (Sys.memGB): new utility * man/unix/Sys.cpuinfo.Rd: incl example 2013-01-16 Martin Maechler * R/ps.goodies.R (pdf.do): set paper to "special" when user specifies 'width' and 'height'. 2013-01-03 Martin Maechler * DESCRIPTION (Version): 1.0-24, released to CRAN on 2013-08-03. * R/prettylab.R (eaxis): for 'log': new 'between.max = 4'; set 'at.small <- FALSE' in such cases, when small ticks are not sensible. 2012-11-01 Martin Maechler * DESCRIPTION (Version): 1.0-23, released to CRAN on 2012-11-01 * R/misc-goodies.R (digitsBase): ndigits default argument needs fuzz (1e-9), e.g., for base 3. 2012-10-20 Martin Maechler * DESCRIPTION (Version): 1.0-22, released to CRAN on 2012-10-20 * R/ps.goodies.R (dev.latex): oops: finally found and fixed bug where the missing(.) checks where never true, as dev.latex() is always called from above with explicit argument passing. * man/histBxp.Rd: renamed hist.bxp() to histBxp() .. on CRAN's urging. 2012-09-26 Martin Maechler * DESCRIPTION (Version): 1.0-21, released to CRAN today * R/prettylab.R (eaxis): new 'small.args' for Marius 2012-04-18 Martin Maechler * man/unix/Sys.cpuinfo.Rd: fix example 2012-03-18 Martin Maechler * DESCRIPTION (Version): 1.0-20, released to CRAN on 2012-03-18 * man/capture-n-write.Rd: new capture.and.write() function 2011-11-21 Martin Maechler * R/misc-goodies.R (seqXtend): change to enable "interpolate" with 'Date' objects. 2011-10-16 Martin Maechler * DESCRIPTION (Version): 1.0-19, released to CRAN on 2011-11-21 * man/str_data.Rd: + examples for 'filterFUN' 2011-10-08 Martin Maechler * R/str_data.R (str_data): new arg 'filterFUN' 2011-10-03 Martin Maechler * DESCRIPTION (Version): 1.0-18, released to CRAN. * R/prettylab.R (eaxis): fix Rversion check. 2011-10-01 Martin Maechler * R/prettylab.R (pretty10exp): digits.fuzz = 7: add fuzz before rounding, twice. (eaxis): new arg draw.between.ticks = TRUE. 2011-07-29 Martin Maechler * DESCRIPTION (Version): 1.0-17, released to CRAN on 2011-10-01. * R/sourceAttach.R (sourceAttach): new utility function 2011-07-27 Martin Maechler * DESCRIPTION (Version): 1.0-16, released to CRAN. * R/pd-matrix.R (posdefify): symmetric = TRUE is now default, as that's needed for asymmetric input. * R/misc-goodies.R: get completely rid of boxplot.matrix: that's been in R, since 2.9.0 now. 2011-05-27 Martin Maechler * DESCRIPTION (Version): 1.0-15, released to CRAN. * R/misc-goodies.R (errbar): 'ylim' now is argument (with same default). 2011-05-04 Martin Maechler * R/prime-numbers-fn.R: finally prime number and factorization "utility" code (partly ~ 13 years old!) to a place where it's easily found. 2011-04-28 Martin Maechler * R/prettylab.R (eaxis): new argument 'max.at' * man/eaxis.Rd: fix docu for at.small & small.mult. 2011-04-18 Martin Maechler * R/diagDA.R (predict.dDA): check for var()==0 als for pool=FALSE. 2010-12-06 Martin Maechler * DESCRIPTION (Version): 1.0-14 * R/pd-matrix.R (posdefify): new argument 'eigen.m'; for efficiency to pass to eigen() in case it's already available. 2010-11-04 Martin Maechler * R/misc-goodies.R (inv.seq): workaround mapply() infelicity 2010-10-27 Martin Maechler * R/misc-goodies.R (repChar): new utility {generalization of bl.string()} * R/printTable.R (margin2table): return *named* dimnames, if original has them. (print.margin2table): use 'right = TRUE' by default 2010-10-20 Martin Maechler * DESCRIPTION (Version): 1.0-13; "Enhances:" for everything in our examples * inst/NEWS: partial update 2010-09-28 Martin Maechler * demo/hatmat-ex.R: add demo for hatMat(), notably how it works for loess(); rather than extending the examples in * man/hatMat.Rd 2010-09-04 Martin Maechler * R/ps.goodies.R (ps.end): call .set.eps_view() only when needed. * R/zzz.R (.set.eps_view): utility function instead of using .onLoad() for setting options("eps_view"). 2010-08-28 Martin Maechler * DESCRIPTION (Version): 1.0-12 * R/misc-goodies.R (plotDS): fix bug for unsorted x and "moreSmooth" 2010-02-21 Martin Maechler * man/nearcor.Rd: cor() no longer works for factors; --> adapt the old example (from Jens or other users). 2009-12-16 Martin Maechler * man/mat2tex.Rd: need quadruple escapes ( \\\\pi ) 2009-12-14 Martin Maechler * DESCRIPTION (Version): 1.0-10 * R/ps.goodies.R (pdf.do): paper="default", width=-1, height=-1 such as to produce the same default as ps.do(). * man/ps.latex.Rd: update accordingly 2009-11-18 Martin Maechler * DESCRIPTION (Version): 1.0-9, CRAN-released: today * man/polyn.eval.Rd, man/p.ts.R, man/eaxis.Rd: fix \link{}s 2009-10-07 Martin Maechler * R/misc-goodies.R (lseq): check that 'from > 0' 2009-08-10 Martin Maechler * DESCRIPTION (Version): 1.0-8 * R/unix/Sys.ps.R (Sys.procinfo): produce unique names; important for multi-core/processor CPUs. * man/unix/Sys.cpuinfo.Rd: ditto 2009-07-16 Martin Maechler * man/uniqueL.Rd: link to Duplicated 2009-04-16 Martin Maechler * man/Duplicated.Rd: clarification 2009-01-10 Martin Maechler * DESCRIPTION (Version): 1.0-7 ready to release 2009-01-09 Martin Maechler * man/n.code.Rd: Rd_parse fixes * ...., man/u.log.Rd: ditto 2008-12-09 Martin Maechler * R/misc-goodies.R (digitsBase): allow integer-valued non-integers 2008-12-08 Martin Maechler * R/misc-goodies.R: get rid of more `x' like backquotes. 2008-11-25 Martin Maechler * DESCRIPTION (Version): 1.0-6 ready to release * R/prettylab.R (eaxis): change default to las = 1, "2" was a thinko! 2008-11-10 Martin Maechler * R/p.goodies.R (p.profileTraces): default 'subtitle' now includes formula 2008-11-08 Martin Maechler * NAMESPACE: export Sys.meminfo() 2008-10-31 Martin Maechler * DESCRIPTION (Version): 1.0-5 released to CRAN * R/Duplicated.R (Duplicated): new by Christoph Buser and MM * NAMESPACE, man/Duplicated.Rd * R/ellipse.R (ellipsePoints): add 'keep.ab.order' argument * man/ellipsePoints.Rd: allowing differ (a,b) from (b,a); thanks to a suggestion from Duncan Elkins 2008-10-23 Martin Maechler * R/prettylab.R (eaxis): add 'las = 2' (new default!) and "..." 2008-10-22 Martin Maechler * R/misc-goodies.R (boxplot.matrix): "moved" to R 2.9.0 2008-09-15 Martin Maechler * R/misc-goodies.R (uniqueL): make 'need.sort' an optional argument which allows for slight speedup * man/uniqueL.Rd: ditto * R/integratexy.R: no longer use backquote ( ` ) in error messages. 2008-08-05 Martin Maechler * R/str_data.R (str_data): fix bug {if there are no "(..)" in the items, they were all dropped accidentally}. 2008-07-31 Martin Maechler * DESCRIPTION (Version): 1.0-4 released to CRAN * R/zzz.R (.onLoad): set options(eps_view) only if unset 2008-06-28 Martin Maechler * R/misc-goodies.R (chars8bit,strcodes): do not use '0' anymore, since \000 = nul is no longer allowed in R strings. * tests/misc.R: new file, testing the above. 2008-06-26 Martin Maechler * DESCRIPTION (Version): 1.0-3, released to CRAN. * R/ps.goodies.R (pdf.do): default for 'paper' is now missing; which is much better than "default". * man/ps.latex.Rd: add useful example for that. 2008-05-03 Martin Maechler * DESCRIPTION (Version): 1.0-2; add 'Encoding: latin1' 2008-02-01 Martin Maechler * R/unix/Sys.ps.R (Sys.procinfo): define, calling stop(".. not yet..."), for non-Linux unix-alikes * man/unix/Sys.cpuinfo.Rd: ditto 2008-01-30 Martin Maechler * DESCRIPTION (Version): 1.0-1 * NAMESPACE: export Sys.cpuinfo() and Sys.MIPS() only on Linux 2008-01-29 Martin Maechler * R/misc-goodies.R (inv.seq): use "non-integer integers" so result has no "L" appended * man/inv.seq.Rd: all.equal(), not identical anymore 2008-01-11 Martin Maechler * R/prettylab.R (eaxis): no wrong warning when labels are expression 2007-12-21 Martin Maechler * R/misc-goodies.R (inv.seq): slight improvement, using mapply(.) instead of apply(.); notably now returning 'language' instead of 'expression'; the nice improvement (parse |-> call(.)) is by Tony Plate 2007-12-05 Martin Maechler * DESCRIPTION (Version, Depends): 1.0-0 now depending on R >= 2.5.0 2007-11-29 Martin Maechler * R/misc-goodies.R (roundfixS): new utility used to implement new method = "interpolate" in seqXtend(). * man/plotDS.Rd: rename pl.ds() to plotDS() 2007-11-27 Martin Maechler * R/misc-goodies.R (seqXtend): new function, e.g., for constructing extended x ranges for pl.ds() * R/misc-goodies.R: allow an extend 'ys' argument to pl.ds() with smooth values on a finer grid. 2007-11-21 Martin Maechler * DESCRIPTION (Version): 0.96-01; (License): standardized * R/prettylab.R (eaxis): 10^par(.) , not exp() * inst/NEWS: renamed from earlier inst/doc/CHANGES.txt and linked to toplevel; * inst/ChangeLog: moved from ./ChangeLog and sym.linked back to toplevel. * man/eaxis.Rd: add example with "traditional" labels * man/potatoes.Rd: add content to \description{.} to make 'R CMD check' happy 2007-10-13 Martin Maechler * R/prettylab.R (eaxis): new function for nice (log) axis labeling. (pretty10exp): drop.1: -10^k instead of -1*10^k 2007-09-13 Martin Maechler * DESCRIPTION (Version): 0.95-13 tested with R-alpha; for release * man/ps.latex.Rd: document change of pdf.do (on July 13). 2007-09-03 Martin Maechler * R/p.ts.R (p.ts): is.unsorted(date.x, na.rm=TRUE) 2007-07-17 Martin Maechler * R/ps.goodies.R (pdf.do): Bug fix: cannot use 'width= -1, height= -1' as for ps.do() ! 2007-08-14 Martin Maechler * R/nearcor.R (nearcor): new function from Jens Oehlschlaegel. 2007-07-13 Martin Maechler * R/ps.goodies.R (ps.do, pdf.do): do *not* use ps.options(), since you cannot pass all postscript() / pdf() options. 2007-06-30 Martin Maechler * DESCRIPTION (Version): 0.95-12 (released) * R/ps.goodies.R (pdf.end): fix 2007-06-29 Martin Maechler * DESCRIPTION (Version): 0.95-11 * R/unix/Sys.ps.R (Sys.meminfo): added via new Sys.procInfo() * R/zzz.R (options("eps_view")): add 'evince' 2007-06-25 Martin Maechler * DESCRIPTION (Suggests): add 'tcltk' {needed for tkdensity()} 2007-05-23 Martin Maechler * NAMESPACE: Sys.cpuinfo etc: only if(... == "unix") 2007-05-22 Martin Maechler * man/wrapFormula.Rd: new function wrapFormula() mainly for gam() etc. 2007-04-26 Martin Maechler * NAMESPACE: now explicitly export (instead of pattern), keeping predict and print S3 methods hidden. * R/ps.goodies.R (pdf.do, pdf.end, pdf.latex): analogues to ps.do() etc. (dev.latex): instead of ps.latex(); (pdf.latex, ps.latex): now wrappers to dev.latex 2007-04-20 Martin Maechler * man/hatMat.Rd (Examples): add sm.regression(); fix '\' 2007-04-19 Martin Maechler * R/hatMat.R (hatMat): add test for sensible 'trace'; give a warning for unsorted 'x', since that can too quickly give wrong answers (not for the default smoothing spline though). 2007-04-17 Martin Maechler * man/digitsBase.Rd: double the \\ so it appears correctly in help() and example() 2007-03-26 Martin Maechler * R/str_data.R (str_data): use indent.str for multi-data datasets; add note about Gabor's wishlist. 2007-03-15 Martin Maechler * DESCRIPTION (Version): 0.95-9 released * R/tkdensity.R (tkdensity): fix to allow *several* 'kernels' to be specified. (tkdensity): temporarily reset par()s such as par("ask") and only reset when quitting tk widget. * man/tkdensity.Rd: complete unfinished 'nor1mix' example 2007-01-24 Martin Maechler * R/str_data.R: new function; very useful to get overview * man/str_data.Rd: over packages' datasets. * R/Deprecated.R: HuberM() and plotCI() are now *Defunct*, i.e., no longer visible but in file Old_Defunct/ex-Deprecated.R 2007-01-18 Martin Maechler * DESCRIPTION (Version): 0.95-8 to be released * R/ps.goodies.R (ps.end): make sure 'call.gv = FALSE' works 2007-01-17 Martin Maechler * R/p.goodies.R: using rep.int() instead of rep() in a few places. * R/misc-goodies.R: ditto 2006-10-27 Martin Maechler * man/posdefify.Rd: note about litterature 2006-10-19 Martin Maechler * DESCRIPTION (Version): 0.95-7 to be released * R/rnls.R (rnls): becomes defunct -- leave stub in * R/Deprecated.R: * man/rnls.Rd.R: removed, too * R/unix/Sys.ps.R (Sys.PID): removed: has been deprecated for long. * man/unix/Sys.ps.Rd: ditto * R/zzz.R (.onLoad): replace \s by \\s 2006-09-23 Martin Maechler * R/Deprecated.R: remove nna(), digits.v(), digits(), tapply.num(), subtit(), p.triangle(), p.panelL() and p.panelS() --- These have been deprecated since Jan. 2004 (!) * man/Deprecated.Rd: ditto 2006-09-21 Martin Maechler * R/unix/Sys.ps.R (Sys.MIPS): if(.Linux-only.) * man/unix/Sys.cpuinfo.Rd: ditto ==> should "work" on MacOS X 2006-08-18 Martin Maechler * R/mult.fig.R (mult.fig): no longer globally assign 'old.par'. This has been deprecated since 2004-08-12, rel. 0.9-5. 2006-08-16 Martin Maechler * R/rrange.R (rrange): no need for old workaround 2006-06-26 Martin Maechler * R/zzz.R (.onLoad): for "unix": more cautious when 'gv' is not there. 2006-06-22 Martin Maechler * DESCRIPTION (Version, Date): 0.95-5 2006-05-18 Martin Maechler * R/TA.plot.R (TA.plot): slightly better warning in mk.main(); slightly improved defaults {line colors} 2006-04-27 Martin Maechler * R/zzz.R (.onLoad): smarter 'gv' command * R/ps.goodies.R (ps.end): use Sys.ps.cmd() -> work on non-antique Linuxen ! * R/unix/Sys.ps.R (Sys.ps.cmd): newer Linux has 'ps w' too! 2006-02-22 Martin Maechler * DESCRIPTION (Version): 0.95-4 * man/Deprecated.Rd: huberM() now in package "robustbase" * R/Deprecated.R: is deprecated here. * R/huber.R: * man/tkdensity.Rd: if(dev.interactive()) { ... } now suddenly needed for CRAN 2006-01-24 Martin Maechler * DESCRIPTION (Version, Date): 0.95-3 * R/prettylab.R (pretty10exp, axTexpr): new functions 2005-11-23 Martin Maechler * R/misc-goodies.R (digitsBase): return S3 class "basedInt" * R/misc-goodies.R (as.intBase): new; inverse of digitsBase() * R/Deprecated.R (digits): point to digitsBase() {not "baseDigits"}! 2005-11-01 Martin Maechler * DESCRIPTION (Version): 0.95-2 --- RELEASED to CRAN * R/rnls.R (rnls): incorporate changes by Andreas Ruckstuhl (fitted.rnls): new basic methods for S3 class "rnls" 2005-10-16 Martin Maechler * DESCRIPTION (Date): update * R/p.goodies.R (p.arrows): use atan2() instead of 2-arg. atan() 2005-07-11 Martin Maechler * man/p.profileTraces.Rd: 'x' must be 'profile' not 'nls' result 2005-07-01 Martin Maechler * R/glob2rx.R (glob2rx): copied glob2rx() to "R-devel" ==> should be part of R-2.2.x 2005-05-14 Martin Maechler * man/diagDA.Rd: fixed typo: s/i.e./e.g./ 2005-05-12 Martin Maechler * DESCRIPTION (Depends): R (>= 2.0.0) is needed for datasets * R/glob2rx.R (glob2rx): add 'trim.*' arguments, with defaults to be exactly back compatible. 2005-05-10 Martin Maechler * DESCRIPTION (Depends): also on 'methods' and 'utils' * R/tkdensity.R (tkdensity): careful to get stats::density.default for R versions >= 2.2.0; new argument 'kernels' 2005-05-09 Martin Maechler * R/ps.goodies.R (ps.end): use 'ps wx' (no "-") 2005-04-25 Martin Maechler * DESCRIPTION (Version): 0.95-2 * INDEX: updated * man/p.hboxp.Rd: also change default to 'medcol= 2' 2005-04-25 Martin Maechler * DESCRIPTION (Version): 0.95-1 --> CRAN * man/*.Rd: added \encoding{latin1} to quite a few * man/AsciiToInt.Rd: example with Umlaut fails to parse(!) in utf-8 locale -> \dontrun{} it. * R/misc-goodies.R (hist.bxp): new default 'medcol = 2': "medcol = 0" is not sensible for '0 = "transparent"'. * R/mat2tex.R (mat2tex): new arg.s 'nam.center', 'col.center' 2005-04-19 Martin Maechler * man/hatMat.Rd: slight improvement in example 2005-02-17 Martin Maechler * DESCRIPTION (Version): 0.95-0 * NAMESPACE: added a namespace (finally). 2005-02-14 Martin Maechler * R/misc-goodies.R (lseq): new function 2005-01-14 Martin Maechler * R/rnls.R (rnls): new function (from A.Ruckstuhl, Ch.Sangiorgio) still quite a few FIXMEs 2004-12-13 Martin Maechler * DESCRIPTION (Version): 0.9-8 --> CRAN * R/pd-matrix.R (posdefify): fix bug in non-default method "allEVadd"! * tests/posdef.R: new file: test the bug I just fixed (and more). 2004-12-09 Martin Maechler * R/diagDA.R (predict.dDA) (diagDA): fix NA prediction * tests/dDA.R: add check for NA prediction * R/misc-goodies.R (QUnif): typo fixed (checkUsagePackage() !) * R/integratexy.R (integrate.xy): dito * R/TA.plot.R (TA.plot): add `type=' in call to residuals; consequently now also works for some lme() results. 2004-11-05 2004-11-04 Martin Maechler * DESCRIPTION (Version): 0.9-7 * INDEX: updated (and saved to ./INDEX-manual) * R/plot.ts.R (plot.ts): remove! (was for R < 1.2.0 !) * R/lag.plot.R (lag.plot): dito * R/misc-goodies.R: remove "stepun" package in comments; drop more old comments * man/*.Rd: in many man pages, remove \link[<..>]s to old package names. * R/D1D2.R: remove "stepfun" package links * R/KS-confint.R: 2004-09-27 Martin Maechler * DESCRIPTION (Version): 0.9-6 * tests/p.R: new test file {for the fixed bug} * R/p.ts.R: oops; need length-2 start(), end() ! (fix bug introduced for 0.9-5) * man/p.ts.Rd: add SMI 2004-08-12 Martin Maechler * DESCRIPTION (Date): release 0.9-5 to CRAN * R/mult.fig.R (mult.fig): no mentioning of global 'old.par' which is now deprecated! * man/mult.fig.Rd: make sure we work with the return value in the example. * man/D2ss.Rd: extraneous "}" in example - left off last 3/4 * man/cum.Vert.funkt.Rd: fix Rd "extraneous" text 2004-08-09 Martin Maechler * R/misc-goodies.R (sHalton): add 'leap = 1' argument. 2004-08-02 Martin Maechler * man/compresid2way.Rd: add the 'warpbreaks' example which clearly exhibits the following (bug and) fix: * R/twoway-r-plot.R (compresid2way): fix the level labeling in 'if(label)' where "A" and "B" where switched, thanks to Christoph Buser. * DESCRIPTION (Version): 0.9-5 - not yet on CRAN * R/plotCI.R (plotCI): deprecate plotCI() from "sfsmisc", since it is in "gregmisc" which has been on CRAN (but not in existence!) long before "sfsmisc". * R/00a.R eliminated (renamed to R/00a.R.~2~) and created * R/zzz.R instead which has a simple .First.lib(). 2004-07-29 Martin Maechler * R/misc-goodies.R (QUnif): new function for Quasi-Random uniform numbers built on Halton sequences: sHalton(). * man/QUnif.Rd: documentation with nice examples 2004-07-27 Martin Maechler * inst/doc/CHANGES.txt: rather than inst/doc/ChangeLog * R/pd-matrix.R (posdefify): new file and new function * man/posdefify.Rd: dito 2004-05-26 Martin Maechler * DESCRIPTION (Version): 0.9-4 --> CRAN * inst/doc/ChangeLog: new symbolic link to this file * man/p.ts.Rd: new arguments; also new example * R/p.ts.R (p.ts): new arg 'do.x.rug' 2004-05-23 Martin Maechler * R/misc-goodies.R (strcodes): fix, needing 0-origin; also fixes the "offset by 1" bug in AsciiToInt() * man/AsciiToInt.Rd: (adapt example output) 2004-04-05 Martin Maechler * R/p.ts.R (p.ts): new arguments 'date.x', 'do.x.axis', 'ax.format' and 'xlab' 2004-03-09 Martin Maechler * R/misc-goodies.R (empty.dimnames): use lapply() 2004-02-25 Martin Maechler * R/p.res.2x.WSt.R (p.res.2x): new default 'scol = 2:3' new arguments xlim, ylim. * man/p.res.2x.Rd: dito 2004-02-24 Martin Maechler * DESCRIPTION (Depends): 1.8.x because of regexpr(*, fixed=TRUE) in ps.end() * R/p.res.2x.WSt.R (p.res.2x): new 'main' argument with default 'z' * man/p.res.2x.Rd: dito * man/p.res.2fact.Rd: dito 2004-02-23 Martin Maechler * DESCRIPTION (Version): 0.9-3 * man/tkdensity.Rd: try for working tcltk 2004-02-18 Martin Maechler * R/TA.plot.R (n.plot): fix non-default 'log = ".."' * R/p.res.2x.WSt.R (p.res.2x): allow scol[1:2} * man/p.res.2x.Rd: dito; + example 2004-02-07 Martin Maechler * DESCRIPTION (Version): 0.9-2 * R/unix/Sys.ps.R: put my Sys.* to unix-only directory - no way for Windows * man/unix/ : put Sys.ps.Rd and Sys.cpuinfo.Rd there * R/u.goodies.R (u.date): make OS-independent, using Sys.time() (u.Datumvonheute): dito * R/ps.goodies.R (ps.end): check for non-Unix and gracefully exit in that case. 2004-02-05 Martin Maechler * R/ps.goodies.R (ps.end): try better to find file name. 2004-02-04 Martin Maechler * DESCRIPTION (Version): 0.9-1 (for first CRAN release) 2004-02-03 Martin Maechler * R/twoway-r-plot.R: new version of old p.two.forget(), from Werner Stahel, called compresid2way(). 2004-01-12 Martin Maechler * R/Ftest-rlm.R (f.robftest): now returns object of class "htest" * DESCRIPTION (Version): 0.9-0 * R/ps.goodies.R (ps.end): command = getOption("eps_view") * R/misc-goodies.R: renamed tapply.num() to tapplySimpl() and use same arguments as tapply(). move p.panel[LS] to ./Deprecated.R * man/tapplySimpl.Rd: new * man/col01scale.Rd : new 2004-01-11 Martin Maechler * R/p.goodies.R: removed p.tst.dev(); deprecated p.triangle() 2004-01-05 Martin Maechler * R/misc-goodies.R: remove test.par() -> ~/R/MM/GRAPHICS/par-misc.R * R/D1D2.R (D1tr, D1ss): renamed d1() to D1tr(), D1() to D1ss(); to get some consistency. * man/D2ss.Rd (D2ss): newly these. 2004-01-03 Martin Maechler * man/AsciiToInt.Rd: new * man/Deprecated.Rd: new; with digits(), 'digits.v' and 'nna' * R/Deprecated.R: 2003-12-15 Martin Maechler * R/ps.goodies.R (ps.do), ps.latex(), ps.end(): get rid of old S-plus color and iso.latin1 stuff 2003-12-10 Martin Maechler * R/misc-goodies.R (table.mat): dropped this (undocumented) function 2003-12-03 Martin Maechler * R/misc-goodies.R (uniqueL): new utility function 2003-12-02 Martin Maechler * R/Sys.ps.R (Sys.ps): better test for "ALL" (warning); (Sys.PID): deprecated {use Sys.getpid() !} 2003-11-21 Martin Maechler * R/diagDA.R (dDA): new function with returns fit of class `dDa'; gets print() and predict() methods. Improve functionality such that it works for single point clusters. * man/Sys.ps.Rd: codoc( use.values = NULL) inconsistency fixes * man/ps.end.Rd: * man/ecdf.ksCI.Rd: * R/TA.plot.R (n.plot): naming ok with data.frames; `col=' argument 2003-11-18 Martin Maechler * R/diagDA.R (diagDA): new: Diagonal Discriminant Analysis = improvement of stat.diag.da() from 'sma' 2003-08-13 Martin Maechler * man/u.boxplot.x.Rd: new * R/misc-goodies.R: boxplot.matrix(): `use.cols' instead of `cols' * man/boxplot.matrix.Rd: 2003-07-14 Martin Maechler * R/plotCI.R (plotCI): new arguments `type' and `log'. * R/tkdensity.R (tkdensity): new `do.rug' argument with sensible default 2003-06-13 Martin Maechler * R/smad.R (huber): improved again: gives (NA,NA) when y has NAs only. 2003-06-10 Martin Maechler * R/rrange.R (rrange): new argument `na.rm = TRUE' * man/rrange.Rd: 2002-12-01 Martin Maechler * R/TA.plot.R (TA.plot): now works with specified (or default!) `ylab' 2002-11-30 Martin Maechler * R/TA.plot.R (n.plot): fix for omitted `ylab' => TA.plot() shows residuals (again!). Use xy.coords() instead of home-made * R/p.goodies.R: drop p.hboxp: Rather use boxplot(*, horizontal=TRUE, add=TRUE) Also drop p.clear() 2002-11-11 Martin Maechler * DESCRIPTION (Version): 0.8-5 * quite a few new man pages (+clean) since Oct; see also ./SfS-changes `only' CMD check warning of 39 undocu. functions 2002-10-01 Martin Maechler * Version 0.8-0 : ``released'' on ftp://stat.ethz.ch/U/maechler/R/ * several man fixes; dropped old "SfS" stuff, see ./SfS-changes * DESCRIPTION (Package): new "sfsmisc" (from internal "SfS") 2002-06-19 Martin Maechler * TODO-MM: new * R/ellipse.R (ellipsePoints): new (from Martin's ..) * man/ellipsePoints.Rd: * R/TA.plot.R (n.plot): add `cex' explicitly; finally : * man/n.plot.Rd: new * R/TA.plot.R (TA.plot): changed some col/lty/lwd defaults (Ruth Meili's hint) and made these arguments (`par0line',..) 2002-05-17 Martin Maechler * INDEX: updated (via build) and manually edited * R/hatMat.R (hatMat): allow matrix predictors `x' 2002-04-30 Martin Maechler * R/tkdensity.R (tkdensity): finally made working again, using tclVar() and tclvalue(.). 2002-04-23 Martin Maechler * R/mult.fig.R: add "line.main" argument, shifting down 1/2 by default. 2002-04-17 Martin Maechler * R/p.goodies.R (p.tst.dev): fix function, now works 2001-05-21 Martin Maechler * DESCRIPTION (Title): a bit shorter (Version): upped to 1.0-2 sfsmisc/inst/NEWS.Rd0000644000176200001440000004147014116665241013755 0ustar liggesusers% Check from R: % news(db = tools:::.build_news_db_from_package_NEWS_Rd("~/R/Pkgs/sfsmisc/inst/NEWS.Rd")) \name{NEWS} \title{News for \R Package \pkg{sfsmisc}} \encoding{UTF-8} %%% TODO: %% \item New \code{rDatetime()} for random date/time sequences %% within a specified time range. \section{CHANGES in sfsmisc VERSION 1.1-12 [2021-09-10]}{ \subsection{NEW FEATURES}{ \itemize{ \item new \code{helppdf(topic)} mostly for interactive use. } } \subsection{BUG FIXES}{ \itemize{ \item \code{shortRversion()} \emph{still} failed with \code{"RC"}. \item \code{relErrV(x1, x2)} now works when both objects are of length zero, but no longer when only one of them is. } } %% \subsection{DEPRECATED & DEFUNCT}{ %% \itemize{ %% \item %% } %% } } \section{CHANGES in sfsmisc VERSION 1.1-11 [2021-04-03]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{sessionInfoX(TRUE)} now choose chooses \emph{all} loaded packages (which were accidentally chosen since 1.1-9, see the bug fixes). } } \subsection{BUG FIXES}{ \itemize{ \item \code{sessionInfoX()} no longer (since 1.1-9, accidentally) chooses \emph{all} packages. \item The \code{nearcor()} tests are less platform dependent. } } \subsection{DEPRECATED & DEFUNCT}{ \itemize{ \item \code{u.assign0()} and \code{u.get0()} are defunct now. } } } \section{CHANGES in sfsmisc VERSION 1.1-10 [2021-03-29]}{ \subsection{BUG FIXES}{ \itemize{ \item \code{shortRversion()} no longer fails for "beta" or "RC" status. } } } \section{CHANGES in sfsmisc VERSION 1.1-9 [2021-03-22]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{sessionInfoX()} now also reports \code{grSoftVersion()} and, when \pkg{tcltk} is loaded, \code{tclVersion()}. %% partly TODO: not yet giving deprecation warning \item \code{repChar()} is deprecated in favour of \R (>= 3.3.0)'s \code{\link{strrep}()}. \item new \code{shortRversion()} (from an old \R script of mine). \item new \code{relErrV()} and \code{relErr()}, improved from the \CRANpkg{Matrix} package \file{test-tools.R} } } } \section{CHANGES in sfsmisc VERSION 1.1-8 [2021-01-06]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{isRshared()} has been \dQuote{factorized out} of \code{sessionInfoX()}, as it maybe useful elsewhere, e.g., in \code{\link{Startup}} code setting \code{\link{.libPaths}()}. \item New utilities \code{pkgDesc()} and \code{pkgBuilt()}, giving named \code{character} result of \code{packageDescription()}. } } \subsection{BUG FIXES}{ \itemize{ \item \code{sessionInfoX()}'s \code{isRshared()} is now based on \code{tools::Rcmd()} instead of \code{system()}, so possibly slightly more portable. \item Fixed not-yet--as-cran \file{NOTE} about undeclared packages in Rd xrefs. } } } \section{CHANGES in sfsmisc VERSION 1.1-7 [2020-05-05]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{eaxis()} gets new option \code{equidist.at.tol = 0.002}, previously hardwired to 0.001. \item \code{seqXtend(, *, "interpolate")} now also works with changed \code{base::c.Date()} from R(4.1.0)-devel. } } } \section{CHANGES in sfsmisc VERSION 1.1-6 [2020-04-04]}{ \subsection{BUG FIXES}{ \itemize{ \item \code{pkgLibs()} now works on macOS, thanks to a hint by Brian Ripley. } } } \section{CHANGES in sfsmisc VERSION 1.1-5 [2020-02-06]}{ \subsection{NEW FEATURES}{ \itemize{ \item on Unix-alikes export new \code{pkgLibs()} utility even though its API may change. } } \subsection{Tweaks}{ \itemize{ \item replace \code{class(.) != ".."} in a \emph{comment}, just for source code purity ;-) } } \subsection{BUG FIXES}{ \itemize{ \item Regression tests should not show differences, even when a version of R crippled by \code{--no-long-double} is used. \item examples now use \code{tempfile()}. } } } \section{CHANGES in sfsmisc VERSION 1.1-4 [2019-04-25]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{eaxis()} gets new optional argument \code{use.expr} in order to force use of \code{pretty10exp()} in a non-log case where non-exponential format would be used. \item \code{sessionInfoX()} now also returns an element \code{isRshared}, and its \code{print()} method prints that and the \code{pcre_config()} information on the PCRE. \item \code{TA.plot()} now also works for \code{lmer()} results (\code{S4} objects, not \code{list}s). } } } \section{CHANGES in sfsmisc VERSION 1.1-3 [2018-11-26]}{ \subsection{Tweaks}{ \itemize{ \item \file{DESCRIPTION} update, contains ORCID. \item \file{README.md} links to blog post on (17 yr old -> GH) } } \subsection{BUG FIXES}{ \itemize{ \item \code{read.org.table()} thinko (\code{grep()}). \item \code{read.org.table(*, encoding=)} notably to work for UTF-8 files. \item \code{pretty10exp(*, lab.type="latex")} works better, notably for non-trivial \code{sub10}. } } } \section{CHANGES in sfsmisc VERSION 1.1-2 [2018-03-05]}{ \subsection{NEW FEATURES}{ \itemize{ \item new \code{funEnv()} utility: \code{list()}-like construction of a set of functions (and more) which all share the same environment. \item Using \code{Authors@R} in \file{DESCRIPTION} and so finally honor the many contributors by listing them. \item Requiring R >= 3.2.0, so we can use \code{\\CRANpkg{.}} in help files. } } \subsection{BUG FIXES}{ \itemize{ \item \code{histBxp()} no longer evokes a warning from \code{hist.default()}. \item \code{digitsBase(0)} now works. } } } \section{CHANGES in sfsmisc VERSION 1.1-1 [2017-06-08]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{sessionInfoX()} now also reports \code{capabilities()} (and more, depending on \R's version). \item \code{mult.fig()}'s default for \code{mgp} now adapts to a non-default value of \code{par("las")}. \item \code{eaxis()} gets new options \code{axp} and \code{n.axp} for more flexible automatic tick marks. } } \subsection{BUG FIXES}{ \itemize{ \item \code{integrate.xy()} is more careful in matching "data" with grid points, thanks to a bug report by Loraine Liping Seng. } } } \section{CHANGES in sfsmisc VERSION 1.1-0 [2016-02-22]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{primes()} has optional \code{pSeq} argument, surprisingly with no known benefit. \item tweaks for \code{xy.unique.x()} speedup. \item \code{QUnif(..., p, ...)} now works for large \eqn{p} (and gets a \code{silent} option to suppress the message). } } \subsection{BUG FIXES}{ \itemize{ \item Fix the \code{tkdensity()} bug introduced on 2015-07-22, hence, for \pkg{sfsmisc} versions \code{1.0-28} and \code{1.0-29}, with the \dQuote{codetools cleanup}. } } } \section{CHANGES in sfsmisc VERSION 1.0-29 [2016-01-22]}{ \subsection{NEW FEATURES}{ \itemize{ \item new function \code{read.org.table()} to read emacs \file{org} files via \code{\link{read.table}()}. \item new \code{loessDemo()}, providing a version of an old \code{loess.demo()}. \item new \code{sessionInfoX()} utility (with \code{print()} method). } } \subsection{BUG FIXES}{ \itemize{ \item (workaround R (<= 3.2.2) bug:) the (invisible) return value \code{str_data()} no longer contains extraneous \code{NULL} entries in the filtering case. } } } \section{CHANGES in sfsmisc VERSION 1.0-28 [2015-08-06]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{tkdensity()} is tweaked such as to look more standard to \pkg{codetools}; \item similarly (much less) for \code{factorize()} and \code{roundfixS()} \item new \code{demo("pretty-lab")} } } \subsection{BUG FIXES}{ \itemize{ \item also import from "base" packages \item \code{pretty10exp(*, lab.type = "latex")} typo fixed; \code{eaxis()} works better with \code{lab.type = "latex"}, both thanks to David Seifert. } } } \section{CHANGES in sfsmisc VERSION 1.0-27 [2015-01-05]}{ \subsection{Repository}{ \itemize{ \item Moved sources to Github (\url{https://github.com/mmaechler/sfsmisc}), on Aug. 9, 2014, from years of emacs backups and a few RCS \dQuote{archives}. Blogged about it on \url{http://mmaechler.blogspot.ch/}. } } \subsection{NEW FEATURES}{ \itemize{ \item New \code{missingCh()} utility, also for didactical purposes; \item new \code{rotn()} "utility". \item \code{eaxis()} gets an optional \code{sub10} argument. \item \code{mat2tex()} gets new option \code{envir = "tabular"}. } } \subsection{BUG FIXES}{ \itemize{ \item \code{cairoSwd()} adapted to new Sweave conventions. } } } \section{CHANGES in sfsmisc VERSION 1.0-26 [2014-06-16]}{ \subsection{NEW FEATURES}{ \itemize{ \item new \code{is.whole()} to test if numbers are integer valued. \item new \code{cairoSwd()} from Alain Hauser (not yet exported). \item new \code{bi2int()} utility (called from \code{as.intBase()}) with a nice IP numbers transformation example. \item \code{toLatex.numeric()} gets \code{times} arg (from Alain). \item \code{pretty10exp()} gets new args \code{lab.type} and \code{lab.sep} from Ben Bolker. } } \subsection{BUG FIXES}{ \itemize{ \item not using \code{prt.DEBUG()} anymore ourselves, as it has been deprecated. } } } \section{CHANGES in sfsmisc VERSION 1.0-25 [2014-01-24]}{ \subsection{NEW FEATURES}{ \itemize{ \item better docu on \code{Sys.cpuinfo()} } } \subsection{BUG FIXES}{ \itemize{ \item finally deprecate \code{prt.DEBUG()} } } } \section{CHANGES in sfsmisc VERSION 1.0-24 [2013-08-03]}{ \subsection{BUG FIXES}{ \itemize{ \item Deprecate u.assign0() as globalenv assignment is mostly deprecated, and the S <-> R compatibility is unneeded now. \item ps.do() and pdf.do() are now closures with their own file name. ==> no globalenv assignment needed anymore. } } } \section{CHANGES in sfsmisc VERSION 1.0-13 [2010-10-20]}{ \subsection{NEW FEATURES}{ \itemize{ \item new \code{demo(hatMat)} being more explicit than \code{?hatMat} } } } \section{CHANGES in sfsmisc VERSION 1.0-12 [2010-09-04]}{ \subsection{BUG FIXES}{ \itemize{ \item \code{plotDS()} bug fix } } } \section{CHANGES in sfsmisc VERSION 1.0-11 [2010-02-22]}{ \subsection{BUG FIXES}{ \itemize{ \item fix nearCor() example } } } \section{CHANGES in sfsmisc VERSION 1.0-10 [2009-12-16]}{ \subsection{BUG FIXES}{ \itemize{ \item pdf.do() with better defaults [ ==> compatible to ps.do() ] } } } \section{CHANGES in sfsmisc VERSION 1.0-9 [2009-11-18]}{ } \section{CHANGES in sfsmisc VERSION 1.0-8 [2009-08-10]}{ } \section{CHANGES in sfsmisc VERSION 1.0-7 [2009-01-10]}{ } \section{CHANGES in sfsmisc VERSION 1.0-6 [2008-11-25]}{ \subsection{NEW FEATURES}{ \itemize{ \item new Sys.meminfo() \item p.profileTraces() improved; eaxis() } } } \section{CHANGES in sfsmisc VERSION 1.0-5 [2008-11-01]}{ \subsection{NEW FEATURES}{ \itemize{ \item new Duplicated() \item ellipsePoints() improvements \item eaxis() improvements } } \subsection{BUG FIXES}{ \itemize{ \item str_data() buglet } } } \section{CHANGES in sfsmisc VERSION 1.0-4 [2008-07-31]}{ } \section{CHANGES in sfsmisc VERSION 1.0-3 [2008-06-26]}{ \subsection{NEW FEATURES}{ \itemize{ \item pdf.do() has better default behavior. } } } \section{CHANGES in sfsmisc VERSION 1.0-2 [2008-05-03]}{ } \section{CHANGES in sfsmisc VERSION 1.0-1 [2008-01-30]}{ \subsection{BUG FIXES}{ \itemize{ \item Encoding (latin1), and other platform issues \item inv.seq() and eaxis() improvements } } } \section{CHANGES in sfsmisc VERSION 1.0-0 [2007-12-10]}{ \subsection{NEW FEATURES}{ \itemize{ \item plotDS() is new name for pl.ds() now allows 'ys' to be a smooth "fit structure". That is now easily constructed via \item new seqXtend() function for constructing a sequence which includes a give set of numbers x. \item y <- roundfixS(x) yields integers y[i] with the same sum as x[i]. } } } \section{CHANGES in sfsmisc VERSION 0.96-01 [2007-11-21]}{ \subsection{NEW FEATURES}{ \itemize{ \item new function eaxis() for "engineering" / "extended" axis drawing, notably for log-axis labeling } } } \section{CHANGES in sfsmisc VERSION 0.95-13 [2007-09-13]}{ \subsection{NEW FEATURES}{ \itemize{ \item new function nearcor() {find nearest correlation matrix}; almost as donated by Jens Oehlschlaegel. } } \subsection{BUG FIXES}{ \itemize{ \item pdf.latex(), pdf.do() : defaults; viewer specifications... } } } \section{CHANGES in sfsmisc VERSION 0.95-12 [2007-06-30]}{ \subsection{NEW FEATURES}{ \itemize{ \item New internal Sys.procinfo() function for cleaner implementation of Sys.cpuinfo() and Sys.meminfo(). } } } \section{CHANGES in sfsmisc VERSION 0.95-10 [2007-06-25]}{ \subsection{NEW FEATURES}{ \itemize{ \item new pdf.do(), pdf.end(), pdf.latex()), as analogues to ps.do() etc, \item implemented as wrapper to new dev.latex() utility function (dev.latex): instead of ps.latex(); (pdf.latex, ps.latex): now wrappers to dev.latex } } } \section{CHANGES in sfsmisc VERSION 0.95-9 [2007-03-15]}{ } \section{CHANGES in sfsmisc VERSION 0.95-8 [2007-01-18]}{ } \section{CHANGES in sfsmisc VERSION 0.95-7 [2006-10-19]}{ } \section{CHANGES in sfsmisc VERSION 0.95-6 [2006-06-26]}{ } \section{CHANGES in sfsmisc VERSION 0.95-5 [2006-06-22]}{ } \section{CHANGES in sfsmisc VERSION 0.95-4 [2006-02-26]}{ } \section{CHANGES in sfsmisc VERSION 0.95-3 [2006-01-25]}{ } \section{CHANGES in sfsmisc VERSION 0.95-2 [2005-11-03]}{ } \section{CHANGES in sfsmisc VERSION 0.95-1 [2005-04-25]}{ \subsection{NEW FEATURES}{ \itemize{ \item rnls() for robust nonlinear regression; lseq() {seq() on log scale} utility \item now has a NAMESPACE } } } \section{CHANGES in sfsmisc VERSION 0.9-8 [2004-12-14]}{ \subsection{BUG FIXES}{ \itemize{ \item TA.plot() now also works for lme() results. } } } \section{CHANGES in sfsmisc VERSION 0.9-7 [2004-11-04]}{ \itemize{ \item Depends on R 1.9.0 (was effectively the case earlier): Removing old package names "modreg", "stepfun", etc } } \section{CHANGES in sfsmisc VERSION 0.9-6 [2004-09-27]}{ \itemize{ \item bug fix in p.ts(): case of start(.) of length 2 } } \section{CHANGES in sfsmisc VERSION 0.9-5 [2004-08-12]}{ \subsection{NEW FEATURES}{ \itemize{ \item new posdefify(m) returns a positive definite matrix close to 'm' \item New QUnif() and sHalton() for quasi-random number generation } } \subsection{BUG FIXES}{ \itemize{ \item fixed labeling bug in compresid2way(). } } \subsection{DEPRECATED & DEFUNCT}{ \itemize{ \item mult.fig()'s global assignment to 'old.par' is now deprecated. do work with op <- mult.fig(...)$old.par instead !! \item plotCI() is now deprecated -- use the one from package "gregmisc"! } } } \section{CHANGES in sfsmisc VERSION 0.9-4 [2004-05-26]}{ \itemize{ \item p.ts() allows date-time objects for x-axis labeling, with new arguments 'date.x', 'do.x.axis', 'do.x.rug', 'ax.format' and 'xlab' \item strcodes() had a bug (offset by 1) which also lead to one in AsciiToInt() \item p.res.2x() has new arguments 'xlim', 'ylim', 'main' and a new default for 'scol' (= 2:3). } } \section{CHANGES in sfsmisc VERSION 0.9-3 [2004-02-23]}{ \itemize{ \item p.res.2x() allows 'scol' of length 2. \item n.plot() fixed the "log = .." (non-default) option. } } \section{CHANGES in sfsmisc VERSION 0.9-2 [2004-02-07]}{ \itemize{ \item put Sys.*() functions into unix-only directory \item ps.end() tries behaves better for non-unix finding the file \item u.date() becomes OS-independent. } } \section{CHANGES in sfsmisc VERSION 0.9-1 [2004-02-04 -- 1st CRAN ver.!]}{ \itemize{ \item new function compresid2way() from Werner Stahel. \item f.robftest() now returns an object of class "htest" \cr \cr %% FIXME: It seems wrong that this cannot be put into a final \note{.} %% tools:::.build_news_db_from_package_NEWS_Rd("~/R/Pkgs/sfsmisc/inst/NEWS.Rd") \item For more details, see the \file{ChangeLog} file! } }