locfit/0000755000176200001440000000000014750166261011542 5ustar liggesuserslocfit/README0000754000176200001440000000033214745724400012421 0ustar liggesusersA note about license: Earlier versions of locfit had a license which restricted usage. The code was re-licensed by Prof. Loader in a version sent to Andy Liaw in 2005 from which this CRAN distribution is derived.locfit/MD50000644000176200001440000002301614750166261012054 0ustar liggesusers7a18160041fa65142ca01cb31d859211 *DESCRIPTION 0a347c326f1f957b78b62b9b57cc783f *NAMESPACE cfb753adc26c57e1a349ba5a0ce83938 *NEWS c69fccb19975aaf5f91b8a35f5761819 *R/firstlib.r a5a1fcf4582dffc3e8548feeefb86d26 *R/locfit.r 99484753a0890e12e6e96722d617f012 *README b401b88bd87bf18f03dd1bfe4cb0f544 *data/ais.rda 0e01701b1a2baf4035fa5ee2a40a5115 *data/bad.rda 4d5540425583246fcdb9c7713dc98147 *data/border.rda 78fae8ff7fdb08a6dbd6424791e6b0f4 *data/chemdiab.tab.gz 3576b10fda18fda073e1d12308c5b561 *data/claw54.rda f96f0aa6b0e3fb819f1fbb9f2fb349a9 *data/cldem.tab.gz bdc4bb78d8195eaa3d43dd9fd8deacb3 *data/cltest.rda 39bdb06a8bbd7bdfd9a7b5e091e4e895 *data/cltrain.rda d10e3aa9623f50de74b9eaf68c4a8fc2 *data/co2.rda ae992d05caede34a7ade68e66b9f2985 *data/diab.tab.gz db80279a53d30f298cddf218c8d11765 *data/ethanol.rda d1ac1b4a04a644bb3e8e947a70c8022c *data/geyser.rda 2cc4f4b666121501f90ac9ed037feb9b *data/geyser.round.tab.gz 779863c4e14b64c83f559d95f4102a84 *data/heart.rda d8172619746fcdafe2e4dfb7302d8796 *data/insect.tab.gz 6faefe2b6973faa2f0ee4648acc30ec4 *data/iris.rda 58efd88dde65f956dbd31e494006bb72 *data/kangaroo.rda 124f014a5c246612ada98ccc6aa2beb8 *data/livmet.rda a7c089ef50abcc4f5a6a0193560db5ff *data/mcyc.tab.gz 719fcbfe1c2b06cb6abd948e84573162 *data/mine.rda 313c0c35e65c97e6223845064bcda53b *data/mmsamp.tab.gz a5a75a58203023b2418061c54c9156e1 *data/morths.rda 6f097baf489800c858ff3e080fa4999b *data/penny.tab.gz dbbc7d95a7dc9325b33374328327e3f3 *data/spencer.rda 89542898fce618ea54521119b431033a *data/stamp.rda 814c2e8cdba028f0d6081d35e50612b5 *data/trimod.tab.gz 5cf8d15b6c46d57690553a737236d03f *man/aic.Rd 5dab5a6e6365d919ec08492e7faf648d *man/aicplot.Rd 954f29ff1bf17286c18fe79c4d4f5d9f *man/ais.Rd 2789e611a8a5df326057c63e447a0f5b *man/ang.Rd 0caea3418dc21ea27027ed1a13c8b8df *man/bad.Rd 7baaaed94d553b0f7605c041769b9308 *man/border.Rd 310b76d87bc13ff514e1fc5bac2cb0fb *man/chemdiab.Rd 918ebffe60cf1c0415ad1a9b85fed809 *man/claw54.Rd 60cc9b47b805d370e39f518dd19205ad *man/cldem.Rd 21c6dc9f3759ed8484fb2dbd01f584ad *man/cltest.Rd 1ce68b975b1210cdfe20d21bf4264b30 *man/cltrain.Rd 470f7796bfeb47d6d245f14dcdfa1362 *man/co2.Rd 823e78796709b909d1b1befbb30c4dce *man/cp.Rd 05f2a0e9f0b81eb31121d79856944b26 *man/cpar.Rd f474b740ced38a360b1c0acb8a9e2351 *man/cpplot.Rd ef45cddcddf448c1a4a033401edfd8bc *man/crit.Rd 23a4309995fd9dd0ced50945511813fa *man/dat.Rd aa7d39e0819a1c6cae9ee7bd1b681cdc *man/density.lf.Rd 0c38114c896e38406924a70c6775bb12 *man/diab.Rd 8af2c41c0995904721b93efb07631c88 *man/ethanol.Rd 707e6e02cf3606f48feae25dc1be73a8 *man/expit.Rd fdd51fad86d1e29dc661339bf59b1472 *man/fitted.locfit.Rd 432191f49dfe798456fa9e56c8330479 *man/formula.locfit.Rd 2e317782016985f49007975d4c024437 *man/gam.lf.Rd 296b84c449c3d791310cdb18e836b28c *man/gam.slist.Rd f131db9d1599dbe8121afd786013d2ed *man/gcv.Rd 4222feca217d6655ab7c1a480e7fe083 *man/gcvplot.Rd acd55d510b22c69b08e2dd4760f9d402 *man/geyser.Rd e5fc50f31c44859555f9102c35298432 *man/geyser.round.Rd 8cc1bb722a5a21ef0f640074b396d661 *man/hatmatrix.Rd e341e4ffc43f9d6986514df4358a20f4 *man/heart.Rd 248d51e226e6fc4fdd674369196162fe *man/insect.Rd 96301d68bac849f992732e32c762d360 *man/iris.Rd 199232da51ae89813ab39cc981d7d809 *man/kangaroo.Rd 65bba0f79f42887f58fc9a7298f5ba03 *man/kappa0.Rd 16c623260bf7cdf5d83fd95ebc0c3384 *man/kdeb.Rd 8e9bd1be75632d0eea238e948c3048e4 *man/km.mrl.Rd 8107521265d13841bc1c01e09008a717 *man/lcv.Rd 8e66b4d57784d66d0b293d2b7489bc59 *man/lcvplot.Rd 1db2cefb09fc34162068501bb9d8d2e5 *man/left.Rd 66b0b9f5b8d6dc6dd1826829bf68283d *man/lf.Rd 9aff1782414e5ea27e3c8699c67428a5 *man/lfeval.Rd b59099e635e0fc955669fb6cf9be0ea2 *man/lfgrid.Rd b78f066f54d8fc870e224d9a93744d24 *man/lfknots.Rd 18ee87a3368a87547b21f48effe1f44c *man/lflim.Rd 81f13d1921e99b376eac592a424ed893 *man/lfmarg.Rd 845d6c03e50557254cacfd8f8aa2c8c1 *man/lines.locfit.Rd f3e95d461e8822cbd9f12564d0af30b7 *man/livmet.Rd 527c29c0873e5d783ff0d4deaca1eaa6 *man/locfit.Rd cc8fbf6c052275d8b3604cc70c509f9e *man/locfit.censor.Rd 0014077c83b12dead053f70cbf50767a *man/locfit.matrix.Rd 527f5f81644050bc642ce11fb5a014fd *man/locfit.quasi.Rd 587b8abf4d85f594ef45d1031955951c *man/locfit.raw.Rd 73581436fec2d93a666c6c3b43be3b41 *man/locfit.robust.Rd 3fd27a82384556dfec015f21f50d39b4 *man/lp.Rd 9342bb1e57ee297e72f5934a090893aa *man/lscv.Rd 6b50ee2cc908c116fbfa43d7960db146 *man/lscv.exact.Rd 6eb960057e2b3eb8babc44cd0d733fab *man/lscvplot.Rd e7ab6ab5040238ccabfe117a3adbb9d5 *man/mcyc.Rd e6ae9d9ffe06cdf0179938b6d9121351 *man/mine.Rd e20eaf737499119779622dd32da95b71 *man/mmsamp.Rd 56e929091794f325b01ea028e46c48d2 *man/morths.Rd 77fb7265f9cd2455450714e528b7a4a6 *man/none.Rd 9af7829853dcd04d7f124a2c48e28f4a *man/panel.locfit.Rd fe700b7b9b12338ff9a673f21c302617 *man/panel.xyplot.lf.Rd 73cf6adf73d81884e805b187e78367bb *man/penny.Rd b3fc993ca221d1f8889e6fae4a7b034e *man/plot.eval.Rd abaad4805a246f0eab1829925e8533f1 *man/plot.gcvplot.Rd 7f76752803ce84ec8ef86585e6de1a8a *man/plot.lfeval.Rd 1d23b35648d976047e5c27adf5b35786 *man/plot.locfit.1d.Rd a3e14a6c1cd14207f6ec7ebf842be3cc *man/plot.locfit.2d.Rd ceb6594274f4a0cd2dffec6ddd51288f *man/plot.locfit.3d.Rd 028241043c76ec38ff84c2f4a403c041 *man/plot.locfit.Rd 6a49423a780c81e78c7025e16be3bae3 *man/plot.preplot.locfit.Rd ad305a3de59f6b8408e894599924e22a *man/plot.scb.Rd 18ab8b61a2600413173b1c25b3bd359f *man/plotbyfactor.Rd 3d6f0b014dff6d69d316e50b28d9d727 *man/points.locfit.Rd 20894697139bac13aa9271168de10f71 *man/predict.locfit.Rd 32d9271a6e7ae5611a9e1656819bc2f3 *man/preplot.locfit.Rd 252ce4a6289a45818a27b1ff8daabb40 *man/preplot.locfit.raw.Rd 4b54bfb7a2558e151fcbfbcc85842757 *man/print.gcvplot.Rd eae256cdfb3886c41962387441c3e708 *man/print.lfeval.Rd de08437d80c2f2a4ab8d60157adac649 *man/print.locfit.Rd 7fe0b9770301085afe2f5aeb1f1cb8d5 *man/print.preplot.locfit.Rd 72d7f9c7b5a14315aefe13e1cc6bd5c1 *man/print.scb.Rd ff83c07fc2fad449383b36a2d018e80c *man/print.summary.locfit.Rd 26ff201ba1102321ad24b910a03ae9e0 *man/rbox.Rd 0f1bd575d1ead0dd28b709dc1c0ffb10 *man/regband.Rd d7ee4b04d7ae1359101c97b64b6f5f9e *man/residuals.locfit.Rd 8515f17ca547b649044a4ef0db4689e0 *man/right.Rd 6a37aa14781c85085a3e05177e5ab781 *man/rv.Rd cc087351c25a5208294428bf4cbab83a *man/rva.Rd e003b0d803716f5b3cbce55f283f22d8 *man/scb.Rd 44854f7b9cc0786b8a492d0bdc710ecd *man/sjpi.Rd e3008feda0ec6d440fd4ca51ed7139b2 *man/smooth.lf.Rd 9db26bf9d04493b22b55caa9494a25fa *man/spence.15.Rd a9a88509b23612f29caa34e886e4a150 *man/spence.21.Rd 0a596ce9d8cb9a82597c938a2cc5f499 *man/spencer.Rd 8afaf2477e3487943d6aaa8506e4d087 *man/stamp.Rd 78df873f7b86341cd5690ddad54fd2bc *man/store.Rd 2ea137ef8fabc79df198723d5cd7530b *man/summary.gcvplot.Rd 14685a6b9e1dccd31bce53e1a37d9cdb *man/summary.locfit.Rd 150eef77617e93a5ace416cf45e95c3b *man/summary.preplot.locfit.Rd ab11750329cf323f3959ab63d66dbce8 *man/trimod.Rd d25c8818c2acab0ef7881aa3f4ffefa2 *man/xbar.Rd e3825965eae38fbc998fad1225508de8 *src/S_enter.c 78db5e65c2d608e1205d49ce02f7620f *src/band.c b778507185712ab4a3b04fb39a349b0f *src/cversion.h 5206ef31989da1d09eeb02215b6930b3 *src/dbinom.c 59fddec93019832c070d29d93c95f4bd *src/dens_haz.c e2b66290355136547427e30a74c58301 *src/dens_int.c 39b3e0be365f3956e90ef26c5e415772 *src/dens_odi.c 7fd28e2dbd810a2c4248029095f78b01 *src/density.c eeb959df9748e76edf7b1b8835bf92e6 *src/design.h 30ae6ebaf86e1d929e5e8a5374f1ffe5 *src/ev_atree.c 426d87a6f2e7a907b23d578b44ff5ab2 *src/ev_interp.c f06c1b6315e27831baaacef0ec6aa7a4 *src/ev_kdtre.c e8c8ce2f9daa21771a36c5c355e87170 *src/ev_main.c e80600c2c21c0f2adcad82540c4be4dc *src/ev_sphere.c e37d9f80788b68bd10610ca2bccb8051 *src/ev_trian.c 08022ea9e18cc0e3ed374ed41f126585 *src/family.c b576a5ebe5e3f16906ea90677fc4b1b1 *src/fitted.c cf0dc26ae462ea44edbf496fd7cbf414 *src/frend.c af75dc440edd6a4f7479a4a62f642b45 *src/imatlb.h a5579b3ee9a8763153063a172f1aa84e *src/lf_adap.c 2b9c0a8fc049ba3e40c01ca53969b77b *src/lf_dercor.c 2c6e640bd0ac59ce9e98437409d35ec7 *src/lf_fitfun.c c99d1529844b56608f4320ab92ff59d5 *src/lf_nbhd.c f8f4a4eecff4d35631e89a09f476fce1 *src/lf_robust.c 9b70a02dcc59e8dbfb6ed5575c95bd36 *src/lf_vari.c 39361d5997fefe34a477d668c94a2716 *src/lf_wdiag.c fdf9f44ed36e6c1cd5f8993795182c87 *src/lfcons.h 9157e63bedea71ab199e1756e353d7dd *src/lffuns.h 7ac5f67e86481bfe56da479876a8839f *src/lfstr.c d0e5d8d81c29d2519013e1c43ddd966d *src/lfstruc.h 067a41c90a1bf5bf358674fc1cee4977 *src/lfwin.h 45d5c7f996c4ea7f89008c91a1f51e4d *src/local.h 8e9487889b7f5c38ec42c52d112a0eb5 *src/locfit.c 9fd4f2b5a4b43ed9c7be752781b9f51c *src/m_chol.c 644feb18f7ea81d158a95b158848dffc *src/m_eigen.c 75416a7e75eccc49f7034b7e4b2eb981 *src/m_icirc.c dd9f108da53e2243e31751a3d099745c *src/m_imont.c fe1a1ffcc9862d5133b171818a1d2067 *src/m_isimp.c aca4d122f3bdd74caad4b5703b9fc18a *src/m_isphr.c 718cb35fe93b4ead3a81710bcfd3bf7e *src/m_jacob.c 7005797572c100b7e0b3c162fb8342f4 *src/m_max.c dc97ae5954170eaf14ccdd3307841f2d *src/m_qr.c f7818f241f31ee45700f21fb3bdd52b9 *src/m_solve.c 222f6557db3b66685fa5bd8abd3e9dc7 *src/m_svd.c c91ab2f34b51b21921d4d0120e7c22ae *src/m_vector.c e846b11ba276430e53273c18e238dd3a *src/math.c 1cb375c813ab44a82b7cae7b7276a5ac *src/minmax.c d446fac6ef2e20d5d3f99d5c9fabee4b *src/mutil.h 3acf7770ef7d1753fe4c0f13f245b805 *src/pcomp.c 79474af88df268b8b7bad9608cff5cf8 *src/preplot.c c7bba9b362377361e855a3d6bcf84a1e *src/prob.c 2bd27530e679f98fc17ea24bfd49f14d *src/procv.c 71222a483c4a95ecf5940a44d4cd83ba *src/scb.c d6c58111626108e63cb67195e4dbf3ea *src/scb_cons.c d6e6e6d3510e1540787fbfad1cc6446e *src/scb_crit.c c7dde405e78904478a0d1bb44ce27a20 *src/scb_iface.c 3a42b531c5ae754093eb8c92af2a2229 *src/simul.c 3348f26bc425b89b5d159788d0a21ea9 *src/smisc.c e5907c45d13ecf2f61604dd19b9a237a *src/startlf.c 2c08d573d0f9ca194a82f0e77626a176 *src/tube.h 02fc9e28e242548f7d8d1f00f5d84d81 *src/weight.c locfit/R/0000755000176200001440000000000014745724400011742 5ustar liggesuserslocfit/R/locfit.r0000754000176200001440000015435514745724400013424 0ustar liggesusers"locfit"<- function(formula, data = sys.frame(sys.parent()), weights = 1, cens = 0, base = 0, subset, geth = FALSE, ..., lfproc = locfit.raw) { Terms <- terms(formula, data = data) attr(Terms, "intercept") <- 0 m <- match.call() m[[1]] <- as.name("model.frame") z <- pmatch(names(m), c("formula", "data", "weights", "cens", "base", "subset")) for(i in length(z):2) if(is.na(z[i])) m[[i]] <- NULL frm <- eval(m, sys.frame(sys.parent())) if (nrow(frm) < 1) stop("fewer than one row in the data") vnames <- as.character(attributes(Terms)$variables)[-1] if(attr(Terms, "response")) { y <- model.extract(frm, "response") yname <- deparse(formula[[2]]) vnames <- vnames[-1] } else { y <- yname <- NULL } x <- as.matrix(frm[, vnames]) if(!inherits(x, "lp")) { if(length(vnames) == dim(x)[2]) { dimnames(x) <- list(NULL, vnames) } } if(!missing(weights)) weights <- model.extract(frm, weights) if(!missing(cens)) cens <- model.extract(frm, cens) if(!missing(base)) base <- model.extract(frm, base) ret <- lfproc(x, y, weights = weights, cens = cens, base = base, geth = geth, ...) if(geth == 0) { ret$terms <- Terms ret$call <- match.call() if(!is.null(yname)) ret$yname <- yname ret$frame <- sys.frame(sys.parent()) } ret } "locfit.raw"<- function(x, y, weights = 1, cens = 0, base = 0, scale = FALSE, alpha = 0.7, deg = 2, kern = "tricube", kt = "sph", acri = "none", basis = list(NULL), deriv = numeric(0), dc = FALSE, family, link = "default", xlim, renorm = FALSE, ev = rbox(), maxk = 100, itype = "default", mint = 20, maxit = 20, debug = 0, geth = FALSE, sty = "none") { if(inherits(x, "lp")) { alpha <- attr(x, "alpha") deg <- attr(x, "deg") sty <- attr(x, "style") acri <- attr(x, "acri") scale <- attr(x, "scale") } if(!is.matrix(x)) { vnames <- deparse(substitute(x)) x <- matrix(x, ncol = 1) d <- 1 } else { d <- ncol(x) if(is.null(dimnames(x))) vnames <- paste("x", 1:d, sep = "") else vnames <- dimnames(x)[[2]] } n <- nrow(x) if((!missing(y)) && (!is.null(y))) { yname <- deparse(substitute(y)) if(missing(family)) family <- if(is.logical(y)) "binomial" else "qgaussian" } else { if(missing(family)) family <- "density" y <- 0 yname <- family } if(!missing(basis)) { ## assign("basis", basis, 1) deg0 <- deg <- length(basis(matrix(0, nrow = 1, ncol = d), rep(0, d))) } if(length(deg) == 1) deg = c(deg, deg) xl <- rep(0, 2 * d) lset <- 0 if(!missing(xlim)) { xl <- lflim(xlim, vnames, xl) lset <- 1 } if(is.character(ev)) { stop("Character ev argument no longer used.") } if(is.numeric(ev)) { xev <- ev mg <- length(xev)/d ev <- list(type = "pres", xev = xev, mg = mg, cut = 0, ll = 0, ur = 0) if(mg == 0) stop("Invalid ev argument") } fl <- c(rep(ev$ll,length.out=d), rep(ev$ur,length.out=d)) mi <- c(n, 0, deg, d, 0, 0, 0, 0, mint, maxit, renorm, 0, 0, 0, dc, maxk, debug, geth, 0, !missing(basis)) if(any(is.na(mi))) print(mi) if(is.logical(scale)) scale <- 1 - as.numeric(scale) if(length(scale) == 1) scale <- rep(scale, d) if(is.character(deriv)) deriv <- match(deriv, vnames) alpha <- c(alpha, 0, 0, 0)[1:3] style <- pmatch(sty, c("none", "z1", "z2", "angle", "left", "right", "cpar")) if(length(style) == 1) style <- rep(style, d) dp <- c(alpha, ev$cut, 0, 0, 0, 0, 0, 0) size <- .C("guessnv", lw = integer(7), evt = as.character(c(ev$type, kt)), dp = as.numeric(dp), mi = as.integer(mi), nvc = integer(5), mg = as.integer(ev$mg), PACKAGE="locfit") nvc <- size$nvc lw <- size$lw z <- .C("slocfit", x = as.numeric(x), y = as.numeric(rep(y, length.out = n)), cens = as.numeric(rep(cens, length.out = n)), w = as.numeric(rep(weights, length.out = n)), base = as.numeric(rep(base, length.out = n)), lim = as.numeric(c(xl, fl)), mi = as.integer(size$mi), dp = as.numeric(size$dp), strings = c(kern, family, link, itype, acri, kt), scale = as.numeric(scale), xev = if(ev$type == "pres") as.numeric(xev) else numeric(d * nvc[1]), wdes = numeric(lw[1]), wtre = numeric(lw[2]), wpc = numeric(lw[4]), nvc = as.integer(size$nvc), iwk1 = integer(lw[3]), iwk2 = integer(lw[7]), lw = as.integer(lw), mg = as.integer(ev$mg), L = numeric(lw[5]), kap = numeric(lw[6]), deriv = as.integer(deriv), nd = as.integer(length(deriv)), sty = as.integer(style), # basis = list(basis, lfbas), PACKAGE="locfit") nvc <- z$nvc names(nvc) <- c("nvm", "ncm", "vc", "nv", "nc") nvm <- nvc["nvm"] ncm <- nvc["ncm"] nv <- max(nvc["nv"], 1) nc <- nvc["nc"] if(geth == 1) return(matrix(z$L[1:(nv * n)], ncol = nv)) if(geth == 2) return(list(const = z$kap, d = d)) if(geth == 3) return(z$kap) dp <- z$dp mi <- z$mi names(mi) <- c("n", "p", "deg0", "deg", "d", "acri", "ker", "kt", "it", "mint", "mxit", "renorm", "ev", "tg", "link", "dc", "mk", "debug", "geth", "pc", "ubas") names(dp) <- c("nnalph", "fixh", "adpen", "cut", "lk", "df1", "df2", "rv", "swt", "rsc") if(geth == 4) { p <- mi["p"] return(list(residuals = z$y, var = z$wdes[n * (p + 2) + p * p + (1:n)], nl.df = dp["df1"] - 2)) } if(geth == 6) return(z$L) if(length(deriv) > 0) trans <- function(x) x else trans <- switch(mi["link"] - 2, function(x) x, exp, expit, function(x) 1/x, function(x) pmax(x, 0)^2, function(x) pmax(sin(x), 0)^2) t1 <- z$wtre t2 <- z$iwk1 xev <- z$xev[1:(d * nv)] if(geth == 7) return(list(x = xev, y = trans(t1[1:nv]))) coef <- matrix(t1[1:((3 * d + 8) * nvm)], nrow = nvm)[1:nv, ] if(nv == 1) coef <- matrix(coef, nrow = 1) if(geth >= 70) { data <- list(x = x, y = y, cens = cens, base = base, w = weights) return(list(xev = matrix(xev, ncol = d, byrow = TRUE), coef = coef[, 1], sd = coef[, d + 2], lower = z$L[1:nv], upper = z$L[nvm + (1:nv)], trans = trans, d = d, vnames = vnames, kap = z$kap, data = data, mi = mi)) } eva <- list(ev = ev, xev = xev, coef = coef, scale = z$scale, pc = z$wpc) class(eva) <- "lfeval" if(nc == 0) { cell <- list(sv = integer(0), ce = integer(0), s = integer(0), lo = as.integer(rep(0, nv)), hi = as.integer(rep(0, nv))) } else { mvc <- max(nv, nc) mvcm <- max(nvm, ncm) vc <- nvc["vc"] cell <- list(sv = t1[nvm * (3 * d + 8) + 1:nc], ce = t2[1:(vc * nc)], s = t2[vc * ncm + 1:mvc], lo = t2[vc * ncm + mvcm + 1:mvc], hi = t2[vc * ncm + 2 * mvcm + 1:mvc]) } ret <- list(eva = eva, cell = cell, terms = NULL, nvc = nvc, box = z$lim[2 * d + 1:(2 * d)], sty = style, deriv = deriv, mi = mi, dp = dp, trans = trans, critval = crit(const = c(rep(0, d), 1), d = d), vnames = vnames, yname = yname, call = match.call(), frame = sys.frame(sys.parent())) class(ret) <- "locfit" ret } "ang" <- function(x, ...) { ret <- lp(x, ..., style = "angle") dimnames(ret) <- list(NULL, deparse(substitute(x))) ret } "gam.lf"<- function(x, y, w, xeval, ...) { if(!missing(xeval)) { fit <- locfit.raw(x, y, weights = w, geth = 5, ...) return(predict(fit, xeval)) } ret <- locfit.raw(x, y, weights = w, geth = 4, ...) names(ret) <- c("residuals", "var", "nl.df") ret } "gam.slist"<- c("s", "lo", "random", "lf") "lf"<- function(..., alpha = 0.7, deg = 2, scale = 1, kern = "tcub", ev = rbox(), maxk = 100) { if(!any(gam.slist == "lf")) warning("gam.slist does not include \"lf\" -- fit will be incorrect") x <- cbind(...) scall <- deparse(sys.call()) attr(x, "alpha") <- alpha attr(x, "deg") <- deg attr(x, "scale") <- scale attr(x, "kern") <- kern attr(x, "ev") <- ev attr(x, "maxk") <- maxk attr(x, "call") <- substitute(gam.lf(data[[scall]], z, w, alpha = alpha, deg = deg, scale = scale, kern = kern, ev = ev, maxk = maxk)) attr(x, "class") <- "smooth" x } #"lfbas" <- #function(dim, indices, tt, ...) #{ # indices <- indices + 1 # # C starts at 0, S at 1 # x <- cbind(...)[indices, ] # res <- basis(x, tt) # as.numeric(t(res)) #} "left"<- function(x, ...) { ret <- lp(x, ..., style = "left") dimnames(ret) <- list(NULL, deparse(substitute(x))) ret } "right"<- function(x, ...) { ret <- lp(x, ..., style = "right") dimnames(ret) <- list(NULL, deparse(substitute(x))) ret } "cpar"<- function(x, ...) { ret <- lp(x, ..., style = "cpar") dimnames(ret) <- list(NULL, deparse(substitute(x))) ret } "lp"<- function(..., nn = 0, h = 0, adpen = 0, deg = 2, acri = "none", scale = FALSE, style = "none") { x <- cbind(...) z <- as.list(match.call()) z[[1]] <- z$nn <- z$h <- z$adpen <- z$deg <- z$acri <- z$scale <- z$style <- NULL dimnames(x) <- list(NULL, z) if(missing(nn) & missing(h) & missing(adpen)) nn <- 0.7 attr(x, "alpha") <- c(nn, h, adpen) attr(x, "deg") <- deg attr(x, "acri") <- acri attr(x, "style") <- style attr(x, "scale") <- scale class(x) <- c("lp", class(x)) x } "[.lp" <- function (x, ..., drop = FALSE) { cl <- oldClass(x) oldClass(x) <- NULL ats <- attributes(x) ats$dimnames <- NULL ats$dim <- NULL ats$names <- NULL y <- x[..., drop = drop] attributes(y) <- c(attributes(y), ats) oldClass(y) <- cl y } "fitted.locfit"<- function(object, data = NULL, what = "coef", cv = FALSE, studentize = FALSE, type = "fit", tr, ...) { if(missing(data)) { data <- if(is.null(object$call$data)) sys.frame(sys.parent()) else eval(object$call$ data) } if(missing(tr)) tr <- if((what == "coef") & (type == "fit")) object$trans else function(x) x mm <- locfit.matrix(object, data = data) n <- object$mi["n"] pred <- .C("sfitted", x = as.numeric(mm$x), y = as.numeric(rep(mm$y, length.out = n)), w = as.numeric(rep(mm$w, length.out = n)), ce = as.numeric(rep(mm$ce, length.out = n)), ba = as.numeric(rep(mm$base, length.out = n)), fit = numeric(n), cv = as.integer(cv), st = as.integer(studentize), xev = as.numeric(object$eva$xev), coef = as.numeric(object$eva$coef), sv = as.numeric(object$cell$sv), ce = as.integer(c(object$cell$ce, object$cell$s, object$cell$lo, object$ cell$hi)), wpc = as.numeric(object$eva$pc), scale = as.numeric(object$eva$scale), nvc = as.integer(object$nvc), mi = as.integer(object$mi), dp = as.numeric(object$dp), mg = as.integer(object$eva$ev$mg), deriv = as.integer(object$deriv), nd = as.integer(length(object$deriv)), sty = as.integer(object$sty), what = as.character(c(what, type)), basis = list(eval(object$call$basis)), PACKAGE="locfit") tr(pred$fit) } "formula.locfit"<- function(x, ...) x$call$formula "predict.locfit"<- function(object, newdata = NULL, where = "fitp", se.fit = FALSE, band = "none", what = "coef", ...) { if((se.fit) && (band == "none")) band <- "global" for(i in 1:length(what)) { pred <- preplot.locfit(object, newdata, where = where, band = band, what = what[i], ...) fit <- pred$trans(pred$fit) if(i == 1) res <- fit else res <- cbind(res, fit) } if(band == "none") return(res) return(list(fit = res, se.fit = pred$se.fit, residual.scale = pred$ residual.scale)) } "lines.locfit"<- function(x, m = 100, tr = x$trans, ...) { newx <- lfmarg(x, m = m)[[1]] y <- predict(x, newx, tr = tr) lines(newx, y, ...) } "points.locfit"<- function(x, tr, ...) { d <- x$mi["d"] p <- x$mi["p"] nv <- x$nvc["nv"] if(d == 1) { if(missing(tr)) tr <- x$trans x1 <- x$eva$xev x2 <- x$eva$coef[, 1] points(x1, tr(x2), ...) } if(d == 2) { xx <- lfknots(x, what = "x") points(xx[, 1], xx[, 2], ...) } } "print.locfit"<- function(x, ...) { if(!is.null(cl <- x$call)) { cat("Call:\n") dput(cl) } cat("\n") cat("Number of observations: ", x$mi["n"], "\n") cat("Family: ", c("Density", "PP Rate", "Hazard", "Gaussian", "Logistic", "Poisson", "Gamma", "Geometric", "Circular", "Huber", "Robust Binomial", "Weibull", "Cauchy")[x$mi["tg"] %% 64], "\n") cat("Fitted Degrees of freedom: ", round(x$dp["df2"], 3), "\n") cat("Residual scale: ", signif(sqrt(x$dp["rv"]), 3), "\n") invisible(x) } "residuals.locfit"<- function(object, data = NULL, type = "deviance", ...) { if(missing(data)) { data <- if(is.null(object$call$data)) sys.frame(sys.parent()) else eval(object$call$ data) } fitted.locfit(object, data, ..., type = type) } "summary.locfit"<- function(object, ...) { mi <- object$mi fam <- c("Density Estimation", "Poisson process rate estimation", "Hazard Rate Estimation", "Local Regression", "Local Likelihood - Binomial", "Local Likelihood - Poisson", "Local Likelihood - Gamma", "Local Likelihood - Geometric", "Local Robust Regression")[mi["tg"] %% 64] estr <- c("Rectangular Tree", "Triangulation", "Data", "Rectangular Grid", "k-d tree", "k-d centres", "Cross Validation", "User-provided")[mi["ev"]] ret <- list(call = object$call, fam = fam, n = mi["n"], d = mi["d"], estr = estr, nv = object$nvc["nv"], deg = mi["deg"], dp = object$dp, vnames = object$vnames) class(ret) <- "summary.locfit" ret } "print.summary.locfit"<- function(x, ...) { cat("Estimation type:", x$fam, "\n") cat("\nCall:\n") print(x$call) cat("\nNumber of data points: ", x$n, "\n") cat("Independent variables: ", x$vnames, "\n") cat("Evaluation structure:", x$estr, "\n") cat("Number of evaluation points: ", x$nv, "\n") cat("Degree of fit: ", x$deg, "\n") cat("Fitted Degrees of Freedom: ", round(x$dp["df2"], 3), "\n") invisible(x) } "rbox"<- function(cut = 0.8, type = "tree", ll = rep(0, 10), ur = rep(0, 10)) { if(!any(type == c("tree", "kdtree", "kdcenter", "phull"))) stop("Invalid type argument") ret <- list(type = type, xev = 0, mg = 0, cut = as.numeric(cut), ll = as.numeric(ll), ur = as.numeric(ur)) class(ret) <- "lf_evs" ret } "lfgrid"<- function(mg = 10, ll = rep(0, 10), ur = rep(0, 10)) { if(length(mg) == 1) mg <- rep(mg, 10) ret <- list(type = "grid", xev = 0, mg = as.integer(mg), cut = 0, ll = as.numeric(ll), ur = as.numeric(ur)) class(ret) <- "lf_evs" ret } "dat"<- function(cv = FALSE) { type <- if(cv) "crossval" else "data" ret <- list(type = type, xev = 0, mg = 0, cut = 0, ll = 0, ur = 0) class(ret) <- "lf_evs" ret } "xbar"<- function() { ret <- list(type = "xbar", xev = 0, mg = 0, cut = 0, ll = 0, ur = 0) class(ret) <- "lf_evs" ret } "none"<- function() { ret <- list(type = "none", xev = 0, mg = 0, cut = 0, ll = 0, ur = 0) class(ret) <- "lf_evs" ret } "plot.locfit"<- function(x, xlim, pv, tv, m, mtv = 6, band = "none", tr = NULL, what = "coef", get.data = FALSE, f3d = (d == 2) && (length(tv) > 0), ...) { d <- x$mi["d"] ev <- x$mi["ev"] where <- "grid" if(missing(pv)) pv <- if(d == 1) 1 else c(1, 2) if(is.character(pv)) pv <- match(pv, x$vnames) if(missing(tv)) tv <- (1:d)[ - pv] if(is.character(tv)) tv <- match(tv, x$vnames) vrs <- c(pv, tv) if(any(duplicated(vrs))) warning("Duplicated variables in pv, tv") if(any((vrs <= 0) | (vrs > d))) stop("Invalid variable numbers in pv, tv") if(missing(m)) m <- if(d == 1) 100 else 40 m <- rep(m, d) m[tv] <- mtv xl <- x$box if(!missing(xlim)) xl <- lflim(xlim, x$vnames, xl) if((d != 2) & (any(ev == c(3, 7, 8)))) pred <- preplot.locfit(x, where = "fitp", band = band, tr = tr, what = what, get.data = get.data, f3d = f3d) else { marg <- lfmarg(xl, m) pred <- preplot.locfit(x, marg, band = band, tr = tr, what = what, get.data = get.data, f3d = f3d) } plot(pred, pv = pv, tv = tv, ...) } "preplot.locfit"<- function(object, newdata = NULL, where, tr = NULL, what = "coef", band = "none", get.data = FALSE, f3d = FALSE, ...) { mi <- object$mi dim <- mi["d"] ev <- mi["ev"] nointerp <- any(ev == c(3, 7, 8)) wh <- 1 n <- 1 if(is.null(newdata)) { if(missing(where)) where <- if(nointerp) "fitp" else "grid" if(where == "grid") newdata <- lfmarg(object) if(any(where == c("fitp", "ev", "fitpoints"))) { where <- "fitp" newdata <- lfknots(object, what = "x", delete.pv = FALSE) } if(where == "data") newdata <- locfit.matrix(object)$x if(where == "vect") stop("you must give the vector points") } else { where <- "vect" if(is.data.frame(newdata)) newdata <- as.matrix(model.frame(delete.response(object$terms), newdata)) else if(is.list(newdata)) where <- "grid" else newdata <- as.matrix(newdata) } if(is.null(tr)) { if(what == "coef") tr <- object$trans else tr <- function(x) x } if((nointerp) && (where == "grid") && (dim == 2)) { nv <- object$nvc["nv"] x <- object$eva$xev[2 * (1:nv) - 1] y <- object$eva$xev[2 * (1:nv)] z <- preplot.locfit.raw(object, 0, "fitp", what, band)$y # haveAkima <- require(akima) #if (! haveAkima) stop("The akima package is needed for the interp() function. Please note its no-compercial-use license.") fhat <- interp::interp(x, y, z, newdata[[1]], newdata[[2]], ncp = 2)$z } else { z <- preplot.locfit.raw(object, newdata, where, what, band) fhat <- z$y } fhat[fhat == 0.1278433] <- NA band <- pmatch(band, c("none", "global", "local", "prediction")) if(band > 1) sse <- z$se else sse <- numeric(0) if(where != "grid") newdata <- list(xev = newdata, where = where) else newdata$where <- where data <- if(get.data) locfit.matrix(object) else list() if((f3d) | (dim > 3)) dim <- 3 ret <- list(xev = newdata, fit = fhat, se.fit = sse, residual.scale = sqrt( object$dp["rv"]), critval = object$critval, trans = tr, vnames = object$ vnames, yname = object$yname, dim = as.integer(dim), data = data) class(ret) <- "preplot.locfit" ret } "preplot.locfit.raw"<- function(object, newdata, where, what, band, ...) { wh <- pmatch(where, c("vect", "grid", "data", "fitp")) switch(wh, { mg <- n <- nrow(newdata) xev <- newdata } , { xev <- unlist(newdata) mg <- sapply(newdata, length) n <- prod(mg) } , { mg <- n <- object$mi["n"] xev <- newdata } , { mg <- n <- object$nvc["nv"] xev <- newdata } ) .C("spreplot", xev = as.numeric(object$eva$xev), coef = as.numeric(object$eva$coef), sv = as.numeric(object$cell$sv), ce = as.integer(c(object$cell$ce, object$cell$s, object$cell$lo, object$ cell$hi)), x = as.numeric(xev), y = numeric(n), se = numeric(n), wpc = as.numeric(object$eva$pc), scale = as.numeric(object$eva$scale), m = as.integer(mg), nvc = as.integer(object$nvc), mi = as.integer(object$mi), dp = as.numeric(object$dp), mg = as.integer(object$eva$ev$mg), deriv = as.integer(object$deriv), nd = as.integer(length(object$deriv)), sty = as.integer(object$sty), wh = as.integer(wh), what = c(what, band), bs = list(eval(object$call$basis)), PACKAGE="locfit") } "print.preplot.locfit"<- function(x, ...) { print(x$trans(x$fit)) invisible(x) } "plot.locfit.1d"<- function(x, add=FALSE, main="", xlab="default", ylab=x$yname, type="l", ylim, lty = 1, col = 1, ...) { y <- x$fit nos <- !is.na(y) xev <- x$xev[[1]][nos] y <- y[nos] ord <- order(xev) if(xlab == "default") xlab <- x$vnames tr <- x$trans yy <- tr(y) if(length(x$se.fit) > 0) { crit <- x$critval$crit.val cup <- tr((y + crit * x$se.fit))[ord] clo <- tr((y - crit * x$se.fit))[ord] } ndat <- 0 if(length(x$data) > 0) { ndat <- nrow(x$data$x) xdsc <- rep(x$data$sc, length.out = ndat) xdyy <- rep(x$data$y, length.out = ndat) dok <- xdsc > 0 } if(missing(ylim)) { if(length(x$se.fit) > 0) ylim <- c(min(clo), max(cup)) else ylim <- range(yy) if(ndat > 0) ylim <- range(c(ylim, xdyy[dok]/xdsc[dok])) } if(!add) { plot(xev[ord], yy[ord], type = "n", xlab = xlab, ylab = ylab, main = main, xlim = range(x$xev[[1]]), ylim = ylim, ...) } lines(xev[ord], yy[ord], type = type, lty = lty, col = col) if(length(x$se.fit) > 0) { lines(xev[ord], cup, lty = 2) lines(xev[ord], clo, lty = 2) } if(ndat > 0) { xd <- x$data$x[dok] yd <- xdyy[dok]/xdsc[dok] cd <- rep(x$data$ce, length.out = ndat)[dok] if(length(x$data$y) < 2) { rug(xd[cd == 0]) if(any(cd == 1)) rug(xd[cd == 1], ticksize = 0.015) } else { plotbyfactor(xd, yd, cd, col = col, pch = c("o", "+"), add = TRUE) } } invisible(NULL) } "plot.locfit.2d"<- function(x, type="contour", main, xlab, ylab, zlab=x$yname, ...) { if(x$xev$where != "grid") stop("Can only plot from grids") if(missing(xlab)) xlab <- x$vnames[1] if(missing(ylab)) ylab <- x$vnames[2] tr <- x$trans m1 <- x$xev[[1]] m2 <- x$xev[[2]] y <- matrix(tr(x$fit)) if(type == "contour") contour(m1, m2, matrix(y, nrow = length(m1)), ...) if(type == "image") image(m1, m2, matrix(y, nrow = length(m1)), ...) if((length(x$data) > 0) && any(type == c("contour", "image"))) { xd <- x$data$x ce <- rep(x$data$ce, length.out = nrow(xd)) points(xd[ce == 0, 1], xd[ce == 0, 2], pch = "o") if(any(ce == 1)) points(xd[ce == 1, 1], xd[ce == 1, 2], pch = "+") } if(type == "persp") { nos <- is.na(y) y[nos] <- min(y[!nos]) persp(m1, m2, matrix(y, nrow = length(m1)), zlab=zlab, ...) } if(!missing(main)) title(main = main) invisible(NULL) } "plot.locfit.3d"<- function(x, main = "", pv, tv, type = "level", pred.lab = x$vnames, resp.lab = x$yname, crit = 1.96, ...) { xev <- x$xev if(xev$where != "grid") stop("Can only plot from grids") xev$where <- NULL newx <- as.matrix(expand.grid(xev)) newy <- x$trans(x$fit) wh <- rep("f", length(newy)) if(length(x$data) > 0) { dat <- x$data for(i in tv) { m <- xev[[i]] dat$x[, i] <- m[1 + round((dat$x[, i] - m[1])/(m[2] - m[1]))] } newx <- rbind(newx, dat$x) if(is.null(dat$y)) newy <- c(newy, rep(NA, nrow(dat$x))) else { newy <- c(newy, dat$y/dat$sc) newy[is.na(newy)] <- 0 } wh <- c(wh, rep("d", nrow(dat$x))) } if(length(tv) == 0) { newdat <- data.frame(newy, newx[, pv]) names(newdat) <- c("y", paste("pv", 1:length(pv), sep = "")) } else { newdat <- data.frame(newx[, tv], newx[, pv], newy) names(newdat) <- c(paste("tv", 1:length(tv), sep = ""), paste("pv", 1: length(pv), sep = ""), "y") for(i in 1:length(tv)) newdat[, i] <- as.factor(signif(newdat[, i], 5)) } loc.strip <- function(...) strip.default(..., strip.names = c(TRUE, TRUE), style = 1) if(length(pv) == 1) { clo <- cup <- numeric(0) if(length(x$se.fit) > 0) { if((!is.null(class(crit))) && (inherits(crit, "kappa"))) crit <- crit$crit.val cup <- x$trans((x$fit + crit * x$se.fit)) clo <- x$trans((x$fit - crit * x$se.fit)) } formula <- switch(1 + length(tv), y ~ pv1, y ~ pv1 | tv1, y ~ pv1 | tv1 * tv2, y ~ pv1 | tv1 * tv2 * tv3) pl <- xyplot(formula, xlab = pred.lab[pv], ylab = resp.lab, main = main, type = "l", cup = cup, wh = wh, panel = panel.xyplot.lf, data = newdat, strip = loc.strip, ...) } if(length(pv) == 2) { formula <- switch(1 + length(tv), y ~ pv1 * pv2, y ~ pv1 * pv2 | tv1, y ~ pv1 * pv2 | tv1 * tv2, y ~ pv1 * pv2 | tv1 * tv2 * tv3) if(type == "contour") pl <- contourplot(formula, xlab = pred.lab[pv[1]], ylab = pred.lab[pv[2]], main = main, data = newdat, strip = loc.strip, ...) if(type == "level") pl <- levelplot(formula, xlab = pred.lab[pv[1]], ylab = pred.lab[pv[2]], main = main, data = newdat, strip = loc.strip, ...) if((type == "persp") | (type == "wireframe")) pl <- wireframe(formula, xlab = pred.lab[pv[1]], ylab = pred.lab[pv[2]], zlab = resp.lab, data = newdat, strip = loc.strip, ...) } if(length(tv) > 0) { ## if(exists("is.R") && is.function(is.R) && is.R()) names(pl$cond) <- pred.lab[tv] ## else names(attr(pl$glist, "endpts")) <- attr(pl$glist, "names") <- names( ## attr(pl$glist, "index")) <- pred.lab[tv] } pl } "panel.xyplot.lf"<- function(x, y, subscripts, clo, cup, wh, type = "l", ...) { wh <- wh[subscripts] panel.xyplot(x[wh == "f"], y[wh == "f"], type = type, ...) if(length(clo) > 0) { panel.xyplot(x[wh == "f"], clo[subscripts][wh == "f"], type = "l", lty = 2, ...) panel.xyplot(x[wh == "f"], cup[subscripts][wh == "f"], type = "l", lty = 2, ...) } if(any(wh == "d")) { yy <- y[wh == "d"] if(any(is.na(yy))) rug(x[wh == "d"]) else panel.xyplot(x[wh == "d"], yy) } } "plot.preplot.locfit"<- function(x, pv, tv, ...) { if(x$dim == 1) plot.locfit.1d(x, ...) if(x$dim == 2) plot.locfit.2d(x, ...) if(x$dim >= 3) print(plot.locfit.3d(x, pv=pv, tv=tv, ...)) invisible(NULL) } "summary.preplot.locfit"<- function(object, ...) object$trans(object$fit) ## Deepayan Sarkar's patched version: "panel.locfit"<- function(x, y, subscripts, z, rot.mat, distance, shade, light.source, xlim, ylim, zlim, xlim.scaled, ylim.scaled, zlim.scaled, region, col, lty, lwd, alpha, col.groups, polynum, drape, at, xlab, ylab, zlab, xlab.default, ylab.default, zlab.default, aspect, panel.aspect, scales.3d, contour, labels, ...) { if(!missing(z)) { zs <- z[subscripts] fit <- locfit.raw(cbind(x, y), zs, ...) marg <- lfmarg(fit, m = 10) zp <- predict(fit, marg) if(!missing(contour)) { #print("contour") #print(range(zp)) #lattice::render.contour.trellis(marg[[1]], marg[[2]], zp, at = at) lattice::panel.contourplot(marg[[1]], marg[[2]], zp, 1:length(zp), at=at) } else { # loc.dat <- # cbind(as.matrix(expand.grid(x = marg[[1]], # y = marg[[1]])), # z = zp) # lattice::render.3d.trellis(cbind(x = x, y = y, z = z[subscripts]), # type = "cloud", # xyz.labs = xyz.labs, # xyz.axes = xyz.axes, # xyz.mid = xyz.mid, # xyz.minmax = xyz.minmax, # xyz.range = xyz.range, # col.regions = col.regions, # at = at, # drape = drape) lattice::panel.wireframe(marg[[1]], marg[[2]], zp, rot.mat, distance, shade, light.source, xlim, ylim, zlim, xlim.scaled, ylim.scaled, zlim.scaled, col, lty, lwd, alpha, col.groups, polynum, drape, at) } } else { panel.xyplot(x, y, ...) args <- list(x = x, y = y, ...) ok <- names(formals(locfit.raw)) llines.locfit(do.call("locfit.raw", args[ok[ok %in% names(args)]])) } } llines.locfit <- function (x, m = 100, tr = x$trans, ...) { newx <- lfmarg(x, m = m)[[1]] y <- predict(x, newx, tr = tr) llines(newx, y, ...) } ## "panel.locfit"<- # function(x, y, subscripts, z, xyz.labs, xyz.axes, xyz.mid, xyz.minmax, # xyz.range, col.regions, at, drape, contour, region, groups, ...) # { # if(!missing(z)) { # zs <- z[subscripts] # fit <- locfit.raw(cbind(x, y), zs, ...) # marg <- lfmarg(fit, m = 10) # zp <- predict(fit, marg) # if(!missing(contour)) { # print("contour") # print(range(zp)) # render.contour.trellis(marg[[1]], marg[[2]], zp, at = at) # } # else { # loc.dat <- cbind(as.matrix(expand.grid(x = marg[[1]], y = marg[[1]])), z # = zp) # render.3d.trellis(cbind(x = x, y = y, z = z[subscripts]), type = "cloud", # xyz.labs = xyz.labs, xyz.axes = xyz.axes, xyz.mid = xyz.mid, xyz.minmax # = xyz.minmax, xyz.range = xyz.range, col.regions = col.regions, at = # at, drape = drape) # } # } # else { # panel.xyplot(x, y) # lines(locfit.raw(x, y, ...)) # } # } "lfmarg"<- function(xlim, m = 40) { if(!is.numeric(xlim)) { d <- xlim$mi["d"] xlim <- xlim$box } else d <- length(m) marg <- vector("list", d) m <- rep(m, length.out = d) for(i in 1:d) marg[[i]] <- seq(xlim[i], xlim[i + d], length.out = m[i]) marg } "lfeval"<- function(object) object$eva "plot.lfeval"<- function(x, add = FALSE, txt = FALSE, ...) { if(inherits(x, "locfit")) x <- x$eva d <- length(x$scale) v <- matrix(x$xev, nrow = d) if(d == 1) { xx <- v[1, ] y <- x$coef[, 1] } if(d == 2) { xx <- v[1, ] y <- v[2, ] } if(!add) { plot(xx, y, type = "n", ...) } points(xx, y, ...) if(txt) text(xx, y, (1:length(xx)) - 1) invisible(x) } "print.lfeval"<- function(x, ...) { if(inherits(x, "locfit")) x <- x$eva d <- length(x$scale) ret <- matrix(x$xev, ncol = d, byrow = TRUE) print(ret) } "lflim"<- function(limits, nm, ret) { d <- length(nm) if(is.numeric(limits)) ret <- limits else { z <- match(nm, names(limits)) for(i in 1:d) if(!is.na(z[i])) ret[c(i, i + d)] <- limits[[z[i]]] } as.numeric(ret) } "plot.eval"<- function(x, add = FALSE, text = FALSE, ...) { d <- x$mi["d"] v <- matrix(x$eva$xev, nrow = d) ev <- x$mi["ev"] pv <- if(any(ev == c(1, 2))) as.logical(x$cell$s) else rep(FALSE, ncol(v)) if(!add) { plot(v[1, ], v[2, ], type = "n", xlab = x$vnames[1], ylab = x$vnames[2]) } if(text) text(v[1, ], v[2, ], (1:x$nvc["nv"]) - 1) else { if(any(!pv)) points(v[1, !pv], v[2, !pv], ...) if(any(pv)) points(v[1, pv], v[2, pv], pch = "*", ...) } if(any(x$mi["ev"] == c(1, 2))) { zz <- .C("triterm", as.numeric(v), h = as.numeric(lfknots(x, what = "h", delete.pv = FALSE)), as.integer(x$cell$ce), lo = as.integer(x$cell$lo), hi = as.integer(x$cell$hi), as.numeric(x$eva$scale), as.integer(x$nvc), as.integer(x$mi), as.numeric(x$dp), nt = integer(1), term = integer(600), box = x$box, PACKAGE="locfit") ce <- zz$term + 1 } else ce <- x$cell$ce + 1 if(any(x$mi["ev"] == c(1, 5, 7))) { vc <- 2^d ce <- matrix(ce, nrow = vc) segments(v[1, ce[1, ]], v[2, ce[1, ]], v[1, ce[2, ]], v[2, ce[2, ]], ...) segments(v[1, ce[1, ]], v[2, ce[1, ]], v[1, ce[3, ]], v[2, ce[3, ]], ...) segments(v[1, ce[2, ]], v[2, ce[2, ]], v[1, ce[4, ]], v[2, ce[4, ]], ...) segments(v[1, ce[3, ]], v[2, ce[3, ]], v[1, ce[4, ]], v[2, ce[4, ]], ...) } if(any(x$mi["ev"] == c(2, 8))) { vc <- d + 1 m <- matrix(ce, nrow = 3) segments(v[1, m[1, ]], v[2, m[1, ]], v[1, m[2, ]], v[2, m[2, ]], ...) segments(v[1, m[1, ]], v[2, m[1, ]], v[1, m[3, ]], v[2, m[3, ]], ...) segments(v[1, m[2, ]], v[2, m[2, ]], v[1, m[3, ]], v[2, m[3, ]], ...) } invisible(NULL) } "rv"<- function(fit) fit$dp["rv"] "rv<-"<- function(fit, value) { fit$dp["rv"] <- value fit } "regband"<- function(formula, what = c("CP", "GCV", "GKK", "RSW"), deg = 1, ...) { m <- match.call() m$geth <- 3 m$deg <- c(deg, 4) m$what <- NULL m$deriv <- match(what, c("CP", "GCV", "GKK", "RSW")) m[[1]] <- as.name("locfit") z <- eval(m, sys.frame(sys.parent())) names(z) <- what z[1:length(what)] } "kdeb"<- function(x, h0 = 0.01 * sd, h1 = sd, meth = c("AIC", "LCV", "LSCV", "BCV", "SJPI", "GKK"), kern = "gauss", gf = 2.5) { n <- length(x) sd <- sqrt(var(x)) z <- .C("kdeb", x = as.numeric(x), mi = as.integer(n), band = numeric(length(meth)), ind = integer(n), h0 = as.numeric(gf * h0), h1 = as.numeric(gf * h1), meth = as.integer(match(meth, c("AIC", "LCV", "LSCV", "BCV", "SJPI", "GKK") )), nmeth = as.integer(length(meth)), kern = pmatch(kern, c("rect", "epan", "bisq", "tcub", "trwt", "gauss")), PACKAGE="locfit") band <- z$band names(band) <- meth band } "lfknots"<- function(x, tr, what = c("x", "coef", "h", "nlx"), delete.pv = TRUE) { nv <- x$nvc["nv"] d <- x$mi["d"] p <- x$mi["p"] z <- 0:(nv - 1) ret <- matrix(0, nrow = nv, ncol = 1) rname <- character(0) if(missing(tr)) tr <- x$trans coef <- x$eva$coef for(wh in what) { if(wh == "x") { ret <- cbind(ret, matrix(x$eva$xev, ncol = d, byrow = TRUE)) rname <- c(rname, x$vnames) } if(wh == "coef") { d0 <- coef[, 1] d0[d0 == 0.1278433] <- NA ret <- cbind(ret, tr(d0)) rname <- c(rname, "mu hat") } if(wh == "f1") { ret <- cbind(ret, coef[, 1 + (1:d)]) rname <- c(rname, paste("d", 1:d, sep = "")) } if(wh == "nlx") { ret <- cbind(ret, coef[, d + 2]) rname <- c(rname, "||l(x)||") } if(wh == "nlx1") { ret <- cbind(ret, coef[, d + 2 + (1:d)]) rname <- c(rname, paste("nlx-d", 1:d, sep = "")) } if(wh == "se") { ret <- cbind(ret, sqrt(x$dp["rv"]) * coef[, d + 2]) rname <- c(rname, "StdErr") } if(wh == "infl") { z <- coef[, 2 * d + 3] ret <- cbind(ret, z * z) rname <- c(rname, "Influence") } if(wh == "infla") { ret <- cbind(ret, coef[, 2 * d + 3 + (1:d)]) rname <- c(rname, paste("inf-d", 1:d, sep = "")) } if(wh == "lik") { ret <- cbind(ret, coef[, 3 * d + 3 + (1:3)]) rname <- c(rname, c("LocLike", "fit.df", "res.df")) } if(wh == "h") { ret <- cbind(ret, coef[, 3 * d + 7]) rname <- c(rname, "h") } if(wh == "deg") { ret <- cbind(ret, coef[, 3 * d + 8]) rname <- c(rname, "deg") } } ret <- as.matrix(ret[, -1]) if(nv == 1) ret <- t(ret) dimnames(ret) <- list(NULL, rname) if((delete.pv) && (any(x$mi["ev"] == c(1, 2)))) ret <- ret[!as.logical(x$cell$s), ] ret } "locfit.matrix"<- function(fit, data) { m <- fit$call n <- fit$mi["n"] y <- ce <- base <- 0 w <- 1 if(m[[1]] == "locfit.raw") { x <- as.matrix(eval(m$x, fit$frame)) if(!is.null(m$y)) y <- eval(m$y, fit$frame) if(!is.null(m$weights)) w <- eval(m$weights, fit$frame) if(!is.null(m$cens)) ce <- eval(m$cens, fit$frame) if(!is.null(m$base)) base <- eval(m$base, fit$frame) } else { Terms <- terms(as.formula(m$formula)) attr(Terms, "intercept") <- 0 m[[1]] <- as.name("model.frame") z <- pmatch(names(m), c("formula", "data", "weights", "cens", "base", "subset")) for(i in length(z):2) if(is.na(z[i])) m[[i]] <- NULL frm <- eval(m, fit$frame) vnames <- as.character(attributes(Terms)$variables)[-1] if(attr(Terms, "response")) { y <- model.extract(frm, "response") vnames <- vnames[-1] } x <- as.matrix(frm[, vnames]) if(any(names(m) == "weights")) w <- model.extract(frm, weights) if(any(names(m) == "cens")) ce <- model.extract(frm, "cens") if(any(names(m) == "base")) base <- model.extract(frm, base) } sc <- if(any((fit$mi["tg"] %% 64) == c(5:8, 11, 12))) w else 1 list(x = x, y = y, w = w, sc = sc, ce = ce, base = base) } "expit"<- function(x) { y <- x ix <- (x < 0) y[ix] <- exp(x[ix])/(1 + exp(x[ix])) y[!ix] <- 1/(1 + exp( - x[!ix])) y } "plotbyfactor"<- function(x, y, f, data, col = 1:10, pch = "O", add = FALSE, lg, xlab = deparse( substitute(x)), ylab = deparse(substitute(y)), log = "", ...) { if(!missing(data)) { x <- eval(substitute(x), data) y <- eval(substitute(y), data) f <- eval(substitute(f), data) } f <- as.factor(f) if(!add) plot(x, y, type = "n", xlab = xlab, ylab = ylab, log = log, ...) lv <- levels(f) col <- rep(col, length.out = length(lv)) pch <- rep(pch, length.out = length(lv)) for(i in 1:length(lv)) { ss <- f == lv[i] if(any(ss)) points(x[ss], y[ss], col = col[i], pch = pch[i]) } if(!missing(lg)) legend(lg[1], lg[2], legend = levels(f), col = col, pch = paste(pch, collapse = "")) } "hatmatrix"<- function(formula, dc = TRUE, ...) { m <- match.call() m$geth <- 1 m[[1]] <- as.name("locfit") z <- eval(m, sys.frame(sys.parent())) nvc <- z[[2]] nvm <- nvc[1] nv <- nvc[4] matrix(z[[1]], ncol = nvm)[, 1:nv] } "locfit.robust"<- function(x, y, weights, ..., iter = 3) { m <- match.call() if((!is.numeric(x)) && (inherits(x, "formula"))) { m1 <- m[[1]] m[[1]] <- as.name("locfit") m$lfproc <- m1 names(m)[[2]] <- "formula" return(eval(m, sys.frame(sys.parent()))) } n <- length(y) lfr.wt <- rep(1, n) m[[1]] <- as.name("locfit.raw") for(i in 0:iter) { m$weights <- lfr.wt fit <- eval(m, sys.frame(sys.parent())) res <- residuals(fit, type = "raw") s <- median(abs(res)) lfr.wt <- pmax(1 - (res/(6 * s))^2, 0)^2 } fit } "locfit.censor"<- function(x, y, cens, ..., iter = 3, km = FALSE) { m <- match.call() if((!is.numeric(x)) && (inherits(x, "formula"))) { m1 <- m[[1]] m[[1]] <- as.name("locfit") m$lfproc <- m1 names(m)[[2]] <- "formula" return(eval(m, sys.frame(sys.parent()))) } lfc.y <- y cens <- as.logical(cens) m$cens <- m$iter <- m$km <- NULL m[[1]] <- as.name("locfit.raw") for (i in 0:iter) { m$y <- lfc.y fit <- eval(m, sys.frame(sys.parent())) fh <- fitted(fit) if(km) { sr <- y - fh lfc.y <- y + km.mrl(sr, cens) } else { rdf <- sum(1 - cens) - 2 * fit$dp["df1"] + fit$dp["df2"] sigma <- sqrt(sum((y - fh) * (lfc.y - fh))/rdf) sr <- (y - fh)/sigma lfc.y <- fh + (sigma * dnorm(sr))/pnorm( - sr) } lfc.y[!cens] <- y[!cens] } m$cens <- substitute(cens) m$y <- substitute(y) fit$call <- m fit } "km.mrl"<- function(times, cens) { n <- length(times) if(length(cens) != length(times)) stop("times and cens must have equal length") ord <- order(times) times <- times[ord] cens <- cens[ord] n.alive <- n:1 haz.km <- (1 - cens)/n.alive surv.km <- exp(cumsum(log(1 - haz.km[ - n]))) int.surv <- c(diff(times) * surv.km) mrl.km <- c(rev(cumsum(rev(int.surv)))/surv.km, 0) mrl.km[!cens] <- 0 mrl.km.ord <- numeric(n) mrl.km.ord[ord] <- mrl.km mrl.km.ord } "locfit.quasi"<- function(x, y, weights, ..., iter = 3, var = abs) { m <- match.call() if((!is.numeric(x)) && (inherits(x, "formula"))) { m1 <- m[[1]] m[[1]] <- as.name("locfit") m$lfproc <- m1 names(m)[[2]] <- "formula" return(eval(m, sys.frame(sys.parent()))) } n <- length(y) w0 <- lfq.wt <- if(missing(weights)) rep(1, n) else weights m[[1]] <- as.name("locfit.raw") for(i in 0:iter) { m$weights <- lfq.wt fit <- eval(m, sys.frame(sys.parent())) fh <- fitted(fit) lfq.wt <- w0/var(fh) } fit } "density.lf"<- function(x, n=50, window="gaussian", width, from, to, cut=if(iwindow == 4) 0.75 else 0.5, ev=lfgrid(mg=n, ll=from, ur=to), deg=0, family="density", link="ident", ...) { if(!exists("logb")) logb <- log # for R x <- sort(x) r <- range(x) iwindow <- pmatch(window, c("rectangular", "triangular", "cosine", "gaussian" ), -1.) if(iwindow < 0.) kern <- window else kern <- c("rect", "tria", NA, "gauss")[iwindow] if(missing(width)) { nbar <- logb(length(x), base = 2.) + 1. width <- diff(r)/nbar * 0.5 } if(missing(from)) from <- r[1.] - width * cut if(missing(to)) to <- r[2.] + width * cut if(to <= from) stop("Invalid from/to values") h <- width/2 if(kern == "gauss") h <- h * 1.25 fit <- locfit.raw(lp(x, h = h, deg = deg), ev = ev, kern = kern, link = link, family = family, ...) list(x = fit$eva$xev, y = fit$eva$coef[, 1]) } "smooth.lf"<- function(x, y, xev = x, direct = FALSE, ...) { # just a simple smooth with (x,y) input, mu-hat output. # locfit.raw options are valid. if(missing(y)) { y <- x x <- 1:length(y) } if(direct) { fit <- locfit.raw(x, y, ev = xev, geth = 7, ...) fv <- fit$y xev <- fit$x if(is.matrix(x)) xev <- matrix(xev, ncol = ncol(x), byrow = TRUE) } else { fit <- locfit.raw(x, y, ...) fv <- predict(fit, xev) } list(x = xev, y = fv, call = match.call()) } "gcv"<- function(x, ...) { m <- match.call() if(is.numeric(x)) m[[1]] <- as.name("locfit.raw") else { m[[1]] <- as.name("locfit") names(m)[2] <- "formula" } fit <- eval(m, sys.frame(sys.parent())) z <- fit$dp[c("lk", "df1", "df2")] n <- fit$mi["n"] z <- c(z, (-2 * n * z[1])/(n - z[2])^2) names(z) <- c("lik", "infl", "vari", "gcv") z } "gcvplot"<- function(..., alpha, df = 2) { m <- match.call() m[[1]] <- as.name("gcv") m$df <- NULL if(!is.matrix(alpha)) alpha <- matrix(alpha, ncol = 1) k <- nrow(alpha) z <- matrix(nrow = k, ncol = 4) for(i in 1:k) { m$alpha <- alpha[i, ] z[i, ] <- eval(m, sys.frame(sys.parent())) } ret <- list(alpha = alpha, cri = "GCV", df = z[, df], values = z[, 4]) class(ret) <- "gcvplot" ret } "plot.gcvplot"<- function(x, xlab = "Fitted DF", ylab = x$cri, ...) { plot(x$df, x$values, xlab = xlab, ylab = ylab, ...) } "print.gcvplot"<- function(x, ...) plot.gcvplot(x = x, ...) "summary.gcvplot"<- function(object, ...) { z <- cbind(object$df, object$values) dimnames(z) <- list(NULL, c("df", object$cri)) z } "aic"<- function(x, ..., pen = 2) { m <- match.call() if(is.numeric(x)) m[[1]] <- as.name("locfit.raw") else { m[[1]] <- as.name("locfit") names(m)[2] <- "formula" } m$pen <- NULL fit <- eval(m, sys.frame(sys.parent())) dp <- fit$dp z <- dp[c("lk", "df1", "df2")] z <- c(z, -2 * z[1] + pen * z[2]) names(z) <- c("lik", "infl", "vari", "aic") z } "aicplot"<- function(..., alpha) { m <- match.call() m[[1]] <- as.name("aic") if(!is.matrix(alpha)) alpha <- matrix(alpha, ncol = 1) k <- nrow(alpha) z <- matrix(nrow = k, ncol = 4) for(i in 1:k) { m$alpha <- alpha[i, ] z[i, ] <- eval(m, sys.frame(sys.parent())) } ret <- list(alpha = alpha, cri = "AIC", df = z[, 2], values = z[, 4]) class(ret) <- "gcvplot" ret } "cp"<- function(x, ..., sig2 = 1) { m <- match.call() if(is.numeric(x)) m[[1]] <- as.name("locfit.raw") else { m[[1]] <- as.name("locfit") names(m)[2] <- "formula" } m$sig2 <- NULL fit <- eval(m, sys.frame(sys.parent())) z <- c(fit$dp[c("lk", "df1", "df2")], fit$mi["n"]) z <- c(z, (-2 * z[1])/sig2 - z[4] + 2 * z[2]) names(z) <- c("lik", "infl", "vari", "n", "cp") z } "cpplot"<- function(..., alpha, sig2) { m <- match.call() m[[1]] <- as.name("cp") m$sig2 <- NULL if(!is.matrix(alpha)) alpha <- matrix(alpha, ncol = 1) k <- nrow(alpha) z <- matrix(nrow = k, ncol = 5) for(i in 1:k) { m$alpha <- alpha[i, ] z[i, ] <- eval(m, sys.frame(sys.parent())) } if(missing(sig2)) { s <- (1:k)[z[, 3] == max(z[, 3])][1] sig2 <- (-2 * z[s, 1])/(z[s, 4] - 2 * z[s, 2] + z[s, 3]) } ret <- list(alpha = alpha, cri = "CP", df = z[, 3], values = (-2 * z[, 1])/ sig2 - z[, 4] + 2 * z[, 2]) class(ret) <- "gcvplot" ret } "lcv"<- function(x, ...) { m <- match.call() if(is.numeric(x)) m[[1]] <- as.name("locfit.raw") else { m[[1]] <- as.name("locfit") names(m)[2] <- "formula" } fit <- eval(m, sys.frame(sys.parent())) z <- fit$dp[c("lk", "df1", "df2")] res <- residuals(fit, type = "d2", cv = TRUE) z <- c(z, sum(res)) names(z) <- c("lik", "infl", "vari", "cv") z } "lcvplot"<- function(..., alpha) { m <- match.call() m[[1]] <- as.name("lcv") if(!is.matrix(alpha)) alpha <- matrix(alpha, ncol = 1) k <- nrow(alpha) z <- matrix(nrow = k, ncol = 4) for(i in 1:k) { m$alpha <- alpha[i, ] z[i, ] <- eval(m, sys.frame(sys.parent())) } ret <- list(alpha = alpha, cri = "LCV", df = z[, 2], values = z[, 4]) class(ret) <- "gcvplot" ret } "lscv"<- function(x, ..., exact = FALSE) { if(exact) { ret <- lscv.exact(x, ...) } else { m <- match.call() m$exact <- NULL if(is.numeric(x)) m[[1]] <- as.name("locfit.raw") else { m[[1]] <- as.name("locfit") names(m)[2] <- "formula" } m$geth <- 6 ret <- eval(m, sys.frame(sys.parent())) } ret } "lscv.exact"<- function(x, h = 0) { if(!is.null(attr(x, "alpha"))) h <- attr(x, "alpha")[2] if(h <= 0) stop("lscv.exact: h must be positive.") ret <- .C("slscv", x = as.numeric(x), n = as.integer(length(x)), h = as.numeric(h), ret = numeric(2), PACKAGE="locfit")$ret ret } "lscvplot"<- function(..., alpha) { m <- match.call() m[[1]] <- as.name("lscv") if(!is.matrix(alpha)) alpha <- matrix(alpha, ncol = 1) k <- nrow(alpha) z <- matrix(nrow = k, ncol = 2) for(i in 1:k) { m$alpha <- alpha[i, ] z[i, ] <- eval(m, sys.frame(sys.parent())) } ret <- list(alpha = alpha, cri = "LSCV", df = z[, 2], values = z[, 1]) class(ret) <- "gcvplot" ret } "sjpi"<- function(x, a) { dnorms <- function(x, k) { if(k == 0) return(dnorm(x)) if(k == 1) return( - x * dnorm(x)) if(k == 2) return((x * x - 1) * dnorm(x)) if(k == 3) return(x * (3 - x * x) * dnorm(x)) if(k == 4) return((3 - x * x * (6 - x * x)) * dnorm(x)) if(k == 6) return((-15 + x * x * (45 - x * x * (15 - x * x))) * dnorm(x)) stop("k too large in dnorms") } alpha <- a * sqrt(2) n <- length(x) M <- outer(x, x, "-") s <- numeric(length(alpha)) for(i in 1:length(alpha)) { s[i] <- sum(dnorms(M/alpha[i], 4)) } s <- s/(n * (n - 1) * alpha^5) h <- (s * 2 * sqrt(pi) * n)^(-0.2) lambda <- diff(summary(x)[c(2, 5)]) A <- 0.92 * lambda * n^(-1/7) B <- 0.912 * lambda * n^(-1/9) tb <- - sum(dnorms(M/B, 6))/(n * (n - 1) * B^7) sa <- sum(dnorms(M/A, 4))/(n * (n - 1) * A^5) ah <- 1.357 * (sa/tb * h^5)^(1/7) cbind(h, a, ah/sqrt(2), s) } "scb"<- function(x, ..., ev = lfgrid(20), simul = TRUE, type = 1) { oc <- m <- match.call() if(is.numeric(x)) m[[1]] <- as.name("locfit.raw") else { m[[1]] <- as.name("locfit") names(m)[2] <- "formula" } m$type <- m$simul <- NULL m$geth <- 70 + type + 10 * simul m$ev <- substitute(ev) fit <- eval(m, sys.frame(sys.parent())) fit$call <- oc class(fit) <- "scb" fit } "plot.scb"<- function(x, add = FALSE, ...) { fit <- x$trans(x$coef) lower <- x$trans(x$lower) upper <- x$trans(x$upper) d <- x$d if(d == 1) plot.scb.1d(x, fit, lower, upper, add, ...) if(d == 2) plot.scb.2d(x, fit = fit, lower = lower, upper = upper, ...) if(!any(d == c(1, 2))) stop("Can't plot this scb") } "plot.scb.1d"<- function(x, fit, lower, upper, add = FALSE, style = "band", ...) { if(style == "test") { lower <- lower - fit upper <- upper - fit } if(!add) { yl <- range(c(lower, fit, upper)) plot(x$xev, fit, type = "l", ylim = yl, xlab = x$vnames[1]) } lines(x$xev, lower, lty = 2) lines(x$xev, upper, lty = 2) if(is.null(x$call$deriv)) { dx <- x$data$x sc <- if(any((x$mi["tg"] %% 64) == c(5:8, 11, 12))) x$data$w else 1 dy <- x$data$y/sc points(dx, dy) } if(style == "test") abline(h = 0, lty = 3) } "plot.scb.2d" <- function(x, fit, lower, upper, style = "tl", ylim, ...) { plot.tl <- function(x, y, z, nint = c(16, 15), v1, v2, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)), legend=FALSE, pch="", ...) { xl <- range(x) if (legend) { mar <- par()$mar if (mar[4] < 6.1) par(mar = c(mar[1:3], 6.1)) on.exit(par(mar = mar)) dlt <- diff(xl) xl[2] <- xl[2] + 0.02 * dlt } plot(1, 1, type = "n", xlim = xl, ylim = range(y), xlab = xlab, ylab = ylab, ...) nx <- length(x) ny <- length(y) if (missing(v)) { v <- seq(min(z) - 0.0001, max(z), length.out = nint + 1) } else { nint <- length(v) - 1 } ix <- rep(1:nx, ny) iy <- rep(1:ny, rep(nx, ny)) r1 <- range(z[, 1]) r2 <- range(z[, 2]) hue <- if (missing(v1)) { floor((nint[1] * (z[, 1] - r1[1]))/(r1[2] - r1[1]) * 0.999999999) } else cut(z[, 1], v1) - 1 sat <- if (missing(v2)) { floor((nint[2] * (z[, 2] - r2[1]))/(r2[2] - r2[1]) * 0.999999999) } else cut(z[, 2], v2) - 1 col <- hue + nint[1] * sat + 1 x <- c(2 * x[1] - x[2], x, 2 * x[nx] - x[nx - 1]) y <- c(2 * y[1] - y[2], y, 2 * y[ny] - y[ny - 1]) x <- (x[1:(nx + 1)] + x[2:(nx + 2)])/2 y <- (y[1:(ny + 1)] + y[2:(ny + 2)])/2 for (i in unique(col)) { u <- col == i if(pch == "") { xx <- rbind(x[ix[u]], x[ix[u] + 1], x[ix[u] + 1], x[ix[u]], NA) yy <- rbind(y[iy[u]], y[iy[u]], y[iy[u] + 1], y[iy[u] + 1], NA) polygon(xx, yy, col = i, border = 0) } else points(x[ix[u]], y[iy[u]], col = i, pch = pch) } if(legend) { yv <- seq(min(y), max(y), length = length(v)) x1 <- max(x) + 0.02 * dlt x2 <- max(x) + 0.06 * dlt for(i in 1:nint) { polygon(c(x1, x2, x2, x1), rep(yv[i:(i + 1)], c(2, 2)), col = i, border = 0) } axis(side = 4, at = yv, labels = v, adj = 0) } } if(style == "trell") { if(missing(ylim)) ylim <- range(c(fit, lower, upper)) loc.dat = data.frame(x1 = x$xev[, 1], x2 = x$xev[, 2], y = fit) pl <- xyplot(y ~ x1 | as.factor(x2), data = loc.dat, panel = panel.xyplot.lf, clo=lower, cup=upper, wh=rep("f", nrow(loc.dat))) plot(pl) } if(style == "tl") { ux <- unique(x$xev[, 1]) uy <- unique(x$xev[, 2]) sig <- abs(x$coef/x$sd) rv1 <- max(abs(fit)) * 1.0001 v1 <- seq( - rv1, rv1, length.out = 17) v2 <- - c(-1e-100, crit(const = x$kap, cov = c(0.5, 0.7, 0.8, 0.85, 0.9, 0.95, 0.98, 0.99, 0.995, 0.999, 0.9999))$crit.val, 1e+300) plot.tl(ux, uy, cbind(fit, - sig), v1 = v1, v2 = v2, xlab = x$vnames[1], ylab = x$vnames[2]) } } "print.scb"<- function(x, ...) { m <- cbind(x$xev, x$trans(x$coef), x$trans(x$lower), x$trans(x$upper)) dimnames(m) <- list(NULL, c(x$vnames, "fit", "lower", "upper")) print(m) } "kappa0"<- function(formula, cov=0.95, ev=lfgrid(20), ...) { if(inherits(formula, "locfit")) { m <- formula$call } else { m <- match.call() m$cov <- NULL } m$dc <- TRUE m$geth <- 2 m$ev <- substitute(ev) m[[1]] <- as.name("locfit") z <- eval(m, sys.frame(sys.parent())) crit(const = z$const, d = z$d, cov = cov) } "crit"<- function(fit, const = c(0, 1), d = 1, cov = 0.95, rdf = 0) { if(!missing(fit)) { z <- fit$critval if(missing(const) & missing(d) & missing(cov)) return(z) if(!missing(const)) z$const <- const if(!missing(d)) z$d <- d if(!missing(cov)) z$cov <- cov if(!missing(rdf)) z$rdf <- rdf } else { z <- list(const = const, d = d, cov = cov, rdf = rdf, crit.val = 0) class(z) <- "kappa" } z$crit.val <- .C("scritval", k0 = as.numeric(z$const), d = as.integer(z$d), cov = as.numeric(z$cov), m = as.integer(length(z$const)), rdf = as.numeric(z$rdf), x = numeric(1), k = as.integer(1), PACKAGE="locfit")$x z } "crit<-"<- function(fit, value) { if(is.numeric(value)) fit$critval$crit.val <- value[1] else { if(!inherits(value, "kappa")) stop("crit<-: value must be numeric or class kappa") fit$critval <- value } fit } "spence.15"<- function(y) { n <- length(y) y <- c(rep(y[1], 7), y, rep(y[n], 7)) n <- length(y) k <- 3:(n - 2) a3 <- y[k - 1] + y[k] + y[k + 1] a2 <- y[k - 2] + y[k + 2] y1 <- y[k] + 3 * (a3 - a2) n <- length(y1) k <- 1:(n - 3) y2 <- y1[k] + y1[k + 1] + y1[k + 2] + y1[k + 3] n <- length(y2) k <- 1:(n - 3) y3 <- y2[k] + y2[k + 1] + y2[k + 2] + y2[k + 3] n <- length(y3) k <- 1:(n - 4) y4 <- y3[k] + y3[k + 1] + y3[k + 2] + y3[k + 3] + y3[k + 4] y4/320 } "spence.21"<- function(y) { n <- length(y) y <- c(rep(y[1], 10), y, rep(y[n], 10)) n <- length(y) k <- 4:(n - 3) y1 <- - y[k - 3] + y[k - 1] + 2 * y[k] + y[k + 1] - y[k + 3] n <- length(y1) k <- 4:(n - 3) y2 <- y1[k - 3] + y1[k - 2] + y1[k - 1] + y1[k] + y1[k + 1] + y1[k + 2] + y1[ k + 3] n <- length(y2) k <- 3:(n - 2) y3 <- y2[k - 2] + y2[k - 1] + y2[k] + y2[k + 1] + y2[k + 2] n <- length(y3) k <- 3:(n - 2) y4 <- y3[k - 2] + y3[k - 1] + y3[k] + y3[k + 1] + y3[k + 2] y4/350 } "store"<- function(data = FALSE, grand = FALSE) { lfmod <- c("ang", "gam.lf", "gam.slist", "lf", "left", "right", #"lfbas", "cpar", "lp") lfmeth <- c("fitted.locfit", "formula.locfit", "predict.locfit", "lines.locfit", "points.locfit", "print.locfit", "residuals.locfit", "summary.locfit", "print.summary.locfit") lfev <- c("rbox", "gr", "dat", "xbar", "none") lfplo <- c("plot.locfit", "preplot.locfit", "preplot.locfit.raw", "print.preplot.locfit", "plot.locfit.1d", "plot.locfit.2d", "plot.locfit.3d", "panel.xyplot.lf", "plot.preplot.locfit", "summary.preplot.locfit", "panel.locfit", "lfmarg") lffre <- c("hatmatrix", "locfit.robust", "locfit.censor", "km.mrl", "locfit.quasi", "density.lf", "smooth.lf") lfscb <- c("scb", "plot.scb", "plot.scb.1d", "plot.scb.2d", "print.scb", "kappa0", "crit", "crit<-", "plot.tl") lfgcv <- c("gcv", "gcvplot", "plot.gcvplot", "print.gcvplot", "summary.gcvplot", "aic", "aicplot", "cp", "cpplot", "lcv", "lcvplot", "lscv", "lscv.exact", "lscvplot", "sjpi") lfspen <- c("spence.15", "spence.21") lffuns <- c("locfit", "locfit.raw", lfmod, lfmeth, lfev, lfplo, "lfeval", "plot.lfeval", "print.lfeval", "lflim", "plot.eval", "rv", "rv<-", "regband", "kdeb", "lfknots", "locfit.matrix", "expit", "plotbyfactor", lffre, lfgcv, lfscb, lfspen, "store") lfdata <- c("bad", "cltest", "cltrain", "co2", "diab", "geyser", "ethanol", "mcyc", "morths", "border", "heart", "trimod", "insect", "iris", "spencer", "stamp") lfgrand <- c("locfit.raw", "crit", "predict.locfit", "preplot.locfit", "preplot.locfit.raw", "expit", "rv", "rv<-", "knots") #"lfbas" dump(lffuns, "S/locfit.s") if(data) dump(lfdata, "S/locfit.dat") if(grand) dump(lfgrand, "src-gr/lfgrand.s") dump(lffuns, "R/locfit.s") } locfit/R/firstlib.r0000754000176200001440000000034714745724400013751 0ustar liggesusers.onAttach <- function(libname, pkgname) { ver <- utils::packageDescription(pkgname, libname, fields = c("Version", "Date")) packageStartupMessage(paste(pkgname, ver[1], "\t", ver[2])) } locfit/NEWS0000754000176200001440000000153214745724400012243 0ustar liggesusers1.5-9: o Support for user-supplied basis function has been withdrawn until further notice. o Changed akima from Import to Suggest. The interp() function from akima is used conditionally in preplot.locfit(). Anyone who needs it will have to install akima, whose license is more restrictive than locfit's. If it's needed but not available, an error message is given with a note regarding the license. 1.5-8: o Added a subset method for the "lp" class to resolve the problem that in a locfit() call, if "subset" is given then any optional argument to lp() are ignored. 1.5-7: o Patches by Brian Ripley (added NAMESPACE, changed Call_S(), etc.) 1.5-6: o Added check for 0-row data so locfit() won't segfault. 1.5-5: o Patches provided by Brian Ripley to clean up some function arguments and documentations. locfit/data/0000755000176200001440000000000014745724400012452 5ustar liggesuserslocfit/data/stamp.rda0000754000176200001440000000161414745724400014272 0ustar liggesusers‹}” hTW†_Æ…$Hª«A4JP¤±óVä¢FêF RŠcb‰m5—ZEDD¤q)ÚªTEãd²M&Û¸ Ö‚¨J ¥ˆH—VÜ¥÷ݹ粒2^¸sþyïÜóåòÍ,7óËó á‚#ÔOÈþ!ñ“#vžØêcÑšÕ†Ño°t2Œ±Ëp&ñqÁgý?BƒƒM¾¯BCrá½í#’8;¥riáé\œí^w¹yR9â#/<~{ âËçßx|ò5âGÏŸºúâw–MÛé•¡±øoþEcUp=„Æ“¯þ®Þ5~´…÷!1C÷ Q»o÷§MA"‰ÇÒM–\hŠu~µùE/šZgýx%½ MÏ®þñáŽñ9„—Ïÿ ÍoÍnò-š¥Ûh4¿ùGxþŠ™~=Z¶óç„áh9ÿÝçcŸ^@«€ŠÈ„û­;ƇÍI¡õ²Œˆ6Q…(mó.ýüð‡Úüì*—¢MbCH†ý‚O!Ó–EHúÑ6¿Dò¦þ í¾× ¹h÷Ó»ñíûýuí½E×î,›Ž”hb¤ø.R_È#uX6)¿Œ·Ðá»MÛ‰Ùî:Žß^,JF‡hÊŒ½[Ñ9ö©¨dd¹E×Ñ)Ã}ƒNQm]|º& A—_ÅÔ5èRóìòÛråºÕ\3c £[Í·û…L=jÎ=›d@ô¨y§ ¹VsO‹)Ï»ti5ÑK1ÉH«{öÝ?GZ݇sþ† -<2Þ»J5?Ý?ø_Z¨ìdemeU€ÒbeÇhïMí½§ì,e§oÉØÍ?àåöÍSÏ—Ïn‘vnˆ²C³ÄËÕxº‰w¤æohçÂYâj}÷=gèù侎:ç~d™s¶û¡ÇÉ~oú~ìj£5+ê…«|«ZYñuð§bÕÚÚ˜~¬¢:Z æWFcÑ’/ëDDÍ=¯nÕú’ÿ“ÊÔ‹œH Ì@X°á „ˆ‰˜¤D(ò U„ʤ²¨l*‡Ê¥ò¨&R‘a’a’a’a’a’a’a’a’a’a’a‘a‘a‘a‘a‘a‘a‘a‘a‘a‘a“a“a“a“a“a“a“a“a“a“ááááááááááá’á’á’á’á’á’á’á’á’á’á‘á‘á‘á‘á‘á‘áùŒ·þþ阮õ~locfit/data/geyser.round.tab.gz0000754000176200001440000000046114745724400016210 0ustar liggesusers‹]”KnÃ0 ÷=ENèÃ'KÇ)šM7 P$÷/Z™l9YåaDʾ½¾ÞŸŸûåãñº?ß.?¿z-úýS<ׂ ÞÀxïànàø›7ÏÇæ5òæò<7ï‘Á×æYÿÏ·kIý›û‹œý5økð×Ü_óÜÁ;ú¸¡¿ð|¨àêð‰ú ¾ÀWz¿îþJdå\Óýþºû ÞÀ³¿þºû‹ç;ýYdô?ýÅùþêO‘'ê'î_àÙŸ¹?ENýÍý¯¨o9Í·¹¿ý õ¦|þôý„ûO#2îÏógî/rž?sÁøJ\˜?aþ„ýæOØ_aþ„ù¾Âü û+|ÿ„ùöWØ_¹¿¿ >Á'ø_ο¬`¸?locfit/data/morths.rda0000754000176200001440000000101614745724400014456 0ustar liggesusers‹…”ËJ#A…+G4 f.\‘ACRÕ¹Œ.lÐÅ€×tçÒ^`RÑÌÌ DÁmÅGñQ|Ÿ@ì6ç?Xb rÎß_uŸú«›ŠwS]JKJ©@ 3;d…lÌgcöúv|ÿÿN©â÷¬ÊñB66¢½‰ÊѾ‚¢>@}€úõ!ê#ÔG¨QGP¹þ4Õ6x¼ ÞÁcð<OÀð<ï€wÀ;àð.x¼ Þï÷À{à=ð>x¼ÞOÁSðêÐ&tÓÓ¦7¯ê­Cöqºì­gÙíŸýyýGÊßoç´ùvc¯GÙa£qØä‹ö߶p#ÇÒåȾKîíWöNn—‹¥K{o+ÇÙ“½éóãÛ‡ÊÇÄ ‰©‰ÑbŒ˜PL]LCLSLKÌ/˜ V¥«Ñi:CÒÕétMº343434343434343434343 3 3 3 3 3 3 3 3 3 3Bf„Ì™2#dF˜g¼æã ü”ôVÑlocfit/data/ais.rda0000754000176200001440000001350614745724400013725 0ustar liggesusers‹íœyŒ×YÆ'vâ$VÏêÝŽÇã}¼Ì½÷»ß½w’8wöíÎÌ]f<ã؉=ñÜ{Ç­Û4-ðLjª­€ˆ±©¨  bSUT@d±E ª ‚R*EBT((*›JÊÌœßóž~'™²”Jý£–nÎw¶÷yßç}ÏùÎòeªÃ‹éí‹Û[ZZ¶´lyèž–-[×ïݲöŸ{Ö~®ý¶.]¿½öߎµÇ÷®¥k¿–W©þÎïÛç·å;¿oÇ_b(m»Qÿ@ýÆÚhji¥ÅFi£þÌÒ:¹{Ýs¢ß}×n,ÝV7ÖXºvçæ­µ§·¿Éayß·èwï·ð·íð[§ðþoàžõºH7û=ô ÷ÏÔï<í›m­Þ|^C·öüuµÚ6w%êë³>sWjÏÝzöŽUÖŸ}vý­êr WÊ7oÜtJmýÚ7æ-­óâŽOw~ÏÇ>]lûÔç·?öÜÏ[?~ùÄW~ïãÅÖçÖ ¾«Øö§ëÿþ¬ØÚØøWl{l£¢Ø¦~™ÅöíÅöÏo<Û×k;¿·Ø¦~ªÿÈÁ—+ÿø‘bòwŒ­ ·þmôëøÄú¿Ÿ*¶!oGïÜ€ï4¹*oÅŽ¶5#.Ÿø—b«ô§Cz­Wå³Oö«¾;[Á5¹ÈiU=í[áã!ì5^…ƒ¾;à«UúÃw»ò-ÿÌž6ð;ÖH;ørµØºžT¾\lÅ>ñÒºAëÃÆk«ôDõ3¹òvˆÿV•Ó¾Kõàwí;лKõè¯øéd|´Â»â¥uƒ†ËÞ.xêÀñ.¼Nùë‹ÅVñ¦8ÁŽVé…=ê×®xGŸvø“ŠïNäˆÿNê;Uôï’žèÓE{ÅUWÀc[—ÍOz¿ÃSò;ÿØÝùò†Àb—ÚK/x”¾¦?ýĻڵƒ+{;Ñ_vv(N)ï¿ÄÆ­Æ3|·k~¯}Íñ©xÁ6NågÕ+ÅQ'ãÎôC_ó_`Wúí’>ÄiW'ÈÙ oâQ~•üvÉ>¼v‘îT{ü¸SüÊ.ñ*ß©ø”²»MÊ»äGÉS| Wñ@{ɮŭô#¾v‚#y]®¿½W‚sˆ~Æ;ñ°Tq®òØÕ­y9¨?@ú0énÚíFþ® ð WvÐo;qÓCÿ=ÔKÎNê•?H^öí%¯~Gh§ò]”KŸSä¥ïÁ ¿pvSÞà(nzÈ¥ýÒä=¤G•b÷añB~_^7x•=¯‡ý»üýÒ;Hwñp˜òýô“žâû@àé-¾öÒNåâUö„¼ w?v¢\ñ¥ùEï—‡y’¯þÊË›}dŸôhÖY{Éïôîâ«Cæêégåôž!ô¼ôÅÎaê¥ÇpI‡°g„öê7rÑõ)¡7ýG߃>ð1„âi=‡è?Hñ3X¤Ý±¤ýê7ðV2?D»!ô’?Äú›=o²Oò„gràMþ•]#ØeþS;äÈŽ1êGÄ v›~Ø?&ÿJOñ‹\ã•öC’‹žÃÔKOé=ò‰$Îq9ª4ððxDÁ7’~•_d/zK¼(^ÆÔ=ÆÀ¥ÿzbϘâ“tíÇ)%®FŇÊÅß±€?Ré«ø–}Š»Qá£×¸x“ßàÝôмî4z‰ÇñcÉ84ÿ¼œÇè7.»ào\zÑÎøFùo‚Tão4ŒÅ)ö+~do1È Gúã_ÓWñ¢ñKÿ ÍßèƒÞö^9_ôž;Ÿ'IOë}¨”ö§hß«ròjFyäô¢—ʵ8”ë½y9§|•Ÿ ä«ŸäžF®ô´~z?+•~’Oÿ^ñ@ñd|‘ø;®RÉ—þ'¹*?¥}’xUªr­Gyæò½á:F¼ÈþÞ *د üsVüÊO´?øEöŸ ú ïúŠÀÒW|È?/ ìé ø>ÄUo ßéMâLöË.Ë«^öSßWJ¶ïcÜ¥_ãÒx â2Ôó\0žLŽì"Ÿ÷œüÈ;Kûs²Cyú¿#/ýƒ¸é xèÝLñð+=ÞÁ ó«ô6žZ’픞 ã0ˆ³Ð/!éGöÈÖžòL0ψÿ>á<«Ÿä¦~e¿ù+àUz¤W“ã@öˆé!{û‚x?̇†ŽÛ–¤>¦¯ì¥>õÙ$g’ñbï•ÚWH³Êóž{Lï?ÒªÖAZï®&óZß÷“ž×: È›\úŸ$?½š¬¦~!WCŸŠö«É¼ô'-Ó/#}W“vh¾‹Z’zÄþµÕ$_—1À/üªßw“øÓÔ_¹›”3Ø?Ñ’l_¤~‚tŽ´Ð’ìêÿ©üÜ+ä§?-¯&ñµ®—^³¤hw"h7øs"Ðk4ˆ›¾ÀαMâE~+­&ý}úv͵$Ëå/Źä”IgœEÚMQ^S<“ú]»J{pV“¼6Z’þo¸ƒ¦âÕ >¥ßÒ§ï&ýt¡˜Äo¼Ž¿oà>I:#~ÄÃÝ$¿²ïRÐn0—Õ`ÜHîøjÒ^Ÿ=A¾ø+ ü~ñn2¾Ôîb1é×’æ¡`ÜÌÓéjrÌþ/“¿ÄãûH”É¥OþâOüHÏf`—âéý¤Íד㦠ÎÒKI=äá]!}¦˜äIú^ âLv/ó’â÷IɧýUá‹Gô,“ãZó»xyæP¿ö^‰¸—Š~ÅÝWe¿àîk²ÜǤ¹wÊrÿ“ýŒ»Ç‰~ÆÝÛÄÜãd¸ß) W–÷]|¿»Ç+Pÿ¬“+œxÄÝeIst÷_¹>×>×ëôÊÿ ÃÑ'Ã}VŽû¥ýó܇泮]ôݤŽÈËípù<ïÿÜ¿9Ü»2ÜgeÙ/fi—Åžìï£÷ö wž}£ìŒyŸç~ÌÝ£Eàæ¶8ýóð—$/ûÿÓÙÑ=ü¸,ˆ÷¿súæØ—ÆïwöE¤q·Ó£ »éŸå~5¢¿Þ³18÷rYä>ú#Ÿ}ó£Èígß\Àÿ“»çí#2øÍôÁo’#_|GðšyŠzÒr2𱞋ðOAq ½ÑÇœ)ú¥'œ4rÓè›zÕ•§8oˆf]û˜øÉ1rÜcçÀ¹ÿÌßGü"¿°}ˆ»~ôQ¼ÄÜ“öÿ¶»ŸÎÁoûÛ¼âDüîrå9ê è—a<ö·ÑŸñžS9v>éô)(î±[ã)¢½Æâ²@;É+Hñ Þ5¾±#ƒÝYÆqtÍÉËÊ?_rùÇÀ{„ú¼e‰Ÿˆvñ_¹ñÃs„½ò–q’aÜi¼e9÷±øÇEÆ[ü“ŽÏóg=ÌšŸ4ó²»5æ°'Ò|ĸP\ÇŒ³çcüÙÿýŒ÷?tõÅ¿u8Ò#‡ó´+¯9ÍsÈ-ü…ã!+?ៜâ{dwL»~ÍóðPxÖ•kž}„¸ðžÈagÌü/8þ²ÏÞ+—ÜÁZñ"û›'ðÓö9sîBªXe~œ']ü«¯þk_FNýšk_ã½ò$óìx]d>Xüw×ÿ r*¤‹z_Óßð }î&× 5æIä^BŸK¿êòUÒËZG¾•”{‰ò§8O¼ sJô¸„ÞZ.þ¨ë÷ÔGiOO ß5ê/Ž&y¼¼š\GjŸõô'ü¹m®½ú_†ŸÆoºò ú-½éú]gÿ^)¸ô"õ•¿tý§àãü,¼–<מÂÎYü3‰>³ô‡§é%Þ«‹Z_=˜ÄUü\ý>׿øFòÜ]çêUü<ˆ<­uÏ3­soü¯u™ì!>u sb­ïñËåü¬óç™·‚û&ðKº¯£Ý´Î•µŸÁž"ëÖ~Ök)Öù`t–õV¾úY¯¤ò®]¿Ö›¬Î3N{Áé'X7œc}“a=z½éì7ÞùnóëÊ^ðN²9§H³n9†žŠ}òÄIFüˆOô>D¿c´?çˆçÖY:>ŒÞ§YÇa}œuÙ ø=ÊzûúÅ®~2ÄkŠõÚYx—'YïB#È=¹'ùÝÍ)¾7=ÙçíF~7q´>ëû!ÖoÝÄ¿¾Ÿ:N»Cð¶ÿíA}wt¿ÆÎ}ÔA¿p£ÏQìë¦_ý°®î!Ž»±ã€xÅþúMváwáœA^7q{ìgÐý».}¿É^Ù·›v;©ßËþFßö¢×qü°»ö¡§¾WÚ‹œÝ赇öûÐGß/é»aû®~ûˆ¯ýð/{*ŽÑ£—¸Ô÷Tñ£ø=‚ïÿöÁ·ôÒw`Ý”wƒ³WþÓwgð‘ZavÐüHþˆöeì¿Rä{_§o¸øç óg7|߇É+>Ž3žOý‡WG˜ŽGŠCñw\ßç:~í½2Ëûcšõõú”ØNÂÏäß;¼™.§Ïø)秩q×’ù«Òíxá}7/eæ¯ö”ЊùºtÜÙ7ËL/6¥]÷Œì/¿ÄyÏ\û&ã»q’òëàü©î;É7wÒþ£AÚ’¼Ï’üçNç(ç½ÔxÅéÓœ—÷rs)É«Ëæ«ÆhRß:rê¬ûëâõ©ì`½RÇþzÀ³áÉž¿&}‘zæCñXǾ:q¢Tí ç3”sžUÇŽ:v/«¼Ø£vœsÖå_ö«uéñA\ Ç²RìW¾Îþs™s€åW’|/Wõ—’÷Üuñƒ—¿šŒ¯å2õØ¿ ²ãÚï¸ö×¾@J\è\òiñ€ÖäýøJ)ïw¯'ïoWˆÏ&ëÛz®èÞ–8hÊ¿Œ«&<®hÜÁ—õc=¾Œ_•×=°CÊWjÉúæ‡]þ:çT+Œ³•!ÚÁûûs® g“8Xa|4é·Â¸Yi$ÇSøà5Ákª¿5÷ãoñ(~_JŽ‹ë:›—ŸÄ‘#ù…xhþq0¿I.|4Yï5X·Š÷:qÒÐ|€=—ôSÜ ·Ž½*o~ ¾4NàSzظ†oÅ‘æÃcùãsIÔ…yE~]Áî汦æ]æ¯æ›Éy_óºâ¶A}ãKÔ3šn]nï•q\eÝWažÔ}F™y~–õ¼îYf)/ëÎéuX}=ù>›ÃÿWèWE¯ ñ£vU浪Ú_!nÊè[c_T%ŽkºWÑzŽý¾ÎmýB|Ôˆ»úÖÀ›f¾”þeÚÏ0J¿2ç™eúW‘WaüT×Uí¯dG°^šOýM?x-ë~I÷Còã«c'xZU©×yjEøÄó,ò¦8'Ÿ Öƒeü2/~¤vÏñþTü,è~D÷ÈŸTܼ–<ÿ-ãëk'=ftÆxÔÿG vÓÈ­ Ÿì*ÑOçÿcè¥ï‰ôÿGèüy$üÿ]è§u§ì«áGñ1÷z°Ÿöóð§ï«Œ­Ïuž>ÞóÄ×<óÖñ>þóð®{ÎIÝ ê“ûŠ ŒÏðlß<»w#•_/wZG_F/Ý{^Tû×’ík´S\hüÏh|kßñVòþõ"ãuáÅ亹ŒÕ¾ŠýWš´Ÿ¬aWIíçè7G¿yÒKøqîtò¾ø)xÕø¶}vUз Ïì+¿’œ×*ÒCv3¯jžÔ8YÀÎKï î­¥‡Úé^Œñ¼€ó*'76?ª'¾ì;;ü>ÚJ~øYÀNígªØ¡û±šã1üëNÏ.=S×_wz¯þ¬ÌíúUû¹›·îØŸ›Òã‚=n¿fOMý5šÑú­[j:8=¡ÇZmT-G—LnipÚD¨pËÂMþ*Íöå¥;Kg·Ö4¬yðÖÍçÏ~½E¯RqOJi=dôé!«‡X9=äõPv©>{JÙSÚž2öÙSÖžb{ÊÙSÞž #miÃHFÚ0Ò†‘6Œ´a¤ #miÃÈFÆ02†‘1ŒŒad #cÃÈFÆ0"È #2ŒÈ0"È #2ŒÈ0"È #kYÃÈFÖ0²†‘5Œ¬ad #kYÈ #6ŒØ0bÈ #6ŒØ0bÈ #6Œœaä #g9ÃÈFÎ0r†‘3Œœaä #oyÃÈFÞ0ò†‘7Œ¼aä #oyÃ(FÁ0 †Q0Œ‚a £`Ã(FA[S}}þ1åÓþ1ã#ÿ˜õ±ÌùǼôh)–òh)–òh)–òh)–òh)–òhi–öhi–öhi–öhi–öhi–öh–ñh–ñh–ñh–ñh–ñh‘G‹œØy=&caF´®¶Ì·RÅ„aÊžýú‘´ë|mŒ¹Å¢"Ó—Pá6Ùà‹½XUû†±*î j=ª»]å«S«Ø §rñÍnOx«×ø…ã®ËÐ1ìq¹•Ühè2_d]½Míþj›Ã åáí­ÑV–“ïB‘ÁÕ%IÏÚ uƒÁþÜ ¨¶/r¼§ aÞé_š@-ûâÖ0ö0û›Ýz¢ ­Ö}lº°Õ§¹b´wÔ×­®¸(fÌÂ£æ ªß;æÔ:¬~8ÃçZÊ.gß»ê矰ÿºýˆGjzPq«ÇÓù‰d‰cL'Ù-ƒ–ix¥ã1øhÉÍ3«µ0QôY|Ôú1«G®×:}‹.üaÁs{¹-¶PÂä>Ù½ ítxZº0ÔƸ‚×?Òw+ÆÖ˜uuÕ32¡NV>½/ìJf=Šœkm=³Ý?”ÍÌÅo~ôr®¯½fÿæ1ô®bLÈë(‡Ü®àîQÍGðã¼û®Ú‘£ 8¯q™Ç¤ñР9½i#¾÷ÅóQµR”VÉû躎ƒF ‡ác.„¦ó›–†Dì0ôdlšî²“ö׫”…ÐÜomÇ;†=“Ø3ü¡´"Åp’¥6®ËêÃXäì5Oî8ðŸõÖ×} B<Æ«L’CɘÉÁ­„ÿ«G~h Àž'GwE%bþéõ‰ìnlŒViU6 ô‰ã5ã‘fPÖ­4Úð¨.ˆýsÖ$^€ ‡š7zªöP]zíʬ þÐf{cýÆD,-Ý8;“á%M¾†Øp0q§{TOwÕüÆwþ–q&í¾‰ÊrwZUÍ Ã2N•Ë‚IØ¢°ðˆ8ÀÅw p§gvùøÝÔŸËã¾”ä "5œge;¤ÚÿŠÔÍü Šã¶M7RÁÄëI·gbžéãa—wñ!)ð¼Ó´wç1z†Áa¦Ïà}ìcǽЖ51ä Û Ÿ~óòÌœÈ ð.Ü-ã Û§nZm¿:öÍ–Ö¿y°¾ÈÒ¢4$[G`eÍ §ô<(U˜âÓÞ¿ÚU^qoÛB»Ç"ùK©ðªvK|fB¶}Õ~º%¡ŠQ¥z_âÇ™OùË› é¸Zâ!§8è\ÁsœX¦Š¥:¦h2¯ÿ€vB–3ÖÍ·®…f`Cï˜{šؾb{|_Ò|ÌtX4©{é× jØm¼ä¸6;OîÖ:?4Ôn‹žƒâXÝ_>¸E@ça=µ&cášì܃ÎôýPœ'[Õ5Ù‡7Ù¼‹€î—/NÍk9¹#z—°KK»HlŽ)¾³rÄŽ°á=/7aÖÊtö¼b.tŒ5í7þ0äÌRjuR1KQ2¼r ¤Ù¥©Íò¢1rê4¾^6Xm(›Ô¨âzÉwÙ¦Xâ>̲·ÈNµÙöÝ`E¦‚ÓoFñ ÷RÅñ÷ÝŽðñük¦þT>v¹ùàتy¾`ÑÙÑØ{Å%îWF%–8‡”lO<…%ß6ðÀð*Fãµ_@Š¸cm_~!Ô‡è_úrIJ+¤ò‹z°óPâR4Þó9 ~¾¼ZÆùÙD<ö€Lãì¤ï >B§Ö‚ÝIÍp(lÃ~ãÍîºS5ŸtCcàE—Û*­Æ´ñÃZá.†ô7Е: šü!³þ;$YY˜?ãF}ç{4Q^~쥂+³“¿XepZ0w³±M‘ PÔ™u?E^jâÂúIEog6mfÀ‡òg$ŽÇ½ì1O¥7 ãaÐë)V˜¨°JØ5Pàµ4)ˆµún5, -D¨|Úó¤}ë,Ù³Qo‚öÍðŸ>°Nê‹ž~¥X® ¹6ÊÚ~‘)Ð]}öºM®Ð»ä®ÿÏÁEÐ2rÿó)n:ÐÀ:-ÊŠ €Zn¿–»Ë ™-5ß:»fhÁ†þt/#Ù3¬5ÒQ¼¶¬ëljXŠßŽ€ÃÞ r®71ËÐF­fd>¼¼üZ%IVƒéΪËÔDgAlbcŸ´ d?ö·ÀjÛ YkBÖœ°XÌé€Êö‡¦ÁY©øvÔ´ÍëUA¤òUÕ« ~ q˜ä×Ü+ƒj„ÐSe Ð’›vü$ÕËÏ®ËÆô¹+5‡O@ÑoKåD9¾øÆ5"ipJÃgÃn)¿•|ƒÛ_žj_-ƒ­fŒÞhÕêê.á•ðäà”q{ƒÔHj:”ÜÝ Èd9®|^’ãy…d­FñðÌXãâl”îµ=¾÷Gx˜7MS»%KåÖ\ÄÜìîήÅOQœS®;\{8”M–‘ èAÕ+åôU•çáÝÑ´Îí+ þ¹OêÓšÐP1Ry_ò9ˆ“çns,Ó…Úú=‚§h…BEïÙ¦(«-;yõ{5(Š¨íxìnÏcú&ÉؘµM¸»ªkÇEqÆäáK}?÷Å: ¡û97³nû 8[;BŽ#ïÕ'æ\Ýq|?dþQ,M½åàõXÝ ›F¿ïܤ Âc3}W¦`ñ¾Ä²d†-¤Øgëïû%bá=MoÍànå½ QÙ¬,ÿE{ûeu,R¯óŠá™ô%,ßóv cœ+V¹{`ú‰f2;ÄÍ)g5šáÍźŠ–ˆ F)…ZžºÐöUªhw 6`äýs͘f4sB_òp¬ “©·ECâeßÎMc0ÿÔÇÍ c­A2j¶éÊú&L4÷ÑþÍϳÞYŠÖÔ¾Ææ+…×/è8@ó-ùâîu†P[½dz½œÔì´ÜÐR¿|lŒ,ºATa65ïÙ¨”ýzÿ®…5>[P®|h>äÎüq¯¦l%–¸LïùæÂ`?3irÚ­*ž-{w,…Bߤ$G‹$h®–ŽA¨JR9”uæ¦ ç¹ÕYÌéálÁð¢ øÑ:Óp´»¿Û’1ê ô›·y»v:aŒ’bá€ÕCü:©æ›@KÈiÏÎÿrº9½vcTý°mô¾Ý³C_@ðÖ>—¯w/ áè­úõÍÕ'wtI¡Ùv¿æqU3,ï¹¥8Hç6v['[‚Xõæµ5¥ÉƒõÊP¬NÊÁ¥Æ]Åjk¡öFlrå+¬¾vê”NÕ%ˆûklÜ«|¨pùeÆèR¡øŠv {`$Vë÷[•܆Šžá¯Í æÿä÷u†æ¹?-Ðòÿy¿ÿôû?ïï.Ÿ[Žºßßõþi¹?÷¸¿ª×OÝþwëõSëûŸ.ÿôþüÕõþÓöô©íãsÛç¶ÓOmÿUîÏíÇ÷z?·^>·}êýýÜqäSûݧŽÿßýé÷?^{ Ûc·ÛñÀ`ûï—^¿o”?Â$‰õïÄpýó‘Îv†ŽÚ8b›ÝA»¹NûOú§ÝUöï=<÷¿cC'²„bÎPàÞPàÁP•™9Ÿ$rLIl’8$qIâ‘Ä'I@1XÄ`ƒE 1XÄ`ƒE 1XÄ`ƒM 61ØÄ`ƒM 61ØÄ`ƒM 618ÄàƒC 18ÄàƒC 18ÄàƒK .1¸ÄàƒK .1¸ÄàƒK .1xÄàƒG 1xÄàƒG 1xÄàƒO >1øÄàƒO >1øÄàƒO >1ÄC@ 1ÄC@ 1ÄCH !1„ÄCH !1„ÄCH á¡Àœ?ŸF&,Ù4rhäÒÈ£‘O£€Fª1©Æ¤“jLª1©Æ¤“jLª1©Æ¤‹j,ª±¨Æ¢‹j,ª±¨Æ¢‹j,ª±©Æ¦›jlª±©Æ¦›jlª±©Æ¦‡jªq¨Æ¡‡jªq¨Æ¡‡jªq©Æ¥—j\ªq©Æ¥—j\ªq©Æ¥j<ªñ¨Æ£j<ªñ¨Æ£j<ªñ©Æ§Ÿj|ªñ©Æ§Ÿj|ªñ©Æ§š€jª ¨& š€jª ¨& š€jª ©&¤šjBª ©&¤šjBª ©FÇÖcIÿïëy×|Èlocfit/data/kangaroo.rda0000754000176200001440000001046514745724400014753 0ustar liggesusers‹Í›;l\Ùyǯ´›Ä -T¸˜"…,.ßR [-iw%[»;#jø‡*")J>†oRÃá›Ò,Rl‘‚EŠ-RL‘Â… .TlÁ"…Š,R¸0ìPáïÿIß­›Ä†ŒÎ=÷žóý¿×yÜÿ=¼ùÓ;MÞù0I’‹ÉÅ_H.^:»¼|ñì¿ g¿Î~W³…Þìèðp’\ú›³úGgå_Ÿ•¹ÿíóû]ø#üþÔøÿ¼üàb÷ùÜ?åò¥³«ÞܽУ‹¡ÐþGÝùlIÍMHO¶{lxôìêwÿ¡ÿcü.ý‰þ¼~oByñ÷DïÑûËž‡ùþÞþÂpéa‰[ôö÷f c9»qe(—φ‹¥s—~ÿ‡2 ùñ› HïL%oþ¥·V);ÎËí¹órç7çå~#÷Î˽—çåÁ¯©ÿŠv ”ãçåî§~:Àÿ/À; þûøõyrÎËoñúlýõr¸/¿)ox?n£ßNuòrû_BÜÉóÝîã]ü°ûÊå…Åuûvè¿«<$Œ§Ý"v£ÿË1o÷ ì> ÷~K‰¾Aÿo<®ÆÕîJìߥýÎ÷>OÔn|=ø+î“Wû¿¤äùvî¢ïžò}÷Áß—ÈßGÿíËÞÿ;äåö¿"GóñÛGŸƒø‰ñòÏÔ_üÚÇm»æå;röNü¼³'ûÈ‹}æ—=ôÚ{íïï_öóÁÆ-þØÅO»‹}Øñ~’û‡^É? ~€=/˜¯<®æËâòRó6yº­:úoL}Êû]zj^ÝI‡ûøs[ùƒ=»û|Ö¼çWâ`ãe¿¯0Ÿ­€·Æ¼²Žþè¹Æó ÆwqµÁ¸ÚÀŸÌ×Ï™¯ªØ³Iþm"w™ÏÓï÷ƒpž3Nªß;È*ù]¥ÿsô¨‚_c\×ÈÛ5òex®ÇÚU/§J^l`Ïsð6°wƒzñ³ ÎÆo}YÃo5æÕMòk™¼XAÿ¥'+ÔWO}¹&½ÉËõEŸ'kÊGÚ=åóåy ûnø|!ÿm¼äi¯rˆylÿ !„<ͯQä•Ðo”ø‘3ªvÄqˆø"gŒv´Ë“Ÿð‹àé_ÀžÁCß~ˆû#Äq˜þ#<A¿üZ$F„ÓèõAÏöÑw0ãíè7Ÿ þŠrSÞ—ÿ ‡^N¡ìýR¨û8 ª]:Ø Þ`Ùã+^òçâR÷ýÿá´o?œ ö ÷HÙë[ 8Eù1ñù1ŠýcôEîXòþ|Ý”}Ê›º·Ïô—ÞÒOrñS>íóaDy[ö¥âE^Ùx™eO£ß ræ¨WÀ[Dî,xóŒ÷¥.ÿ|‰û Ì[óø£ò:ÌÈfÞ›E¿9잣ÿœž£çœä1Ž*¬ ‡¾>óÌÛpç™W景+è=üÖã%æÓEü7-?¡çŒüÅü[¹êõ¬zœ%ä¬à‡ô›eÞ›o–|ªÈè]áþúW˜ÇçÉ—Šîã¯yü;^å[¯ç"ïYKŠí¦Á™fý¬0Íž†{f?³²w<Ä»*}!.)¯÷úM}FuäN#oú8Ôñ×,òft?íý:Wöq!ßl¼ ’Ÿýaüi\æ5_Ãü¥ñ©yJóNâ×™ÍËÔKšwðWâqÕ.®7ýÔÒaIùypðÄÏÛ’7œñórQýhWìò¥ÖEõë×üžx?hÝѼ?ì͇ù_ó®pú3¾ zö•ý<«~Š­3!ŽÂ7=º#»m}£ß òúÓÞÿIÈ µ ë’ù³è×G­ƒ¶9 ûìÎQözû{‘ó€~}Ñïå'´W~÷žøuhàзW;Ù/{X?m¼Ü§]·Jôè>ñû•jßö%½ø1wèíë‘ý‰Ïoåûý”Ç‹þê¡Ì¥¼üø¹¨§pUâÇžïo{N¿‰·£7ãóáAÆë{9݇ÞÒ«;ñ¸}!Nò‡ÚÝOûþ„+?¨}Ùûɞˎ²·C¸ÒCã²Wû›ôûý+<é)ÿ Gý”/Ê»¾”Ÿ_†4㾨îó@û;ù#§:8ÙàWÅKñÌE¿¤}œ»C(/ÌuŸwý)ç?/“àŽÓnœ~“̯“¬kÙLð|ŠûO}ý õ'ÌcO)³•é_fýOyù“< þcöã§ýó×ıÇ{Œ=Søå±ô§ýcü4…œ©¢/Ÿ€÷}§ÀGŸ â0ü éwêõžÊxœiöAÏÐóIÝ÷Ÿ@ïIäN5úçSÑΠ·Ù×äÈ¿”OÑÿ©êŠ÷‘÷ÿ$ëØá¤=Þ³´Ç3üú==òq–?•/ÏoW™}ç£cŸ‡TâÏq•àM¨ìòõÇ]Þ–gèýøÐÇiý&•ç'/K賄]‹´[¢\æù*ïKì+WÙ®'ž7ZAßU⺊Üeô[GÞï' Ô—Ù//aßò·ž/Y¾âß–Ä+%¯B¯Ué]õ|Ë z.ë}‚ýõŠø–ñPò|½‰ç"ö,bÇÒ¸çË–ð×*qzÞàKñ|æwéÕàßó–¾ ï}z¿:òz/˲¹+UïWÕ·5Ú/óþ²*¿y>n y«´[ÇÏ+à®açšäþN~xêùÄ ÅWù@þ,Ño‘÷²%⼌–3ÞƯ•}‰gS>Šo]E¿µÀ¿ÏÖíµ^jý´}jÆïãµV]ïâŒOé ûÀºç#†ÂûRäc¤W!ð:Úë=&òdƒ‘' ïÒSû‡Bà_þ_ÏÕ_ïgqßý¤÷ñ4z¾žÛ{Vx?0?„÷ñP…°ïŽKÏ]ó<ç\×ðž]wýLŸãÀ¯+Þê'øk<ðØ쿈ëìoŒ>óÜ_Ð÷â¹Ðèyïú-ŠÞ ~‘ŸÅKß«žž%ÿg‘7›ñ~QÙ5G½’ ~ÿvù`ã%KÞ)ž†z†ú]ìü ¿ÿœúmÕiwù7ʾ~/´ÿŒöÿPö|Î}•Ø™¡ü9™”¯ß¥ü*íõÈœx½o'ÿ+îÿŒú=Ê›”_ðü+êwÅK¥<_#¾å^Ð/#\Ê&úß ü;ÙŸx{Ä‹}žxyâ…²eÏ[Ý£ü¬îë_ûä¯/GñìJ{¾O<“Úõz»¾ ~O¥8Iù‹ºÏ§[´ÿZyCù‰Çï;ñþo'L|œxSk—öñÉ^-› öe|œÅ÷JOñ ½OV>ܪû<üœúeÿü³´³ÆÅMù)ä¯Æ×çi?.¥ÿÍÄûïNÀ•é©çj¯üúR¸iŸ/_Pï¢_&í㮸j|Ý‘ýeɹÆÕ­0˜ß$¯ìÇí‰~/Œ»;Içu?.dß/áÊšGî…yN~RÞÊÞ;aEÿþ/uÎIç kœÛÒ9bkþ/Úq>Kç›79_·Åy-ÔùO;ÏÄùÊ ÎÑÕtΈýX =jì#ìëúû›Mö#:Ÿ·¿·ÐkSç^uÞøZhÏ~o›uy‹ýEUçÊtž {un®&q^q¿ë<ó.8:Ç«s®5öÕ)o_~›øKçÏj:ÇËùÈ-ËCMäm¢ßy¡s¾²ÇÎ#"¯†~›ì‹j«þ¹_g^ßaÿ¹IèÜì6çIw³«såè¿Câ$”i¿ï’]Zﳉ×GþÏ?t‡ý‹ì‘MßÄÛÕ¾§Þöt‡ï¸¶ªûý•}ûÛLÐGvdâó“°oÍ?ż­ûïíÒ/ÆßôJ¹ÒÆ‹öÚ§æÿÝÜÎc$þ»è@à©tCç&ô]\ßO çôþ’ þíß—õÝVþ¶ïÏÿû‡¾3ë;n.|ß•~ýA¯\ÝËU<»ÃùûžxjáI¾xñ?:7cßñ)unCþßáõýYçóWÚûm0ø'žï&ýÍoiÏöÞUö軿Î! ^K<—øáT¸âù@åcO8/¡s"=?àùÍê‡ÞñÄvž)œSè ~W|°ËÆËœxx_3LçÅ# g^¼Ç+Ï—Íêy ñQâ¯i¿˜öxâ%fÙÙyÏ”çwÄktôÞ¡çiæ¯yL¼ß|C(Ù7蜠îOg<e'^½æ®x»ÅwUðË\ƒ«ÎwŠŸ[ÀŽ=¿ê¾Æ?È-d‡rúƒÜ¸y©”çòr©˜ëVÛûÙÒõ¼*ÃÝÝo+ÅlÞW½•ÿNŸ7•G&yäú=Èg»ßv™œè}[)¿íò£Ñw+¥á¢ ¸Ü=úöAá͆²_yônÅÈ–º¯÷ýÀ_§~ø ;–½Þ3zæ©à½F‡]׃9\øDMºhÖE‹.ZuѦ‹v]t袓‹‹Ÿ4ÚÕ'vÕdWÍvÕbW­vÕfWívÕaW†ÑdM†ÑdM†ÑdM†ÑdM†ÑdM†Ñl͆Ñl͆Ñl͆Ñl͆Ñl͆Ñb-†Ñb-†Ñb-†Ñb-†Ñb-†Ñj­†Ñj­†Ñj­†Ñj­†Ñj­†Ñfm†Ñfm†Ñfm†Ñfm†Ñfm†Ñní†Ñní†Ñní†Ñní†Ñní†Ña†Ña†Ña†Ña†Ña†Ñi†Ñi†Ñi†Ñi†Ñi¸ôIcãÛË7(oþZýwÿ)1MžâBlocfit/data/trimod.tab.gz0000754000176200001440000000501714745724400015064 0ustar liggesusers‹5˜k’#8ƒÿ÷)réÂàçÍöøûI¤kjk²óBä¿øü7~þåï~7æŠÏ§~ï{ïš?ÿâ·ö9{ŒÏgüžuÏxküpeƼ£î翱ß|3îÏ'¹’Ï·#–lÌ®Ü7^´‘qóäÍ¥'ï­Ê·?ú˜kì³SÇu0‘‘{湩'sc#îçßøÅÕ…Sûƒ™5î,ÙæC÷Ï^8.Û#¸›/~øæŒsÞZº}qvÎòÛc­©ãW÷Ì)ë÷ÍÚ9Þ‡QµØHñ`¤Ž×ÁÆ^>~玬óù7C9Ûó*œœ'Æ)D夨ïëÃÙ¤ÎFÈä][¶ñb®ÜaøLœêï òœm’Ø!#†˜ï“í;î¦>ªå_;Þtª(qTºòº}îvª±ß-°­X|÷¢òÞq|œ€ðU9ß\˜”âÃë%ÀÞ³•ª³¾¦ž¼sPÙtª¶×»Îà$ˆ³¸=ǤjªŽPšû¼;å÷>w= ¢>‡2ðΈ…9íåØk~¡¹ö;Ãùλùæ ‡“[^ 'º˜<í2jφæI…t‘—Úö'ã%#ô¥ÞéÞÔ}ù}ÈÔº¥Z&e]”^·Áö™ _ËÐ,…CË_…séÑõäwç^éÿÀiÚŽë–ªéžBÁC ‡~èĆâ44× w£ŸVô¿lŸ âÇ\dhò‘.Ú‹k6²çZá¢Í1©¸Žy¥(››ä&-’”aÑ^1 Ÿ€8ê]q•QE¡FÏaVÒWmßš†²qBãÐÇ.Ã_ŸŒœà07n€ûMÝ#ø^ÂÆ[¥&áö¾ðɶƒCè9&<²¶È¹*Obß”X ó®ÀMBÕã¼íÛ"™oå·B_Ýi$Шò+è’¼NãÛ RÎÔqB\ïš8Þƒ¡šÎà@Ó ±ãúN•jŽwÒÃÍ7D3²7ÞÙ%ßÆ`ðÎvN¸M'⢎©Þ·{‡ÎÝ)#´ëÞIq\Kæ„8ÙıôJ¸ I ƒMšä¿%|'©‡ u<àz:#M°þÝK`c‘úlØCr¯ŒAq#Ü7:xŠ9¢Û•épwÚLB0Ô‚’^9' B{u`t×[¦ÞÊáZÒ¡Å7NžFP)øsT—j„QœØšä­¶ù;{žÑ¿ßÑT€‡…‡Ê ‘áo™ð ¾•«dºòŒûNÐèéàKe|4YáÙ²ßôÖ)7à]Ôº¢Y“œ§T<ºu9'—þ§w]âÅ3'<9 @«Û<¾ay¨ÉO™¿çœ OØçù84`1@|4Gj˜ˆCøHUâê!­ZÑ’‡íИ6–5'Jñ‹é>Àá’+×y}2ö_¸S1 Ôî(|^öè°¡[Ÿ ”À¬—™c;|—ÎVÐÌSÈ5üÓqÑ/™m‡ùBj[e¼§†F4©3˜Ð ”Ô{dÓÂeSŸíò Z«ãªÉÄDQcõ¼ög< …{@¦phûúÃ< =ÅKþCÀøsqðCWØn–UœÈø¥!¢/Ó¨¡ÝåÅ#Þ²ŸŒY&g¸qž}ž0Ȳbƒj!¨Ñyfˆ¿qŒzL ;]Gdu5ËHŸoF7Ur}oH¿µ)FxÙ©"ïÌö‹˜–?îÙãû„¾ç´‘”ãí®K 8aµ–¿Oû?h6 <ç BBEÚø¥[2¨Áaçw›KI2³ÿ‹g¦_2<Ý-ÁüõôUoÃúy,]Ud±ŽÏÑ€›ÆsŸ6¬ÎÏ<ÀÃ}ÄäbHå'L²Îéz¢óƒZ¸Rpõkµ@~Ft Í7r¶i+Û§ðùÈþV-îë¾£g4©ò) ÉDùæùIÜúJ=ŠzFÇÀæcÂ’{ ‡šdákÈco?óN+0×÷¤Gü´n€Ì·í$ã_2£íÐœ$XOI!tØSj2m U€qŽë(IŸ"4™„¨Ñc9."aq~`òzßúÕu{)6€'Š/<‘™ÉÓv‚ì—…("K¶ñ´þkÉI ëoßQ[ˆlX_1"æmÚ@÷Xc@ÂÉùé1#’7…²ðþ*?* ÁaŠBN¾Û稒9ÌKx€¶ˆÕ8ût½& a4?¨Á_Û'@~uM)K©¯I VÂeÿ•Ï×<©ÈaÇ®õÄÙKá¢ñ„+J±ùt3ðOv_ þ¢ëë% \ñ•;³%AáØ{ß<ÐâCóÕP¤ 7»5ôOÕw`%Îö“R“‡å’’fh9¦'ayô2"–4ßwÞ]m…V¢Éʼä?IDNzé³ò`ÌÓ~©í:«ÄŸ^qØ%è Ä(¼„°©úò'e<ãÏøù ÚÇ ý ÑÐþˆ^¯x Š¦}«ùSñù 7P#¶d/NZj¯×¶#­„/üs­ŠÒ7+†þÏhEóÄO2È8Që ²8龆ájóÛ,^¯´¤|j^¥åþÚgYÍBOËlÏš›r™œ æšOŠ…ȸÝÚŸ£_=p¥V·Ð7™ÛÍcŒbëñ-½Å(kü KÅ«wNýwjµì… :ŒÌk&>÷⹂Fx-Zñ¾§´$÷×lìŠ4ÑA¦ß„€l“·KÊXd‰h@¦˜Õ5ªYÁ+šà#ßwlLív– Xz×^yÅÏõzÎ0<‘—uúñh§3[ܲ¾±º·‚a…@>8Ž‰·Rô³)‡¹-%Îf8Y3$•×‘Ÿñöˆ*D´ëë Û]¥¥ y»ËSé‰ÓPÐÜe9ºív¿sŽ.¼æ–16•&xý\€8ÝM |]m…@;-õâô„B&±PÍù¥Àk9WZ ™LÑ^=±Ak7‡t{ƒ–íNû® ÿï‹r½°Í¶ìùá Åÿ NAM‡[UßÑ¥ÅY„àîùœe¯ AÀÿ%ˆì»õˆ ïHi73èÍ/åÒŽRD6Å2LE¾ß`Ù»÷ôòC]ÀÉnÀ=6¾L7ùÓ¼Qh—f›_ xU§N;°?Õ?¦¥vp:ü~u:ÌÒ¿(‘ñ󼺺{kXh¡µ›ÃŒ NÓjþ¾¤-PÞ5¶»¿æ àŸïBg:í©Æq€ÿÅ2Ô÷ålocfit/data/co2.rda0000754000176200001440000000462014745724400013631 0ustar liggesusers‹íšml^eÇÛncmÑ„†›cÂœ%&eÏuWI·óaˆà`[”S¬£d"{aç>L4Æ©‰‹Ä ŠÊ:&QX¦0Ù`Èp/1†—9¦N\fÍŠanÌ!2=÷ÿ\Ù÷“øáiÒ]÷y»~×}Ý÷ùµk»pþMÒ{SoGGGWGהΎ® åpbWùOgùÙS~NXºRÊ/l ËÏ)å•ÑìÁïv´>ê‹?¨9nª9>\sÜ\s|¬æøxÍq[Íñ©šãŽšã®šãîšãÞšãokŽ/ÖÔÕ×ÔÇjŽã5Ç7jŽ'kŽ§kŽÿ®7~¿£æ8±æØ]s<¯æØWsì¯9N­5Vÿ˜÷öNf݈}ˆýˆx,›Ž8ñ2ÄYˆ³|lçoçoçoçoçoçoçoçoçoçoçÿÿÉo¿È·n»ñØÚK³ü¹­A–?ÿJïЪMY~àÍgîYrE–¿Öÿ…?_³%Ëñó—ü×C«6¾Ò›å?¾gÉÀ›ÏfùåÕþ/fùzÄêüVï*³ÎØ–å{‘ïeð^o^˜åï žÂý‡Z7f9~žšãçþÆy´…Êò­²ú³|Ï–²À•õ¶Nß‘åGQïIÏsç€÷Vy8pª¼Žãß`^ÓJå?»µõ‘åOkë#Ë÷Ý_~<å‡À9Šë§ý±;ÇÏÓïïs“ñÜ?{[‰³?ÏËwb~£»‘ïâßÀÿ;êzÛçq–wß8ž¹øë®ý{ ÷ÿóÙ±·üØ—åÛq~?úÿÔs uvúõuçúõuùù¸™èÓ4ßG7uŽ¡Ÿ»÷,i- ë÷¤¿ßMD_ÎEžKQ¿ße~ÿ¼ëÃsÇï úú;¬Gu?r“ñÜE~ýÝåÈ›øºÜ\Ì/õûÂÍòûÇM@ž¿bü ëò/¿?Üù~]Üe¾ïîƒx~×çƒ=ú?üÙ¾Nwöéq쓘w7ú9ÝÏÓÍFŸ¯D߯Â}×ûõsŸ@ý‹|}næ7uu"ÿЇ pýCÈ“ ÿsQ× èËgЇÛçf<¿óD]— Ž>Ü_í·ý¹}YŒùÜ‚üwsä¿u}ÜA̯â á}Y€û«:—!®B\þ: Ïçx?c¿)Ž#\¿}ø8ŸC¼}[ƒù݇uzÏ} õ~ÏÇ×aÝ«¾Ž MÜ·un@ž‡pþ pvó+\ÿ ê]ãùVaïÆ>ù:ú¯º‡Ñÿ'ð?ëûQçNðCž{‘Ç¡OÕú|óØ€uÙˆу<Óqþþ/E€ë ÿ|1ûé úõ*ê}ûê¾ïë+†±W#ÎòëWt#ö"oUgŒx-îÿ$Ž—ùõ-ðþwƒ·Ïóÿæ Óð|ó¨êXäûVŒ +û­¸óÀ>,¾„ù.Åz_…¼CÈ·Àï£b9ŽïBžµÈómïÛb êÄｋGpþ^ä½ÇÇ<úõ.nÇ|FÑÿuˆß¯Ê÷ îÇûQìÄõû Ôµ÷݆ó£˜ßÿûn38Ob¾/ãúaœ¯ŽŸÂúàïAŠo¢¿£þ}(îÃyü½B±óÄ÷ŸÅ‹¸ïu¬¾*Žã¾—PÏÓèÓ&ԻǿÄúíC¾#¨ß75;/öy›øz×|Ÿ÷@¿)Ž Ï/`Ýö`ÿùOø}×ìñõ4ñ^4§z^3ðýmâësóJ__sòœÆ<¢o@½Ç‘o’ßÍ‹ñÜ€¿¿)àÌóû¬¹À¯GsžÏÛ¼ó©Þ§cè ¾¿lvûy5g¼;ß³þdhÒŠáå#y9èà µNN\32¼ººaùÊnÙ{þÀè½ –Þ>œW ª“½· »áÁ[W—¹Ïº½gõÊ;ÿ‡Ù9Š j Õ@«AP ÂjUƒ¸$Õ Å «1ÇF ‰ÔFBE6Šm”ØÈb 1†CŒ!Æcˆ1Äb 1†C¡ÆPc¨1Ôj 5†C#0F`ŒÀ1cÆŒ#0FhŒÐ¡1Bc„Æ#4FhŒÐ‘1"cDƈŒ#2FdŒÈ‘1"cÄƈ#6FlŒØ±1bcÄƈ‘#1FbŒÄ‰1c$ÆHŒ‘#1FjŒÔ©1Rc¤ÆH‘#5FjŒ´bLhÌ™ÃaƒCáP9 8 9Œ8Œ9L8$­AZƒ´i Ò¤5HkÖ ­AZƒ4!MHÒ„4!MHÒ„4!MHSÒ”4%MISÒ”4%MISÒ”´€´€´€´€´€´€´€´€´€´€´´´´´´´´´´´ˆ´ˆ´ˆ´ˆ´ˆ´ˆ´ˆ´ˆ´ˆ´ˆ´˜´˜´˜´˜´˜´˜´˜´˜´˜´˜´„´„´„´„´„´„´„´„´„´„´”´”´”´”´”´”´”´”´”4ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDè¡K„.ºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDé¥K”.QºDßuÉ™ÖçëšÊó4locfit/data/cldem.tab.gz0000754000176200001440000000115714745724400014653 0ustar liggesusers‹=TɵA»;ŠIÀýØ—~ÆÎÞªi¨¾ñ¨Iþ~þýúüæ'Ä(ùóƒžÊ°Ðì #%­ŠNø¡G˜Ü(d²)ÄìÈþù†íNÝóØ­Ócÿ팢òïc>aUWNVËLsJ±»Åöe¥")=ÙS ¨œª¿á)E%¡4Yʶ´” ­ññT€êÔEM,e‹¹¨«ÒõKP#p*ÏåÛÂÅRø·O#†tê-K¿Â•»rÑ#,?¦‘¤ô>æ§Oȱ¥´4Íh©K±¦Îcr â¡OM⺹­s²lV^+¬ªt³-HªÀTlµsJòéÛ,˜hæ`fh7óåG­ÝÜta8œ“,ÓHµ»º}!ÛfyÙ•_FòÉÑ#F²6 ì¸¥c…­N #Á7)á2Š*A·Éšw&óNß}W:ü&©¾ô1}¯ì¥Ï÷j¬°,ݘF--‘wS¼`XçëvsMÑžͱ‡þâ·fèµ !% ¬VÎÇѽö6ƒmºÖHjÒî«3·àÁ.NYaW¶–U˜WØ‚¬Øºå‹mÍ ²q;Á°@¹JBÈl}¥;žDÙ¶^FÇü.±ë¬Ê¡%nÖÖu²Š15•ë±“ìuá²æk¸nª¿;ë*v`å€Q$jQ«JÅ~X|xÛ." öT`ÙØiµízC Ö{åhTÛDÄžÌn[!®Æ}Ûë¢{£(âBÖ~;u²JÇ.›sg(à¼i‹ív|Ž®X17jc_Ê<9y€P²¯íK?½ÛxDXrT;KzA‹9çwÙärXæìˆlŽ}DlÚ÷Z£r-K”ü2֋ƺ »y$ó2Q±µròÖ¸Ôé2%{ŽHêùyw²™M¶ˆí„•vr~ýK.ED>ßyÁ·¾Ä38Ï*nÅÜEŸ9ëˆì¬|ˆ½n‘:'0Ùz¤¿þûáõë£NÐ’s®D Å%n-É‹%ï œ2Qïc#‰ zá݉CËü²Ö©Ž)3ÉÉe~e#]ѯþ¼ãùÂìw¢¤/´|x½çµuG‰«R+±&š/ ¬w³ÀÖï6²ŒÝß»¨÷&^¼¸Lû"º’”¹ *o>—ÈGÿä;š&s¯›ûÒ"¢zÆ~ÄeÙt‰’ç]Q›ÂëerɼC);‚H‘Å:»—¤QNYުХ¤Ç®¡nîó¥nòÎ^Ǭt¾z °f;ägÓ®@½8žºóÓ|ùAIäÝ[ø†Ÿ†UVjT[r¾¬%%^»T"Ûï†óc®ÇÕáw®¶Ë»D™7ìÞÆ¡ëˆâŽ@²èŠJjjÞóÓW…QûùâdÃOÔ±F¡ôµn¬û‚ÊîÐ,._\­×’Õ_wHñžDôû.GÃeø›¬¯Éé©ôá6_à#qå×2_µrмՆ– \i×x®^7±ÿTJæ—Ôlocfit/data/spencer.rda0000754000176200001440000000076614745724400014614 0ustar liggesusers‹ r‰0âŠàb```b`âcd`b2Y˜€#s1{qAj^rj³0XK9˜0€ƒ)”6ƒÒæPÚJ[Bi+(m ¥m ´-”¶ƒÒöPÚF7@hG(ßÊw‚ò |g(ßÊwò] |W(ßÊwƒòÝ |˜¿ì —Ç\Øw;àÀZæ›+Cì '¥HuçÙzü9¿Î¾tkñ«Íé íKÖûó¶ø2Úù¶ÏüÞû’‚”7/³/ínª_¸à¼}9õ<6þ'öÜ* ;.ØWij}›âVb_Õà™V/c_öÓ8Vež}]_BCqø3ûzEÝrÃþ£öõw_ßdì+µoø*urýÃ[öÁ•¿¦?4¶o”ç19¸b}Ó¡ªäâœûöÍS «Îøý´o9â~˜× ˾3ìÀµ¯®öí–¹œâ׶ٷ³üwvœg€¬y‰¹©Å@†42A‚̉é©P&gn~QIbNfI%ºÆäœÄb˜F˜ WJbI¢^ZÐL4åœEùåzÈvIA% a #ÃÆ01La 3ÃÆ°€1,¡ &C8ËÎ2‚³Œá,8ËÎ2ƒ³Ìá, 8 n‡Ü#¸Fp;ŒàvÁí0‚Ûa²ãäÄEanlocfit/data/diab.tab.gz0000754000176200001440000000047014745724400014463 0ustar liggesusers‹=RKN1 Û÷¹ÀDMÿ=Î6,¸¿„ãtXZqÛíëë–·×ï­÷§|¿ÿ$éZD®¥&MW’¥K.„–,kÇ4ëvžÃ8ÁéÚ6¹ÊÖ ˜“w7«¶dE'àÂ.aÇîE…¦Ûï.HJ ßÝ@y&)tUa£:¹‘ìwîÊt²až#&¡œ95ªpevy¢»3w1õ€¡G@ß-qhøÓêdŒr¦teÃî€2¦•žÈæ‰2‹-Œ`íHuL§“$/*wÑse“Æê¦W»3îs·<2PÃõµ7’WH¹gЇ:õ§(vCÿô\@ž«A“Êáªß{ÿOÝîv>ʈŸdã ¸ùú9È™+Û°ôeÑQ –locfit/data/heart.rda0000754000176200001440000000266114745724400014254 0ustar liggesusers‹͘ML\UÇPË¢iÔ… .\Óy÷Þ÷%myÐa†jÑhCŒV†BÁˆ- (ÕØd¦%M¡SÒ‚Zˆ_M.\téÂ…K—]ãÒ¸rá•qèýßsx'LÊЦq’éÿܯó;÷Ü3¯÷ñj~Hµµ{ž×êµîkñZÛêæžÖú?-õïÞú÷±‰±reÖóÚž¬76G÷Õ¿wÒïÞ'}Z€.œµúvÕê úWž¶¡==eu íç G°îÂ/Vo~mµlÇ»þ¼KÏZ}íï~³ºžó¶~Òü  ]DûÛ­Þ†ÿ>Œ_ÙŸwqŸùÑê§vÃéH5;oÖrÓ[kØ7úoÙ¤ßX@:ŸËŽ¦V'‡1ïO«‰Ëçô¿iõyôÃú¯^C~7à㇠ýЊMtzíæ#EŒÏcŸÙ§¯ ÿEè(æ@ûË'¬®."i–·qÓêÎycq ëÈûúë×àÜG³ù¹p×ê6iõñùÝl¼Ÿýluí«—Ñ¿†y!Úyè3ÐUäe5—Íÿõ¬Þ@\µ_³õRCÕçøïÈïOV¯"žäiy˜F>»àçÚßV{ÑžÃþj¨»ê öC¶®¯" KÙü/#î>Ì[Æ9,…ÆV'Pw‡±n û¸‚:¿ü=ò}œÀø;ÐKýPün¦–²¿ÓE¬›E‹V/¢}ë^G{zû=º~zã ¨›ÔÓ'®ŽqŽ=®z™G¾«¨‹*ö5†þð;‡ó;‡ýϧ§¼Ìó(ýù;‹üÎ gWe´gÁ©Àïôp¶'ÁÁ¼qÄsÊùÁºäá-ÔÅÐ!Ì?žfŸ‹G¡^öùéžãÞÿì³%¾G²n§þšõßhþÃŽóQç»Q^î§Íæ·ÑúûÅÛ,÷A÷Ûì¹ïv_;õÓì¼Ýîk·qì4Îfël·ûzØym¶ŽTé>> î5½â¾ëîBÝÿý˜×[Íö;?/ASŒ—„wq8¿yè1Ñ_mw_é÷×B£~1^ãG„ÿÔËj¿È“ãk1^ªfïÃŽwHä±$â*‰õN{½íÏ¥ â-ˆ÷ çÏS^ÜÓÝû•ÛÇA´»«â<„wÿëëßåq º}^éü¯SÔCQ¼çuŠ:;Øà\J¢ÎŠâ]Þ\)á· ê!/ê²KÔ·ó¯E>\Ý ê2ç]¬n_oî=J‰|8ínp>…¿—~á_žK öãüYOÕì{¦ãõˆ|v‹:(ˆ¼•„¿>Qw‡Å:#Î»Ø ¯Ž÷‚ˆ º}]ɸ¤ßÞq–D•Ä{u^äÕˆ|¹Ó|¦ùLó™æ3ÍgšbšbšbšbšbšbšbšbšbšbšfšfšfšfšfšfšfšfšfšfšašašašašašašašašašaZÀ´€iÓ¦L ˜0-`ZÀ´€i!ÓB¦…L ™2-dZÈ´i!ÓB¦EL‹˜1-bZÄ´ˆiÓ"¦EL‹˜3-fZÌ´˜i÷ÿn~ÿ×u©îœlocfit/data/mine.rda0000754000176200001440000000113414745724400014073 0ustar liggesusers‹…•ßnAÆ‹M(M{Ñ /ŒiŒ )3ÛWnm­¥šj T¼Ò¥P¥)¨€Ñ˜yÂGáQxŸÀ¸¸ç|ñXÜdú}gæÌùÍÛ™êQÃE" (XÉQOì­ ù“KÚò4èvzm¢üíÄ/%m%i›¥ÏÃ_¤žhU÷G4ÿ‘¼™|¯é:ˆ’—ù¨S0Jó×—É-Ì×™÷ÊzßBF½µùyØç ÷ߌS}VˆªŸR}iý4ÑÚâ:Í»Z¯xþcQÒzÌý5æõYߎuïÍÿöFçÜJõ«Yçs~p—cÝ3¿Éý5Ò*üW¤óD¯™sŸt^Åì³ÝǬ}•þ3Òz1Òë’üº™'ãõh±Ê|©këËïoû%®Ðâü ³;ïŒæ¯G´–Q_ë7û|šñ}s|ÊñŽŸ³>5z˜¡RW¾ŸÊH«ŒŸæÖMýgf]²?­Ÿºþ±©'‰™z‡f^ÃhÕè‰Qûÿi¾CÙgœcëæ<œh•ó&kçÒÆâs.zqîm]×ùè—óöžQ¹'ʬ%£¼¯¡©wgñ}1Ã)üçýöIq̹ԋ»íAbVù’ü{q^õãKöùN¯)¹í/Ãþ í¸ûN& ;ݶ­|y¤²t[ñ0.%ågÒ—ûï?—þ]Ì&äÊbœ/&³-fGÌ®˜=1ûl‚ò\ÎÁy¸nnnn †ÃáÀp`80 †ÃáÁð`x0< †ÃáÁÁÁÁÁ§ŒßÓö¢U@˜ locfit/data/geyser.rda0000754000176200001440000000060614745724400014444 0ustar liggesusers‹]R;P1 ?œÜq ÔØb«5“-œÑ* Z´°A­ÄšÚZ[¬©¯ÖVkjji±@@óy›Ý™\n³›÷v_¶{Ö;Iz‰B ™•„ܱ¿ei?%»*ví] îï·ö/³ëšÔh~>mÕuîâ]ÿ릹^è_çy óhCÛ_%b€locfit/data/mcyc.tab.gz0000754000176200001440000000200514745724400014513 0ustar liggesusers‹–K®ä6 Eç½ o ñ'RË =h 2²þ\R¶Ë®ò “÷ç©©Ë+~üÏï¿~müüùëÏíß¿l7ݶ­·¾å¿y9Ûö¢&w,¹ù'OA4Á÷éñdÔ•8ž”xá¯Óñ;žƒÄsù¨„úc:Ày¥•7ü„*È×iz|zö›ä9¶d:ßA§_ø£läцá§ïx)ùÿx>yÑÀ•ß˜z>ðá7wi3L€ó²ušc6Õ£ 7zÀ&Íž°¶ù‰¡Dó„ñþSpëìÇÊbû­ãç gÚ/e\)Í»wæ¬ÛÌ{leÛHý$oéï'~2¡Ü ÞqÖÉœuÚ‘Üì¾cœÖôà‚£‚§ô´»ìxwöŠg»+qž-´÷Âzêvêìä'vÎÉqÕŽg{Ž©Í'!6÷K짋(¬)Ð3K›£9sž¦:-5%-'@˜ÖÓÅië…+ùHAŠäC ®éç• “²\”XO«T glŽ´Ê²p®Ñµ6/¯<3ÚiåKoùF\XOÝápÌ~àmõå glYUŠE e:«¾Qšø5s$ôŽØR;m“´†ºX›6PšRË ŠsÜc á´Ì•pvmä´—¼ÕH&RisfU-¬™ÔÆ.reÌФY¯k ¡QóV4Ϧ×Ä=û&’T…m¹ãA{£É½hŠAÕV@F|¬-Âh‹™Ž.ºë½Ò,£ìx¢M†{QøYÑ k¶q ÜæʺÒ*¼zÊ&ÃÓÎnkG^h”;õLmA¦'Å'…ßè,ßKŸ›5Œ.ªÇ·ŽCŠWñk¯¥´ŠÉP9©k2IµžQz憪Î,jpÂM6Ûéki¸Ðú~\e¤ ÄEÏ/5üÇpÛéáB¥rÓ¢0‰Uà™®oÇÊBFVšêû3I`OÆ>S{»#„ý´¾'åÜÚ”E©µCÖÄàìCι¸èÒp¡Q´Üa Þ¡·YìR %t)(¿5T•hö‘­1\q }N×ìý!I‡b›Ý#\©žgSLd±Ææ~6}ð?þO¨Ú locfit/data/iris.rda0000754000176200001440000000205414745724400014113 0ustar liggesusers‹ݘÝNQ…‡Tð§(ˆˆ?}#ó?WpÑ'è•·±!¡jÀè³´ÏÔ¾‹¦¦iSC;À^+eQÒ{'Á½÷9û¬oŸs†9ƒïß]x勲ã8®ãîä7Ÿ¹7û“Ë>¥i0 ÆŽ“¯f~1³Û™½´þ×ðq_ÇgaÏÖ†ýûþ0Û5§bÓÖò}4ôn†7#k)ÝF׃^WŠ½awŒñT½êöîfc'ÙggztŽÙÕ9ü4½>wŽÌÖ­½i¶þez}íú³«Sµ¼æÕìêÔ¬¿fùÖß°¸ayu³MËG|`º m‡ŽÅà3–:Ž¬ú ©ó‚%×â}©»)óF]ªÓy`˜>êÂzI?8Ð9–yc?N­ûp"ó>6ÛÔýÅ<¬®#ô­ÿTÖ‘÷‡ñO¥nåcžº_è?±ø­Yôë>+çPö uóÓûB÷óF½vßñ{R2=Ø Ës­¾5±e³yÓ_7[´ñŽñ6Ìæ¬}]òÁAÆ#¿`í¨ |´#¦ž´#FÁx¨;/uÃbܦÔéŠ.ê(È< ’¯ºº:ŸòÆmÈútžoY¥óSnIúw°Þ¦““ûDï è—EO÷cU¼³â~ÓõÝ\qÿ0[”ºË+öqIßÁ5ÿžì™ÞžåáùT±xÏtÑ|ðÐÿÆô·,¯by‡ýÛ5t+Â^ÕlEêƒÞ®õC¯*ÏsèmÉþo[>85§Ô }Ô‰z8iÇúpÄîÊ}]<kržê¹Û”zõÂs:û8G /í×çrMÎåª<¿×åü©ÊûÇÒûƒœ3u©±¾ÔEÅø¥uÄ9.ï?ˆ¡cãð=iŸÇíó|Úçù¸¥øç\§ý(íÐyÄè×|ÍCüdœË×z¾Í×gIö—õ«þ“ÔÌ ù?K°.b]­õXŒç[{bûëXÞ‹<×ÑŽy¾Hž“οõxîã\µóo‰ã.îÏIGô1Nê]ªË‘ûh"z9Yw[Wró+æëÈûêžÈøÂâ<–ø²úsæºû±Ÿ3Ek\ßö{ƒYóì·Ð¸Ûž û׋ ƒK4Üöï3æ ³Œ)/ÿ[~1•/»wݳ«QF—ŠJ£›‡³¿«$ׂãÁñápB8œN'5ÇmÓkÑóèùôz!½ˆ^L/¡G†G†G†G†G†G†G†G†G†G†G†O†O†O†O†O†O†O†O†O†OF@F@F@F@F@F@F@F@F@F@FHFHFHFHFHFHFHFHFHFHFDFDFDFDFDFDFDFDFDFDFLFLFLFLFLFLFLFLFLFLFBFBFBFBFBFBFBFBFBFBFJFJFJFJFJFJFJFJFJF F¾u~nÿ6™ü`±œrlocfit/data/livmet.rda0000754000176200001440000001543014745724400014447 0ustar liggesusers‹Õ_lW^Ç'ɲ{›®¶n×¥îÖMÄqçŸïù3÷Þ8®Çâ8¶“ØqvY¤‚Øvj³¥-쪼äeâ¥ðÀH ¡å±ÒòÀ+RÔìh…„V*Hl-…ˆvæ÷;_î/>9sfÎ8ÅR2sçÎœï9¿ßï|~¿3¾s}kå‹êèfYv8;ü™CÙá#»»Ÿ8¼ûß¡ÝOìþûäë¿ð+o¼úN–ùìî«'wÿ}f÷ä» ?ÌüÈm‘ ocß÷Wõ:_;¡×!Ðñn]ûÄŽ7¤kç¶Æ±ý¯ÛϪþŠÕ‹m¯îUí%û[µªëFŸŸëÎߪý­ÊÑ`ÿ=ã¯:ÿ\œx®ó½ëOŸ^U»Eß'¨èŸ`Òy´ÝƒçGr:¶Š^ÏtêåÕªë¢Øû¡ùë÷ŸBã÷ù34/Bñ;/BóªjŠý=X,_¼qÝ©Ö^ð÷­8ŽÖ¿Ðü‹ŸX>U­‹ªÆSÕ¼[ÿ„8{¸j^‹]¿û8\5žêr)d×_ŠHýªö¯|ÿ°ã©;õêùªó³n¼Tµw,/¼ó¢S×Á<©›ÿb×U±ñRµŽ¬;¯düÅÖUûâ[UVýiÚÿØߟÕíWì窮ê®[¡3ôœi1IÛ±¸ûAÅŒˆº¾˜¦í¨hBlù¼ñáó]ûã‚Ÿãâú1gG=ÛâúŽè÷sD¼?*Îñ\ïÓô´7îé·OgFœÇïOy®èLxŽg¢IÝäëÑΘ8>ã9¿ã9îÛNâkÊ/ã¢1fÄu£žø”~ž ô{ÜcçqO»OÜŒxꊱ€Ç<öÊçgxñ\7â±£'Þÿ¤Ç?²’“.ŒìÕñĉÇHÀO>…Þõøu40OÆ<ñèáÍCy|2ÀQawýˆçüqÑ®/NëÜ—‚uŠ/>;eÕêv¯&þ”:3ûInOyÚyô}-ïüó ð¡ã™çÿÄWO]à½o1æáMæÉÏrøêSþyì4âÉ×™Gw<Àû=ÆãðùÕ§7˜/óúX ^ž ÔujóÁgw|¢ZºðÐøX¯¨×åø¦+®/|ö˜Ø?Þªwd~Õz°m{¤®oš“m­kÛZO¶½Ž­mÕÿ©8žj=ÖVýþˆÏÃÝwóý4ýüàAocš~î¿j{uí\wuýÛ¯¶ûûºéx›þ4§¶çEÝçÚzζ®=šÆWÝþ¤šu??kÿºÏ™¤æYÝñ7Í3©Ú©—©â¢iœ4?©ôšú/o›ÎǦõB[|n{ž§®›úó ~R×}MŸ§jš§ÚªSšÖG©¸×t<©óo꼊WMë—ÔÜ­›¯R¯SÙµiýqPy¨i=Õvœ4ß›æ§T냦ñ•z]ÿ¸××MóFêû5úñÈïwû¸ÝoK=_šÆg[ëûƒÊ©êû¦ù4Õ:,Õú8U<·uß-uý¸nS×á©êé¶îK¥š§©×©¿G¦®ÛºŠkmçõ¶¾¦í<ÿ¸ê‚ÔëǶï÷§ž—m餮“Rݯnºl;6­Ëú~Bêù\÷þÂãªoRå郮ÇRÝïhº®hÏm­“RÛ­íû?Mï«´½Îhû÷ÒMï«4]¥¾÷q©—Ú¾Úöï×zý’ð~b¥çLÛþ;Í¡vÚzž+¤ßôy¿ØñÕµwê¿—ë϶žƒ¨êǶþÞqªçêy’¶æeÓçsRý=çTó8Õç˜S=WßVœÆΟºvhj÷¦\KÅúöª—MíÖTçq?o‘šk©óúA=ß—ŠS±y9u}Ô”kMy‘Ú©8ÖÔÞMŸs®[Ï>îú«­õAªç¹Sו©¹Q·>¯Û~*»·ý}B©êɺë Ç?uëùÔÏi§þ¾Ôyª©šr¥­õr[붶ê¦T|¨ëÿÔë‹Â_oèónM?gÖöOêçlÚ¾_šú÷}©?/ÖÔ¯©>ÿPµÝª¯ÛŽ—ƒúœÂAÍŸ¶þ~Pê¿ST×uçkªÏ­¶ÅT~më÷Ö±\9¨ÏmÔm§nÖ‹ºœý¸Äe,×›Îïƒú»Yuý_W7õçæêú¥­ïñøÿöùë¦\iû¹–¶êŸÔù8Õç ›r.u\7îÛæd[öKŧT|m+o§~^¸m>¦Ê¿uëý¶×YëyºK–ºNUO4­‹×÷‹¥~Žúí?¸ïVûú±ooøõâÌïìýün1³ôÞ+Ó}§˜þ©£óo~ã{E÷éwϸUôÿàê·Fßý èß~÷ƒÝ½BÝ»ð_Š™ßØ;íh±Øùèý÷^9Sô~«<Ÿÿ.Š¦×³[^wúä÷vþÃâäS»2ï¿WœùåÝ˦ÿ£¸H¯Ÿû Ô1¯=ø)ì÷÷º÷R1¾wôê·Š©¿ÙûùnñÒƒæ~µèS»§èz>oð£í=ábðOe;sÔÞ¥¿*Ç«®”Û§iܳ^¶7÷§zï§èÿ[ÙNNן¤óΓ]ÎS?¸ÿÇi¼³ß,íÂvêþÚ^‡ÖŠSt>Ûw†ÚÓ¤w‘ÚávÏQgÈ^†ÚÕ_+Ç5ó{Ã}¥¸Dýc™?*ý0Kן£×ì™îzkþ—ŠI:þ,Ù‘ý}–üyÎ;Oú§yœºìï:ÿ4mägîïIÒ?ú‹Î›¤q6ËqN“=–éõâwÊëÕ½²¿§Êþ,üˆú? ¿œ£vN±_Èÿ—¨ót·GqÔcÿ’æH÷Åà jç÷ì_îÉÏŠ³Å·Ëë—(ÞÏÒùKŸ/ÏŸ#?,”ºKBïÿEé¯eÒg¿M’NQ?•þ_ø¯ÑRo„æíGWËvdK×P¼÷>U¾Ž³O“=&ÉþŸ¥×/Qû³Ô_}·lç"Åŧž/íÛ¥öŸÝ.ýü“ij¯Ç‡Û_øêï4õƒý9Köž¢~ŽÑv”Û!öhË:“¥þõ}âÅÙŠŸçx<ä×±c¥¿5Í÷‹4_t©ï~/ñÅÿõ‹í±ôse»÷ËË¥ÇÑõ{™ì´|‘üüÛåùEAñJü\!;.–wqx‘ì³òbg—ÌÛÅI1CçîÏ׉ƒŸ-÷9ÎÉî:ßµÏçQÜ÷)ÎØoÇo3dæmŸú5 ¸áö8®d—(^úäÏË|œ8ß'¿÷™›¤7G~šæ o9.ÿc7|ý]–â”·†ü{†®?ͼf^‘,Åïyjšâø õ§Göc{¾øí2?ðûŸû°´WlWŽÖ¡~Ï_*ç÷ošúµJý¸H[žÇ/Òü;Îù‚Úá¼ú sŽÆušÚ}š®ãOvïÏ’}³lg¶äÔÂ÷)^/ÉÎÌg®iœÇxÞR?fÉ./Ó8 'çMÒqóêeŠ×‚êÀg¸N¡öèúœâíeŠÇI®Û©=^÷Ì‘¿ÏG˜§–æåÕü>ñ°PÌ_žG4Ηhs¤3O~.~¦ÿê'ûO ¯—\¿æ¸n§v¸žâzœÇ“S{Ë4/»ß^'r¾éÑü8Iþä:žëC˧vyýÆã6”‰{sÔÏYŠ'æ>¯›-õ©Ž,r²ÓYÛG‘Þ Ù9§~ää?ΛŠô»\'+²»¡ó9®סäo^¯jê7¯£&^®Wºd_Mýš%=Cï¿^ÆÏ%Š» ²«¦zo‰Ö-õkœâ•×Ѩ=Î W‰‹]êßóT_¬ügÙO¶Ïeêóìr?ò>D¡hÌSÿ©^ž%»±=Ø?/Q~åz5§ñYŠ^×s]ÆOöÅÙå%Z‡¢vû4o¹~1Ä]^+Z|÷MZÿR»Ì×å»Ëä¶;Ç5­Cþ›ê âŸËK\OŽ‘¦©_\¬Ðü¼DëüO“>s×ý\_Îçç)î¦h¼.åºRS¼ÎR?yqœq}Ïõ%çO®ßx½u‘úÃv™"]Y‡?Eu×Å=öµËãa®r½u–Ú;KÜž¡þŸ¤ã|¿‚댫”¯ø~ÉÅ'srŽxÔ%¿qm¹:Îu×z6Üo‹{û¿«·ËãÙȆÇÉ×]çqwh»!Æq]è]ýáöØÞlÿmÙl¸¶··å±÷“_ßþ¸.ì¿}¸||CÚéÞ°?9>دW„nˆq]ínŠqn ÿ-‰~^篊xÜãy(^³áöo ;ÞãabØÏ[Å°¾œ77<ãÜ~àv¶…¿x^ݺ?ÜŸm]o ?ïˆó¸ÿÜÏ[´]ãåëv„}Öe–…ßù<é5a¯UGvÄ|öaý›Â×D¬ ¿p¿ ákÂnk">®Šv¤®ä§›'"Î/Dÿn‹÷eÞÙñ$¯_q»)Æ÷™g¯‹|rS—ùîv±^Úqr]Øg[lYgEħäþ¦è߆ä®à3ÇϪàÕ¦èç¥l°Ýøüº~É“Ç%/7e܉v%ÿ]Þ¼?ì_Ékòøš°÷’°ÛmÁåë"¯òyW§7D] ãQæö ¿¾rÏ¿"^n Þñy…ŒŸûÃñxC´KäÍÏgÃÛ á§Y§Ýߟӛžº@Î?¶ã–ØÞq-uåø7E^ßö¸!êÍb>­ ½uO}sÅSÿî^³ÿ·…Ý\¾üºì±÷ºäˆ·m¿7îíÏ/ß¼ZñyK䕇êÙbÿ¼zKä;ɉ51ßd°#æˢȳÏâüuá÷uW÷‡í¸-ëv¡³)Úg{ìxæ‘´‹¬¯ˆú@öSÖÉëÂ/["Î¥wD|ºþ ®È<¸%ìqKôﶌqýª¸^®K¥Þ51?6ä|—q,âïZ¶ÿ|ùã䪨»o ^®‰×²®–ëåÛ"ïl þ­ ßÈö瀬?$Ïäüº!óy±y]ÖÓb»-â‚ûñ²¸Nrx«xôúö¦ä^!x)ü¶æY·¬Èú_ÄçãÛ"¿ÉqËõ[ûç?ngGÔ'ëÂ[÷÷¯³ÿD^Y‘óVØë "o\çݾ¿?ÏäýŠ-aç­û^^»·}¹æYGo‹ó‹{û×Y›"®×E]wÝc¯ Q?ò¼½í©\~Ç7å:{[\·2|^–}âðî‡vÿ=±ûï'îÞyãÕ·wwö>^ó$<üæ;´wä»oðî»ïòû_r_¿ó¦Û}ëË´{ˆO<òö«_ãkÞæk¹Æï|ùUÙŸýÎÛÜ>xôKwÞ¹sáµ·v{*Nâ­¯|õÂÿÁƒÇghtyGñŽæÃ;–wrÞéñNŸwÜýî¬Ûëº=åö´Û3nϺ½ÜíõÜ^ßí9 å4”ÓPNC9 å4”ÓPNC9 å4”ÓÐNC; í4´ÓÐNC; í4´ÓÐNC; ã4ŒÓ0NÃ8 ã4ŒÓ0NÃ8 ã4ŒÓ°NÃ: ë4¬Ó°NÃ: ë4¬Ó°NÃ:ÜiäN#w¹ÓÈFî4r§‘;ÜiäN£ç4zN£ç4zN£ç4zN£ç4zN£ç4zN£ï4úN£ï4úN£ï4úN£ï4úN£ï4úNcà4Ncà4Ncà4Ncà4Ncà4¬q¤;;‹Ý.vv5v v-vsìö°ÛÇ.ÔºPëB­ µ.ÔºPëB­ µ.ÔºPëBMAMAMAMAMAMAMAMAMAMAMCMCMCMCMCMCMCMCMCMCÍ@Í@Í@Í@Í@Í@Í@Í@Í@Í@ÍBÍBÍBÍBÍBÍBÍBÍBÍBÍB-‡Zµj9Ôr¨åPË¡–C-‡ZµÔzPëA­µÔzPëA­µÔzPëC­µ>ÔúPëC­µ>ÔúPëC­µÔP@mµÔP@mµÔÀ–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Q`‰KX¢À–(°D% ,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á –h°Dƒ%,Ñ`‰K4X¢Á–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,1`‰K XbÀ–°Ä€%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ –X°Ä‚%,±`‰K,XbÁ’,ÉÁ’,ÉÁ’,ÉÁ’,ÉÁ’,ÉÁ’,ÉÁ’,ÉÁ’,ÉÁ’,ÉÁ’,ÉÁ’,ÉÁ’üK~¼÷ïœoSŽñlocfit/data/border.rda0000754000176200001440000000511014745724400014416 0ustar liggesusers‹Õ™ pTåÇ7 $!a %RI$†¶Ú¦ÙsïÝ{·‚\”Gx„W€R@p” h…>×Z‡vÇq˜¶¢í~ØVÑÖ¡ô1–: M-µU±VjÖqZkmK¡ò&Pzî~ç;ÇûÍ0 –îLøw÷î÷;ßyü/“Ì?Êæ—%‰ÂDဂDa.ûâ?øÓŠ—¬êê\Ö•HUâUôñü°_˜ÛòÕIÛªÂÜ¢A+¿~7jåšË¿€zùŽYûïBþÒ W¡~¼lÌ-ßAÝýÀC¯ÍA}þ/Ww.@Ý×å;f£žøõ3óÃÜ‘T þQßÿFt[-êî½±k{˜;XÜðÊG‡¡~/¯@uð›?üjSÕ§_mA¸ß@mŒºlñ¸¯ø¨x{Ý/Q+M5îC0KP)ŽƒèS½i-*çP"z¡˜‡ ~póæÍ÷£N}jëÁj[Ïo^ŠÚž<þä=¨ßúí닯Eݪã9´sùçß|õåzüõ7à+Ìù6ìVTŠãèC¯µõ<úÜÞÞF=üè©®@¥8ŽE·­G ï´ò>ÔŸc+t>Ž­}òžö…¹ã”§ãkÝ{ø»aîDÉU…ý§ ÄŠ—“Ÿ@MOx𙟣ÎÐç>Yhýêú(PÔ/âm Q|¦ûÎA¨ÎÍÃ\Ϻß:ú8*žªþT:GÅÝCyì¡ø{0=C6„¹Þòë¾zG1*böA¥¼õRÞzµ ‡ú‚®W/åëä¿4õÈöºÝßs§¨¿Nõó§>õ*¶Áe[P›ëv?ð0êg0Ìñ¨_ªÞ´f'ê–¨ÑP)ϧˆsêæ$*å÷4å÷4Å÷Ö˜[ðdaîÌmºÏ`5ÌCÅ4'O ÒyÏèó©„î•Ø–ï?•x<Ÿ_•ˆÒ5õ¯Ø~ÓPßÌçWhž*ЛïWÕWÏ“êÛ›¯£*.ˆ µ.Ÿ'U¥ªµ?¨ê?åýF £}‡Q¾k´O¨š!š_3!2 T:g åµæ{yS5ÚOU §¶,\Ôj½o­«óW;VÇ]«}SÕ¶êú §~NuNy­ë‹9€JýXGqÔQuQ»¥P—èzÖSŸÕSÝêµoªzí;ª¾[ç¡žæp„ö%5‚ø#ˆ?‚ø ä Q:F¢RÜ Tçâ7¨¨À¨?ÅcNG%hØ£ë9r{ÞÕȺ#ÿ¬¿×Ø'晴êß8:ÿœR4÷u7åŸãj”öA5ŠâEs0ŠâMR¼Išã$ùW’æ!ù#=Iýa¯ÎúÜôõøl|~š¬ó¥¬¾3ý¤ã²ñ}f…ñ8 ÷Fë>ßú|IïC»>­V½—ZsÝhõÉkKÜÂÎÅgw¼o®$í ûÛ³ñó›|˜þ¼Úšÿ™Öœ˜ó-¢s5Óõ,«>&ßã,m±ú÷¦-ñ>œ`å©Åô•5¦NíÇìîxÞ*¬>¨Ž÷-÷³¹ß|¿ÙêÃj+ÓãýÁu3õžcÚèzr6îÃÓ¬þ3¾Xót¥µÿÕV¿´Yùœa½ïž¥RÖü›9gÕÁôƒý\jÍÆçt´õy•õœ™bùÓ¼îø>®å‹MÖùG[}jÎ7;ŒŸç“ÙxýgÇ}álÏ{î¯k¬÷g%_ma|ŽÍý7Yçh±ü¦Ùz®›çvš3os­~6õù°õ|3ûO0‘ÇþÒweÇŠe«qQA ‰Þ,êìXOË•«hÕ§kíÊÕö·—ÞܱÚ|Û¼YÖÙ±¦£é†.Üغ½_תۛÞÌÿ–$ú)H™˜…c®Yxf‘6 ß,³È˜°SͼJñ xåðÊå•Ç«4¯|^¼b0˜Ìf3€À `0˜á0Ãa†Ã ‡3f8Ìp˜á0Ãa†Ë —.3\f¸Ìp™á2Ãe†Ë —33|føÌð™á3Ãg†Ï Ÿ3f̘0#`FÀŒ€3fd˜‘aF†fd˜‘aF†fd˜‘1Œ¢Ts³,S²Y:²teéÉ2-K_–,…–ZJh)¡¥„–ZJh)¡¥„–ZJh 4 „B¡Ð@h 4š#4GhŽÐ¡9Bs„æÍš#4Gh®Ð\¡¹Bs…æ Íš+4Wh®Ð\¡yBó„æ Íš'4OhžÐ<¡yBó„–ZZhi¡¥…–ZZhi¡¥…–ZZh¾Ð|¡ùBó…æ Íš/4_h¾Ð|¡B „-Z ´@hСB „–ZFh¡e„–ZFh¡e„–šx ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—€x ˆ—@ÞKÞŽ~þ ª×®$locfit/data/insect.tab.gz0000754000176200001440000000010414745724400015043 0ustar liggesusers‹ËIÎÏKVHIM,É(VÈËÌ+æ2PP0R06à2TP°ÑF †¦ ÚXÁÈD›(™ƒh®|݆:locfit/data/claw54.rda0000754000176200001440000000077414745724400014253 0ustar liggesusers‹åþRDX2 X  claw546?¿H¤Ð.?ì¡PG@0r¿íž1yÏÏ?ßo°&£Ø¸?ð³¬Õ¶€Z?èÞéd³?ì4FX©åA?á#ˆY¿á%¤Ÿ‡d?Ñl”}Ðæ7?åb]Ã)¶?áñgù¿·öÙe·iä?‰¤ô^ N¿í~Òmö} ?â@êa2J¿ïU)þK¿ö‚ëcÉ¿ñ Qj‹¿ôÿ4“…ƒb¿íظ'ú ¿þÍοìº?ò¸t…ãÚ0?ÛämÓB1Ô?ï©©²‘b¿ìɃÐàX?ët/|ÅM}?ä¶v~â^/?ò€©Þ‹;2¿ñzƒô즇¿ã&óp-?»ˆ×ªva?ô!Z³S¿òï—g2?Ç z^jïb¿ ¸ÏùÜû?§cn9n‹¤¿å8.–ì@¿‚´†/£¤ÀýæOTÒ¿à0Ôý÷¿Øtµ'¿Å#ŒÇùÿ@žµ²ÔÔ¿öc†Lµ»8?æ5:>À/0¿â º(…ZG?ïxå#Û§[¿Èo"ÍŠb?ñg2Ë@DŽO¹?ðM‰‹.œË?î9AŸÝ€y?áÓ¹ñ'õèþ½pbþålocfit/data/penny.tab.gz0000754000176200001440000000045014745724400014713 0ustar liggesusers‹U’KnÃ0 D÷=…O`H:NQHQ ‹¦›Þ¾æoàìFCj(ñïþþ³ý>>?¾¾ïÏçÛ\ÄÏÝŠh'Ùø¶E”¤®W2'):Ò·P»¼³ŸòpŠfÔò„6ýŽÐhGgáÛÆD‘”©os*»Ö”™YÐY:)ë•8O­3_èL/yÛIš §QÄ©M÷IQ"½“¤v¦7d-u§ò1ú±W„O@àSפˆ#©|ß½«5íӘûèlŸSöÓ£'ºÐ™~24êW~¥¸ {u!…O¡Yo˜bÃtÁ·úÔFŸ&…6{K {eñŠŠ›ï‹B£þUÃÆýBÆý~&ýo†9 Ûd˜ÈìJÕeõï[MôÖEËà“locfit/data/bad.rda0000754000176200001440000000343214745724400013674 0ustar liggesusers‹]Õ TSWð$€„`g\G=JQ!{ùRYÚJÁAÅ1ˆ±ØŠÐ:-‚,‚­´¸´£ˆ[-*RDÑûP‘EŠdQ ; ¢ V˜¼|§Çœó’Þ¹¹¿ïny¾nþ|‹ÅaqxlÇ€Ž†úM_\ú2RÓïlÂbñè‹þ>õ‚¸o³8/6¤1Ÿg§½Jó?YÌ÷KÍû·®ÖEBŽ±Ç³ì›pÝÊtðk“h¸‘óê‰cÚ|Èwo½¡š šH½…a7"×8¾2==àÅ­3@UÏÿ=s!ܳ,à]êè‡û;ÙmþÞŸ@1óû’ÑÞbã§Z(eúyx¬î|AÐQ(cú+_BBúì¡‚é·²ðRˆÕ•ð˜é¿Ú.üDuê—P]¥3wÎm‡ß#v'd+½ ÆRÍš5òÔÀȘy àIpý€vu<Ôšø†üSµ9ª’C~P·ñÃÍNYw¡n´¨æLéPfìrŽx³ê™zê{·Ø{Émà)SWƒxý›¸ah`êkŒqç½-+&¦Î¦ Ù¸’wš™zŸÍõo³Ü¹ž>Ù|8! žyÕ ^úZ¦?ô ¬†–+kî—é* Õn[ú<ã¡5z^£e´V5ÌIXÆÕ¢¾wœÅ ŠØðÍ×P•ÚÜÞyÚ˜ñµ…f8{r{ §ú/V7ò—û‚š¯:ÿ¸½õº[ aÆ­ 4?ÿmØbÐ0ãoçœsío{¡}ãVßNûsОmùí|—:hU–oXÏ…¯´éIŠÕБáãJö‡AÇï«áØóÐé^^¸,­:O%Ž(.˜Ag¯‡ðdþÐåbë]Ì|u©¿Sõ‡A73oÝIf›·œ°ƒnfþzjJo¦B3=µOAãÿ —™ÏÞƒ©…ãÝ ·bÝHòÉHè[h*,ʾ }aeû^´B_qüûòY ëÚ½£ù#ÐîaÛü má]Å㱫 3JŸf®]´Ñy‘èòf˜/½íýÌü÷Ó«òý³SÐϬÀþdL9{Kòå0Ó\(©ùXãáCz®Ô£®Ri~ܱ2J¹ØÉÈ«…â%Ëo…“AŽx•Í>¢Mø£À:ó4e¸Í‘í@±øñ+’ZȸÃä†%c [™¡} e´rÝ¿óý\)#ɘñ¯o–‘71Áq¼¹V”‘0SpšG(óÄûC­32fd'¼œóš2XµÖz%yδébü=ò³µŒêÕÒUЫîs2“âLÜ]Cn¯¥ '}6Újßï=Iý‘øzºDR8’—¨Þ=H±f6ª;ŠeèâÝÜÚãYåññ±ÐG”Q3}Ú-äDe{®¥@ú_òvoØPPPéŠ95øDë }êÙf¿º„íp@nuôaò2çèë¬Î_È ïÔüÜuÉ8fß ?ÏÝÛHI¿î7^4»:þ•{;ö±=T?(ìÚ°j&Ôo½ÜÐåBJ&·‘œÜ[U)Êö?/ìÎ$®úÉ ^ŽÅÇ:o7€Ös<΢5ûÈ3UcÔ ™¥œeDo“â&(–æ’Óð*ð3C*`Ôw†&»AïOÕ_v¯„á«ÃÊÂ`xjȃ©ù]ÎÊYUÅ äÛC{²{=`è)}<—Õʧ%+ƒÊM¹úðÈGrÓñ”‰“Ãß¹]Xìbãþ7—ŽZ™jrn‚Ö¹Ñ?MVvÑ?ÊâáZÎd Y;Y0ܳ}F¤Á‡00àø•uÅ7¤’¹?œë›íšôÉ}A”CÖ‘¿˜&‘jî×××L7%/¢fç…÷äBm2%d<žXnY Í®O|ï:é¿íÖnº-—ôYÜÙµ4Úƒ”DEÌʪɅrõߧí(]Ot i[B% ÐX«âO‰æ€ŠëG)‡ÝáùO+ÜRí’à‘.Ÿ³}y*i¦[{ç­%ƒ›„MyéÐóRHÿ£Ì&“ÇÙÆ “^šØF’v“ ŸÐ[NnxÍóôoq)ðbÝÄŽ€î§)ÿ±}çQcô™bïÎp:Ìd67Ù‘úpðÝæ;Báúæú›&ÁŠ…îýtOï4çîÿü€ÃŸ…`}ÇNúÀ×>õA¤b}èƒTdLà89brÂÄÇ$À$Ä$Â$Æ$Á$Å„ >|4øhðÑà£ÁGƒ >4hР!@C€† 4hÑ¢!DCˆ† !B4„hÑ¢!BC„† "4DhˆÐ¡!BC„† 1b4ÄhˆÑ£!FCŒ† 14$hHР!AC‚† 4$hHÑ¢!ECŠ† )R4¤hHÑ¢!CC†† 24dhÈС!CC¦7 œ'±‰ëÿb}äzå locfit/data/cltest.rda0000754000176200001440000000745414745724400014454 0ustar liggesusers‹­ØTTÇðE,H¢¢¢±D1bgû.ˆŧˆÆ‚KEªF±E)‚€(QEco€ÂGoR¥—E–ºKoR¢ÈÃw3ïåœw^4¹çÌîïìßÌ-3{vÃrc–¼±<ƒÁƦ(Ã&;‡|‘,£ËH Û}–Îû ÙqƒŸ>U+–ThºÔæ*zÉÂú£µMž2ðx„4¶o ¤Vͼf-踯Þ27šÎ‚³5#or(BR[ÊÑb§Nl×J›{gê~ì|uNÍØÿ Tk<—y°ŠÔ25¯•~qð‚dæm5Ì 3 <’zžõ nš¿?m4MvN߉uÞ×C6nFð}7ËàÇ<És6¹Ø¦’FE7¤¡Ð“iÝ[1Ï…+’Ò=Ïe\Ž$ëßÉm S Ç^¥ÃA#•jàu§iÅYÉ#ØQX_—é‡Ï>t–XÛ…•uã™J¶n( ±>ølê)èò]³â#v:MR >Ì…~½ò¬ª°lÑ#ã7ÍðÎιÎ5<k\ú£(k„¾wÅh¬™rf…,|Ík‹läd6CdШh‹¥˜Èððyi2 ú¼øŒ•†W±' J·DQ[¶}U¬íU÷»¢ ‚ìLuùëz1§íìÕnx 2;ž¹Ëž&•OLØ£Ž9wZ8ÏöÁ¦Ð¥%&!òоÅØ¡tûxgîîµi› ò[·ø¯õB Ó7Óõ£æ?e² *gH£ô¶â€ååæ#öÑ?7:ÿ+7{¬:4méƒ]”š‡d…ÅCÜ »MŽŽÛ ÿam‹¾4ü>/H¨íek6ÄHŸiCÝÁ^û±#/êŽ(Mt|zp™®lÁìŒe C¸@7ç.Øë}›¬cuš5—Üîº Ý6ǧ_Éþ¥½±eýñLV€p m!–gìÖ}Ö• 3^êöS&6ü8aÏ‘u"]Æä6ÎÃ*ˆWü–öÍJ(=knΓ*ìµLÝ:Æ¥fÓ¶GNz‰ïßYß;Ù«} +·‡¬‚X÷Ê1LyôïÕV >Ý…^o¬lâ,±­Àø›¹+öaåã+S®¼€46§òñ¶·P>+»Ü :ä¼›ï}zçŸ?ruäÊÿ|ÓÌ°êW\›Ì{„y7´}ç%æà›B¥¢1ö±r=›Ó´U¡YasoY"6‡›g·¥`²wª0Vu¸_ÿý—ù<ìЪ˜iÅž§bt—)a×ê Z#]ñåå›Æã¢×`GóÖS¤¨'–Y%œ„.×õ¡üŸ ±Óç_Eqˆÿá~eo~ÔX::WÞØ •ÉóQÛT!¿Ql)¿"Jôóúê#¾‚ôùš‹žnÄjŽFrjX&6¿ « ïƒ:Ù…G´Æ,Ã×é"¹SldE,éÈö+Àz³3²¾•Ð¦z‹ÉÌ…Ö˶O¬Óæ­|²,ž 3¶ù—¼ŽŒeø¯Ÿç;ÀÀVåÓ?[C‰E4•@·²ÄíB ôÕNêlÊX‰].Çʵ„°¸GJE5Æ.yh<“1ƒ×Oò¨²…ª©)[§BOË¢G‰¬tl·š¦°Åu3žQ¿#»O#ÓWkŸÛ— E·-vôîÚ¹ózïe.B•vòñ»Ò±,ï4U0Ä6çCU Ñ!„±úv ¦t^ño \„ÂÇÞ95yuW]ïZdØÂë}Q¶Pëvh»ïâLèUÌ chÀ”ÆI*öØÅ»çP×!Åx;·I%ãK±üë_‹NCωì ÁÎ×ئõ‹¿_ÉÌÚ]¦»pB$æÉõfŽ(z ÁrOeoÏÇJ½ã‡Åß´`o¨åÍŸôïcóÛ£Îi³b›‘ž†ó+o®á ´½ûo#ÌÊ¢çC‰µ¿ÊÚr¾ýà«õlÔSÈ÷¨•$óû³|Mb"àšBªå»±·\f*Ïñ7(=lÔwKÄÐ7R]´xr0´Ù][”·{§;õØ™ÂøyËhyBSu_é•õØö|â±ë)(šÝùàÂMul}üæ›s xÿC@q¸‹šžK÷Ø ƒªår{Ͼ6‚V/÷óU‘ÒÕýµ «tƒŒbû¡¨0ÏÀVi*3TèSH~™Ó*ý&_ÿƒÏy… ì ;l:¥u5ÔîŠNœbhÒ ‡óž½› õ'õµ ŸHàyøŒnµL&þþ<Þæêá ¬°X>Ê?“5?…µ]aÚã+#Yë‹ç”‡Öl¸·^´Ì²£v­¬ïž:E >¿X¶ƒäé8ó'ã;Á½ÙÖþÐ5Ý`Z•tY5Ͳ ÛŽŸTÿ‚] ±£íWcUF+ópˆJWF2k¶à §$µCêдP^]_Ó ü ŸÆDŽÉƒ7š›ï'†bò^_cáÈÉ5à ÔJ¯^ÖØŠåZkZkÞG®5Ž‹tÝ°qï[ÆÝžÝÐä¦íìì7 'ͼ>>bˆœ/î¿8o< Ä©¢MÃ1żéGs¯:(‰òÈŸ±k²öÙFZÅ€¸Ã-¡÷AýÝïLÖZ ¹+Û›lÂÚ[î7.‡Î»3Ï¥¹"fŸÒ˜´¦¿Ó‹ N+¯+AqAÒ"§Ò±P“0»õhn4ˆ^2:ìVŽÀÎè˜%ÊëÏ`ÝÁà àâ¦îÓÆ>:§mÕXž€™šZ[ìĦðüå˜3·ÎcG’2HÕAò½‡Z«ß:(Òðž:­€uI»6]\„™¦ïÇnÙ ûF÷oÝJñ75@µr˜|œúL$]~zêveg² ·@]^@VÀ±z¨ôV‹™8g'ˆßD5ßâK@rÏxû…9ßc­(dÕà1ÏsÊWï§4ßÜ3¯}6˜–œÚÃY€M3V”Ÿœ9íæß—}ŠíÝÇ £û C³p~ût¬ŽÌU)h42»ÍÓÚN+A½×·v>_£Èg#^y6 “ÚU]OÝÆ*…• û_Ü1InYbð}3Ì»·Ìx·ºÔÝcý*îŽE^­g±%–Gî݇eÏ®^˜<šcýNךµB¾¾ÒSÉÒeèø[œbaÄQ‹âfÛ(ÎhoÜ­Ÿ mó•£Ì­ú±ix纉~ÿ€ë[l†ÍT[Œ5"ßœòɘ¹$SI ½ß,]:Wó0ä¦Ü}ØÌ„‰¥â9|òiÙzèIück­ü è;MƒÞo'â-¦Õ“áðkE¸ÝÌÎÕ(Ù¤¡ë-Miö8 Ïqã1$î‰ï„¥XP´ù¢§W%3¬/Ûjbµ»ÁÅ#«æ`[rì˜ëál,s_Sx{¶ò·±pB…NºMXÝ«ê²Ì$Qƒ«ŸâCD?˳°Aɾ¹¿ºk‡@ckƒNw™/6-i}Ûcð^n¸V9üE7duW^=gS íé|Užë§jC˕闛°Þq¶vßÝ Ø¥|–Ê:b’ùÂWŸ%˜9#Wóm`9ä‹ Ï­?ûò>òuN¶ŽÁœ¼ÖÂhåK(õì¬Ù•ž…öi¯Œç€h‰Ñ7dz®ñJËB| sRkC¡îÊõ=ï:v€$Øwn‹ò8hˆ©=y¤ç&E+Ž•haî4½µOßcÝw«t_>êÀòÎ¥/ûBJq{ÎÞUXí¥¯†I˜÷½lD‡ú~xS®uÑ%Q‚¥©5ûM?îÅœèÀ"³Ã+°ÚášýUE”6{ypƒVbqÞ/Îj >¡g zÖaMÇQÿ…ùë°ðuÚ¥óß^ƒÜ5Y‡ º]P¤¨?®òŒ–¶p>˜))aáy›uk;~ÃêßeZš=F@»l‘÷þ…w°Ý³zªã<%xytçƒ{2P¯™qÚ¨µ«ËË— Ç¿ÃʪYò)²¦x=íaÄ%1ô8¨w›œWAñ“S)‡ŽîÇâi§óùyØuçÓeRÆ‚իrÛ}"1™lè1EÓ•Ôw0/Nýa p3 rw™´™ÚÕ÷2âjÇ.…ê®ݯÜÓ¡5xGê¥'uØòó÷·"t!úêÌÊ‚ClΞÍk_XnÇOH¯íÙƒïtÜãÊdô°Âeî »p(œv$>M'SéÉzfC‚j4#¬¥nŸZùMÿ‰tŒ[Оã³i>Š¬Ÿ ›±çáÐ:ÂøÃmÿýþ¿öiýç:ÿkû³õ_ÚßÏmïÏŽóÏÖ®÷ÿÎ÷çîÿ»ûùW¯ßŸÝ¾ô|}nÿþ®ûâs½Ïíï_}.¿ô<üÕúϽ¯¿ôúý]í|éóù¥Ïí_?ÿì8þ;ÿõ¯×;³½–΃Aùßz}Ú9ì “$Ö¿“ŒË´°5s:rh§üN³}f‹¬œýÃ×G;ÙXôŸXêPÃC– ¡ØC3¸C7øCA0„C}fj’DÆÁd‘Ä&‰C—$I|’$ƒE 1XÄ`ƒE 1XÄ`ƒE 1ØÄ`ƒM 61ØÄ`ƒM 61ØÄ`ƒC 18ÄàƒC 18ÄàƒC 1¸ÄàƒK .1¸ÄàƒK .1¸ÄàƒG 1xÄàƒG 1xÄàƒG 1øÄàƒO >1øÄàƒO >1øÄàC@ 1ÄC@ 1ÄC@ 1„ÄCH !1„ÄCH !1„IJLMM™4²hdÓÈ¡‘K#F>©Æ¤“jLª1©Æ¤“jLª1©Æ¤“j,ª±¨Æ¢‹j,ª±¨Æ¢‹j,ª±¨Æ¦›jlª±©Æ¦›jlª±©Æ¦›jªq¨Æ¡‡jªq¨Æ¡‡jªq¨Æ¥—j\ªq©Æ¥—j\ªq©Æ¥—j<ªñ¨Æ£j<ªñ¨Æ£j<ªñ¨Æ§Ÿj|ªñ©Æ§Ÿj|ªñ©Æ§Ÿjª ¨& š€jª ¨& š€jª ¨&¤šjBª ©&¤šjBª ©&¤KXÿšK>~*ÿ¢pŒ™Çlocfit/data/mmsamp.tab.gz0000754000176200001440000000064314745724400015060 0ustar liggesusers‹-RÉ @û§Ši`W`îÎ’îñ¯‘,ÆÆ6ß¿?¾)™ü>ôUÇ æNõ>ü…ƒd§¿Ç_bÍE,ØifJÅx†S ˜™ pᘥjE $â~h˜%%t™Y8ÞÓ¯YÉ"‘.1ZRä9H‰©¾|A–¾¿Ú¶èáA<ij§Å;ÓòË,íYéu‚„ R^q¾¬-¯÷^Ç/ B½ ªåWË#61éwÕAmlgÐÿV«ÃòÈ „ëæŒôݦ;ãv;Sï¾it9vˆ¡Õ'U­ÌëBky¼Mà§å6<>­,s‹æ{ø²t«.q¿‚”lSÚû¸ ¼4¢Œ·e‘ŠA9lÔ)Ê×Eª”¿zÓÕ"uÅhQü:í.JfÆÌ뺰¤M•‰/1¥îy˜ zê©I«¸Ü†i‡xæ^+–'~Éœ·Á¡ËÇÄçZºîÚûšåÚ)ÉéKÅ&¦—jõl_öbt¿"˜l\[Ý/-¬zWÞmXnƒÞÑóu‘¼ÌŒßE%1ob,ÇŸÿZ±åþˆlocfit/data/ethanol.rda0000754000176200001440000000235314745724400014601 0ustar liggesusers‹–}hUuÇï½››»{Q–”Y,fƒðÚλˆ<¿R‰(5]ȉ­¦ˆ¬­¶‘Ë̈ˆˆ©þˆÞ3!DBD"¢W³¨è•Q"uwwwïu»Û¹ç´éÜ‹ý^žßC\¸lxàœç¹ç÷òy~Ïs~ßßݱ©Õˆ·Æ#‘H,«‹FbeÜ-ñG”ßUü®ÜÝ··½«»3)»ŽÿíuüneµùW÷öœ¼•Åv5M|ùÊ.¸té§?¯áVYsï'ÛÙí#Ï7œÙÁ‹Ö¦IÚwhê|ã/œ‘ ,vaíŠw>Û©Ž‡nþhq3«•ævð#ò‚qõÂú®7^Þö7äßûþóçê»aêñ÷➀™tÛ]/º÷ÃU¿TWVÉ…‚¿³|ù‘¾OYT„uöCOµðŒÝ“ä‚àêj1Ñ¿0vîÔ:>5 J\=‹òÏLÊ×[Y ö›Vñ°ª£r"V&¢m¹ 32]ëY¹(ÏÊoع¼r¶¤G,è˜Â¼Nª|3U®gXTõƒl³ÌÁ”¨ÒöQV+ÓÖË*‘W·ì@òžË ë¬Uue5<©<å,®êwËoáÉâ=Y¹Šò˜ÏËgµ(×¹S,rBN c*Ÿ¬óœ•exrÈ‹Èt<ÀjEÛî†AÌO2~ƒ2Íû -—s# à¼ÿàw8·G^ô7©ïm^ÛXÂÎ7.Ö@Û0O¿D NC‘5Šlñøâþ%ú%®‘_*ŽbÛ8-5oâ×¹P[*Þ…Ö}¡y,U‡Rq4”ø¾JäCÇÛcÅ»E-ˆm}p |¥7b»û#ÄýQPº ¾”ϧ D}Í£njŸB€ú™Z/†•>A÷]u©€ú›G}Ëá>-(}õ0Àñáq!¼› øA\? kùWºY¡·/Ã~F…9t…âÆþ!곯Ûñ)pµá#Ò¬,êr Ìt|ui}_=ODÃ-âû!—ÓO‡a¡‚’0¢uJÊâÓ0Šqæ0/i<·4gL?m0‚çZó”i‘…€<æQç-Pçd°N£:¢\ýÐ9¢Îå°î±ÎºŸ®Wˆõñ1Þæyë{Q£àËôv@€çì(ž/!®'Àõçð{G~(ä}ümBÝNa¾qIŒ7‰ùRº\ô·cQWûc»{¹³ÿtˆ—e[·õ£ݨÍÅ#ílïÕ#õËxG{_{bOŸ´¨{UO÷þÄÿa­zâfíÚ1µciÇÖŽ£W;žvÖ¡k¾“¼fò òLò,òlòò\ò<òˆaà †A ƒ1 bÄ0ˆaà †I “&1Lb˜Ä0‰aÃ$†I “1,bXÄ°ˆaÃ"†E ‹1,bØÄ°‰aÃ&†M ›61lbØÄ°‰áÃ!†C ‡1b8ÄpˆáÃ!†K —.1\b¸Äp‰áÃ%†K —11) printf(" procvraw: %d\n",v); des->xev = evpt(&lf->fp,v); if (acri(&lf->sp)==ANONE) lf_status = locfit(&lf->lfd,des,&lf->sp,0,1,0); else lf_status = alocfit(&lf->lfd,&lf->sp,&lf->dv,des); lf->fp.h[v] = des->h; for (i=0; incoef; i++) coef[i] = des->cf[cfn(des,i)]; if (!lf_error) { if (dc(&lf->fp)) dercor(&lf->lfd,&lf->sp,des,coef); subparcomp(des,lf,coef); for (i=0; incoef; i++) lf->fp.coef[i*lf->fp.nvm+v] = coef[i]; } lf->fp.deg[v] = deg(&lf->sp); return(lf_status); } /* * Set default values for the likelihood e.t.c. This * is called in cases where the optimization for the fit * has failed. */ void set_default_like(fitpt *fp, int v) /* fitpt *fp; int v; */ { int i, nvm, d; nvm = fp->nvm; d = fp->d; fp->lik[v] = fp->lik[nvm+v] = 0; fp->lik[2*nvm+v] = 0; /* should use sum of weights here? */ for (i=0; i<=d; i++) fp->t0[i*nvm+v] = fp->nlx[i*nvm+v] = 0.0; } int procv(design *des, lfit *lf, int v) /* design *des; lfit *lf; int v; */ { int p, nvm, i, k; double trc[6], t0[1+MXDIM], vari[1+MXDIM]; k = procvraw(des,lf,v); if (lf_error) return(k); //d = lf->lfd.d; p = npar(&lf->sp); nvm = lf->fp.nvm; switch(k) { case LF_OK: break; case LF_NCON: WARN(("procv: locfit did not converge")); break; case LF_OOB: WARN(("procv: parameters out of bounds")); break; case LF_PF: if (lf_debug>1) WARN(("procv: perfect fit")); set_default_like(&lf->fp,v); return(k); case LF_NOPT: WARN(("procv: no points with non-zero weight")); set_default_like(&lf->fp,v); return(k); case LF_INFA: if (lf_debug>1) WARN(("procv: initial value problem")); set_default_like(&lf->fp,v); return(k); case LF_DEMP: WARN(("procv: density estimate, empty integration region")); set_default_like(&lf->fp,v); return(k); case LF_XOOR: WARN(("procv: fit point outside xlim region")); set_default_like(&lf->fp,v); return(k); case LF_DNOP: if (lf_debug>1) WARN(("density estimation -- insufficient points in smoothing window")); set_default_like(&lf->fp,v); return(k); case LF_FPROB: WARN(("procv: f problem; likelihood failure")); set_default_like(&lf->fp,v); return(k); default: WARN(("procv: unknown return code %d",k)); set_default_like(&lf->fp,v); return(k); } comp_vari(&lf->lfd,&lf->sp,des,trc,t0); lf->fp.lik[v] = des->llk; lf->fp.lik[nvm+v] = trc[2]; lf->fp.lik[2*nvm+v] = trc[0]-trc[2]; for (i=0; incoef; i++) vari[i] = des->V[p*cfn(des,0) + cfn(des,i)]; vari[0] = sqrt(vari[0]); if (vari[0]>0) for (i=1; incoef; i++) vari[i] /= vari[0]; t0[0] = sqrt(t0[0]); if (t0[0]>0) for (i=1; incoef; i++) t0[i] /= t0[0]; subparcomp2(des,lf,vari,t0); for (i=0; incoef; i++) { lf->fp.nlx[i*nvm+v] = vari[i]; lf->fp.t0[i*nvm+v] = t0[i]; } return(k); } double intvo(design *des, lfit *lf, double *c0, double *c1, double a, int p, double t0, double t20, double t21) /* design *des; lfit *lf; double *c0, *c1, a, t0, t20, t21; int p; */ { double th, lk, link[LLEN]; int i; lk = 0; for (i=0; in; i++) { th = (1-a)*innerprod(c0,&des->X[i*p],p) + a*innerprod(c1,&des->X[i*p],p); stdlinks(link,&lf->lfd,&lf->sp,(int)des->ind[i],th,robscale); lk += des->w[i]*link[ZLIK]; } des->llk = lk; return(vocri(des->llk,t0,(1-a)*t20+a*t21,pen(&lf->sp))); } int procvvord(design *des, lfit *lf, int v) /* design *des; lfit *lf; int v; */ { double tr[6], gcv, g0, ap, coef[4][10], th, md=0.0; int i, j, k=0, d1, i0, p1; des->xev = evpt(&lf->fp,v); ap = pen(&lf->sp); if ((ap==0) & ((fam(&lf->sp)&63)!=TGAUS)) ap = 2.0; d1 = deg(&lf->sp); p1 = npar(&lf->sp); for (i=0; isp); i<=d1; i++) { deg(&lf->sp) = i; des->p = npar(&lf->sp) = calcp(&lf->sp,lf->lfd.d); k = locfit(&lf->lfd,des,&lf->sp,0, i==deg0(&lf->sp),0); local_df(&lf->lfd,&lf->sp,des,tr); gcv = vocri(des->llk,tr[0],tr[2],ap); if ((i==deg0(&lf->sp)) || (gcvp; j++) coef[i][j] = des->cf[j]; /*#ifdef RESEARCH t2[i] = tr[2]; printf("variable order\n"); if ((ip) && (i>deg0(&lf->sp))) { for (j=1; j<10; j++) { gcv = intvo(des,lf,coef[i-1],coef[i],j/10.0,des->p,tr[0],t2[i-1],t2[i]); if (gcvfp.h[v] = des->h; if (lf->fp.h[v]<=0) WARN(("zero bandwidth in procvvord")); if (i0sp) = i0; des->p = npar(&lf->sp) = calcp(&lf->sp,lf->lfd.d); k = locfit(&lf->lfd,des,&lf->sp,0,0,0); for (i=npar(&lf->sp); icf[i] = 0.0; i0 = (int) md; if (i0==d1) i0--; th = md-i0; for (i=0; icf[i] = (1-th)*coef[i0][i]+th*coef[i0+1][i]; deg(&lf->sp) = d1; npar(&lf->sp) = p1; } for (i=0; ifp.coef[i*lf->fp.nvm+v] = des->cf[i]; lf->fp.deg[v] = md; return(k); } int procvhatm(design *des, lfit *lf, int v) /* design *des; lfit *lf; int v; */ { int k=0; double *l; l = &lf->fp.L[v*lf->lfd.n]; if ((ker(&lf->sp)!=WPARM) | (!haspc(&lf->pc))) { k = procvraw(des,lf,v); wdiag(&lf->lfd,&lf->sp,des,l,&lf->dv,0,1,1); } else wdiagp(&lf->lfd,&lf->sp,des,l,&lf->pc,&lf->dv,0,1,1); return(k); } locfit/src/ev_interp.c0000754000176200001440000001460014745734161014477 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include "local.h" double linear_interp(double h, double d, double f0, double f1) /* linear_interp(h,d,f0,f1) double h,d,f0,f1; */ { if (d==0) return(f0); return( ( (d-h)*f0 + h*f1 ) / d ); } void hermite2(double x, double z, double *phi) /* hermite2(x,z,phi) double x,z,*phi; */ { double h; if (z==0) { phi[0] = 1.0; phi[1] = phi[2] = phi[3] = 0.0; return; } h = x/z; if (h<0) { phi[0] = 1; phi[1] = 0; phi[2] = h; phi[3] = 0; return; } if (h>1) { phi[0] = 0; phi[1] = 1; phi[2] = 0; phi[3] = h-1; return; } phi[1] = h*h*(3-2*h); phi[0] = 1-phi[1]; phi[2] = h*(1-h)*(1-h); phi[3] = h*h*(h - 1); } double cubic_interp(double h, double f0, double f1, double d0, double d1) /* cubic_interp(h,f0,f1,d0,d1) double h,f0,f1,d0,d1; */ { double phi[4]; hermite2(h,1.0,phi); return(phi[0]*f0+phi[1]*f1+phi[2]*d0+phi[3]*d1); } double cubintd(double h, double f0, double f1, double d0, double d1) /* cubintd(h,f0,f1,d0,d1) double h,f0,f1,d0,d1; */ { double phi[4]; phi[1] = 6*h*(1-h); phi[0] = -phi[1]; phi[2] = (1-h)*(1-3*h); phi[3] = h*(3*h-2); return(phi[0]*f0+phi[1]*f1+phi[2]*d0+phi[3]*d1); } /* interpolate over a rectangular cell. x = interpolation point. vv = array of vertex values. ll = lower left corner. ur = upper right corner. d = dimension. nc = no of coefficients. */ double rectcell_interp(double *x, double vv[64][64], double *ll, double *ur, int d, int nc) /* rectcell_interp(x,vv,ll,ur,d,nc) double *x, vv[64][64], *ll, *ur; int d, nc; */ { double phi[4]; int i, j, k, tk; tk = 1<=0; i--) { tk = 1<=0; i--) { hermite2(x[i]-ll[i],ur[i]-ll[i],phi); tk = 1<=0; i--) { hermite2(x[i]-ll[i],ur[i]-ll[i],phi); tk = 1<coef; break; case PVARI: case PNLX: values = fp->nlx; break; case PT0: values = fp->t0; break; case PBAND: vv[0] = fp->h[nv]; return(1); case PDEGR: vv[0] = fp->deg[nv]; return(1); case PLIK: vv[0] = fp->lik[nv]; return(1); case PRDF: vv[0] = fp->lik[2*fp->nvm+nv]; return(1); default: ERROR(("Invalid what in exvval")); return(0); } vv[0] = values[nv]; if (!fp->hasd) return(1); if (z) { for (i=0; invm+nv]; return(1<nvm+nv]; return(d+1); } } void exvvalpv(double *vv, double *vl, double *vr, int d, int k, double dl, int nc) /* exvvalpv(vv,vl,vr,d,k,dl,nc) double *vv, *vl, *vr, dl; int d, k, nc; */ { int i, tk, td; double f0, f1; if (nc==1) { vv[0] = (vl[0]+vr[0])/2; return; } tk = 1<d; ll = evpt(fp,0); ur = evpt(fp,fp->nv-1); mg = mg(evs); z0 = 0; vc = 1<=0; j--) { v[j] = (int)((mg[j]-1)*(x[j]-ll[j])/(ur[j]-ll[j])); if (v[j]<0) v[j]=0; if (v[j]>=mg[j]-1) v[j] = mg[j]-2; z0 = z0*mg[j]+v[j]; } nce[0] = z0; nce[1] = z0+1; sk = jj = 1; for (i=1; id,what,0); return(vv[0]); } double xbar_int(fitpt *fp, double *x, int what) /* xbar_int(fp,x,what) fitpt *fp; double *x; int what; */ { int i, nc; double vv[1+MXDIM], f; nc = exvval(fp,vv,0,fp->d,what,0); f = vv[0]; if (nc>1) for (i=0; id; i++) f += vv[i+1]*(x[i]-evptx(fp,0,i)); return(f); } double dointpoint(lfit *lf, double *x, int what, int ev, int j) /* dointpoint(lf,x,what,ev,j) lfit *lf; double *x; int what, ev, j; */ { double xf, f=0.0; int i; fitpt *fp; evstruc *evs; fp = &lf->fp; evs = &lf->evs; for (i=0; id; i++) if (lf->lfd.sty[i]==STANGL) { xf = floor(x[i]/(2*PI*lf->lfd.sca[i])); x[i] -= xf*2*PI*lf->lfd.sca[i]; } switch(ev) { case EGRID: f = grid_int(fp,evs,x,what); break; case EKDTR: f = kdtre_int(fp,evs,x,what); break; case ETREE: f = atree_int(lf,x,what); break; case EPHULL: f = triang_int(lf,x,what); break; case EFITP: f = fitp_int(fp,x,what,j); break; case EXBAR: f = xbar_int(fp,x,what); break; case ENONE: f = 0; break; case ESPHR: f = sphere_int(lf,x,what); break; default: ERROR(("dointpoint: cannot interpolate structure %d",ev)); } if (((what==PT0)|(what==PNLX)) && (f<0)) f = 0.0; f += addparcomp(lf,x,what); return(f); } locfit/src/ev_trian.c0000754000176200001440000003402714745734575014331 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include "local.h" void solve(double *A, double *b, int d) /* this is crude! A organized by column. */ /* solve(A,b,d) double *A, *b; int d; */ { int i, j, k; double piv; for (i=0; ifp.d; vc = d+1; for (i=0; ifp,ce[i],k)-evptx(&lf->fp,ce[j],k); di = rho(dfx,lf->lfd.sca,d,KSPH,NULL); le[i*vc+j] = le[j*vc+i] = di/MIN(lf->fp.h[ce[i]],lf->fp.h[ce[j]]); nts = nts || le[i*vc+j]>cut(&lf->evs); } return(nts); } void resort(int *pv, double *xev, int *dig) /* resort(pv,xev,dig) double *xev; int *pv, *dig; */ { double d0, d1, d2; int i; d0 = d1 = d2 = 0; for (i=0; i<3; i++) { d0 += (xev[3*pv[11]+i]-xev[3*pv[1]+i])*(xev[3*pv[11]+i]-xev[3*pv[1]+i]); d1 += (xev[3*pv[ 7]+i]-xev[3*pv[2]+i])*(xev[3*pv[ 7]+i]-xev[3*pv[2]+i]); d2 += (xev[3*pv[ 6]+i]-xev[3*pv[3]+i])*(xev[3*pv[ 6]+i]-xev[3*pv[3]+i]); } if ((d0<=d1) & (d0<=d2)) { dig[0] = pv[1]; dig[1] = pv[11]; dig[2] = pv[2]; dig[3] = pv[7]; dig[4] = pv[3]; dig[5] = pv[6]; } else if (d1<=d2) { dig[0] = pv[2]; dig[1] = pv[7]; dig[2] = pv[1]; dig[3] = pv[11]; dig[4] = pv[3]; dig[5] = pv[6]; } else { dig[0] = pv[3]; dig[1] = pv[6]; dig[2] = pv[2]; dig[3] = pv[7]; dig[4] = pv[1]; dig[5] = pv[11]; } } void triang_grow(design *des, lfit *lf, Sint *ce, Sint *ct, Sint *term) /* triang_grow(des,lf,ce,ct,term) design *des; lfit *lf; Sint *ce, *ct, *term; */ { double le[(1+MXDIM)*(1+MXDIM)], ml; int d, i, j, im=0, jm=0, vc, pv[(1+MXDIM)*(1+MXDIM)], dig[6]; Sint nce[1+MXDIM]; if (lf_error) return; d = lf->fp.d; vc = d+1; if (!triang_split(lf,ce,le)) { if (ct != NULL) { for (i=0; i3) { ml = 0; for (i=0; iml) { ml = le[i*vc+j]; im = i; jm = j; } pv[0] = newsplit(des,lf,(int)ce[im],(int)ce[jm],0); for (i=0; ievs)); for (i=0; i<=d; i++) /* corners */ { for (j=0; j<=d; j++) nce[j] = (j==i) ? ce[i] : pv[i*vc+j]; triang_grow(des,lf,nce,ct,term); } if (d==2) /* center for d=2 */ { nce[0] = pv[5]; nce[1] = pv[2]; nce[2] = pv[1]; triang_grow(des,lf,nce,ct,term); } if (d==3) /* center for d=3 */ { resort(pv,evp(&lf->fp),dig); nce[0] = dig[0]; nce[1] = dig[1]; nce[2] = dig[2]; nce[3] = dig[4]; triang_grow(des,lf,nce,ct,term); nce[2] = dig[5]; nce[3] = dig[3]; triang_grow(des,lf,nce,ct,term); nce[2] = dig[2]; nce[3] = dig[5]; triang_grow(des,lf,nce,ct,term); nce[2] = dig[4]; nce[3] = dig[3]; triang_grow(des,lf,nce,ct,term); } } void triang_descend(lfit *tr, double *xa, Sint *ce) /* triang_descend(tr,xa,ce) lfit *tr; double *xa; Sint *ce; */ { double le[(1+MXDIM)*(1+MXDIM)], ml; int d, vc, i, j, im=0, jm=0, pv[(1+MXDIM)*(1+MXDIM)]; design *des; des = NULL; if (!triang_split(tr,ce,le)) return; d = tr->fp.d; vc = d+1; if (d>3) /* split longest edge */ { ml = 0; for (i=0; iml) { ml = le[i*vc+j]; im = i; jm = j; } pv[0] = newsplit(des,tr,(int)ce[im],(int)ce[jm],0); if (xa[im]>xa[jm]) { xa[im] -= xa[jm]; xa[jm] *= 2; ce[jm] = pv[0]; } else { xa[jm] -= xa[im]; xa[im] *= 2; ce[im] = pv[0]; } triang_descend(tr,xa,ce); return; } for (i=0; ievs)); for (i=0; i<=d; i++) if (xa[i]>=0.5) /* in corner */ { for (j=0; j<=d; j++) { if (i!=j) ce[j] = pv[i*vc+j]; xa[j] = 2*xa[j]; } xa[i] -= 1; triang_descend(tr,xa,ce); return; } if (d==1) { ERROR(("weights sum to < 1")); } if (d==2) /* center */ { ce[0] = pv[5]; xa[0] = 1-2*xa[0]; ce[1] = pv[2]; xa[1] = 1-2*xa[1]; ce[2] = pv[1]; xa[2] = 1-2*xa[2]; triang_descend(tr,xa,ce); } if (d==3) /* center */ { double z; int dig[6]; resort(pv,evp(&tr->fp),dig); ce[0] = dig[0]; ce[1] = dig[1]; xa[0] *= 2; xa[1] *= 2; xa[2] *= 2; xa[3] *= 2; if (xa[0]+xa[2]>=1) { if (xa[0]+xa[3]>=1) { ce[2] = dig[2]; ce[3] = dig[4]; z = xa[0]; xa[3] += z-1; xa[2] += z-1; xa[0] = xa[1]; xa[1] = 1-z; } else { ce[2] = dig[2]; ce[3] = dig[5]; z = xa[3]; xa[3] = xa[1]+xa[2]-1; xa[1] = z; z = xa[2]; xa[2] += xa[0]-1; xa[0] = 1-z; } } else { if (xa[1]+xa[2]>=1) { ce[2] = dig[5]; ce[3] = dig[3]; xa[1] = 1-xa[1]; xa[2] -= xa[1]; xa[3] -= xa[1]; } else { ce[2] = dig[4]; ce[3] = dig[3]; z = xa[3]; xa[3] += xa[1]-1; xa[1] = xa[2]; xa[2] = z+xa[0]-1; xa[0] = 1-z; } } triang_descend(tr,xa,ce); } } void covrofdata(lfdata *lfd, double *V, double *mn) /* covar of data; mean in mn */ /* covrofdata(lfd,V,mn) lfdata *lfd; double *V, *mn; */ { int d, i, j, k; double s; s = 0; d = lfd->d; for (i=0; in; i++) { s += prwt(lfd,i); for (j=0; j1+eps)) return(0); return(1); } void triang_start(design *des, lfit *lf) /* triang_start(des,lf) design *des; lfit *lf; */ /* Triangulation with polyhedral start */ { int i, j, k, n, d, nc, nvm, ncm, vc; Sint *ce, ed[1+MXDIM]; double V[MXDIM*MXDIM], P[MXDIM*MXDIM], sigma, z[MXDIM], xa[1+MXDIM], *xev; xev = evp(&lf->fp); d = lf->lfd.d; n = lf->lfd.n; lf->fp.nv = nc = 0; triang_guessnv(&nvm,&ncm,&vc,d,mk(&lf->evs)); trchck(lf,nvm,ncm,vc); ce = lf->evs.ce; for (j=0; jpc.xbar[j]; lf->fp.nv = 1; covrofdata(&lf->lfd,V,xev); /* fix this with scaling */ eig_dec(V,P,d); for (i=0; ifp.nv*d+j] = xev[j]-2*sigma*P[j*d+i]; lf->fp.nv++; for (j=0; jfp.nv*d+j] = xev[j]+2*sigma*P[j*d+i]; lf->fp.nv++; } for (i=0; ilfd,k,i)-xev[k]); ed[j+1] = 2*j+1+(z[j]>0); for (k=0; klfd,j,i); } k = intri(z,ed,xev,xa,d); if (xa[0]<0) { for (j=1; j<=d; j++) for (k=0; k>=1; } } for (i=0; ifp.nv; i++) { des->vfun(des,lf,i); if (lf_error) return; lf->evs.s[i] = 0; } for (i=0; ievs.nce = nc; } double triang_cubicint(double *v, double *vv, Sint *w, int d, int nc, double *xxa) /* triang_cubicint(v,vv,w,d,nc,xxa) double *v, *vv, *xxa; int d, nc; Sint *w; */ { double sa, lb, *vert0, *vert1, *vals0=NULL, *vals1, deriv0, deriv1; int i, j, k; if (nc==1) /* linear interpolate */ { sa = 0; for (i=0; i<=d; i++) sa += xxa[i]*vv[i]; return(sa); } sa = 1.0; for (j=d; j>0; j--) /* eliminate v[w[j]] */ { lb = xxa[j]/sa; for (k=0; kd; if (evs->s[i]==0) return(exvval(fp,vv,i,d,what,0)); il = evs->lo[i]; nc = triang_getvertexvals(fp,evs,vl,il,what); ih = evs->hi[i]; nc = triang_getvertexvals(fp,evs,vh,ih,what); vv[0] = (vl[0]+vh[0])/2; if (nc==1) return(nc); P = 1.5*(vh[0]-vl[0]); le = 0.0; for (j=0; jfp; evs= &lf->evs; d = fp->d; vc = d+1; ce = evs->ce; i = 0; while ((ince) && (!intri(x,&ce[i*vc],evp(fp),xa,d))) i++; if (i==evs->nce) return(NOSLN); i *= vc; for (j=0; jnce[i+1]) { j=nce[i]; nce[i]=nce[i+1]; nce[i+1]=j; k=1; lb = xa[i]; xa[i] = xa[i+1]; xa[i+1] = lb; } } while(k); nc = 0; for (i=0; i #include "local.h" #include "tube.h" /* * some old math libraries choke on lgamma()... */ /* #define LGAMMA(arg) lgamma(arg) */ #define LOGPI 1.144729885849400174143427 /* area(d) = 2 pi^(d/2) / Gamma(d/2) * = surface area of unit sphere in R^d */ static double A[10] = { 1, /* d=0, whatever */ 2, 6.2831853071795864770, /* 2*pi */ 12.566370614359172954, /* 4*pi */ 19.739208802178717238, /* 2*pi^2 */ 26.318945069571622985, /* 8/3*pi^2 */ 31.006276680299820177, /* pi^3 */ 33.073361792319808190, /* 16/15*pi^3 */ 32.469697011334145747, /* 1/3*pi^4 */ 29.686580124648361825 /* 32/105*pi^4 */ }; double area(int d) /* area(d) int d; */ { if (d<10) return(A[d]); return(2*exp(d*LOGPI/2.0-LGAMMA(d/2.0))); } double tailp_uniform(double c, double *k0, int m, int d, int s, double n) /* tailp_uniform(c,k0,m,d,s,n) double c, *k0, n; int m, d, s; */ { int i; double p; p = 0.0; for (i=0; id+1) m = d+1; if ((alpha<=0) | (alpha>=1)) { printf("critval: invalid alpha %8.5f\n",alpha); return(2.0); } if (alpha>0.5) printf("critval: A mighty large tail probability alpha=%8.5f\n",alpha); if (m==0) { d = 0; k0[0] = 1; m = 1; } switch(process) { case UNIF: c = 0.5; c0 = 0.0; c1 = 1.0; tpf = tailp_uniform; tdf = taild_uniform; break; case GAUSS: c = 2.0; c0 = 0.0; c1 = 0.0; tpf = tailp_gaussian; tdf = taild_gaussian; break; case TPROC: c = 2.0; c0 = 0.0; c1 = 0.0; tpf = tailp_tprocess; tdf = taild_tprocess; break; default: printf("critval: unknown process.\n"); return(0.0); } for (j=0; j0) c0 = c; if (tp<0) c1 = c; cn = c + tp/td; if (cn0.0) && (cn>c1)) cn = (c+c1)/2; c = cn; if (fabs(tp/alpha)<1.0e-10) return(c); } return(c); } locfit/src/lf_nbhd.c0000754000176200001440000001271414745735210014100 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * * Functions for determining bandwidth; smoothing neighborhood * and smoothing weights. */ #include "local.h" /* ||x|| for appropriate distance metric */ double rho(double *x, double *sc, int d, int kt, int *sty) /*double *x, *sc; int d, kt, *sty;*/ { double rhoi[MXDIM], s; int i; for (i=0; is) s = rhoi[i]; } return(s); } if (kt==KSPH) { for (i=0; i=i0) && (x[ind[r]]>piv)) r--; if (l<=r) ISWAP(ind[l],ind[r]); } /* now, x[ind[i0..r]] <= piv < x[ind[l..i1]] */ if (rxl; d = lfd->d; k = 1; for (j=0; j=xlim[j]) & (datum(lfd,j,i)<=xlim[j+d])); } return(k); } double compbandwid(double *di, Sint *ind, double *x, int n, int d, int nn, double fxh) /*double *di, *x, fxh; Sint *ind; int n, d, nn;*/ { int i; double nnh; if (nn==0) return(fxh); if (nnn; x = des->xev[0]; xd = dvari(lfd,0); sc = lfd->sca[0]; /* find closest data point to x */ if (x<=xd[0]) z = 0; else if (x>=xd[n-1]) z = n-1; else { l = 0; r = n-1; while (r-l>1) { z = (r+l)/2; if (xd[z]>x) r = z; else l = z; } /* now, xd[0..l] <= x < x[r..n-1] */ if ((x-xd[l])>(xd[r]-x)) z = r; else z = l; } /* closest point to x is xd[z] */ if (nn(sp)<0) /* user bandwidth */ h = sp->vb(des->xev); else { if (k>0) /* set h to nearest neighbor bandwidth */ { l = r = z; if (l==0) r = k-1; if (r==n-1) l = n-k; while (r-lx) z--; /* so xd[z]<=x */ /* look left */ for (i=z; i>=0; i--) if (inlim(lfd,i)) { des->di[i] = (x-xd[i])/sc; des->w[m] = weight(lfd, sp, &xd[i], &x, h, 1, des->di[i]); if (des->w[m]>0) { des->ind[m] = i; m++; } else i = 0; } /* look right */ for (i=z+1; idi[i] = (xd[i]-x)/sc; des->w[m] = weight(lfd, sp, &xd[i], &x, h, 1, des->di[i]); if (des->w[m]>0) { des->ind[m] = i; m++; } else i = n; } des->n = m; des->h = h; } void nbhd_zeon(lfdata *lfd, design *des) /*lfdata *lfd; design *des;*/ { int i, j, m, eq; m = 0; for (i=0; in; i++) { eq = 1; for (j=0; jd; j++) eq = eq && (des->xev[j] == datum(lfd,j,i)); if (eq) { des->w[m] = 1; des->ind[m] = i; m++; } } des->n = m; des->h = 1.0; } void nbhd(lfdata *lfd, design *des, int nn, int redo, smpar *sp) /*lfdata *lfd; design *des; int redo, nn; smpar *sp;*/ { int d, i, j, m, n; double h, u[MXDIM]; if (lf_debug>1) printf("nbhd: nn %d fixh %8.5f\n",nn,fixh(sp)); d = lfd->d; n = lfd->n; if (ker(sp)==WPARM) { for (i=0; iw[i] = 1.0; des->ind[i] = i; } des->n = n; return; } if (kt(sp)==KZEON) { nbhd_zeon(lfd,des); return; } if (kt(sp)==KCE) { des->h = 0.0; return; } /* ordered 1-dim; use fast searches */ if ((nn<=n) & (lfd->ord) & (ker(sp)!=WMINM) & (lfd->sty[0]!=STANGL)) { nbhd1(lfd,sp,des,nn); return; } if (!redo) { for (i=0; ixev[j]; des->di[i] = rho(u,lfd->sca,d,kt(sp),lfd->sty); des->ind[i] = i; } } else for (i=0; iind[i] = i; if (ker(sp)==WMINM) { des->h = minmax(lfd,des,sp); return; } if (nn<0) h = sp->vb(des->xev); else h = compbandwid(des->di,des->ind,des->xev,n,lfd->d,nn,fixh(sp)); m = 0; for (i=0; iw[m] = weight(lfd, sp, u, des->xev, h, 1, des->di[i]); if (des->w[m]>0) { des->ind[m] = i; m++; } } des->n = m; des->h = h; } locfit/src/m_isphr.c0000754000176200001440000001303714745736117014153 0ustar liggesusers#include "mutil.h" #include static double *res, *resb, *orig, rmin, rmax; static int ct0; void sphM(double *M, double r, double *u) /*double *M, r, *u;*/ { double h, u1[3], u2[3]; /* set the orthogonal unit vectors. */ h = sqrt(u[0]*u[0]+u[1]*u[1]); if (h<=0) { u1[0] = u2[1] = 1.0; u1[1] = u1[2] = u2[0] = u2[2] = 0.0; } else { u1[0] = u[1]/h; u1[1] = -u[0]/h; u1[2] = 0.0; u2[0] = u[2]*u[0]/h; u2[1] = u[2]*u[1]/h; u2[2] = -h; } /* parameterize the sphere as r(cos(t)cos(v)u + sin(t)u1 + cos(t)sin(v)u2). * first layer of M is (dx/dt, dx/dv, dx/dr) at t=v=0. */ M[0] = r*u1[0]; M[1] = r*u1[1]; M[2] = r*u1[2]; M[3] = r*u2[0]; M[4] = r*u2[1]; M[5] = r*u2[2]; M[6] = u[0]; M[7] = u[1]; M[8] = u[2]; /* next layers are second derivative matrix of components of x(r,t,v). * d^2x/dt^2 = d^2x/dv^2 = -ru; d^2x/dtdv = 0; * d^2x/drdt = u1; d^2x/drdv = u2; d^2x/dr^2 = 0. */ M[9] = M[13] = -r*u[0]; M[11]= M[15] = u1[0]; M[14]= M[16] = u2[0]; M[10]= M[12] = M[17] = 0.0; M[18]= M[22] = -r*u[1]; M[20]= M[24] = u1[1]; M[23]= M[25] = u2[1]; M[19]= M[21] = M[26] = 0.0; M[27]= M[31] = -r*u[1]; M[29]= M[33] = u1[1]; M[32]= M[34] = u2[1]; M[28]= M[30] = M[35] = 0.0; } double ip3(double *a, double *b) /*double *a, *b;*/ { return(a[0]*b[0] + a[1]*b[1] + a[2]*b[2]); } void rn3(double *a) /*double *a;*/ { double s; s = sqrt(ip3(a,a)); a[0] /= s; a[1] /= s; a[2] /= s; } double sptarea(double *a, double *b, double *c) /*double *a, *b, *c;*/ { double ea, eb, ec, yab, yac, ybc, sab, sac, sbc; double ab[3], ac[3], bc[3], x1[3], x2[3]; ab[0] = a[0]-b[0]; ab[1] = a[1]-b[1]; ab[2] = a[2]-b[2]; ac[0] = a[0]-c[0]; ac[1] = a[1]-c[1]; ac[2] = a[2]-c[2]; bc[0] = b[0]-c[0]; bc[1] = b[1]-c[1]; bc[2] = b[2]-c[2]; yab = ip3(ab,a); yac = ip3(ac,a); ybc = ip3(bc,b); x1[0] = ab[0] - yab*a[0]; x2[0] = ac[0] - yac*a[0]; x1[1] = ab[1] - yab*a[1]; x2[1] = ac[1] - yac*a[1]; x1[2] = ab[2] - yab*a[2]; x2[2] = ac[2] - yac*a[2]; sab = ip3(x1,x1); sac = ip3(x2,x2); ea = acos(ip3(x1,x2)/sqrt(sab*sac)); x1[0] = ab[0] + yab*b[0]; x2[0] = bc[0] - ybc*b[0]; x1[1] = ab[1] + yab*b[1]; x2[1] = bc[1] - ybc*b[1]; x1[2] = ab[2] + yab*b[2]; x2[2] = bc[2] - ybc*b[2]; sbc = ip3(x2,x2); eb = acos(ip3(x1,x2)/sqrt(sab*sbc)); x1[0] = ac[0] + yac*c[0]; x2[0] = bc[0] + ybc*c[0]; x1[1] = ac[1] + yac*c[1]; x2[1] = bc[1] + ybc*c[1]; x1[2] = ac[2] + yac*c[2]; x2[2] = bc[2] + ybc*c[2]; ec = acos(ip3(x1,x2)/sqrt(sac*sbc)); /* * Euler's formula is a+b+c-PI, except I've cheated... * a=ea, c=ec, b=PI-eb, which is more stable. */ return(ea+ec-eb); } void li(double *x, int (*f)(), int (*fb)(), int mint, double ar) /*double *x, ar; int (*f)(), (*fb)(), mint;*/ { int i, j, nr=0, nrb, ct1, w; double u[3], r, M[36]; double sres[MXRESULT], tres[MXRESULT]; /* divide mint by 2, and force to even (Simpson's rule...) * to make comparable with rectangular interpretation of mint */ mint <<= 1; if (mint&1) mint++; ct1 = 0; for (i= (rmin==0) ? 1 : 0; i<=mint; i++) { r = rmin + (rmax-rmin)*i/mint; w = 2+2*(i&1)-(i==0)-(i==mint); u[0] = orig[0]+x[0]*r; u[1] = orig[1]+x[1]*r; u[2] = orig[2]+x[2]*r; nr = f(u,3,tres,NULL); if (ct1==0) setzero(sres,nr); for (j=0; j1) { ab[0] = a[0]+b[0]; ab[1] = a[1]+b[1]; ab[2] = a[2]+b[2]; rn3(ab); ac[0] = a[0]+c[0]; ac[1] = a[1]+c[1]; ac[2] = a[2]+c[2]; rn3(ac); bc[0] = b[0]+c[0]; bc[1] = b[1]+c[1]; bc[2] = b[2]+c[2]; rn3(bc); lev >>= 1; if (cent==0) { sphint(f,fb,a,ab,ac,lev,mint,1); sphint(f,fb,ab,bc,ac,lev,mint,0); } else { sphint(f,fb,a,ab,ac,lev,mint,1); sphint(f,fb,b,ab,bc,lev,mint,1); sphint(f,fb,c,ac,bc,lev,mint,1); sphint(f,fb,ab,bc,ac,lev,mint,1); } return; } x[0] = a[0]+b[0]+c[0]; x[1] = a[1]+b[1]+c[1]; x[2] = a[2]+b[2]+c[2]; rn3(x); ar = sptarea(a,b,c); for (i=0; i<8; i++) { if (i>0) { x[0] = -x[0]; if (i%2 == 0) x[1] = -x[1]; if (i==4) x[2] = -x[2]; } switch(cent) { case 2: /* the reflection and its 120', 240' rotations */ ab[0] = x[0]; ab[1] = x[2]; ab[2] = x[1]; li(ab,f,fb,mint,ar); ab[0] = x[2]; ab[1] = x[1]; ab[2] = x[0]; li(ab,f,fb,mint,ar); ab[0] = x[1]; ab[1] = x[0]; ab[2] = x[2]; li(ab,f,fb,mint,ar); case 1: /* and the 120' and 240' rotations */ ab[0] = x[1]; ab[1] = x[2]; ab[2] = x[0]; li(ab,f,fb,mint,ar); ac[0] = x[2]; ac[1] = x[0]; ac[2] = x[1]; li(ac,f,fb,mint,ar); case 0: /* and the triangle itself. */ li( x,f,fb,mint,ar); } } } void integ_sphere(int (*f)(), int (*fb)(), double *fl, double *Res, double *Resb, int *mg) /*double *fl, *Res, *Resb; int (*f)(), (*fb)(), *mg;*/ { double a[3], b[3], c[3]; a[0] = 1; a[1] = a[2] = 0; b[1] = 1; b[0] = b[2] = 0; c[2] = 1; c[0] = c[1] = 0; res = Res; resb=Resb; orig = &fl[2]; rmin = fl[0]; rmax = fl[1]; ct0 = 0; sphint(f,fb,a,b,c,mg[1],mg[0],0); } locfit/src/preplot.c0000754000176200001440000000623014745736561014177 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include "local.h" /* preplot(): interpolates the fit to a new set of points. lf -- the fit structure. x -- the points to predict at. f -- vector to return the predictions. se -- vector to return std errors (NULL if not req'd) band-- char for conf band type. ('n'=none, 'g'=global etc.) n -- no of predictions (or vector of margin lengths for grid) where -- where to predict: 1 = points in the array x. 2 = grid defined by margins in x. 3 = data points from lf (ignore x). 4 = fit points from lf (ignore x). what -- what to predict. (PCOEF etc; see lfcons.h file) */ static char cb; double *sef, *fit, sigmahat; void predptall(lfit *lf, double *x, int what, int ev, int i) /* lfit *lf; double *x; int what, ev, i; */ { double lik, rdf; fit[i] = dointpoint(lf,x,what,ev,i); if (cb=='n') return; sef[i] = dointpoint(lf,x,PNLX,ev,i); if (cb=='g') { sef[i] *= sigmahat; return; } if (cb=='l') { lik = dointpoint(lf,x,PLIK,ev,i); rdf = dointpoint(lf,x,PRDF,ev,i); sef[i] *= sqrt(-2*lik/rdf); return; } if (cb=='p') { sef[i] = sigmahat*sqrt(1+sef[i]*sef[i]); return; } } void prepvector(lfit *lf, double **x, int n, int what) /* interpolate a vector */ /* lfit *lf; double **x; int n, what; */ { int i, j; double xx[MXDIM]; for (i=0; ifp.d; j++) xx[j] = x[j][i]; predptall(lf,xx,what,ev(&lf->evs),i); if (lf_error) return; } } void prepfitp(lfit *lf, int what) /* lfit *lf; int what; */ { int i; for (i=0; ifp.nv; i++) { predptall(lf,evpt(&lf->fp,i),what,EFITP,i); if (lf_error) return; } } void prepgrid(lfit *lf, double **x, Sint *mg, int n, int what) /* interpolate a grid given margins */ /* lfit *lf; double **x; Sint *mg; int n, what; */ /* interpolate a grid given margins */ { int i, ii, j, d; double xv[MXDIM]; d = lf->fp.d; for (i=0; ievs),i); if (lf_error) return; } } void preplot(lfit *lf, double **x, double *f, double *se, char band, Sint *mg, int where, int what) /* lfit *lf; double **x, *f, *se; Sint *mg; int where, what; char band; */ { int d, i, n=0; double *xx[MXDIM]; d = lf->fp.d; fit = f; sef = se; cb = band; if (cb!='n') sigmahat = sqrt(rv(&lf->fp)); switch(where) { case 1: /* vector */ n = mg[0]; prepvector(lf,x,n,what); break; case 2: /* grid */ n = 1; for (i=0; ilfd.n; if ((ev(&lf->evs)==EDATA) | (ev(&lf->evs)==ECROS)) prepfitp(lf,what); else { for (i=0; ilfd,i); prepvector(lf,xx,n,what); } break; case 4: /* fit points */ n = lf->fp.nv; prepfitp(lf,what); break; default: ERROR(("unknown where in preplot")); } if ((what==PT0)|(what==PVARI)) for (i=0; id; p = des->p; m = des->n; if (lf_debug>1) printf(" Correcting derivatives\n"); fitfun(lfd, sp, des->xev,des->xev,des->f1,NULL); jacob_solve(&des->xtwx,des->f1); setzero(dc,d); /* correction term is e1^T (XTWVX)^{-1} XTW' ldot. */ for (i=0; if1,&des->X[i*p],p); ii = des->ind[i]; stdlinks(link,lfd,sp,ii,des->th[i],robscale); for (j=0; jw[i]*weightd(datum(lfd,j,ii)-des->xev[j],lfd->sca[j], d,ker(sp),kt(sp),des->h,lfd->sty[j],des->di[ii]); dc[j] += s1*wd*link[ZDLL]; } } for (j=0; jn; i++) { ip = innerprod(a,d_xi(des,i),des->p); wt = prwt(mm_lfd,i); w0 = ip - gam*des->wd[i]; w1 = ip + gam*des->wd[i]; des->w[i] = 0.0; if (w0>0) { des->w[i] = w0; sw += wt*w0*w0; } if (w1<0) { des->w[i] = w1; sw += wt*w1*w1; } } return(sw/2-a[0]); } /* compute sum_{w!=0} AA^T; e1-sum wA */ int mmsums(double *coef, double *f, double *z, jacobian *J) /* int mmsums(coef,f,z,J) double *coef, *f, *z; jacobian *J; */ { int i, j, p, sing; double *A; mmsm_ct++; A = J->Z; *f = setmmwt(mm_des,coef,mm_gam); p = mm_des->p; setzero(A,p*p); setzero(z,p); z[0] = 1.0; for (i=0; in; i++) if (mm_des->w[i]!=0.0) { addouter(A,d_xi(mm_des,i),d_xi(mm_des,i),p,prwt(mm_lfd,i)); for (j=0; jw[i]*mm_des->X[i*p+j]; } J->st = JAC_RAW; jacob_dec(J,JAC_EIGD); sing = 0; for (i=0; iZ[i*p+i]xtwx.Z[i*p+i]xtwx.dg[sd]>0) for (i=0; ixtwx.Q[p*i+sd]*des->xtwx.dg[i]; else { for (i=0; ixtwx); c0 = c1 = 0.0; for (i=0; ixtwx.Z[i*p+j]*tmp[j]; } if (debug) printf("sdir: c0 %8.5f c1 %8.5f z %8.5f %8.5f tmp %8.5f %8.5f\n",c0,c1,z[0],z[1],tmp[0],tmp[1]); if (c0<0) for (i=0; isw0-CONVTOL) /* go back one step */ { f /= 2; for (i=0; ixtwx); if (st==NR_OK) return(0); coef[0] *= 2; if (coef[0]>1e8) return(1); } } void mmax(double *coef, double *old_coef, double *f1, double *delta, jacobian *J, int p, int maxit, double tol, int *err) /* void mmax(coef, old_coef, f1, delta, J, p, maxit, tol, err) double *coef, *old_coef, *f1, *delta, tol; int p, maxit, *err; jacobian *J; */ { double f, old_f, lambda; int i, j, fr, sing=0; *err = NR_OK; J->p = p; J->st = JAC_RAW; fr = mmsums(coef,&f,f1,J); for (j=0; jst = JAC_RAW; if (j==0) printf("init singular\n"); f = updatesd(mm_des,delta,p,coef,old_coef,f,mm_gam); fr = mmsums(coef,&f,f1,J); } else { jacob_solve(J,f1); memmove(delta,f1,p*sizeof(double)); /* printf("delta %8.5f %8.5f\n",f1[0],f1[1]); */ lambda = 1.0; do { for (i=0; ist = JAC_RAW; fr = mmsums(coef,&f,f1,J); lambda = lambda/2.0; /* if (fr==NR_SINGULAR) printf("singular\n"); */ } while (((lambda>0.000000001) & (f > old_f+0.001)) /* | (fr==NR_SINGULAR) */ ); if (f>old_f+0.001) { printf("lambda prob\n"); *err = NR_NDIV; return; } } if (f==0.0) { if (sing) printf("final singular - conv\n"); return; } if (debug) { for (i=0; i0) & (fabs(f-old_f)p; /* starting values for nr iteration */ coef = mm_des->cf; for (i=0; if1, p, coef)) { WARN(("findab: initial value divergence")); return(0.0); } else mmax(coef, mm_des->oc, mm_des->res, mm_des->f1, &mm_des->xtwx, p, lf_maxit, CONVTOL, &nr_stat); if (nr_stat != NR_OK) return(0.0); sl = 0.0; for (i=0; in; i++) sl += fabs(mm_des->w[i])*mm_des->wd[i]; return(sl-gam); } double weightmm(double *coef, double di, double *ff, double gam) /* double weightmm(coef,di,ff,gam) double *coef, di, *ff, gam; */ { double y1, y2, ip; ip = innerprod(ff,coef,mm_des->p); y1 = ip-gam*di; if (y1>0) return(y1/ip); y2 = ip+gam*di; if (y2<0) return(y2/ip); return(0.0); } double minmax(lfdata *lfd, design *des, smpar *sp) /* double minmax(lfd,des,sp) lfdata *lfd; design *des; smpar *sp; */ { double h, u[MXDIM], gam; int i, j, m, d1, p1, err_flag; mm_lfd = lfd; mm_des = des; mmsm_ct = 0; d1 = deg(sp)+1; p1 = factorial(d1); for (i=0; in; i++) { for (j=0; jd; j++) u[j] = datum(lfd,j,i); des->wd[i] = sp->nn/p1*ipower(des->di[i],d1); des->ind[i] = i; fitfun(lfd, sp, u,des->xev,d_xi(des,i),NULL); } /* designmatrix(lfd,sp,des); */ /* find gamma (i.e. solve eqn 13.17 from book), using the secant method. * As a side effect, this finds the other minimax coefficients. * Note that 13.17 is rewritten as * g2 = sum |l_i(x)| (||xi-x||^(p+1) M/(s*(p+1)!)) * where g2 = gamma * s * (p+1)! / M. The gam variable below is g2. * The smoothing parameter is sp->nn == M/s. */ gam = solve_secant(findab, 0.0, 0.0,1.0, 0.0000001, BDF_EXPRIGHT, &err_flag); /* * Set the smoothing weights, in preparation for the actual fit. */ h = 0.0; m = 0; for (i=0; in; i++) { des->w[m] = weightmm(des->cf, des->wd[i],d_xi(des,i),gam); if (des->w[m]>0) { if (des->di[i]>h) h = des->di[i]; des->ind[m] = i; m++; } } des->n = m; return(h); } locfit/src/lf_adap.c0000754000176200001440000001334214745735031014071 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ /* Functions implementing the adaptive bandwidth selection. Will make the final call to nbhd() to set smoothing weights for selected bandwidth, But will **not** make the final call to locfit(). */ #include "local.h" static double hmin; double adcri(double lk, double t0, double t2, double pen) /* adcri(lk,t0,t2,pen) double lk, t0, t2, pen; */ { double y; /* return(-2*lk/(t0*exp(pen*log(1-t2/t0)))); */ /* return((-2*lk+pen*t2)/t0); */ y = (MAX(-2*lk,t0-t2)+pen*t2)/t0; return(y); } double mmse(lfdata *lfd, smpar *sp, deriv *dv, design *des) /* mmse(lfd,sp,dv,des) lfdata *lfd; smpar *sp; deriv *dv; design *des; */ { int i, ii, j, p1; double sv, sb, *l, dp; l = des->wd; wdiag(lfd, sp, des,l,dv,0,1,0); sv = sb = 0; // p = npar(sp); for (i=0; in; i++) { sv += l[i]*l[i]; ii = des->ind[i]; dp = des->di[ii]; for (j=0; jdi[ii]; sb += fabs(l[i])*dp; } p1 = factorial(deg(sp)+1); return(sv+sb*sb*pen(sp)*pen(sp)/(p1*p1)); } static double mcp, clo, cup; /* Initial bandwidth will be (by default) k-nearest neighbors for k small, just large enough to get defined estimate (unless user provided nonzero nn or fix-h components) */ int ainitband(lfdata *lfd, smpar *sp, deriv *dv, design *des) /* ainitband(lfd,sp,dv,des) lfdata *lfd; smpar *sp; deriv *dv; design *des; */ { int lf_status=0, p, z, cri, noit, redo; double ho, t[6]; if (lf_debug >= 2) printf("ainitband:\n"); p = des->p; cri = acri(sp); noit = (cri!=AOK); z = (int)(lfd->n*nn(sp)); if ((noit) && (zn) z = des->n; if (des->h>ho) lf_status = locfit(lfd,des,sp,noit,0,0); z++; redo = 1; } while ((z<=lfd->n) && ((des->h==0)||(lf_status!=LF_OK))); hmin = des->h; switch(cri) { case ACP: local_df(lfd,sp,des,t); mcp = adcri(des->llk,t[0],t[2],pen(sp)); return(lf_status); case AKAT: local_df(lfd,sp,des,t); clo = des->cf[0]-pen(sp)*t[5]; cup = des->cf[0]+pen(sp)*t[5]; return(lf_status); case AMDI: mcp = mmse(lfd,sp,dv,des); return(lf_status); case AOK: return(lf_status); } ERROR(("aband1: unknown criterion")); return(LF_ERR); } /* aband2 increases the initial bandwidth until lack of fit results, or the fit is close to a global fit. Increase h by 1+0.3/d at each iteration. */ double aband2(lfdata *lfd, smpar *sp, deriv *dv, design *des, double h0) /* aband2(lfd,sp,dv,des,h0) lfdata *lfd; smpar *sp; deriv *dv; design *des; double h0; */ { double t[6], h1, nu1, cp, ncp, tlo, tup; int d, inc, n, p, done; if (lf_debug >= 2) printf("aband2:\n"); d = lfd->d; n = lfd->n; p = npar(sp); h1 = des->h = h0; done = 0; nu1 = 0.0; inc = 0; ncp = 0.0; while ((!done) & (nu1<(n-p)*0.95)) { fixh(sp) = (1+0.3/d)*des->h; nbhd(lfd,des,0,1,sp); if (locfit(lfd,des,sp,1,0,0) > 0) WARN(("aband2: failed fit")); local_df(lfd,sp,des,t); nu1 = t[0]-t[2]; /* tr(A) */ switch(acri(sp)) { case AKAT: tlo = des->cf[0]-pen(sp)*t[5]; tup = des->cf[0]+pen(sp)*t[5]; /* printf("h %8.5f tlo %8.5f tup %8.5f\n",des->h,tlo,tup); */ done = ((tlo>cup) | (tuph; } break; case ACP: cp = adcri(des->llk,t[0],t[2],pen(sp)); /* printf("h %8.5f lk %8.5f t0 %8.5f t2 %8.5f cp %8.5f\n",des->h,des->llk,t[0],t[2],cp); */ if (cph; } if (cp>=ncp) inc++; else inc = 0; ncp = cp; done = (inc>=10) | ((inc>=3) & ((t[0]-t[2])>=10) & (cp>1.5*mcp)); break; case AMDI: cp = mmse(lfd,sp,dv,des); if (cph; } if (cp>ncp) inc++; else inc = 0; ncp = cp; done = (inc>=3); break; } } return(h1); } /* aband3 does a finer search around best h so far. Try h*(1-0.2/d), h/(1-0.1/d), h*(1+0.1/d), h*(1+0.2/d) */ double aband3(lfdata *lfd, smpar *sp, deriv *dv, design *des, double h0) /* aband3(lfd,sp,dv,des,h0) lfdata *lfd; smpar *sp; deriv *dv; design *des; double h0; */ { double t[6], h1, cp, tlo, tup; int i, i0, d; if (lf_debug >= 2) printf("aband3:\n"); d = lfd->d; // n = lfd->n; h1 = h0; i0 = (acri(sp)==AKAT) ? 1 : -2; if (h0==hmin) i0 = 1; for (i=i0; i<=2; i++) { if (i==0) i++; fixh(sp) = h0*(1+0.1*i/d); nbhd(lfd,des,0,1,sp); if (locfit(lfd,des,sp,1,0,0) > 0) WARN(("aband3: failed fit")); local_df(lfd,sp,des,t); switch (acri(sp)) { case AKAT: tlo = des->cf[0]-pen(sp)*t[5]; tup = des->cf[0]+pen(sp)*t[5]; if ((tlo>cup) | (tuph; clo = MAX(clo,tlo); cup = MIN(cup,tup); } break; case ACP: cp = adcri(des->llk,t[0],t[2],pen(sp)); if (cph; } else { if (i>0) i = 2; } break; case AMDI: cp = mmse(lfd,sp,dv,des); if (cph; } else { if (i>0) i = 2; } } } return(h1); } int alocfit(lfdata *lfd, smpar *sp, deriv *dv, design *des) /* alocfit(lfd,sp,dv,des) lfdata *lfd; smpar *sp; deriv *dv; design *des; */ { int lf_status; double h0; lf_status = ainitband(lfd,sp,dv,des); if (lf_error) return(lf_status); if (acri(sp) == AOK) return(lf_status); h0 = fixh(sp); fixh(sp) = aband2(lfd,sp,dv,des,des->h); fixh(sp) = aband3(lfd,sp,dv,des,fixh(sp)); nbhd(lfd,des,0,1,sp); lf_status = locfit(lfd,des,sp,0,0,0); fixh(sp) = h0; return(lf_status); } locfit/src/lfwin.h0000754000176200001440000000366514745724400013634 0ustar liggesusers#define LFM_EXIT 0 #define LFM_COPY 1 #define LFM_PASTE 2 #define LFM_RUN 3 #define LFM_READA 10 #define LFM_SAVED 11 #define LFM_READD 12 #define LFM_SUMD 13 #define LFM_PLOTD 18 #define LFM_LOCF 20 #define LFM_READF 22 #define LFM_SUMF 23 #define LFM_PRFIT 24 #define LFM_ALPH 70 #define LFM_FIXH 71 #define LFM_APEN 72 #define LFM_DEG0 75 #define LFM_DEG1 76 #define LFM_DEG2 77 #define LFM_DEG3 78 #define LFM_ABOUT 81 #define LFM_INDEX 82 #define LFM_READM 83 #define LFM_WWW 84 #define LFP_ROT 10 #define LFP_STY 11 #define LFP_PS 42 #define LFP_COL 13 #define LFP_XLAB 20 #define LFP_YLAB 21 #define LFP_ZLAB 22 #define LFP_MAIN 23 #define AB_WWW 10 #define CM_LINE 1 #define CM_OK 99 #define RL_ALP 0 #define RL_ALPV 1 #define RL_H 2 #define RL_HV 3 #define RL_PEN 4 #define RL_PENV 5 #define RL_DEG 10 #define RL_FORM 20 #define RL_FAMY 21 #define RL_QUAS 22 #define RL_ROBU 23 #define RL_FIT 98 #define RL_OK 99 #define RP_VS 1 #define RP_HS 2 #define RP_AUT 3 #define RP_DRAW 98 #define RP_OK 99 #define PD_X 1 #define PD_Y 2 #define PD_Z 3 #define PD_DRAW 10 #define PD_ADD 11 #define PD_WIN 12 #define PS_FIL 1 #define PS_DR 8 #define PS_CA 9 #define PS_H 10 #define PS_W 11 #define SC_COL 1 #define SC_SCO 2 #define SC_DR 8 #define SC_OK 9 #define VN_VN 1 #define VN_SA 2 #define VN_RF 98 #define VN_CA 99 #define BP_ALP 1 #define BP_ALV 2 #define BP_AUT 3 #define BP_FIT 4 #define BP_EX 99 #define GR_CM 10 #define GR_ST 11 #define LB_LAB 10 #define LB_DRAW 11 #define LD_QUIT 99 /* about.c */ extern void AboutDlg(); /* devwin.c */ extern void getwinsize(), GetFontInfo(); /* dlgraph.c */ extern void GStyleDlg(), LabelDlg(), PostDlg(), RotateDlg(), SetColDlg(); /* winfile.c */ extern void ReadFileDlg(), ReadDataDlg(), SaveDataDlg(), RunDlg(); extern void ReadFitDlg(); /* windlg.c */ extern void BandDlg(), LocfitDlg(), PlotDataDlg(), wdispatch(); extern int LFDefDlgProc(); locfit/src/ev_atree.c0000754000176200001440000001222714745734110014273 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * This file contains functions for constructing and * interpolating the adaptive tree structure. This is * the default evaluation structure used by Locfit. */ #include "local.h" /* Guess the number of fitting points. Needs improving! */ void atree_guessnv(evstruc *evs, int *nvm, int *ncm, int *vc, int d, double alp) /* evstruc *evs; int *nvm, *ncm, *vc, d; double alp; */ { double a0, cu, ifl; int i, nv, nc; *ncm = 1<<30; *nvm = 1<<30; *vc = 1 << d; if (alp>0) { a0 = (alp > 1) ? 1 : 1/alp; if (cut(evs)<0.01) { WARN(("guessnv: cut too small.")); cut(evs) = 0.01; } cu = 1; for (i=0; ifp.d; vc = 1<fp.h[ce[i]]; if ((h>0) && ((hmin==0)|(hlfd.sca[i]; if ((lf->lfd.sty[i]==STCPAR) || (hmin==0)) score[i] = 2*(ur[i]-ll[i])/(lf->evs.fl[i+d]-lf->evs.fl[i]); else score[i] = le[i]/hmin; if (score[i]>score[is]) is = i; } if (cut(&lf->evs)fp.d; vc = 1<lfd.sty[i]!=STCPAR) && (le[ns] < (cut(&lf->evs)*MIN(lf->fp.h[i0],lf->fp.h[i1]))); nce[i] = newsplit(des,lf,i0,i1,pv); if (lf_error) return; } } z = ur[ns]; ur[ns] = (z+ll[ns])/2; atree_grow(des,lf,nce,ct,term,ll,ur); if (lf_error) return; ur[ns] = z; for (i=0; i1) printf(" In atree_start\n"); d = lf->fp.d; atree_guessnv(&lf->evs,&nvm,&ncm,&vc,d,nn(&lf->sp)); if (lf_debug>2) printf(" atree_start: nvm %d ncm %d\n",nvm,ncm); trchck(lf,nvm,ncm,vc); /* Set the lower left, upper right limits. */ for (j=0; jevs.fl[j]; ur[j] = lf->evs.fl[j+d]; } /* Set the initial cell; fit at the vertices. */ for (i=0; ifp,i,k) = (j%2) ? ur[k] : ll[k]; j >>= 1; } lf->evs.ce[i] = i; des->vfun(des,lf,i); if (lf_error) return; lf->evs.s[i] = 0; } lf->fp.nv = vc; /* build the tree */ atree_grow(des,lf,lf->evs.ce,NULL,NULL,ll,ur); lf->evs.nce = 1; } double atree_int(lfit *lf, double *x, int what) /* lfit *lf; double *x; int what; */ { double vv[64][64], *ll, *ur, h, xx[MXDIM]; int lo, tk, ns, nv, nc=0, d, i, vc; Sint ce[64]; fitpt *fp; evstruc *evs; fp = &lf->fp; evs= &lf->evs; d = fp->d; vc = 1<ce[i]; } ns = 0; while(ns!=-1) { ll = evpt(fp,ce[0]); ur = evpt(fp,ce[vc-1]); ns = atree_split(lf,ce,xx,ll,ur); if (ns!=-1) { tk = 1<s[nv]) exvvalpv(vv[i+tk],vv[i],vv[i+tk],d,ns,h,nc); else exvval(fp,vv[i+tk],nv,d,what,1); } else { ce[i] = nv; if (evs->s[nv]) exvvalpv(vv[i],vv[i],vv[i+tk],d,ns,h,nc); else exvval(fp,vv[i],nv,d,what,1); } } } } ll = evpt(fp,ce[0]); ur = evpt(fp,ce[vc-1]); return(rectcell_interp(x,vv,ll,ur,d,nc)); } locfit/src/density.c0000754000176200001440000003137214745733711014170 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include "local.h" extern int lf_status; static double u[MXDIM], ilim[2*MXDIM], *ff, hh, *cff; static lfdata *den_lfd; static design *den_des; static smpar *den_sp; int fact[] = {1, 1, 2, 6, 24, 120, 720, 5040, 40320, 362880, 3628800}; int de_mint = 20; int de_itype = IDEFA; int de_renorm= 0; int multint(double *t, double *resp1, double *resp2, double *cf, double h); int prodint(double *t, double *resp, double *resp2, double *coef, double h); int gausint(double *t, double *resp, double *C, double *cf, double h, double *sca); int mlinint(double *t, double *resp1, double *resp2, double *cf, double h); void prresp(double *coef, double *resp, int p) { int i, j; printf("Coefficients:\n"); for (i=0; ip; wt = weight(den_lfd, den_sp, u, NULL, hh, 0, 0.0); if (wt==0) { setzero(resp,p*p); return(p*p); } fitfun(den_lfd, den_sp, u,NULL,ff,NULL); if (link(den_sp)==LLOG) wt *= lf_exp(innerprod(ff,cff,p)); for (i=0; isca)); d = den_lfd->d; for (i=0; id; p = den_des->p; sca = den_lfd->sca; hd = 1; for (i=0; i1) { jj[1] = 2; w0 = wint(d,jj,2,ker(den_sp)) * hd*h*h*h*h; } jj[0] = 4; w1 = wint(d,jj,1,ker(den_sp)) * hd*h*h*h*h/4; z = d+1; for (i=0; i1.0e-8)) { j++; jj[0] = 2*j; w0 = wint(d,jj,1,ker(den_sp)); if (d==1) g[3] += wt * w0; else { jj[0] = 2; jj[1] = 2*j-2; w1 = wint(d,jj,2,ker(den_sp)); g[3] += wt*w1; g[2] += wu*(w0-w1); } wt /= (2*j-1.0); g[1] += wt*w0; wt *= nb/(2*j); g[0] += wt*w0; wu /= (2*j-1.0)*(2*j); if (j>1) wu *= nb; } if (j==jmax) WARN(("mlinint: series not converged")); } g[0] *= hd; g[1] *= hd; g[2] *= hd; g[3] *= hd; resp1[0] = g[0]; for (i=1; i<=d; i++) { resp1[i] = resp1[(d+1)*i] = cf[i]*SQR(h*sca[i-1])*g[1]; for (j=1; j<=d; j++) { resp1[(d+1)*i+j] = (i==j) ? g[3]*SQR(h*sca[i-1]) : 0; resp1[(d+1)*i+j] += g[2]*SQR(h*h*sca[i-1]*sca[j-1])*cf[i]*cf[j]; } } return(LF_OK); } ERROR(("mlinint: deg=0,1 only")); return(LF_ERR); } void prodintresp(double *resp, double prod_wk[MXDIM][2*MXDEG+1], int dim, int deg, int p) { double prod; int i, j, k, j1, k1; prod = 1.0; for (i=0; id; p = den_des->p; for (i=0; isca[i]; for (j=0; j=2 */ } /* transfer to the resp array */ prodintresp(resp,prod_wk,dim,deg(den_sp),p); /* Symmetrize. */ for (k=0; kd; p = den_des->p; m1 = d+1; nb = 0; P = &C[d*d]; resp[0] = 1; for (i=0; ip; if ((link(den_sp)==LIDENT) && (coef[0] != 0.0)) return(NR_BREAK); lf_status = (den_des->itype)(den_des->xev,A,den_des->xtwx.Q,coef,den_des->h); if (lf_error) lf_status = LF_ERR; if (lf_status==LF_BADP) { *lk0 = -1.0e300; return(NR_REDUCE); } if (lf_status!=LF_OK) return(NR_BREAK); if (lf_debug>2) prresp(coef,A,p); den_des->xtwx.p = p; rstat = NR_OK; switch(link(den_sp)) { case LLOG: r = den_des->ss[0]/A[0]; coef[0] += log(r); multmatscal(A,r,p*p); A[0] = den_des->ss[0]; lk = -A[0]; if (fabs(coef[0]) > 700) { lf_status = LF_OOB; rstat = NR_REDUCE; } for (i=0; iss[i]; f1[i] = den_des->ss[i]-A[i]; } break; case LIDENT: lk = 0.0; for (i=0; iss[i]; for (j=0; jres[i] -= A[i*p+j]*coef[j]; } break; } *lk0 = den_des->llk = lk; return(rstat); } int inre(double *x, double *bound, int d) { int i, z; z = 1; for (i=0; i=bound[i]) & (x[i]<=bound[i+d]); return(z); } int setintlimits(lfdata *lfd, double *x, double h, int *ang, int *lset) { int d, i; d = lfd->d; *ang = *lset = 0; for (i=0; isty[i]==STANGL) { ilim[i+d] = ((h<2) ? 2*asin(h/2) : PI)*lfd->sca[i]; ilim[i] = -ilim[i+d]; *ang = 1; } else { ilim[i+d] = h*lfd->sca[i]; ilim[i] = -ilim[i+d]; if (lfd->sty[i]==STLEFT) { ilim[i+d] = 0; *lset = 1; } if (lfd->sty[i]==STRIGH) { ilim[i] = 0; *lset = 1; } if (lfd->xl[i]xl[i+d]) /* user limits for this variable */ { if (lfd->xl[i]-x[i]> ilim[i]) { ilim[i] = lfd->xl[i]-x[i]; *lset=1; } if (lfd->xl[i+d]-x[i]< ilim[i+d]) { ilim[i+d] = lfd->xl[i+d]-x[i]; *lset=1; } } } if (ilim[i]==ilim[i+d]) return(LF_DEMP); /* empty integration */ } return(LF_OK); } int selectintmeth(int itype, int lset, int ang) { if (itype==IDEFA) /* select the default method */ { if (fam(den_sp)==THAZ) { if (ang) return(IDEFA); return( IHAZD ); } if (ubas(den_sp)) return(IMULT); if (ang) return(IMULT); if (iscompact(ker(den_sp))) { if (kt(den_sp)==KPROD) return(IPROD); if (lset) return( (den_lfd->d==1) ? IPROD : IMULT ); if (deg(den_sp)<=1) return(IMLIN); if (den_lfd->d==1) return(IPROD); return(IMULT); } if (ker(den_sp)==WGAUS) { if (lset) WARN(("Integration for Gaussian weights ignores limits")); if ((den_lfd->d==1)|(kt(den_sp)==KPROD)) return(IPROD); if (deg(den_sp)<=1) return(IMLIN); if (deg(den_sp)==2) return(IMULT); } return(IDEFA); } /* user provided an integration method, check it is valid */ if (fam(den_sp)==THAZ) { if (ang) return(INVLD); if (!iscompact(ker(den_sp))) return(INVLD); return( ((kt(den_sp)==KPROD) | (kt(den_sp)==KSPH)) ? IHAZD : INVLD ); } if ((ang) && (itype != IMULT)) return(INVLD); switch(itype) { case IMULT: if (ker(den_sp)==WGAUS) return(deg(den_sp)==2); return( iscompact(ker(den_sp)) ? IMULT : INVLD ); case IPROD: return( ((den_lfd->d==1) | (kt(den_sp)==KPROD)) ? IPROD : INVLD ); case IMLIN: return( ((kt(den_sp)==KSPH) && (!lset) && (deg(den_sp)<=1)) ? IMLIN : INVLD ); } return(INVLD); } int densinit(lfdata *lfd, design *des, smpar *sp, double *cf) { int p, i, ii, j, nnz, rnz, ang, lset, status; double w; den_lfd = lfd; den_des = des; den_sp = sp; p = des->p; ff = des->xtwx.wk; cf[0] = NOSLN; for (i=1; ixev,lfd->xl,lfd->d)) return(LF_XOOR); status = setintlimits(lfd,des->xev,des->h,&ang,&lset); if (status != LF_OK) return(status); switch(selectintmeth(de_itype,lset,ang)) { case IMULT: des->itype = multint; break; case IPROD: des->itype = prodint; break; case IMLIN: des->itype = mlinint; break; case IHAZD: des->itype = hazint; break; case INVLD: ERROR(("Invalid integration method %d",de_itype)); break; case IDEFA: ERROR(("No integration type available for this model")); break; default: ERROR(("densinit: unknown integral type")); } switch(deg(den_sp)) { case 0: rnz = 1; break; case 1: rnz = 1; break; case 2: rnz = lfd->d+1; break; case 3: rnz = lfd->d+2; break; default: ERROR(("densinit: invalid degree %d",deg(den_sp))); } if (lf_error) return(LF_ERR); setzero(des->ss,p); nnz = 0; for (i=0; in; i++) { ii = des->ind[i]; if (!cens(lfd,ii)) { w = des->w[i]*prwt(lfd,ii); for (j=0; jss[j] += d_xij(des,i,j)*w; if (des->w[i]>0.00001) nnz++; } } if (fam(den_sp)==THAZ) haz_init(lfd,des,sp,ilim); if (lf_debug>2) { printf(" LHS: "); for (i=0; iss[i]); printf("\n"); } switch(link(den_sp)) { case LIDENT: cf[0] = 0.0; return(LF_OK); case LLOG: if (nnzsp.fixh; if (xx[0]<=0) { ERROR(("regband: initialize h>0")); return; } for (i=0; i<=10; i++) { if (i>0) xx[i] = (1+GOLDEN)*xx[i-1]; yy[i] = f(xx[i],des,tr,meth); if ((i==0) || (yy[i]eps) { if (y[1]sp) = h; startlf(des,lf,procv,0); ressumm(lf,des); cp = -2*llk(&lf->fp) + pen*df0(&lf->fp); return(cp); } double loccp(double h, design *des, lfit *lf, int m) /* m=1: cp m=2: gcv */ /* loccp(h,des,lf,m) double h; design *des; lfit *lf; int m; */ { double cp; int dg, n; n = lf->lfd.n; nn(&lf->sp) = 0; fixh(&lf->sp) = h; dg = deg(&lf->sp); deg(&lf->sp) = deg0(&lf->sp); startlf(des,lf,procv,0); ressumm(lf,des); if (m==1) cp = -2*llk(&lf->fp)/sig2 - n + 2*df0(&lf->fp); else cp = -2*n*llk(&lf->fp)/((n-df0(&lf->fp))*(n-df0(&lf->fp))); printf("h %8.5f deg %2d rss %8.5f trl %8.5f cp: %8.5f\n",h,deg(&lf->sp),-2*llk(&lf->fp),df0(&lf->fp),cp); deg0(&lf->sp) = deg(&lf->sp); deg(&lf->sp) = dg; return(cp); } double cp(design *des, lfit *lf, int meth) /* cp(des,lf,meth) design *des; lfit *lf; int meth; */ { double hm, ym; goldensec(loccp,des,lf,0.001,&hm,&ym,meth); return(hm); } double gkk(design *des, lfit *lf) /* gkk(des,lf) design *des; lfit *lf; */ { double h, h5, nf, th; int i, j, n, dg0, dg1; ev(&lf->evs)= EDATA; nn(&lf->sp) = 0; n = lf->lfd.n; dg0 = deg0(&lf->sp); /* target degree */ dg1 = dg0+1+(dg0%2==0); /* pilot degree */ nf = exp(log(1.0*n)/10); /* bandwidth inflation factor */ h = lf->sp.fixh; /* start bandwidth */ for (i=0; i<=10; i++) { deg(&lf->sp) = dg1; lf->sp.fixh = h*nf; startlf(des,lf,procv,0); th = 0; for (j=10; jfp.coef[dg1*n+j]*lf->fp.coef[dg1*n+j]; th *= n/(n-20.0); h5 = sig2 * Wikk(ker(&lf->sp),dg0) / th; h = exp(log(h5)/(2*dg1+1)); /* printf("pilot %8.5f sel %8.5f\n",lf->sp.fixh,h); */ } return(h); } double rsw(design *des, lfit *lf) /* rsw(des,lf) design *des; lfit *lf; */ { int i, j, k, nmax, nvm, n, mk, evo, dg0, dg1; double rss[6], cp[6], th22, dx, d2, hh; nmax = 5; evo = ev(&lf->evs); ev(&lf->evs) = EGRID; mk = ker(&lf->sp); ker(&lf->sp) = WRECT; dg0 = deg0(&lf->sp); dg1 = 1 + dg0 + (dg0%2==0); deg(&lf->sp) = 4; for (k=nmax; k>0; k--) { lf->evs.mg[0] = k; lf->evs.fl[0] = 1.0/(2*k); lf->evs.fl[1] = 1-1.0/(2*k); nn(&lf->sp) = 0; fixh(&lf->sp) = 1.0/(2*k); startlf(des,lf,procv,0); nvm = lf->fp.nvm; rss[k] = 0; for (i=0; ifp.lik[i]; } n = lf->lfd.n; k = 1; for (i=1; i<=nmax; i++) { /* cp[i] = (n-5*nmax)*rss[i]/rss[nmax]-(n-10*i); */ cp[i] = rss[i]/sig2-(n-10*i); if (cp[i]evs.mg[0] = k; lf->evs.fl[0] = 1.0/(2*k); lf->evs.fl[1] = 1-1.0/(2*k); nn(&lf->sp) = 0; fixh(&lf->sp) = 1.0/(2*k); startlf(des,lf,procv,0); ker(&lf->sp) = mk; ev(&lf->evs) = evo; nvm = lf->fp.nvm; th22 = 0; for (i=10; ilfd,0,i)); if (j>=k) j = k-1; dx = datum(&lf->lfd,0,i)-evptx(&lf->fp,0,j); if (dg1==2) d2 = lf->fp.coef[2*nvm+j]+dx*lf->fp.coef[3*nvm+j]+dx*dx*lf->fp.coef[4*nvm+j]/2; else d2 = lf->fp.coef[4*nvm+j]; th22 += d2*d2; } hh = Wikk(mk,dg0)*sig2/th22*(n-20.0)/n; return(exp(log(hh)/(2*dg1+1))); } void rband(design *des, lfit *lf, double *hhat, int *meth, int nmeth) /* rband(des,lf,hhat,meth,nmeth) design *des; lfit *lf; double *hhat; int *meth; int nmeth; */ { int i, dg; double h0; /* first, estimate sigma^2 */ dg = deg(&lf->sp); deg(&lf->sp) = 2; h0 = lf->sp.fixh; lf->sp.fixh = 0.05; printf("alp: %8.5f h: %8.5f deg %2d ev %2d\n",nn(&lf->sp),fixh(&lf->sp),deg(&lf->sp),ev(&lf->evs)); startlf(des,lf,procv,0); ressumm(lf,des); deg(&lf->sp) = dg; lf->sp.fixh = h0; sig2 = rv(&lf->fp); printf("sd est: %8.5f\n",sqrt(sig2)); for (i=0; isp.fixh = h0; deg(&lf->sp) = dg; } } locfit/src/smisc.c0000754000176200001440000000201014745737234013616 0ustar liggesusers/* * Copyright (c) 1996-2000 Lucent Technologies. * See README file for details. * * some miscellaneous entry points. */ #include "local.h" void scritval(double *k0, Sint *d, double *cov, Sint *m, double *rdf, double *z, Sint *k) /* scritval(k0,z,cov,m,d,rdf,k) double *k0, *z, *cov, *rdf; Sint *d, *m, *k; */ { int i; lf_error = 0; for (i=0; i<*k; i++) z[i] = critval(1-cov[i], k0, (int)(*m), (int)(*d), TWO_SIDED,*rdf, (*rdf==0) ? GAUSS : TPROC); } void slscv(double *x, int *n, double *h, double *z) /* slscv(x,h,z,n) double *x, *h, *z; int *n; */ { double res[4]; kdecri(x,*h,res,0.0,3,WGAUS,*n); z[0] = res[0]; z[1] = res[2]; } void kdeb(double *x, Sint *mi, double *band, Sint *ind, double *h0, double *h1, Sint *meth, Sint *nmeth, Sint *ker) /* kdeb(x,mi,band,ind,h0,h1,meth,nmeth,ker) double *x, *band, *h0, *h1; Sint *mi, *ind, *meth, *nmeth, *ker; */ { int i, imeth[10]; for (i=0; i<*nmeth; i++) imeth[i] = meth[i]; kdeselect(band,x,ind,*h0,*h1,imeth,(int)*nmeth,(int)*ker,(int)mi[MN]); } locfit/src/lf_robust.c0000754000176200001440000000654614745735262014520 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * This file includes functions to solve for the scale estimate in * local robust regression and likelihood. The main entry point is * lf_robust(lfd,sp,des,mxit), * called from the locfit() function. * * The update_rs(x) accepts a residual scale x as the argument (actually, * it works on the log-scale). The function computes the local fit * assuming this residual scale, and re-estimates the scale from this * new fit. The final solution satisfies the fixed point equation * update_rs(x)=x. The function lf_robust() automatically calls * update_rs() through the fixed point iterations. * * The estimation of the scale from the fit is based on the sqrt of * the median deviance of observations with non-zero weights (in the * gaussian case, this is the median absolute residual). * * TODO: * Should use smoothing weights in the median. */ #include "local.h" extern int lf_status; double robscale; static lfdata *rob_lfd; static smpar *rob_sp; static design *rob_des; static int rob_mxit; double median(double *x, int n) /*double *x; int n;*/ { int i, j, lt, eq, gt; double lo, hi, s; lo = hi = x[0]; for (i=0; ilo) & (x[i]s); } if ((2*(lt+eq)>n) && (2*(gt+eq)>n)) return(s); if (2*(lt+eq)<=n) lo = s; if (2*(gt+eq)<=n) hi = s; } } return((hi+lo)/2); } double nrobustscale(lfdata *lfd, smpar *sp, design *des, double rs) /*lfdata *lfd; smpar *sp; design *des; double rs;*/ { int i, ii, p; double link[LLEN], sc, sd, sw, e; p = des->p; sc = sd = sw = 0.0; for (i=0; in; i++) { ii = des->ind[i]; des->th[i] = base(lfd,ii)+innerprod(des->cf,d_xi(des,i),p); e = resp(lfd,ii)-des->th[i]; stdlinks(link,lfd,sp,ii,des->th[i],rs); sc += des->w[i]*e*link[ZDLL]; sd += des->w[i]*e*e*link[ZDDLL]; sw += des->w[i]; } /* newton-raphson iteration for log(s) -psi(ei/s) - log(s); s = e^{-th} */ rs *= exp((sc-sw)/(sd+sc)); return(rs); } double robustscale(lfdata *lfd, smpar *sp, design *des) /*lfdata *lfd; smpar *sp; design *des;*/ { int i, ii, p, fam, lin; double rs, link[LLEN]; p = des->p; fam = fam(sp); lin = link(sp); for (i=0; in; i++) { ii = des->ind[i]; des->th[i] = base(lfd,ii) + innerprod(des->cf,d_xi(des,i),p); links(des->th[i],resp(lfd,ii),fam&127,lin,link,cens(lfd,ii),prwt(lfd,ii),1.0); des->res[i] = -2*link[ZLIK]; } rs = sqrt(median(des->res,des->n)); if (rs==0.0) rs = 1.0; return(rs); } double update_rs(double x) /*double x;*/ { double nx; if (lf_status != LF_OK) return(x); robscale = exp(x); lfiter(rob_des,rob_mxit); if (lf_status != LF_OK) return(x); nx = log(robustscale(rob_lfd,rob_sp,rob_des)); if (nx typedef struct { double *Z; /* jacobian matrix, length p*p */ double *Q; /* eigenvalue matrix, length p*p */ double *wk; /* work vector in eig_solve, length p */ double *dg; /* diag vector in eigd, length p */ int p; /* dimension */ int st; /* status */ int sm; /* requested decomposition */ } jacobian; /* m_jacob.c */ extern int jac_reqd(); extern double *jac_alloc(); extern void jacob_dec(), chol_dec(), eig_dec(); extern int jacob_solve(), chol_solve(), eig_solve(); extern int jacob_hsolve(),chol_hsolve(),eig_hsolve(); extern double jacob_qf(), chol_qf(), eig_qf(); /* m_max.c */ extern double max_grid(double (*f)(), double xlo, double xhi, int n, char flag); extern double max_golden(double (*f)(), double xlo, double xhi, int n, double tol, int *err, char flag); extern double max_quad(double (*f)(), double xlo, double xhi, int n, double tol, int *err, char flag); extern double max_nr(int (*F)(), double *coef, double *old_coef, double *f1, double *delta, jacobian *J, int p, int maxit, double tol, int *err); /* m_qr.c */ extern void qr(double *X, int n, int p, double *w); extern void qrinvx(double *R, double *x, int n, int p); extern void qrtinvx(double *R, double *x, int n, int p); extern void qrsolv(double *R, double *x, int n, int p); /* m_svd.c */ extern void svd(double *x, double *p, double *q, int d, int mxit); extern void hsvdsolve(double *x, double *w, double *P, double *D, double *Q, int d, double tol); extern int svdsolve(double *x, double *w, double *P, double *D, double *Q, int d, double tol); /* m_solve.c */ extern double solve_secant(double (*f)(), double c, double xlo, double xhi, double tol, int bd_flag, int *err); extern double solve_nr(double (*f)(), double (*f1)(), double c, double x0, double tol, int *err); extern double solve_fp(double (*f)(), double x0, double tol, int maxit); /* m_vector.c */ extern void setzero(double *v, int p); extern void unitvec(double *x, int k, int p); extern void addouter(double *A, double *v1, double *v2, int p, double c); extern void multmatscal(double *A, double z, int n); extern void transpose(double *x, int m, int n); extern double innerprod(double *v1, double *v2, int p); extern double m_trace(double *x, int n); #define BDF_NONE 0 #define BDF_EXPLEFT 1 #define BDF_EXPRIGHT 2 /* return codes for functions optimized by max_nr */ #define NR_OK 0 #define NR_INVALID 1 #define NR_BREAK 2 #define NR_REDUCE 3 #define NR_NCON 10 #define NR_NDIV 11 /* jacobian status definitions */ #define JAC_RAW 0 #define JAC_CHOL 1 #define JAC_EIG 2 #define JAC_EIGD 3 /* Numerical Integration Stuff */ #define MXRESULT 5 #define MXIDIM 10 /* max. dimension */ extern void simpsonm(), simpson4(), integ_disc(), integ_circ(); extern void integ_sphere(), monte(), rn3(); extern double simpson(), sptarea(); /* Density, distribution stuff */ #ifndef PI #define PI 3.141592653589793238462643 #endif #define PIx2 6.283185307179586476925286 /* 2*pi */ #define HF_LG_PIx2 0.918938533204672741780329736406 /* 0.5*log(2*pi) */ #define SQRT2 1.4142135623730950488 #define LOG_ZERO -1e100 #define D_0 ((give_log) ? LOG_ZERO : 0.0) #define D_1 ((give_log) ? 0.0 : 1.0) #define DEXP(x) ((give_log) ? (x) : exp(x)) #define FEXP(f,x) ((give_log) ? -0.5*log(f)+(x) : exp(x)/sqrt(f)) #define INVALID_PARAMS 0.0 extern double stirlerr(double), bd0(double, double); extern double dbinom_raw(double, double, double, double, int), dpois_raw(double, double, int); extern double dbinom(int, int, double, int), dpois(int, double, int), dnbinom(int, double, double, int), dbeta(double, double, double, int), dgamma(double, double, double, int), dt(double, double, int), df(double, double, double, int), dhyper(int, int, int, int, int); extern double dchisq(double, double, int); extern double igamma(double, double), ibeta(double, double, double); extern double pf(double, double, double), pchisq(), mut_pnorm(double, double, double); #define pchisq(x,df) igamma((x)/2.0,(df)/2.0) #endif /* define I_MUT_H */ locfit/src/tube.h0000754000176200001440000000161014745724400013440 0ustar liggesusers/* * Copyright (c) 1998-2001 Catherine Loader, Jiayang Sun * See README file for details. * * * Headers for the tube library. */ #ifndef I_TUBE_H #define I_TUBE_H /* * public functions needed by routines calling the tube library. */ extern double critval(); extern double tailp(), taild(); extern int tube_constants(); extern int k0_reqd(); /* * stuff used internally. */ #include "mutil.h" #define TUBE_MXDIM 10 /* * definitions for integration methods. * these match locfit evaluation structures where applicable. */ #define ISIMPSON 4 /* grid */ #define ISPHERIC 11 /* circle or sphere */ #define IDERFREE 25 /* derivative free */ #define IMONTE 30 /* monte carlo */ #ifndef PI #define PI 3.141592653589793238462643 #endif #define ONE_SIDED 1 #define TWO_SIDED 2 #define UNIF 400 #define GAUSS 401 #define TPROC 402 #endif /* define I_TUBE_H */ locfit/src/lfstruc.h0000754000176200001440000000454114745724400014171 0ustar liggesusers/* * Copyright (c) 1998-2001 Lucent Technologies. * See README file for details. * * * * Structures, typedefs etc used in Locfit */ typedef struct { double *wk, *coef, *xbar, *f; jacobian xtwx; int lwk, haspc; } paramcomp; #define haspc(pc) ((pc)->haspc) typedef struct { double *x[MXDIM]; double *y; double *w; double *b; double *c; double sca[MXDIM]; double xl[2*MXDIM]; int n, d, ord; int sty[MXDIM]; varname yname, xname[MXDIM], wname, bname, cname; } lfdata; #define resp(lfd,i) (((lfd)->y==NULL) ? 0.0 : (lfd)->y[i]) #define base(lfd,i) (((lfd)->b==NULL) ? 0.0 : (lfd)->b[i]) #define prwt(lfd,i) (((lfd)->w==NULL) ? 1.0 : (lfd)->w[i]) #define cens(lfd,i) (((lfd)->c==NULL) ? 0 : (int)(lfd)->c[i]) #define datum(lfd,i,j) ((lfd)->x[i][j]) #define dvari(lfd,i) ((lfd)->x[i]) typedef struct { double nn, fixh, adpen; int ker, kt; int deg, deg0, p; int acri; int fam, lin; int ubas; double (*vb)(); void (*vbasis)(); } smpar; #define nn(sp) ((sp)->nn) #define fixh(sp) ((sp)->fixh) #define pen(sp) ((sp)->adpen) #define ker(sp) ((sp)->ker) #define kt(sp) ((sp)->kt) #define deg(sp) ((sp)->deg) #define deg0(sp) ((sp)->deg0) #define npar(sp) ((sp)->p) #define acri(sp) ((sp)->acri) #define ubas(sp) ((sp)->ubas) #define fam(sp) ((sp)->fam) #define link(sp) ((sp)->lin) typedef struct { int deriv[MXDEG+2]; int nd; } deriv; typedef struct { int ev; double *sv; double cut; double fl[2*MXDIM]; Sint *iwk, *ce, *s, *lo, *hi; int liw, nce, ncm, maxk; int mg[MXDIM]; void (*espec)(); } evstruc; #define ev(evs) ((evs)->ev) #define cut(evs) ((evs)->cut) #define mk(evs) ((evs)->maxk) #define mg(evs) ((evs)->mg) typedef struct { double *xev, *coef, *nlx, *t0, *lik, *h, *deg, *L; int lev, lwk, ll; int d, dcor, geth, hasd; int nv, nvm; double df0, df1, llk, rv, rsc; double kap[10]; } fitpt; #define evp(fp) ((fp)->xev) #define evpt(fp,i) (&(fp)->xev[(i)*(fp)->d]) #define evptx(fp,i,k) ((fp)->xev[(i)*(fp)->d+(k)]) #define df0(fp) ((fp)->df0) #define df1(fp) ((fp)->df1) #define llk(fp) ((fp)->llk) #define dc(fp) ((fp)->dcor) #define geth(fp) ((fp)->geth) #define rv(fp) ((fp)->rv) #define rsc(fp) ((fp)->rsc) typedef struct { int lf_init_id; lfdata lfd; smpar sp; evstruc evs; fitpt fp; deriv dv; paramcomp pc; } lfit; #define LF_INIT_ID 34897239 locfit/src/ev_kdtre.c0000754000176200001440000002147514745734254014322 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * Routines for building and interpolating the kd tree. * Initially, this started from the loess code. * * Todo: EKDCE isn't working. */ #include "local.h" void newcell(int *nv, int vc, double *xev, int d, int k, double split_val, Sint *cpar, Sint *clef, Sint *crig); static int nterm; void kdtre_guessnv(evstruc *evs, int *nvm, int *ncm, int *vc, int n, int d, double alp) /* kdtre_guessnv(evs,nvm,ncm,vc,n,d,alp) evstruc *evs; int *nvm, *ncm, *vc, n, d; double alp; */ { int k; if (ev(evs) == EKDTR) { nterm = (int)(cut(evs)/4 * n * MIN(alp,1.0) ); k = 2*n/nterm; *vc = 1<=l) && (x[pi[il]]>= t)) il--; if (ir t */ jl = ir; jr = r; while (ir=jl) && (x[pi[jr]] > t)) jr--; if (ir=m)) return(jr); /* update l or r. */ if (m>=ir) l = ir; if (m<=il) r = il; } if (l==r) return(l); ERROR(("ksmall failure")); return(0); } int terminal(lfit *lf, int p, Sint *pi, int fc, int d, int *m, double *split_val) /* terminal(lf,p,pi,fc,d,m,split_val) lfit *lf; Sint *pi; int p, d, fc, *m; double *split_val; */ { int i, k, lo, hi, split_var; double max, min, score, max_score, t; /* if there are fewer than fc points in the cell, this cell is terminal. */ lo = lf->evs.lo[p]; hi = lf->evs.hi[p]; if (hi-lo < fc) return(-1); /* determine the split variable */ max_score = 0.0; split_var = 0; for (k=0; klfd, k, pi[lo]); for (i=lo+1; i<=hi; i++) { t = datum(&lf->lfd,k,pi[i]); if (tmax) max = t; } score = (max-min) / lf->lfd.sca[k]; if (score > max_score) { max_score = score; split_var = k; } } if (max_score==0) /* all points in the cell are equal */ return(-1); *m = ksmall(lo,hi,(lo+hi)/2, dvari(&lf->lfd,split_var), pi); *split_val = datum(&lf->lfd, split_var, pi[*m]); if (*m==hi) /* all observations go lo */ return(-1); return(split_var); } void kdtre_start(design *des, lfit *lf) /* kdtre_start(des,lf) design *des; lfit *lf; */ { Sint *pi; int i, j, vc, d, nc, nv, ncm, nvm, k, m, n, p; double sv; d = lf->lfd.d; n = lf->lfd.n; pi = des->ind; kdtre_guessnv(&lf->evs,&nvm,&ncm,&vc,n,d,nn(&lf->sp)); trchck(lf,nvm,ncm,vc); nv = 0; if (ev(&lf->evs) != EKDCE) { for (i=0; ifp,i,k) = lf->evs.fl[d*(j%2)+k]; j >>= 1; } } nv = vc; for (j=0; jevs.ce[j] = j; } for (i=0; ievs.lo[p] = 0; lf->evs.hi[p] = n-1; lf->evs.s[p] = -1; while (p=0) { if ((ncmevs.nce = nc; lf->fp.nv = nv; return; } /* new lo cell has obsn's lo[p]..m */ lf->evs.lo[nc] = lf->evs.lo[p]; lf->evs.hi[nc] = m; lf->evs.s[nc] = -1; /* new hi cell has obsn's m+1..hi[p] */ lf->evs.lo[nc+1] = m+1; lf->evs.hi[nc+1] = lf->evs.hi[p]; lf->evs.s[nc+1] = -1; /* cell p is split on variable k, value sv */ lf->evs.s[p] = k; lf->evs.sv[p] = sv; lf->evs.lo[p] = nc; lf->evs.hi[p] = nc+1; nc=nc+2; i = nv; /* now compute the new vertices. */ if (ev(&lf->evs) != EKDCE) newcell(&nv,vc,evp(&lf->fp), d, k, sv, &lf->evs.ce[p*vc], &lf->evs.ce[(nc-2)*vc], &lf->evs.ce[(nc-1)*vc]); } else if (ev(&lf->evs)==EKDCE) /* new vertex at cell center */ { sv = 0; for (i=0; ifp,nv,i) = 0; for (j=lf->evs.lo[p]; j<=lf->evs.hi[p]; j++) { sv += prwt(&lf->lfd,(int)pi[j]); for (i=0; ifp,nv,i) += datum(&lf->lfd,i,pi[j])*prwt(&lf->lfd,(int)pi[j]); } for (i=0; ifp,nv,i) /= sv; lf->lfd.n = lf->evs.hi[p] - lf->evs.lo[p] + 1; des->ind = &pi[lf->evs.lo[p]]; /* why? */ des->vfun(des,lf,nv); lf->lfd.n = n; des->ind = pi; nv++; } p++; } /* We've built the tree. Now do the fitting. */ if (ev(&lf->evs)==EKDTR) for (i=0; ivfun(des,lf,i); lf->evs.nce = nc; lf->fp.nv = nv; return; } void newcell(int *nv, int vc, double *xev, int d, int k, double split_val, Sint *cpar, Sint *clef, Sint *crig) /* newcell(nv,vc,xev,d,k,split_val,cpar,clef,crig) double *xev, split_val; Sint *cpar, *clef, *crig; int *nv, vc, d, k; */ { int i, ii, j, j2, tk, match; tk = 1<ce; for (k=0; k<4; k++) /* North South East West */ { k1 = (k>1); v0 = ll[k1]; v1 = ur[k1]; j0 = ce[j+2*(k==0)+(k==2)]; j1 = ce[j+3-2*(k==1)-(k==3)]; xibar = (k%2==0) ? ur[k<2] : ll[k<2]; m = nt; while ((m>=0) && ((evs->s[t[m]] != (k<=1)) | (evs->sv[t[m]] != xibar))) m--; if (m >= 0) { m = (k%2==1) ? evs->lo[t[m]] : evs->hi[t[m]]; while (evs->s[m] != -1) m = (x[evs->s[m]] < evs->sv[m]) ? evs->lo[m] : evs->hi[m]; if (v0 < evptx(fp,ce[4*m+2*(k==1)+(k==3)],k1)) { j0 = ce[4*m+2*(k==1)+(k==3)]; v0 = evptx(fp,j0,k1); } if (evptx(fp,ce[4*m+3-2*(k==0)-(k==2)],k1) < v1) { j1 = ce[4*m+3-2*(k==0)-(k==2)]; v1 = evptx(fp,j1,k1); } } nc = exvval(fp,g0,j0,2,what,0); nc = exvval(fp,g1,j1,2,what,0); if (nc==1) gg[k] = linear_interp((x[(k>1)]-v0),v1-v0,g0[0],g1[0]); else { hermite2(x[(k>1)]-v0,v1-v0,phi); gg[k] = phi[0]*g0[0]+phi[1]*g1[0]+(phi[2]*g0[1+k1]+phi[3]*g1[1+k1])*(v1-v0); gp[k] = phi[0]*g0[2-k1] + phi[1]*g1[2-k1]; } } s = -s; if (nc==1) for (k=0; k<2; k++) s += linear_interp(x[k]-ll[k],ur[k]-ll[k],gg[3-2*k],gg[2-2*k]); else for (k=0; k<2; k++) /* EW NS */ { hermite2(x[k]-ll[k],ur[k]-ll[k],phi); s += phi[0]*gg[3-2*k] + phi[1]*gg[2-2*k] +(phi[2]*gp[3-2*k] + phi[3]*gp[2-2*k]) * (ur[k]-ll[k]); } return(s); } double kdtre_int(fitpt *fp, evstruc *evs, double *x, int what) /* kdtre_int(fp,evs,x,what) fitpt *fp; evstruc *evs; double *x; int what; */ { Sint *ce; int k, vc, t[20], nt, nc, j, d; double *ll, *ur, ff, vv[64][64]; d = fp->d; vc = 1< 6) ERROR(("d too large in kdint")); /* descend the tree to find the terminal cell */ nt = 0; t[nt] = 0; k = 0; while (evs->s[k] != -1) { nt++; if (nt>=20) { ERROR(("Too many levels in kdint")); return(NOSLN); } k = t[nt] = (x[evs->s[k]] < evs->sv[k]) ? evs->lo[k] : evs->hi[k]; } ce = &evs->ce[k*vc]; ll = evpt(fp,ce[0]); ur = evpt(fp,ce[vc-1]); nc = 0; for (j=0; j #include "R.h" #include "mutil.h" extern void setzero(); /* static int lfindex[MXIDIM]; static double M[(1+MXIDIM)*MXIDIM*MXIDIM]; */ void monte(int (*f)(), double *ll, double *ur, int d, double *res, int n) /*int (*f)(), d, n; double *ll, *ur, *res;*/ { int i, j, nr=0; double z, x[MXIDIM], tres[MXRESULT]; /* srand48(234L); */ GetRNGstate(); /* Use R's RNG */ for (i=0; i2, an initial grid search is performed with n intervals * (this helps deal with local maxima). * convergence criterion is |x-xmax| < tol. * err is an error flag. * if flag='x', return value is xmax. * otherwise, return value is f(xmax). * * max_quad(f,xlo,xhi,n,tol,err,flag) * quadratic maximization. * * max_nr() * newton-raphson, handles multivariate case. * * TODO: additional error checking, non-convergence stop. */ #include #include #include #include #include "mutil.h" #define gold_rat 0.6180339887498948482045870 #define max_val(a,b) ((flag=='x') ? a : b) double max_grid(double (*f)(), double xlo, double xhi, int n, char flag) /*double (*f)(), xlo, xhi; int n; char flag;*/ { int i, mi=0; double x, y, mx=0.0, my=0.0; for (i=0; i<=n; i++) { x = xlo + (xhi-xlo)*i/n; y = f(x); if ((i==0) || (y>my)) { mx = x; my = y; mi = i; } } if (mi==0) return(max_val(xlo,my)); if (mi==n) return(max_val(xhi,my)); return(max_val(mx,my)); } double max_golden(double (*f)(), double xlo, double xhi, int n, double tol, int *err, char flag) /*double (*f)(), xhi, xlo, tol; int n, *err; char flag;*/ { double dlt, x0, x1, x2, x3, y0, y1, y2, y3; *err = 0; if (n>2) { dlt = (xhi-xlo)/n; x0 = max_grid(f,xlo,xhi,n,'x'); if (xlox0) xhi = x0+dlt; } x0 = xlo; y0 = f(xlo); x3 = xhi; y3 = f(xhi); x1 = gold_rat*x0 + (1-gold_rat)*x3; y1 = f(x1); x2 = gold_rat*x3 + (1-gold_rat)*x1; y2 = f(x2); while (fabs(x3-x0)>tol) { if ((y1>=y0) && (y1>=y2)) { x3 = x2; y3 = y2; x2 = x1; y2 = y1; x1 = gold_rat*x0 + (1-gold_rat)*x3; y1 = f(x1); } else if ((y2>=y3) && (y2>=y1)) { x0 = x1; y0 = y1; x1 = x2; y1 = y2; x2 = gold_rat*x3 + (1-gold_rat)*x1; y2 = f(x2); } else { if (y3>y0) { x0 = x2; y0 = y2; } else { x3 = x1; y3 = y1; } x1 = gold_rat*x0 + (1-gold_rat)*x3; y1 = f(x1); x2 = gold_rat*x3 + (1-gold_rat)*x1; y2 = f(x2); } } if (y0>=y1) return(max_val(x0,y0)); if (y3>=y2) return(max_val(x3,y3)); return((y1>y2) ? max_val(x1,y1) : max_val(x2,y2)); } double max_quad(double (*f)(), double xlo, double xhi, int n, double tol, int *err, char flag) /*double (*f)(), xhi, xlo, tol; int n, *err; char flag;*/ { double x0, x1, x2, xnew, y0, y1, y2, ynew, a, b; *err = 0; if (n>2) { x0 = max_grid(f,xlo,xhi,n,'x'); if (xlox0) xhi = x0+1.0/n; } x0 = xlo; y0 = f(x0); x2 = xhi; y2 = f(x2); x1 = (x0+x2)/2; y1 = f(x1); while (x2-x0>tol) { /* first, check (y0,y1,y2) is a peak. If not, * next interval is the halve with larger of (y0,y2). */ if ((y0>y1) | (y2>y1)) { if (y0>y2) { x2 = x1; y2 = y1; } else { x0 = x1; y0 = y1; } x1 = (x0+x2)/2; y1 = f(x1); } else /* peak */ { a = (y1-y0)*(x2-x1) + (y1-y2)*(x1-x0); b = ((y1-y0)*(x2-x1)*(x2+x1) + (y1-y2)*(x1-x0)*(x1+x0))/2; /* quadratic maximizer is b/a. But first check if a's too * small, since we may be close to constant. */ if ((a<=0) | (bx2*a)) { /* split the larger halve */ xnew = ((x2-x1) > (x1-x0)) ? (x1+x2)/2 : (x0+x1)/2; } else { xnew = b/a; if (10*xnew < (9*x0+x1)) xnew = (9*x0+x1)/10; if (10*xnew > (9*x2+x1)) xnew = (9*x2+x1)/10; if (fabs(xnew-x1) < 0.001*(x2-x0)) { if ((x2-x1) > (x1-x0)) xnew = (99*x1+x2)/100; else xnew = (99*x1+x0)/100; } } ynew = f(xnew); if (xnew>x1) { if (ynew >= y1) { x0 = x1; y0 = y1; x1 = xnew; y1 = ynew; } else { x2 = xnew; y2 = ynew; } } else { if (ynew >= y1) { x2 = x1; y2 = y1; x1 = xnew; y1 = ynew; } else { x0 = xnew; y0 = ynew; } } } } return(max_val(x1,y1)); } double max_nr(int (*F)(), double *coef, double *old_coef, double *f1, double *delta, jacobian *J, int p, int maxit, double tol, int *err) /*double *coef, *old_coef, *f1, *delta, tol; int (*F)(), p, maxit, *err; jacobian *J;*/ { double old_f, f, lambda; int i, j, fr; double nc, nd, cut; int rank; *err = NR_OK; J->p = p; fr = F(coef, &f, f1, J->Z); J->st = JAC_RAW; for (i=0; i1.0) cut = 1.0; cut *= 0.0001; do { for (j=0; jZ); J->st = JAC_RAW; if (fr==NR_BREAK) return(old_f); lambda = (fr==NR_REDUCE) ? lambda/2 : lambda/10.0; } while ((lambda>cut) & (f <= old_f - 1.0e-3)); if (f < old_f - 1.0e-3) { *err = NR_NDIV; return(f); } if (fr==NR_REDUCE) return(f); if (fabs(f-old_f) < tol) return(f); } *err = NR_NCON; return(f); } locfit/src/m_svd.c0000754000176200001440000000747614745736360013634 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include #include "local.h" #include "mutil.h" /* svd of square matrix */ void svd(double *x, double *p, double *q, int d, int mxit) /* void svd(x,p,q,d,mxit) double *x, *p, *q; int d, mxit; */ { int i, j, k, iter, ms, zer; double r, u, v, cp, cm, sp, sm, c1, c2, s1, s2, mx; for (i=0; is2) ? s1 : s2; zer = 1; if (mx*mx>1.0e-15*fabs(x[i*d+i]*x[j*d+j])) { if (fabs(x[i*(d+1)])0) { cp /= r; sp /= r; } else { cp = 1.0; zer = 0;} cm = x[i*(d+1)]-x[j*(d+1)]; sm = x[i*d+j]+x[j*d+i]; r = sqrt(cm*cm+sm*sm); if (r>0) { cm /= r; sm /= r; } else { cm = 1.0; zer = 0;} c1 = cm+cp; s1 = sm+sp; r = sqrt(c1*c1+s1*s1); if (r>0) { c1 /= r; s1 /= r; } else { c1 = 1.0; zer = 0;} if (fabs(s1)>ms) ms = (int)fabs(s1); c2 = cm+cp; s2 = sp-sm; r = sqrt(c2*c2+s2*s2); if (r>0) { c2 /= r; s2 /= r; } else { c2 = 1.0; zer = 0;} for (k=0; k0) { mx = D[0]; for (i=1; imx) mx = D[i*(d+1)]; tol *= mx; } rank = 0; for (i=0; itol) { w[i] /= D[i*(d+1)]; rank++; } for (i=0; i0) { mx = D[0]; for (i=1; imx) mx = D[i*(d+1)]; tol *= mx; } for (i=0; itol) w[i] /= sqrt(D[i*(d+1)]); for (i=0; isp)&64)==0) { rv(&lf->fp) = 1.0; return; } for (i=0; ifp.nv; i++) { s0 += lf->fp.lik[2*lf->fp.nvm+i]; s1 += lf->fp.lik[i]; } if (s0==0.0) rv(&lf->fp) = 0.0; else rv(&lf->fp) = -2*s1/s0; } void ressumm(lfit *lf, design *des) /* ressumm(lf,des) lfit *lf; design *des; */ { int i, j, evo, tg, orth; double *oy, pw, r1, r2, rdf, t0, t1, u[MXDIM], link[LLEN]; fitpt *fp; fp = &lf->fp; llk(fp) = df0(fp) = df1(fp) = 0.0; evo = ev(&lf->evs); if ((evo==EKDCE) | (evo==EPRES)) { rv(fp) = 1.0; return; } if (lf->dv.nd>0) { ressummd(lf); return; } r1 = r2 = 0.0; if ((evo==EDATA) | (evo==ECROS)) evo = EFITP; orth = (geth(&lf->fp)==GAMF) | (geth(&lf->fp)==GAMP); for (i=0; ilfd.n; i++) { for (j=0; jlfd.d; j++) u[j] = datum(&lf->lfd,j,i); des->th[i] = base(&lf->lfd,i)+dointpoint(lf,u,PCOEF,evo,i); des->wd[i] = resp(&lf->lfd,i) - des->th[i]; des->w[i] = 1.0; des->ind[i] = i; } tg = fam(&lf->sp); rsc(&lf->fp) = 1.0; if ((tg==TROBT+64) | (tg==TCAUC+64)) /* global robust scale */ { oy = lf->lfd.y; lf->lfd.y = des->wd; des->xev = lf->pc.xbar; locfit(&lf->lfd,des,&lf->sp,1,0); lf->lfd.y = oy; rsc(fp) = robscale; } if (orth) /* orthog. residuals */ { int od, op; des->n = lf->lfd.n; od = deg(&lf->sp); op = npar(&lf->sp); deg(&lf->sp) = 1; npar(&lf->sp) = des->p = 1+lf->lfd.d; oy = lf->lfd.y; lf->lfd.y = des->wd; des->xev = lf->pc.xbar; locfit(&lf->lfd,des,&lf->sp,1,0); for (i=0; ilfd.n; i++) oy[i] = resp(&lf->lfd,i) - des->th[i]; lf->lfd.y = oy; deg(&lf->sp) = od; npar(&lf->sp) = op; } for (i=0; ilfd.n; i++) { for (j=0; jlfd.d; j++) u[j] = datum(&lf->lfd,j,i); t0 = dointpoint(lf,u,PT0,evo,i); t1 = dointpoint(lf,u,PNLX,evo,i); stdlinks(link,&lf->lfd,&lf->sp,i,des->th[i],rsc(fp)); t1 = t1*t1*link[ZDDLL]; t0 = t0*t0*link[ZDDLL]; if (t1>1) t1 = 1; if (t0>1) t0 = 1; /* no observation gives >1 deg.free */ llk(fp) += link[ZLIK]; df0(fp) += t0; df1(fp) += t1; pw = prwt(&lf->lfd,i); if (pw>0) { r1 += link[ZDLL]*link[ZDLL]/pw; r2 += link[ZDDLL]/pw; } if (orth) des->di[i] = t1; } if (orth) return; rv(fp) = 1.0; if ((fam(&lf->sp)&64)==64) /* quasi family */ { rdf = lf->lfd.n-2*df0(fp)+df1(fp); if (rdf<1.0) { WARN(("Estimated rdf < 1.0; not estimating variance")); } else rv(fp) = r1/r2 * lf->lfd.n / rdf; } /* try to ensure consistency for family="circ"! */ if (((fam(&lf->sp)&63)==TCIRC) & (lf->lfd.d==1)) { Sint *ind; int nv; double dlt, th0, th1; ind = des->ind; nv = fp->nv; for (i=0; icoef[ind[i]]-dlt*fp->coef[ind[i]+nv]-fp->coef[ind[i-1]]; th1 = fp->coef[ind[i]]-dlt*fp->coef[ind[i-1]+nv]-fp->coef[ind[i-1]]; if ((th0>PI)&(th1>PI)) { for (j=0; jcoef[ind[j]] += 2*PI; i--; } if ((th0<(-PI))&(th1<(-PI))) { for (j=0; jcoef[ind[j]] -= 2*PI; i--; } } } } double rss(lfit *lf, design *des, double *df) /* rss(lf,des,df) lfit *lf; design *des; double *df; */ { //double ss; // ss = 0; ressumm(lf,des); *df = lf->lfd.n - 2*df0(&lf->fp) + df1(&lf->fp); return(-2*llk(&lf->fp)); } locfit/src/family.c0000754000176200001440000003727114745734647014007 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include "local.h" #define HUBERC 2.0 extern double rs, log(); int defaultlink(int link, int family) /* defaultlink(link,family) int link, family; */ { if (link==LDEFAU) switch(family&63) { case TDEN: case TRAT: case THAZ: case TGAMM: case TGEOM: case TPROB: case TPOIS: return(LLOG); case TCIRC: case TGAUS: case TCAUC: case TROBT: return(LIDENT); case TRBIN: case TLOGT: return(LLOGIT); } if (link==LCANON) switch(family&63) { case TDEN: case TRAT: case THAZ: case TPROB: case TPOIS: return(LLOG); case TGEOM: WARN(("Canonical link unavaialable for geometric family; using inverse")); case TGAMM: return(LINVER); case TCIRC: case TGAUS: case TCAUC: case TROBT: return(LIDENT); case TRBIN: case TLOGT: return(LLOGIT); } return(link); } int validlinks(int link, int family) /* validlinks(link,family) int link, family; */ { switch(family&63) { case TDEN: case TRAT: case THAZ: return((link==LLOG) | (link==LIDENT)); case TGAUS: return((link==LIDENT) | (link==LLOG) | (link==LLOGIT)); case TROBT: case TCAUC: case TCIRC: return(link==LIDENT); case TLOGT: return((link==LLOGIT) | (link==LIDENT) | (link==LASIN)); case TRBIN: return(link==LLOGIT); case TGAMM: return((link==LLOG) | (link==LINVER) | (link==LIDENT)); case TGEOM: return((link==LLOG) | (link==LIDENT)); case TPOIS: case TPROB: return((link==LLOG) | (link==LSQRT) | (link==LIDENT)); } ERROR(("Unknown family %d in validlinks",family)); return(0); } int famdens(double mean, double th, int link, double *res, int cens, double w) /* famdens(mean,th,link,res,cens,w) double mean, th, *res, w; int link, cens; */ { if (cens) res[ZLIK] = res[ZDLL] = res[ZDDLL] = 0.0; else { res[ZLIK] = w*th; res[ZDLL] = res[ZDDLL] = w; } return(LF_OK); } int famgaus(double y, double mean, double th, int link, double *res, int cens, double w) /* famgaus(y,mean,th,link,res,cens,w) double y, mean, th, *res, w; int link, cens; */ { double z, pz, dp; if (link==LINIT) { res[ZDLL] = w*y; return(LF_OK); } z = y-mean; if (cens) { if (link!=LIDENT) { ERROR(("Link invalid for censored Gaussian family")); return(LF_LNK); } pz = mut_pnorm(-z,0.0,1.0); dp = ((z>6) ? ptail(-z) : exp(-z*z/2)/pz)/2.5066283; res[ZLIK] = w*log(pz); res[ZDLL] = w*dp; res[ZDDLL]= w*dp*(dp-z); return(LF_OK); } res[ZLIK] = -w*z*z/2; switch(link) { case LIDENT: res[ZDLL] = w*z; res[ZDDLL]= w; break; case LLOG: res[ZDLL] = w*z*mean; res[ZDDLL]= w*mean*mean; break; case LLOGIT: res[ZDLL] = w*z*mean*(1-mean); res[ZDDLL]= w*mean*mean*(1-mean)*(1-mean); break; default: ERROR(("Invalid link for Gaussian family")); return(LF_LNK); } return(LF_OK); } int famrobu(double y, double mean, double th, int link, double *res, int cens, double w, double rs) /* famrobu(y,mean,th,link,res,cens,w,rs) double y, mean, th, *res, w, rs; int link, cens; */ { double z, sw; if (link==LINIT) { res[ZDLL] = w*y; return(LF_OK); } sw = (w==1.0) ? 1.0 : sqrt(w); /* don't want unnecess. sqrt! */ z = sw*(y-mean)/rs; res[ZLIK] = (fabs(z) HUBERC) { res[ZDLL] = sw*HUBERC/rs; res[ZDDLL]= 0.0; return(LF_OK); } res[ZDLL] = sw*z/rs; res[ZDDLL] = w/(rs*rs); return(LF_OK); } int famcauc(double y, double p, double th, int link, double *res, int cens, double w, double rs) /* famcauc(y,p,th,link,res,cens,w,rs) double y, p, th, *res, w, rs; int link, cens; */ { double z; if (link!=LIDENT) { ERROR(("Invalid link in famcauc")); return(LF_LNK); } z = w*(y-th)/rs; res[ZLIK] = -log(1+z*z); res[ZDLL] = 2*w*z/(rs*(1+z*z)); res[ZDDLL] = 2*w*w*(1-z*z)/(rs*rs*(1+z*z)*(1+z*z)); return(LF_OK); } int famrbin(double y, double p, double th, int link, double *res, int cens, double w) /* famrbin(y,p,th,link,res,cens,w) double y, p, th, *res, w; int link, cens; */ { double s2y; if (link==LINIT) { res[ZDLL] = y; return(LF_OK); } if ((y<0) | (y>w)) /* goon observation; delete it */ { res[ZLIK] = res[ZDLL] = res[ZDDLL] = 0.0; return(LF_OK); } res[ZLIK] = (th<0) ? th*y-w*log(1+exp(th)) : th*(y-w)-w*log(1+exp(-th)); if (y>0) res[ZLIK] -= y*log(y/w); if (yHUBERC*HUBERC/2.0) { s2y = sqrt(-2*res[ZLIK]); res[ZLIK] = HUBERC*(HUBERC/2.0-s2y); res[ZDLL] *= HUBERC/s2y; res[ZDDLL] = HUBERC/s2y*(res[ZDDLL]-1/(s2y*s2y)*w*p*(1-p)); } return(LF_OK); } int fambino(double y, double p, double th, int link, double *res, int cens, double w) /* fambino(y,p,th,link,res,cens,w) double y, p, th, *res, w; int link, cens; */ { double wp; if (link==LINIT) { if (y<0) y = 0; if (y>w) y = w; res[ZDLL] = y; return(LF_OK); } wp = w*p; if (link==LIDENT) { if ((p<=0) && (y>0)) return(LF_BADP); if ((p>=1) && (y0) { res[ZLIK] += y*log(wp/y); res[ZDLL] += y/p; res[ZDDLL]+= y/(p*p); } if (yw)) /* goon observation; delete it */ { res[ZLIK] = res[ZDLL] = res[ZDDLL] = 0.0; return(LF_OK); } res[ZLIK] = (th<0) ? th*y-w*log(1+exp(th)) : th*(y-w)-w*log(1+exp(-th)); if (y>0) res[ZLIK] -= y*log(y/w); if (y0)) return(LF_BADP); if ((p>=1) && (yPI/2)) return(LF_BADP); res[ZDLL] = res[ZDDLL] = res[ZLIK] = 0; if (y>0) { res[ZDLL] += 2*y*sqrt((1-p)/p); res[ZLIK] += y*log(wp/y); } if (y0) res[ZLIK] += y*(th-log(y/w)); res[ZDDLL] = wmu; return(LF_OK); } if (link==LIDENT) { if ((mean<=0) && (y>0)) return(LF_BADP); res[ZLIK] = y-wmu; res[ZDLL] = -w; res[ZDDLL] = 0; if (y>0) { res[ZLIK] += y*log(wmu/y); res[ZDLL] += y/mean; res[ZDDLL]= y/(mean*mean); } return(LF_OK); } if (link==LSQRT) { if ((mean<=0) && (y>0)) return(LF_BADP); res[ZLIK] = y-wmu; res[ZDLL] = -2*w*th; res[ZDDLL]= 2*w; if (y>0) { res[ZLIK] += y*log(wmu/y); res[ZDLL] += 2*y/th; res[ZDDLL]+= 2*y/mean; } return(LF_OK); } ERROR(("link %d invalid for Poisson family",link)); return(LF_LNK); } int famgamm(double y, double mean, double th, int link, double *res, int cens, double w) /* famgamm(y,mean,th,link,res,cens,w) double y, mean, th, *res, w; int link, cens; */ { double pt, dg; if (link==LINIT) { res[ZDLL] = MAX(y,0.0); return(LF_OK); } if ((mean<=0) & (y>0)) return(LF_BADP); if (cens) { if (y<=0) { res[ZLIK] = res[ZDLL] = res[ZDDLL] = 0.0; return(LF_OK); } if (link==LLOG) { pt = 1-igamma(y/mean,w); dg = exp((w-1)*log(y/mean)-y/mean-LGAMMA(w)); res[ZLIK] = log(pt); res[ZDLL] = y*dg/(mean*pt); res[ZDDLL]= dg*(w*y/mean-y*y/(mean*mean))/pt+SQR(res[ZDLL]); return(LF_OK); } if (link==LINVER) { pt = 1-igamma(th*y,w); dg = exp((w-1)*log(th*y)-th*y-LGAMMA(w)); res[ZLIK] = log(pt); res[ZDLL] = -y*dg/pt; res[ZDDLL]= dg*y*((w-1)*mean-y)/pt+SQR(res[ZDLL]); return(LF_OK); } } else { if (y<0) WARN(("Negative Gamma observation")); if (link==LLOG) { res[ZLIK] = -y/mean+w*(1-th); if (y>0) res[ZLIK] += w*log(y/w); res[ZDLL] = y/mean-w; res[ZDDLL]= y/mean; return(LF_OK); } if (link==LINVER) { res[ZLIK] = -y/mean+w-w*log(mean); if (y>0) res[ZLIK] += w*log(y/w); res[ZDLL] = -y+w*mean; res[ZDDLL]= w*mean*mean; return(LF_OK); } if (link==LIDENT) { res[ZLIK] = -y/mean+w-w*log(mean); if (y>0) res[ZLIK] += w*log(y/w); res[ZDLL] = (y-mean)/(mean*mean); res[ZDDLL]= w/(mean*mean); return(LF_OK); } } ERROR(("link %d invalid for Gamma family",link)); return(LF_LNK); } int famgeom(double y, double mean, double th, int link, double *res, int cens, double w) /* famgeom(y,mean,th,link,res,cens,w) double y, mean, th, *res, w; int link, cens; */ { double p, pt, dp, dq; if (link==LINIT) { res[ZDLL] = MAX(y,0.0); return(LF_OK); } p = 1/(1+mean); if (cens) /* censored observation */ { if (y<=0) { res[ZLIK] = res[ZDLL] = res[ZDDLL] = 0; return(LF_OK); } pt = 1-ibeta(p,w,y); dp = -exp(LGAMMA(w+y)-LGAMMA(w)-LGAMMA(y)+(y-1)*th+(w+y-2)*log(p))/pt; dq = ((w-1)/p-(y-1)/(1-p))*dp; res[ZLIK] = log(pt); res[ZDLL] = -dp*p*(1-p); res[ZDDLL]= (dq-dp*dp)*p*p*(1-p)*(1-p)+dp*(1-2*p)*p*(1-p); res[ZDDLL]= -res[ZDDLL]; return(LF_OK); } else { res[ZLIK] = (y+w)*log((y/w+1)/(mean+1)); if (y>0) res[ZLIK] += y*log(w*mean/y); if (link==LLOG) { res[ZDLL] = (y-w*mean)*p; res[ZDDLL]= (y+w)*p*(1-p); return(LF_OK); } if (link==LIDENT) { res[ZDLL] = (y-w*mean)/(mean*(1+mean)); res[ZDDLL]= w/(mean*(1+mean)); return(LF_OK); } } ERROR(("link %d invalid for geometric family",link)); return(LF_LNK); } int famweib(double y, double mean, double th, int link, double *res, int cens, double w) /* famweib(y,mean,th,link,res,cens,w) double y, mean, th, *res, w; int link, cens; */ { double yy; yy = pow(y,w); if (link==LINIT) { res[ZDLL] = MAX(yy,0.0); return(LF_OK); } if (cens) { res[ZLIK] = -yy/mean; res[ZDLL] = res[ZDDLL] = yy/mean; return(LF_OK); } res[ZLIK] = 1-yy/mean-th; if (yy>0) res[ZLIK] += log(w*yy); res[ZDLL] = -1+yy/mean; res[ZDDLL]= yy/mean; return(LF_OK); } int famcirc(double y, double mean, double th, int link, double *res, int cens, double w) /* famcirc(y,mean,th,link,res,cens,w) double y, mean, th, *res, w; int link, cens; */ { if (link==LINIT) { res[ZDLL] = w*sin(y); res[ZLIK] = w*cos(y); return(LF_OK); } res[ZDLL] = w*sin(y-mean); res[ZDDLL]= w*cos(y-mean); res[ZLIK] = res[ZDDLL]-w; return(LF_OK); } /* void robustify(res,rs) double *res, rs; { double sc, z; sc = rs*HUBERC; if (res[ZLIK] > -sc*sc/2) return; z = sqrt(-2*res[ZLIK]); res[ZDDLL]= -sc*res[ZDLL]*res[ZDLL]/(z*z*z)+sc*res[ZDDLL]/z; res[ZDLL]*= sc/z; res[ZLIK] = sc*sc/2-sc*z; } */ void robustify(double *res, double rs) /* robustify(res,rs) double *res, rs; */ { double sc, z; sc = rs*HUBERC; if (res[ZLIK] > -sc*sc/2) { res[ZLIK] /= sc*sc; res[ZDLL] /= sc*sc; res[ZDDLL] /= sc*sc; return; } z = sqrt(-2*res[ZLIK]); res[ZDDLL]= (-sc*res[ZDLL]*res[ZDLL]/(z*z*z)+sc*res[ZDDLL]/z)/(sc*sc); res[ZDLL]*= 1.0/(z*sc); res[ZLIK] = 0.5-z/sc; } double lf_link(double y, int lin) /* lf_link(y,lin) double y; int lin; */ { switch(lin) { case LIDENT: return(y); case LLOG: return(log(y)); case LLOGIT: return(logit(y)); case LINVER: return(1/y); case LSQRT: return(sqrt(fabs(y))); case LASIN: return(asin(sqrt(y))); } ERROR(("link: unknown link %d",lin)); return(0.0); } double invlink(double th, int lin) /* invlink(th,lin) double th; int lin; */ { switch(lin) { case LIDENT: return(th); case LLOG: return(lf_exp(th)); case LLOGIT: return(expit(th)); case LINVER: return(1/th); case LSQRT: return(th*fabs(th)); case LASIN: return(sin(th)*sin(th)); case LINIT: return(0.0); } ERROR(("invlink: unknown link %d",lin)); return(0.0); } /* the link and various related functions */ int links(double th, double y, int fam, int link, double *res, int c, double w, double rs) /* links(th,y,fam,link,res,c,w,rs) double th, y, *res, w, rs; int fam, link, c; */ { double mean; int st; mean = res[ZMEAN] = invlink(th,link); if (lf_error) return(LF_LNK); switch(fam&63) { case THAZ: case TDEN: case TRAT: return(famdens(mean,th,link,res,c,w)); case TGAUS: st = famgaus(y,mean,th,link,res,c,w); break; case TLOGT: st = fambino(y,mean,th,link,res,c,w); break; case TRBIN: return(famrbin(y,mean,th,link,res,c,w)); case TPROB: case TPOIS: st = fampois(y,mean,th,link,res,c,w); break; case TGAMM: st = famgamm(y,mean,th,link,res,c,w); break; case TGEOM: st = famgeom(y,mean,th,link,res,c,w); break; case TWEIB: return(famweib(y,mean,th,link,res,c,w)); case TCIRC: st = famcirc(y,mean,th,link,res,c,w); break; case TROBT: return(famrobu(y,mean,th,link,res,c,w,rs)); case TCAUC: return(famcauc(y,mean,th,link,res,c,w,rs)); default: ERROR(("links: invalid family %d",fam)); return(LF_FAM); } if (st!=LF_OK) return(st); if (link==LINIT) return(st); if ((fam&128)==128) robustify(res,rs); return(st); } /* stdlinks is a version of links when family, link, response e.t.c all come from the standard places. */ int stdlinks(double *res, lfdata *lfd, smpar *sp, int i, double th, double rs) /* stdlinks(res,lfd,sp,i,th,rs) lfdata *lfd; smpar *sp; double th, rs, *res; int i; */ { return(links(th,resp(lfd,i),fam(sp),link(sp),res,cens(lfd,i),prwt(lfd,i),rs)); } /* * functions used in variance, skewness, kurtosis calculations * in scb corrections. */ double b2(double th, int tg, double w) /* b2(th,tg,w) double th, w; int tg; */ { double y; switch(tg&63) { case TGAUS: return(w); case TPOIS: return(w*lf_exp(th)); case TLOGT: y = expit(th); return(w*y*(1-y)); } ERROR(("b2: invalid family %d",tg)); return(0.0); } double b3(double th, int tg, double w) /* b3(th,tg,w) double th, w; int tg; */ { double y; switch(tg&63) { case TGAUS: return(0.0); case TPOIS: return(w*lf_exp(th)); case TLOGT: y = expit(th); return(w*y*(1-y)*(1-2*y)); } ERROR(("b3: invalid family %d",tg)); return(0.0); } double b4(double th, int tg, double w) /* b4(th,tg,w) double th, w; int tg; */ { double y; switch(tg&63) { case TGAUS: return(0.0); case TPOIS: return(w*lf_exp(th)); case TLOGT: y = expit(th); y = y*(1-y); return(w*y*(1-6*y)); } ERROR(("b4: invalid family %d",tg)); return(0.0); } locfit/src/m_solve.c0000754000176200001440000000655414745736322014162 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * solve f(x)=c by various methods, with varying stability etc... * xlo and xhi should be initial bounds for the solution. * convergence criterion is |f(x)-c| < tol. * * double solve_secant(f,c,xlo,xhi,tol,bd_flag,err) * secant method solution of f(x)=c. * xlo and xhi are starting values and bound for solution. * tol = convergence criterion, |f(x)-c| < tol. * bd_flag = if (xlo,xhi) doesn't bound a solution, what action to take? * BDF_NONE returns error. * BDF_EXPRIGHT increases xhi. * BDF_EXPLEFT decreases xlo. * err = error flag. * The (xlo,xhi) bound is not formally necessary for the secant method. * But having such a bound vastly improves stability; the code performs * a bisection step whenever the iterations run outside the bounds. * * double solve_nr(f,f1,c,x0,tol,err) * Newton-Raphson solution of f(x)=c. * f1 = f'(x). * x0 = starting value. * tol = convergence criteria, |f(x)-c| < tol. * err = error flag. * No stability checks at present. * * double solve_fp(f,x0,tol) * fixed-point iteration to solve f(x)=x. * x0 = starting value. * tol = convergence criteria, stops when |f(x)-x| < tol. * Convergence requires |f'(x)|<1 in neighborhood of true solution; * f'(x) \approx 0 gives the fastest convergence. * No stability checks at present. * * TODO: additional error checking, non-convergence stop. */ #include #include #include #include "mutil.h" double solve_secant(double (*f)(), double c, double xlo, double xhi, double tol, int bd_flag, int *err) /* double solve_secant(f,c,xlo,xhi,tol,bd_flag,err) double (*f)(), c, xhi, xlo, tol; int bd_flag, *err; */ { double ylo, yhi, x1, x2, x, y1, y2, y; *err = 0; ylo = f(xlo)-c; yhi = f(xhi)-c; switch(bd_flag) { case BDF_EXPRIGHT: while (yhi*ylo > 0) { x1 = xhi + (xhi-xlo); y1 = f(x1) - c; xlo = xhi; xhi = x1; ylo = yhi; yhi = y1; } break; case BDF_EXPLEFT: while (yhi*ylo > 0) { x1 = xlo - (xhi-xlo); y1 = f(x1) - c; xhi = xlo; xlo = x1; yhi = ylo; ylo = y1; } break; case BDF_NONE: default: if (yhi*ylo > 0) { *err = 1; return((xlo+xhi)/2); } break; } x1 = xlo; y1 = ylo; x2 = xhi; y2 = yhi; while (1) { x = x2 + (x1-x2)*y2/(y2-y1); if ((x<=xlo) | (x>=xhi)) x = (xlo+xhi)/2; y = f(x)-c; if (fabs(y) < tol) return(x); if (y*ylo>0) { xlo = x; ylo = y; } else { xhi = x; yhi = y; } if (y2==y) { Rprintf("secant: y2 %12.9f\n",y2); return(x); } x1 = x2; y1 = y2; x2 = x; y2 = y; } } double solve_nr(double (*f)(), double (*f1)(), double c, double x0, double tol, int *err) /* double solve_nr(f,f1,c,x0,tol,err) double (*f)(), (*f1)(), c, x0, tol; int *err; */ { double y; do { y = f(x0)-c; x0 -= y/f1(x0); } while (fabs(y)>tol); return(x0); } double solve_fp(double (*f)(), double x0, double tol, int maxit) /* double solve_fp(f,x0,tol,maxit) double (*f)(), x0, tol; int maxit; */ { double x1=0.0; int i; for (i=0; i */ #include "local.h" extern int deitype(char *); /* in lfstr.c */ static design des; static lfit lf; int lf_error; #ifdef RVERSION typedef char * CALL_S_FUNC; typedef void * CALL_S_ARGS; #else typedef void * CALL_S_FUNC; typedef char * CALL_S_ARGS; #endif typedef long int CALL_S_LEN; typedef long int CALL_S_NARG; typedef char * CALL_S_MODE; typedef long int CALL_S_NRES; typedef char * CALL_S_VALS; static CALL_S_FUNC bsfunc, bsf2; #ifdef OLD void basis(x,t,f,dim,p) double *x, *t, *f; Sint dim, p; { CALL_S_ARGS args[2]; CALL_S_LEN length[2]; CALL_S_NARG nargs; CALL_S_MODE mode[2]; CALL_S_NRES nres; CALL_S_VALS values[1]; /* double z0[1], z1[1], *vptr; */ double *vptr; int i; args[0] = (CALL_S_ARGS)x; mode[0] = "double"; length[0] = dim; args[1] = (CALL_S_ARGS)t; mode[1] = "double"; length[1] = dim; nargs = 2; nres = 1; call_S(bsfunc,nargs,args,mode,length,(char **)NULL,nres,values); vptr = (double *)values[0]; for (i=0; i= R_Version(4, 5, 0) PROTECT(pcall = call = allocLang(d + 5)); #else PROTECT(pcall = call = allocList(d + 5)); SET_TYPEOF(call, LANGSXP); #endif SETCAR(pcall, (SEXP) bsf2); pcall = CDR(pcall); SETCAR(pcall, ScalarInteger(d)); pcall = CDR(pcall); SETCAR(pcall, allocVector(INTSXP, m)); memmove(INTEGER(CAR(pcall)), ind, m * sizeof(int)); pcall = CDR(pcall); SETCAR(pcall, allocVector(REALSXP, d)); memmove(REAL(CAR(pcall)), t, d * sizeof(double)); for (int i = 0 ; i < d ; i++) { pcall = CDR(pcall); SETCAR(pcall, allocVector(REALSXP, n)); memmove(REAL(CAR(pcall)), x[i], n * sizeof(double)); } PROTECT(s = eval(call, R_GlobalEnv)); memmove(X, REAL(s), m * p * sizeof(double)); UNPROTECT(2); } #endif static void setevs(evstruc *evs, Sint *mi, double cut, int *mg, double *flim) /* evstruc *evs; int *mg; Sint *mi; double cut, *flim; */ { double *ll, *ur; int i, d; ev(evs) = mi[MEV]; mk(evs) = mi[MK]; d = mi[MDIM]; if (flim != NULL) { ll = flim; ur = &flim[d]; memmove(evs->fl,ll,d*sizeof(double)); memmove(&evs->fl[d],ur,d*sizeof(double)); } switch(ev(evs)) { case ETREE: case EKDTR: case EKDCE: case EPHULL: cut(evs) = cut; return; case EGRID: for (i=0; img[i] = mg[i]; return; case ESPHR: for (i=0; i<2; i++) evs->mg[i] = mg[i]; return; case EDATA: case ECROS: case EPRES: case EXBAR: case ENONE: return; default: printf("setevs: %2d not defined.\n",ev(evs)); } } static void setdata(lfdata *lfd, double *x, double *y, double *c, double *w, double *b, Sint n, Sint d, double *sca, Sint *sty) /* lfdata *lfd; double *x, *y, *c, *w, *b, *sca; Sint n, d, *sty; */ { int i; for (i=0; isca[i] = sca[i]; lfd->sty[i] = sty[i]; } lfd->y = y; lfd->w = w; lfd->b = b; lfd->c = c; lfd->n = n; lfd->d = d; lfd->ord = 0; } static void setsmpar(smpar *sp, double *dp, Sint *mi) /* smpar *sp; double *dp; Sint *mi; */ { nn(sp) = dp[DALP]; fixh(sp)= dp[DFXH]; pen(sp) = dp[DADP]; ker(sp) = mi[MKER]; kt(sp) = mi[MKT]; acri(sp)= mi[MACRI]; deg(sp) = mi[MDEG]; deg0(sp) = mi[MDEG0]; fam(sp) = mi[MTG]; link(sp) = mi[MLINK]; ubas(sp) = mi[MUBAS]; npar(sp) = mi[MP]; lf.sp.vbasis = vbasis; } static void slocfit(double *x, double *y, double *c, double *w, double *b, double *lim, Sint *mi, double *dp, char **str, double *sca, double *xev, double *wdes, double *wtre, double *wpc, Sint *nvc, Sint *iwk1, Sint *iwk2, Sint *lw, Sint *mg, double *L, double *kap, Sint *dv, Sint *nd, Sint *sty) /* double *x, *y, *c, *w, *b, *lim, *dp, *sca, *xev, *L, *kap, *wdes, *wtre, *wpc; Sint *mi, *nvc, *iwk1, *iwk2, *lw, *mg, *dv, *nd, *sty; char **str; */ /* CALL_S_FUNC *bs; */ { Sint n, d, i; mi[MKER] = lfkernel(str[0]); mi[MTG] = lffamily(str[1]); mi[MLINK]= lflink(str[2]); mi[MIT] = deitype(str[3]); mi[MACRI]= lfacri(str[4]); mi[MKT] = lfketype(str[5]); /* if (mi[MUBAS]) { bsfunc = bs[0]; bsf2 = bs[1]; } */ lf_error = 0; n = mi[MN]; d = mi[MDIM]; lfit_alloc(&lf); setdata(&lf.lfd,x,y,c,w,b,n,d,sca,sty); setsmpar(&lf.sp,dp,mi); setevs(&lf.evs,mi,dp[DCUT],mg,&lim[2*d]); lf_maxit = mi[MMXIT]; lf_debug = mi[MDEB]; de_mint = mi[MMINT]; de_itype = mi[MIT]; de_renorm= mi[MREN]; dc(&lf.fp) = mi[MDC]; geth(&lf.fp)=mi[MGETH]; des.wk = wdes; des.lwk = lw[0]; des.ind= iwk2; des.lind = lw[6]; des.des_init_id = DES_INIT_ID; lf.fp.xev = xev; lf.fp.lev = d*nvc[0]; lf.fp.coef= wtre; lf.fp.lwk = lw[1]; lf.pc.wk = wpc; lf.pc.lwk = lw[3]; lf.evs.iwk = iwk1; lf.evs.liw = lw[2]; lf.fp.L = L; lf.fp.ll = lw[4]; lf.fp.nvm = nvc[0]; lf.dv.nd = *nd; for (i=0; i= 70) scb(&des,&lf); else switch(mi[MGETH]) { case GSTD: /* the standard fit */ case GAMF: /* for gam.lf, return residuals */ case GAMP: /* for gam.lf prediction */ if (mi[MDEG0]==mi[MDEG]) { startlf(&des,&lf,procv,0); if (!lf_error) ressumm(&lf,&des); } else startlf(&des,&lf,procvvord,0); break; case GSMP: startlf(&des,&lf,procvraw,0); break; case GHAT: startlf(&des,&lf,procvhatm,(int)mi[MKER]!=WPARM); break; case GKAP: constants(&des,&lf); for(i=0; i0) | dc(&lf.fp); switch(mi[MEV]) { case ETREE: case EKDTR: case EGRID: case ESPHR: vc = 1<= 70) { lw[4] = k0_reqd(d,n,0); if (lw[4]<2*nvm) lw[4] = 2*nvm; lw[5] = d+1; } else switch(mi[MGETH]) { case GSTD: lw[4] = 1; break; /* standard fit */ case GSMP: lw[4] = 1; break; /* simple fit */ case GHAT: lw[4] = nvm*n; break; /* hat matrix */ case GKAP: lw[4] = k0_reqd(d,n,0); /* kappa0 */ lw[5] = 1+d; break; case GRBD: lw[5] = 10; /* regband */ case GAMF: /* gam.lf fit */ case GAMP: lw[4] = 1; break; /* gam.lf pred */ case GLSC: lw[4] = 2; break; /* lscv */ default: printf("sguessnv: invalid geth\n"); lw[4] = 0; } nvc[0] = nvm; nvc[1] = ncm; nvc[2] = vc; nvc[3] = nvc[4] = 0; } /* Registration added Mar 2012 */ #include /* From smisc.c */ void kdeb(double *x, int *mi, double*band, int *ind, double *h0, double *h1, int *meth, int *nmeth, int *ker); void scritval(double *k0, int *d, double *cov, int *m, double *rdf, double *z, int *k); void slscv(double *x, int *n, double *h, double *z); static const R_CMethodDef CEntries[] = { {"guessnv", (DL_FUNC) &guessnv, 6}, {"slocfit", (DL_FUNC) &slocfit, 24}, {"sfitted", (DL_FUNC) &sfitted, 23}, {"spreplot", (DL_FUNC) &spreplot, 20}, {"triterm", (DL_FUNC) &triterm, 12}, {"kdeb", (DL_FUNC) &kdeb, 9}, {"slscv", (DL_FUNC) &slscv, 4}, {"scritval", (DL_FUNC) &scritval, 7}, {NULL, NULL, 0} }; void R_init_locfit(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } locfit/src/weight.c0000754000176200001440000003163114745737325014003 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * Defines the weight functions and related quantities used * in LOCFIT. */ #include "local.h" /* The weight functions themselves. Used everywhere. */ double W(double u, int ker) /* W(u,ker) double u; int ker; */ { u = fabs(u); switch(ker) { case WRECT: return((u>1) ? 0.0 : 1.0); case WEPAN: return((u>1) ? 0.0 : 1-u*u); case WBISQ: if (u>1) return(0.0); u = 1-u*u; return(u*u); case WTCUB: if (u>1) return(0.0); u = 1-u*u*u; return(u*u*u); case WTRWT: if (u>1) return(0.0); u = 1-u*u; return(u*u*u); case WQUQU: if (u>1) return(0.0); u = 1-u*u; return(u*u*u*u); case WTRIA: if (u>1) return(0.0); return(1-u); case W6CUB: if (u>1) return(0.0); u = 1-u*u*u; u = u*u*u; return(u*u); case WGAUS: return(exp(-SQR(GFACT*u)/2.0)); case WEXPL: return(exp(-EFACT*u)); case WMACL: return(1/((u+1.0e-100)*(u+1.0e-100))); case WMINM: ERROR(("WMINM in W")); return(0.0); case WPARM: return(1.0); } ERROR(("W(): Unknown kernel %d\n",ker)); return(1.0); } int iscompact(int ker) /* iscompact(ker) int ker; */ { if ((ker==WEXPL) | (ker==WGAUS) | (ker==WMACL) | (ker==WPARM)) return(0); return(1); } double weightprod(lfdata *lfd, double *u, double h, int ker) /* weightprod(lfd,u,h,ker) lfdata *lfd; double *u, h; int ker; */ { int i; double sc, w; w = 1.0; for (i=0; id; i++) { sc = lfd->sca[i]; switch(lfd->sty[i]) { case STLEFT: if (u[i]>0) return(0.0); w *= W(-u[i]/(h*sc),ker); break; case STRIGH: if (u[i]<0) return(0.0); w *= W(u[i]/(h*sc),ker); break; case STANGL: w *= W(2*fabs(sin(u[i]/(2*sc)))/h,ker); break; case STCPAR: break; default: w *= W(fabs(u[i])/(h*sc),ker); } if (w==0.0) return(w); } return(w); } double weightsph(lfdata *lfd, double *u, double h, int ker, int hasdi, double di) /* weightsph(lfd,u,h,ker,hasdi,di) lfdata *lfd; double *u, h, di; int ker, hasdi; */ { int i; if (!hasdi) di = rho(u,lfd->sca,lfd->d,KSPH,lfd->sty); for (i=0; id; i++) { if ((lfd->sty[i]==STLEFT) && (u[i]>0.0)) return(0.0); if ((lfd->sty[i]==STRIGH) && (u[i]<0.0)) return(0.0); } if (h==0) return((di==0.0) ? 1.0 : 0.0); return(W(di/h,ker)); } double weight(lfdata *lfd, smpar *sp, double *x, double *t, double h, int hasdi, double di) /* weight(lfd,sp,x,t,h,hasdi,di) lfdata *lfd; smpar *sp; double *x, *t, h, di; int hasdi; */ { double u[MXDIM]; int i; for (i=0; id; i++) u[i] = (t==NULL) ? x[i] : x[i]-t[i]; switch(kt(sp)) { case KPROD: return(weightprod(lfd,u,h,ker(sp))); case KSPH: return(weightsph(lfd,u,h,ker(sp), hasdi,di)); } ERROR(("weight: unknown kernel type %d",kt(sp))); return(1.0); } double sgn(double x) /* sgn(x) double x; */ { if (x>0) return(1.0); if (x<0) return(-1.0); return(0.0); } double WdW(double u, int ker) /* W'(u)/W(u) */ /* WdW(u,ker) double u; int ker; */ { double eps=1.0e-10; if (ker==WGAUS) return(-GFACT*GFACT*u); if (ker==WPARM) return(0.0); if (fabs(u)>=1) return(0.0); switch(ker) { case WRECT: return(0.0); case WTRIA: return(-sgn(u)/(1-fabs(u)+eps)); case WEPAN: return(-2*u/(1-u*u+eps)); case WBISQ: return(-4*u/(1-u*u+eps)); case WTRWT: return(-6*u/(1-u*u+eps)); case WTCUB: return(-9*sgn(u)*u*u/(1-u*u*fabs(u)+eps)); case WEXPL: return((u>0) ? -EFACT : EFACT); } ERROR(("WdW: invalid kernel")); return(0.0); } /* deriv. weights .. spherical, product etc u, sc, sty needed only in relevant direction Acutally, returns (d/dx W(||x||/h) ) / W(.) */ double weightd(double u, double sc, int d, int ker, int kt, double h, int sty, double di) /* weightd(u,sc,d,ker,kt,h,sty,di) double u, sc, h, di; int d, ker, kt, sty; */ { if (sty==STANGL) { if (kt==KPROD) return(-WdW(2*sin(u/(2*sc)),ker)*cos(u/(2*sc))/(h*sc)); if (di==0.0) return(0.0); return(-WdW(di/h,ker)*sin(u/sc)/(h*sc*di)); } if (sty==STCPAR) return(0.0); if (kt==KPROD) return(-WdW(u/(h*sc),ker)/(h*sc)); if (di==0.0) return(0.0); return(-WdW(di/h,ker)*u/(h*di*sc*sc)); } double weightdd(double *u, double *sc, int d, int ker, int kt, double h, int *sty, double di, int i0, int i1) /* weightdd(u,sc,d,ker,kt,h,sty,di,i0,i1) double *u, *sc, h, di; int d, ker, kt, i0, i1, *sty; */ { /* double w; w = 1; if (kt==KPROD) { w = WdW(u[i0]/(h*sc[i0]),ker)*WdW(u[i1]/(h*sc[i1]),ker)/(h*h*sc[i0]*sc[i1]); } */ return(0.0); } /* Derivatives W'(u)/u. Used in simult. conf. band computations, and kernel density bandwidth selectors. */ double Wd(double u, int ker) /* Wd(u,ker) double u; int ker; */ { double v; if (ker==WGAUS) return(-SQR(GFACT)*exp(-SQR(GFACT*u)/2)); if (ker==WPARM) return(0.0); if (fabs(u)>1) return(0.0); switch(ker) { case WEPAN: return(-2.0); case WBISQ: return(-4*(1-u*u)); case WTCUB: v = 1-u*u*u; return(-9*v*v*u); case WTRWT: v = 1-u*u; return(-6*v*v); default: ERROR(("Invalid kernel %d in Wd",ker)); } return(0.0); } /* Second derivatives W''(u)-W'(u)/u. used in simult. conf. band computations in >1 dimension. */ double Wdd(double u, int ker) /* Wdd(u,ker) double u; int ker; */ { double v; if (ker==WGAUS) return(SQR(u*GFACT*GFACT)*exp(-SQR(u*GFACT)/2)); if (ker==WPARM) return(0.0); if (u>1) return(0.0); switch(ker) { case WBISQ: return(12*u*u); case WTCUB: v = 1-u*u*u; return(-9*u*v*v+54*u*u*u*u*v); case WTRWT: return(24*u*u*(1-u*u)); default: ERROR(("Invalid kernel %d in Wdd",ker)); } return(0.0); } /* int u1^j1..ud^jd W(u) du. Used for local log-linear density estimation. Assume all j_i are even. Also in some bandwidth selection. */ double wint(int d, int *j, int nj, int ker) /* wint(d,j,nj,ker) int d, *j, nj, ker; */ { double I=0.0, z, dj_d; int k, dj; dj = d; for (k=0; k2) return(0.0); return(2-v); case WEPAN: v = fabs(v); if (v>2) return(0.0); return((2-v)*(16+v*(8-v*(16-v*(2+v))))/30); case WBISQ: v = fabs(v); if (v>2) return(0.0); v2 = 2-v; return(v2*v2*v2*v2*v2*(16+v*(40+v*(36+v*(10+v))))/630); } ERROR(("Wconv not implemented for kernel %d",ker)); return(0.0); } /* derivative of Wconv. 1/v d/dv int W(x)W(x+v)dx used in kde bandwidth selection. */ double Wconv1(double v, int ker) /* Wconv1(v,ker) double v; int ker; */ { double v2; v = fabs(v); switch(ker) { case WGAUS: return(-0.5*SQRPI*GFACT*exp(-SQR(GFACT*v)/4)); case WRECT: if (v>2) return(0.0); return(1.0); case WEPAN: if (v>2) return(0.0); return((-16+v*(12-v*v))/6); case WBISQ: if (v>2) return(0.0); v2 = 2-v; return(-v2*v2*v2*v2*(32+v*(64+v*(24+v*3)))/210); } ERROR(("Wconv1 not implemented for kernel %d",ker)); return(0.0); } /* 4th derivative of Wconv. used in kde bandwidth selection (BCV, SJPI, GKK) */ double Wconv4(double v, int ker) /* Wconv4(v,ker) double v; int ker; */ { double gv; switch(ker) { case WGAUS: gv = GFACT*v; return(exp(-SQR(gv)/4)*GFACT*GFACT*GFACT*(12-gv*gv*(12-gv*gv))*SQRPI/16); } ERROR(("Wconv4 not implemented for kernel %d",ker)); return(0.0); } /* 5th derivative of Wconv. used in kde bandwidth selection (BCV method only) */ double Wconv5(double v, int ker) /* Wconv5(v,ker) double v; int ker; */ { double gv; switch(ker) { case WGAUS: gv = GFACT*v; return(-exp(-SQR(gv)/4)*GFACT*GFACT*GFACT*GFACT*gv*(60-gv*gv*(20-gv*gv))*SQRPI/32); } ERROR(("Wconv5 not implemented for kernel %d",ker)); return(0.0); } /* 6th derivative of Wconv. used in kde bandwidth selection (SJPI) */ double Wconv6(double v, int ker) /* Wconv6(v,ker) double v; int ker; */ { double gv, z; switch(ker) { case WGAUS: gv = GFACT*v; gv = gv*gv; z = exp(-gv/4)*(-120+gv*(180-gv*(30-gv)))*0.02769459142; gv = GFACT*GFACT; return(z*gv*gv*GFACT); } ERROR(("Wconv6 not implemented for kernel %d",ker)); return(0.0); } /* int W(v)^2 dv / (int v^2 W(v) dv)^2 used in some bandwidth selectors */ double Wikk(int ker, int deg) /* Wikk(ker,deg) int ker, deg; */ { switch(deg) { case 0: case 1: /* int W(v)^2 dv / (int v^2 W(v) dv)^2 */ switch(ker) { case WRECT: return(4.5); case WEPAN: return(15.0); case WBISQ: return(35.0); case WGAUS: return(0.2820947918*GFACT*GFACT*GFACT*GFACT*GFACT); case WTCUB: return(34.15211105); case WTRWT: return(66.08391608); } case 2: case 3: /* 4!^2/8*int(W1^2)/int(v^4W1)^2 W1=W*(n4-v^2n2)/(n0n4-n2n2) */ switch(ker) { case WRECT: return(11025.0); case WEPAN: return(39690.0); case WBISQ: return(110346.9231); case WGAUS: return(14527.43412); case WTCUB: return(126500.5904); case WTRWT: return(254371.7647); } } ERROR(("Wikk not implemented for kernel %d",ker)); return(0.0); } locfit/src/lf_wdiag.c0000754000176200001440000001372414745735427014274 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * Routines for computing weight diagrams. * wdiag(lf,des,lx,deg,ty,exp) * Must locfit() first, unless ker==WPARM and has par. comp. * */ #include "local.h" static double *wd; extern double robscale; void nnresproj(lfdata *lfd, smpar *sp, design *des, double *u, int m, int p) /*lfdata *lfd; smpar *sp; design *des; double *u; int m, p;*/ { int i, j; double link[LLEN]; setzero(des->f1,p); for (j=0; jind[j],des->th[j],robscale); for (i=0; if1[i] += link[ZDDLL]*d_xij(des,j,i)*u[j]; } jacob_solve(&des->xtwx,des->f1); for (i=0; if1,d_xi(des,i),p)*des->w[i]; } void wdexpand(double *l, int n, Sint *ind, int m) /*double *l; Sint *ind; int n, m;*/ { int i, j, t; double z; for (j=m; j=0) { if (ind[j]==j) j--; else { i = ind[j]; z = l[j]; l[j] = l[i]; l[i] = z; t = ind[j]; ind[j] = ind[i]; ind[i] = t; if (ind[j]==-1) j--; } } /* for (i=n-1; i>=0; i--) { l[i] = ((j>=0) && (ind[j]==i)) ? l[j--] : 0.0; } */ } int wdiagp(lfdata *lfd, smpar *sp, design *des, double *lx, paramcomp *pc, deriv *dv, int deg, int ty, int exp) /*lfdata *lfd; smpar *sp; design *des; paramcomp *pc; deriv *dv; double *lx; int deg, ty, exp;*/ { int i, j, p, nd; double *l1; p = des->p; fitfun(lfd,sp,des->xev,pc->xbar,des->f1,dv); if (exp) { jacob_solve(&pc->xtwx,des->f1); for (i=0; in; i++) lx[i] = innerprod(des->f1,d_xi(des,i),p); return(lfd->n); } jacob_hsolve(&pc->xtwx,des->f1); for (i=0; if1[i]; nd = dv->nd; dv->nd = nd+1; if (deg>=1) for (i=0; id; i++) { dv->deriv[nd] = i; l1 = &lx[(i+1)*p]; fitfun(lfd,sp,des->xev,pc->xbar,l1,dv); jacob_hsolve(&pc->xtwx,l1); } dv->nd = nd+2; if (deg>=2) for (i=0; id; i++) { dv->deriv[nd] = i; for (j=0; jd; j++) { dv->deriv[nd+1] = j; l1 = &lx[(i*lfd->d+j+lfd->d+1)*p]; fitfun(lfd,sp,des->xev,pc->xbar,l1,dv); jacob_hsolve(&pc->xtwx,l1); } } dv->nd = nd; return(p); } int wdiag(lfdata *lfd, smpar *sp, design *des, double *lx, deriv *dv, int deg, int ty, int exp) /*lfdata *lfd; smpar *sp; design *des; deriv *dv; double *lx; int deg, ty, exp;*/ { double w, *X, *lxd=NULL, *lxdd=NULL, wdd, wdw, *ulx, link[LLEN], h; double dfx[MXDIM], hs[MXDIM]; int i, ii, j, k, l, m, d, p, nd; h = des->h; nd = dv->nd; wd = des->wd; d = lfd->d; p = des->p; X = d_x(des); ulx = des->res; m = des->n; for (i=0; isca[i]; if (deg>0) { lxd = &lx[m]; setzero(lxd,m*d); if (deg>1) { lxdd = &lxd[d*m]; setzero(lxdd,m*d*d); } } if (nd>0) fitfun(lfd,sp,des->xev,des->xev,des->f1,dv); /* c(0) */ else unitvec(des->f1,0,p); jacob_solve(&des->xtwx,des->f1); /* c(0) (X^TWX)^{-1} */ for (i=0; iind[i]; lx[i] = innerprod(des->f1,&X[i*p],p); /* c(0)(XTWX)^{-1}X^T */ if (deg>0) { wd[i] = Wd(des->di[ii]/h,ker(sp)); for (j=0; jxev[j]; lxd[j*m+i] = lx[i]*des->w[i]*weightd(dfx[j],lfd->sca[j], d,ker(sp),kt(sp),h,lfd->sty[j],des->di[ii]); /* c(0) (XTWX)^{-1}XTW' */ } if (deg>1) { wdd = Wdd(des->di[ii]/h,ker(sp)); for (j=0; jdi[ii]==0) ? 0 : h/des->di[ii]; w = wdd * (des->xev[k]-datum(lfd,k,ii)) * (des->xev[j]-datum(lfd,j,ii)) * w*w / (hs[k]*hs[k]*hs[j]*hs[j]); if (j==k) w += wd[i]/(hs[j]*hs[j]); lxdd[(j*d+k)*m+i] = lx[i]*w; /* c(0)(XTWX)^{-1}XTW'' */ } } } lx[i] *= des->w[i]; } dv->nd = nd+1; if (deg==2) { for (i=0; ideriv[nd] = i; fitfun(lfd,sp,des->xev,des->xev,des->f1,dv); for (k=0; kind[k],des->th[k],robscale); for (j=0; jf1[j] -= link[ZDDLL]*lxd[i*m+k]*X[k*p+j]; /* c'(x)-c(x)(XTWX)^{-1}XTW'X */ } jacob_solve(&des->xtwx,des->f1); /* (...)(XTWX)^{-1} */ for (j=0; jf1,&X[j*p],p); /* (...)XT */ for (j=0; jind[k]; dfx[j] = datum(lfd,j,ii)-des->xev[j]; wdw = des->w[k]*weightd(dfx[j],lfd->sca[j],d,ker(sp), kt(sp),h,lfd->sty[j],des->di[ii]); lxdd[(i*d+j)*m+k] += ulx[k]*wdw; lxdd[(j*d+i)*m+k] += ulx[k]*wdw; } /* + 2(c'-c(XTWX)^{-1}XTW'X)(XTWX)^{-1}XTW' */ } for (j=0; j0) { for (j=0; jderiv[nd]=i; fitfun(lfd,sp,des->xev,des->xev,des->f1,dv); jacob_solve(&des->xtwx,des->f1); for (k=0; kf1[l]*X[k*p+l]*des->w[k]; /* add c'(0)(XTWX)^{-1}XTW */ } } dv->nd = nd+2; if (deg==2) { for (i=0; ideriv[nd]=i; for (j=0; jderiv[nd+1]=j; fitfun(lfd,sp,des->xev,des->xev,des->f1,dv); jacob_solve(&des->xtwx,des->f1); for (k=0; kf1[l]*X[k*p+l]*des->w[k]; /* + c''(x)(XTWX)^{-1}XTW */ } } } dv->nd = nd; k = 1+d*(deg>0)+d*d*(deg==2); if (exp) wdexpand(lx,lfd->n,des->ind,m); if (ty==1) return(m); for (i=0; iind[i],des->th[i],robscale); link[ZDDLL] = sqrt(fabs(link[ZDDLL])); for (j=0; jlwk < rw) { pc->wk = (double *)calloc(rw,sizeof(double)); pc->lwk= rw; } z = pc->wk; pc->xbar = z; z += d; pc->coef = z; z += p; pc->f = z; z += p; z = jac_alloc(&pc->xtwx,p,z); pc->xtwx.p = p; } void compparcomp(design *des, lfdata *lfd, smpar *sp, paramcomp *pc, int geth, int nopc) /* void compparcomp(des, lfd, sp, pc, geth, nopc) design *des; lfdata *lfd; smpar *sp; paramcomp *pc; int geth; int nopc; */ { int i, j, k, p; double wt, sw; if (lf_debug>1) printf(" compparcomp:\n"); p = des->p; pcchk(pc,lfd->d,p,1); for (i=0; id; i++) pc->xbar[i] = 0.0; sw = 0.0; for (i=0; in; i++) { wt = prwt(lfd,i); sw += wt; for (j=0; jd; j++) pc->xbar[j] += datum(lfd,j,i)*wt; des->ind[i] = i; des->w[i] = 1.0; } for (i=0; id; i++) pc->xbar[i] /= sw; if ((nopc) || noparcomp(sp,geth)) { haspc(pc) = 0; return; } haspc(pc) = 1; des->xev = pc->xbar; k = locfit(lfd,des,sp,0,0,0); if (lf_error) return; switch(k) { case LF_NOPT: ERROR(("compparcomp: no points in dataset?")); return; case LF_INFA: ERROR(("compparcomp: infinite parameters in param. component")); return; case LF_NCON: ERROR(("compparcom: not converged")); return; case LF_OOB: ERROR(("compparcomp: parameters out of bounds")); return; case LF_PF: WARN(("compparcomp: perfect fit")); case LF_OK: for (i=0; icoef[i] = des->cf[i]; pc->xtwx.dg[i] = des->xtwx.dg[i]; pc->xtwx.wk[i] = des->xtwx.wk[i]; } for (i=0; ixtwx.Z[i] = des->xtwx.Z[i]; pc->xtwx.Q[i] = des->xtwx.Q[i]; } pc->xtwx.sm = des->xtwx.sm; pc->xtwx.st = des->xtwx.st; return; default: ERROR(("compparcomp: locfit unknown return status %d",k)); return; } } void subparcomp(design *des, lfit *lf, double *coef) /* void subparcomp(des, lf, coef) design *des; lfit *lf; double *coef; */ { int i, nd; deriv *dv; paramcomp *pc; pc = &lf->pc; if (!haspc(pc)) return; dv = &lf->dv; nd = dv->nd; fitfun(&lf->lfd, &lf->sp, des->xev,pc->xbar,des->f1,dv); coef[0] -= innerprod(pc->coef,des->f1,pc->xtwx.p); if (des->ncoef == 1) return; dv->nd = nd+1; for (i=0; ilfd.d; i++) { dv->deriv[nd] = i; fitfun(&lf->lfd, &lf->sp, des->xev,pc->xbar,des->f1,dv); coef[i+1] -= innerprod(pc->coef,des->f1,pc->xtwx.p); } dv->nd = nd; } void subparcomp2(design *des, lfit *lf, double *vr, double *il) /* void subparcomp2(des, lf, vr, il) design *des; lfit *lf; double *vr, *il; */ { double t0, t1; int i, nd; deriv *dv; paramcomp *pc; pc = &lf->pc; if (!haspc(pc)) return; dv = &lf->dv; nd = dv->nd; fitfun(&lf->lfd, &lf->sp, des->xev,pc->xbar,des->f1,dv); for (i=0; isp); i++) pc->f[i] = des->f1[i]; jacob_solve(&pc->xtwx,des->f1); t0 = sqrt(innerprod(pc->f,des->f1,pc->xtwx.p)); vr[0] -= t0; il[0] -= t0; if ((t0==0) | (des->ncoef==1)) return; dv->nd = nd+1; for (i=0; ilfd.d; i++) { dv->deriv[nd] = i; fitfun(&lf->lfd, &lf->sp, des->xev,pc->xbar,pc->f,dv); t1 = innerprod(pc->f,des->f1,pc->xtwx.p)/t0; vr[i+1] -= t1; il[i+1] -= t1; } dv->nd = nd; } double addparcomp(lfit *lf, double *x, int c) /* double addparcomp(lf, x, c) lfit *lf; double *x; int c; */ { double y; paramcomp *pc; pc = &lf->pc; if (!haspc(pc)) return(0.0); fitfun(&lf->lfd, &lf->sp, x,pc->xbar,pc->f,&lf->dv); if (c==PCOEF) return(innerprod(pc->coef,pc->f,pc->xtwx.p)); if ((c==PNLX)|(c==PT0)|(c==PVARI)) { y = sqrt(jacob_qf(&pc->xtwx,pc->f)); return(y); } return(0.0); } locfit/src/dbinom.c0000754000176200001440000002074414745733425013764 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include #include "mutil.h" /* stirlerr(n) = log(n!) - log( sqrt(2*pi*n)*(n/e)^n ) */ #define S0 0.083333333333333333333 /* 1/12 */ #define S1 0.00277777777777777777778 /* 1/360 */ #define S2 0.00079365079365079365079365 /* 1/1260 */ #define S3 0.000595238095238095238095238 /* 1/1680 */ #define S4 0.0008417508417508417508417508 /* 1/1188 */ /* error for 0, 0.5, 1.0, 1.5, ..., 14.5, 15.0. */ static double sferr_halves[31] = { 0.0, /* n=0 - wrong, place holder only */ 0.1534264097200273452913848, /* 0.5 */ 0.0810614667953272582196702, /* 1.0 */ 0.0548141210519176538961390, /* 1.5 */ 0.0413406959554092940938221, /* 2.0 */ 0.03316287351993628748511048, /* 2.5 */ 0.02767792568499833914878929, /* 3.0 */ 0.02374616365629749597132920, /* 3.5 */ 0.02079067210376509311152277, /* 4.0 */ 0.01848845053267318523077934, /* 4.5 */ 0.01664469118982119216319487, /* 5.0 */ 0.01513497322191737887351255, /* 5.5 */ 0.01387612882307074799874573, /* 6.0 */ 0.01281046524292022692424986, /* 6.5 */ 0.01189670994589177009505572, /* 7.0 */ 0.01110455975820691732662991, /* 7.5 */ 0.010411265261972096497478567, /* 8.0 */ 0.009799416126158803298389475, /* 8.5 */ 0.009255462182712732917728637, /* 9.0 */ 0.008768700134139385462952823, /* 9.5 */ 0.008330563433362871256469318, /* 10.0 */ 0.007934114564314020547248100, /* 10.5 */ 0.007573675487951840794972024, /* 11.0 */ 0.007244554301320383179543912, /* 11.5 */ 0.006942840107209529865664152, /* 12.0 */ 0.006665247032707682442354394, /* 12.5 */ 0.006408994188004207068439631, /* 13.0 */ 0.006171712263039457647532867, /* 13.5 */ 0.005951370112758847735624416, /* 14.0 */ 0.005746216513010115682023589, /* 14.5 */ 0.005554733551962801371038690 /* 15.0 */ }; double stirlerr(double n) { double nn; if (n<15.0) { nn = 2.0*n; if (nn==(int)nn) return(sferr_halves[(int)nn]); return(lgamma(n+1.0) - (n+0.5)*log((double)n)+n - HF_LG_PIx2); } nn = (double)n; nn = nn*nn; if (n>500) return((S0-S1/nn)/n); if (n>80) return((S0-(S1-S2/nn)/nn)/n); if (n>35) return((S0-(S1-(S2-S3/nn)/nn)/nn)/n); return((S0-(S1-(S2-(S3-S4/nn)/nn)/nn)/nn)/n); } double bd0(double x,double np) { double ej, s, s1, v; int j; if (fabs(x-np)<0.1*(x+np)) { s = (x-np)*(x-np)/(x+np); v = (x-np)/(x+np); ej = 2*x*v; v = v*v; for (j=1; ;++j) { ej *= v; s1 = s+ej/((j<<1)+1); if (s1==s) return(s1); s = s1; } } return(x*log(x/np)+np-x); } /* Raw binomial probability calculation. (1) This has both p and q arguments, when one may be represented more accurately than the other (in particular, in df()). (2) This should NOT check that inputs x and n are integers. This should be done in the calling function, where necessary. (3) Does not check for 0<=p<=1 and 0<=q<=1 or NaN's. Do this in the calling function. */ double dbinom_raw(double x, double n, double p, double q, int give_log) { double f, lc; if (p==0.0) return((x==0) ? D_1 : D_0); if (q==0.0) return((x==n) ? D_1 : D_0); if (x==0) { lc = (p<0.1) ? -bd0(n,n*q) - n*p : n*log(q); return( DEXP(lc) ); } if (x==n) { lc = (q<0.1) ? -bd0(n,n*p) - n*q : n*log(p); return( DEXP(lc) ); } if ((x<0) | (x>n)) return( D_0 ); lc = stirlerr(n) - stirlerr(x) - stirlerr(n-x) - bd0(x,n*p) - bd0(n-x,n*q); f = (PIx2*x*(n-x))/n; return( FEXP(f,lc) ); } double dbinom(int x, int n, double p, int give_log) { if ((p<0) | (p>1) | (n<0)) return(INVALID_PARAMS); if (x<0) return( D_0 ); return( dbinom_raw((double)x,(double)n,p,1-p,give_log) ); } /* Poisson probability lb^x exp(-lb) / x!. I don't check that x is an integer, since other functions that call dpois_raw() (i.e. dgamma) may use a fractional x argument. */ double dpois_raw(double x, double lambda, int give_log) { if (lambda==0) return( (x==0) ? D_1 : D_0 ); if (x==0) return( DEXP(-lambda) ); if (x<0) return( D_0 ); return(FEXP( PIx2*x, -stirlerr(x)-bd0(x,lambda) )); } double dpois(int x, double lambda,int give_log) { if (lambda<0) return(INVALID_PARAMS); if (x<0) return( D_0 ); return( dpois_raw((double)x,lambda,give_log) ); } double dbeta(double x, double a, double b, int give_log) { double f, p; if ((a<=0) | (b<=0)) return(INVALID_PARAMS); if ((x<=0) | (x>=1)) return(D_0); if (a<1) { if (b<1) /* a<1, b<1 */ { f = a*b/((a+b)*x*(1-x)); p = dbinom_raw(a,a+b,x,1-x,give_log); } else /* a<1, b>=1 */ { f = a/x; p = dbinom_raw(a,a+b-1,x,1-x,give_log); } } else { if (b<1) /* a>=1, b<1 */ { f = b/(1-x); p = dbinom_raw(a-1,a+b-1,x,1-x,give_log); } else /* a>=1, b>=1 */ { f = a+b-1; p = dbinom_raw(a-1,(a-1)+(b-1),x,1-x,give_log); } } return( (give_log) ? p + log(f) : p*f ); } /* * To evaluate the F density, write it as a Binomial probability * with p = x*m/(n+x*m). For m>=2, use the simplest conversion. * For m<2, (m-2)/2<0 so the conversion will not work, and we must use * a second conversion. Note the division by p; this seems unavoidable * for m < 2, since the F density has a singularity as x (or p) -> 0. */ double df(double x, double m, double n, int give_log) { double p, q, f, dens; if ((m<=0) | (n<=0)) return(INVALID_PARAMS); if (x <= 0.0) return(D_0); f = 1.0/(n+x*m); q = n*f; p = x*m*f; if (m>=2) { f = m*q/2; dens = dbinom_raw((m-2)/2.0, (m+n-2)/2.0, p, q, give_log); } else { f = m*m*q / (2*p*(m+n)); dens = dbinom_raw(m/2.0, (m+n)/2.0, p, q, give_log); } return((give_log) ? log(f)+dens : f*dens); } /* * Gamma density, * lb^r x^{r-1} exp(-lb*x) * p(x;r,lb) = ----------------------- * (r-1)! * * If USE_SCALE is defined below, the lb argument will be interpreted * as a scale parameter (i.e. replace lb by 1/lb above). Otherwise, * it is interpreted as a rate parameter, as above. */ /* #define USE_SCALE */ double dgamma(double x, double r, double lambda, int give_log) { double pr; if ((r<=0) | (lambda<0)) return(INVALID_PARAMS); if (x<=0.0) return( D_0 ); #ifdef USE_SCALE lambda = 1.0/lambda; #endif if (r<1) { pr = dpois_raw(r,lambda*x,give_log); return( (give_log) ? pr + log(r/x) : pr*r/x ); } pr = dpois_raw(r-1.0,lambda*x,give_log); return( (give_log) ? pr + log(lambda) : lambda*pr); } double dchisq(double x, double df, int give_log) { return(dgamma(x, df/2.0, 0.5 ,give_log)); /* #ifdef USE_SCALE 2.0 #else 0.5 #endif ,give_log)); */ } /* * Given a sequence of r successes and b failures, we sample n (\le b+r) * items without replacement. The hypergeometric probability is the * probability of x successes: * * dbinom(x,r,p) * dbinom(n-x,b,p) * p(x;r,b,n) = --------------------------------- * dbinom(n,r+b,p) * * for any p. For numerical stability, we take p=n/(r+b); with this choice, * the denominator is not exponentially small. */ double dhyper(int x, int r, int b, int n, int give_log) { double p, q, p1, p2, p3; if ((r<0) | (b<0) | (n<0) | (n>r+b)) return( INVALID_PARAMS ); if (x<0) return(D_0); if (n==0) return((x==0) ? D_1 : D_0); p = ((double)n)/((double)(r+b)); q = ((double)(r+b-n))/((double)(r+b)); p1 = dbinom_raw((double)x,(double)r,p,q,give_log); p2 = dbinom_raw((double)(n-x),(double)b,p,q,give_log); p3 = dbinom_raw((double)n,(double)(r+b),p,q,give_log); return( (give_log) ? p1 + p2 - p3 : p1*p2/p3 ); } /* probability of x failures before the nth success. */ double dnbinom(int x, double n, double p, int give_log) { double prob, f; if ((p<0) | (p>1) | (n<=0)) return(INVALID_PARAMS); if (x<0) return( D_0 ); prob = dbinom_raw(n,x+n,p,1-p,give_log); f = n/(n+x); return((give_log) ? log(f) + prob : f*prob); } double dt(double x, double df, int give_log) { double t, u, f; if (df<=0.0) return(INVALID_PARAMS); /* exp(t) = Gamma((df+1)/2) /{ sqrt(df/2) * Gamma(df/2) } = sqrt(df/2) / ((df+1)/2) * Gamma((df+3)/2) / Gamma((df+2)/2). This form leads to a computation that should be stable for all values of df, including df -> 0 and df -> infinity. */ t = -bd0(df/2.0,(df+1)/2.0) + stirlerr((df+1)/2.0) - stirlerr(df/2.0); if (x*x>df) u = log( 1+ x*x/df ) * df/2; else u = -bd0(df/2.0,(df+x*x)/2.0) + x*x/2.0; f = PIx2*(1+x*x/df); return( FEXP(f,t-u) ); } locfit/src/prob.c0000754000176200001440000000657214745736633013465 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include "mutil.h" #define LOG_2 0.6931471805599453094172321214581765680755 #define IBETA_LARGE 1.0e30 #define IBETA_SMALL 1.0e-30 #define IGAMMA_LARGE 1.0e30 #define DOUBLE_EP 2.2204460492503131E-16 double ibeta(double x, double a, double b) /* double x, a, b; */ { int flipped = 0, i, k, count; double I = 0, temp, pn[6], ak, bk, next, prev, factor, val; if (x <= 0) return(0); if (x >= 1) return(1); /* use ibeta(x,a,b) = 1-ibeta(1-x,b,z) */ if ((a+b+1)*x > (a+1)) { flipped = 1; temp = a; a = b; b = temp; x = 1 - x; } pn[0] = 0.0; pn[2] = pn[3] = pn[1] = 1.0; count = 1; val = x/(1.0-x); bk = 1.0; next = 1.0; do { count++; k = count/2; prev = next; if (count%2 == 0) ak = -((a+k-1.0)*(b-k)*val)/((a+2.0*k-2.0)*(a+2.0*k-1.0)); else ak = ((a+b+k-1.0)*k*val)/((a+2.0*k)*(a+2.0*k-1.0)); pn[4] = bk*pn[2] + ak*pn[0]; pn[5] = bk*pn[3] + ak*pn[1]; next = pn[4] / pn[5]; for (i=0; i<=3; i++) pn[i] = pn[i+2]; if (fabs(pn[4]) >= IBETA_LARGE) for (i=0; i<=3; i++) pn[i] /= IBETA_LARGE; if (fabs(pn[4]) <= IBETA_SMALL) for (i=0; i<=3; i++) pn[i] /= IBETA_SMALL; } while (fabs(next-prev) > DOUBLE_EP*prev); /* factor = a*log(x) + (b-1)*log(1-x); factor -= LGAMMA(a+1) + LGAMMA(b) - LGAMMA(a+b); */ factor = dbeta(x,a,b,1) + log(x/a); I = exp(factor) * next; return(flipped ? 1-I : I); } /* * Incomplete gamma function. * int_0^x u^{df-1} e^{-u} du / Gamma(df). */ double igamma(double x, double df) /* double x, df; */ { double factor, term, gintegral, pn[6], rn, ak, bk; int i, count, k; if (x <= 0.0) return(0.0); if (df < 1.0) return( dgamma(x,df+1.0,1.0,0) + igamma(x,df+1.0) ); factor = x * dgamma(x,df,1.0,0); /* factor = exp(df*log(x) - x - lgamma(df)); */ if (x > 1.0 && x >= df) { pn[0] = 0.0; pn[2] = pn[1] = 1.0; pn[3] = x; count = 1; rn = 1.0 / x; do { count++; k = count / 2; gintegral = rn; if (count%2 == 0) { bk = 1.0; ak = (double)k - df; } else { bk = x; ak = (double)k; } pn[4] = bk*pn[2] + ak*pn[0]; pn[5] = bk*pn[3] + ak*pn[1]; rn = pn[4] / pn[5]; for (i=0; i<4; i++) pn[i] = pn[i+2]; if (pn[4] > IGAMMA_LARGE) for (i=0; i<4; i++) pn[i] /= IGAMMA_LARGE; } while (fabs(gintegral-rn) > DOUBLE_EP*rn); gintegral = 1.0 - factor*rn; } else { /* For x DOUBLE_EP*gintegral); gintegral *= factor/df; } return(gintegral); } double pf(double q, double df1, double df2) /* double q, df1, df2; */ { return(ibeta(q*df1/(df2+q*df1), df1/2, df2/2)); } #ifdef RVERSION extern double Rf_pnorm5(); double mut_pnorm(double x, double mu, double s) /* double x, mu, s; */ { return(Rf_pnorm5(x, mu, s, 1L, 0L)); } #else double mut_pnorm(double x, double mu, double s) /* double x, mu, s; */ { if(x == mu) return(0.5); x = (x-mu)/s; if(x > 0) return((1 + erf(x/SQRT2))/2); return(erfc(-x/SQRT2)/2); } #endif locfit/src/lf_fitfun.c0000754000176200001440000001344314745735145014467 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * Evaluate the locfit fitting functions. * calcp(sp,d) * calculates the number of fitting functions. * makecfn(sp,des,dv,d) * makes the coef.number vector. * fitfun(lfd, sp, x,t,f,dv) * lfd is the local fit structure. * sp smoothing parameter structure. * x is the data point. * t is the fitting point. * f is a vector to return the results. * dv derivative structure. * designmatrix(lfd, sp, des) * is a wrapper for fitfun to build the design matrix. * */ #include "local.h" int calcp(smpar *sp, int d) /* calcp(sp,d) smpar *sp; int d; */ { int i, k; if (ubas(sp)) { printf("calcp-ubas\n"); return(npar(sp)); } switch (kt(sp)) { case KSPH: case KCE: k = 1; for (i=1; i<=deg(sp); i++) k = k*(d+i)/i; return(k); case KPROD: return(d*deg(sp)+1); case KLM: return(d); case KZEON: return(1); } ERROR(("calcp: invalid kt %d",kt(sp))); return(0); } int coefnumber(deriv *dv, int kt, int d, int deg) /* coefnumber(dv,kt,d,deg) deriv *dv; int kt, d, deg; */ { int d0, d1, t; if (d==1) { if (dv->nd<=deg) return(dv->nd); return(-1); } if (dv->nd==0) return(0); if (deg==0) return(-1); if (dv->nd==1) return(1+dv->deriv[0]); if (deg==1) return(-1); if (kt==KPROD) return(-1); if (dv->nd==2) { d0 = dv->deriv[0]; d1 = dv->deriv[1]; if (d0=3")); return(-1); } void makecfn(smpar *sp, design *des, deriv *dv, int d) /* makecfn(sp,des,dv,d) smpar *sp; design *des; deriv *dv; int d; */ { int i, nd; nd = dv->nd; des->cfn[0] = coefnumber(dv,kt(sp),d,deg(sp)); des->ncoef = 1; if (nd >= deg(sp)) return; if (kt(sp)==KZEON) return; if (d>1) { if (nd>=2) return; if ((nd>=1) && (kt(sp)==KPROD)) return; } dv->nd = nd+1; for (i=0; ideriv[nd] = i; des->cfn[i+1] = coefnumber(dv,kt(sp),d,deg(sp)); } dv->nd = nd; des->ncoef = 1+d; } void fitfunangl(double dx, double *ff, double sca, int cd, int deg) /* fitfunangl(dx,ff,sca,cd,deg) double dx, *ff, sca; int cd, deg; */ { if (deg>=3) WARN(("Can't handle angular model with deg>=3")); switch(cd) { case 0: ff[0] = 1; ff[1] = sin(dx/sca)*sca; ff[2] = (1-cos(dx/sca))*sca*sca; return; case 1: ff[0] = 0; ff[1] = cos(dx/sca); ff[2] = sin(dx/sca)*sca; return; case 2: ff[0] = 0; ff[1] = -sin(dx/sca)/sca; ff[2] = cos(dx/sca); return; default: WARN(("Can't handle angular model with >2 derivs")); } } void fitfun(lfdata *lfd, smpar *sp, double *x, double *t, double *f, deriv *dv) /* fitfun(lfd,sp,x,t,f,dv) lfdata *lfd; smpar *sp; double *x, *t, *f; deriv *dv; */ { int d, deg, nd, m, i, j, k, ct_deriv[MXDIM]; double ff[MXDIM][1+MXDEG], dx[MXDIM], *xx[MXDIM]; if (ubas(sp)) { for (i=0; id; i++) xx[i] = &x[i]; i = 0; sp->vbasis(xx,t,1,lfd->d,&i,1,npar(sp),f); return; } d = lfd->d; deg = deg(sp); m = 0; nd = (dv==NULL) ? 0 : dv->nd; if (kt(sp)==KZEON) { f[0] = 1.0; return; } if (kt(sp)==KLM) { for (i=0; ideriv[i]]++; for (i=0; isty[i]) { case STANGL: fitfunangl(dx[i],ff[i],lfd->sca[i],ct_deriv[i],deg(sp)); break; default: for (j=0; jind contains the indices of * the required data points; des->n the number of points; des->xev * the fitting point. */ void designmatrix(lfdata *lfd, smpar *sp, design *des) /* designmatrix(lfd,sp,des) lfdata *lfd; smpar *sp; design *des; */ { int i, ii, j, p; double *X, u[MXDIM]; X = d_x(des); p = des->p; if (ubas(sp)) { sp->vbasis(lfd->x,des->xev,lfd->n,lfd->d,des->ind,des->n,p,X); return; } for (i=0; in; i++) { ii = des->ind[i]; for (j=0; jd; j++) u[j] = datum(lfd,j,ii); fitfun(lfd,sp,u,des->xev,&X[i*p],NULL); } } locfit/src/locfit.c0000754000176200001440000002047714745735467014007 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include "local.h" int lf_maxit = 20; int lf_debug = 0; static double s0, s1, tol; static lfdata *lf_lfd; static design *lf_des; static smpar *lf_sp; int lf_status; int ident=0; int (*like)(); extern double robscale; void lfdata_init(lfdata *lfd) /*lfdata *lfd;*/ { int i; for (i=0; isty[i] = 0; lfd->sca[i] = 1.0; lfd->xl[i] = lfd->xl[i+MXDIM] = 0.0; } lfd->y = lfd->w = lfd->c = lfd->b = NULL; lfd->d = lfd->n = 0; } void smpar_init(smpar *sp, lfdata *lfd) /*smpar *sp; lfdata *lfd;*/ { nn(sp) = 0.7; fixh(sp)= 0.0; pen(sp) = 0.0; acri(sp)= ANONE; deg(sp) = deg0(sp) = 2; ubas(sp) = 0; kt(sp) = KSPH; ker(sp) = WTCUB; fam(sp) = 64+TGAUS; link(sp)= LDEFAU; npar(sp) = calcp(sp,lfd->d); } void deriv_init(deriv *dv) /*deriv *dv;*/ { dv->nd = 0; } int des_reqd(int n, int p) /*int n, p;*/ { return(n*(p+5)+2*p*p+4*p + jac_reqd(p)); } int des_reqi(int n, int p) /*int n, p;*/ { return(n+p); } void des_init(design *des, int n, int p) /*design *des; int n, p;*/ { double *z; int k; if (n<=0) WARN(("des_init: n <= 0")); if (p<=0) WARN(("des_init: p <= 0")); if (des->des_init_id != DES_INIT_ID) { des->lwk = des->lind = 0; des->des_init_id = DES_INIT_ID; } k = des_reqd(n,p); if (k>des->lwk) { des->wk = (double *)calloc(k,sizeof(double)); des->lwk = k; } z = des->wk; des->X = z; z += n*p; des->w = z; z += n; des->res=z; z += n; des->di =z; z += n; des->th =z; z += n; des->wd =z; z += n; des->V =z; z += p*p; des->P =z; z += p*p; des->f1 =z; z += p; des->ss =z; z += p; des->oc =z; z += p; des->cf =z; z += p; z = jac_alloc(&des->xtwx,p,z); k = des_reqi(n,p); if (k>des->lind) { des->ind = (Sint *)calloc(k,sizeof(Sint)); des->lind = k; } des->fix = &des->ind[n]; for (k=0; kfix[k] = 0; des->n = n; des->p = p; des->smwt = n; des->xtwx.p = p; } void deschk(design *des, int n, int p) /*design *des; int n, p;*/ { WARN(("deschk deprecated - use des_init()")); des_init(des,n,p); } int likereg(double *coef, double *lk0, double *f1, double *Z) /*double *coef, *lk0, *f1, *Z;*/ { int i, ii, j, p; double lk, ww, link[LLEN], *X; if (lf_debug>2) printf(" likereg: %8.5f\n",coef[0]); lf_status = LF_OK; lk = 0.0; p = lf_des->p; setzero(Z,p*p); setzero(f1,p); for (i=0; in; i++) { ii = lf_des->ind[i]; X = d_xi(lf_des,i); lf_des->th[i] = base(lf_lfd,ii)+innerprod(coef,X,p); lf_status = stdlinks(link,lf_lfd,lf_sp,ii,lf_des->th[i],robscale); if (lf_status == LF_BADP) { *lk0 = -1.0e300; return(NR_REDUCE); } if (lf_error) lf_status = LF_ERR; if (lf_status != LF_OK) return(NR_BREAK); ww = lf_des->w[i]; lk += ww*link[ZLIK]; for (j=0; jfix[i]) { for (j=0; j4) prresp(coef,Z,p); if (lf_debug>3) printf(" likelihood: %8.5f\n",lk); *lk0 = lf_des->llk = lk; switch (fam(lf_sp)&63) /* parameter checks */ { case TGAUS: /* prevent iterations! */ if ((link(lf_sp)==LIDENT)&((fam(lf_sp)&128)==0)) return(NR_BREAK); break; case TPOIS: case TGEOM: case TWEIB: case TGAMM: if ((link(lf_sp)==LLOG) && (fabs(coef[0])>700)) { lf_status = LF_OOB; return(NR_REDUCE); } if (lk > -1.0e-5*s0) { lf_status = LF_PF; return(NR_REDUCE); } break; case TRBIN: case TLOGT: if (lk > -1.0e-5*s0) { lf_status = LF_PF; return(NR_REDUCE); } if (fabs(coef[0])>700) { lf_status = LF_OOB; return(NR_REDUCE); } break; } return(NR_OK); } int robustinit(lfdata *lfd, design *des) /*lfdata *lfd; design *des;*/ { int i; for (i=0; in; i++) des->res[i] = resp(lfd,(int)des->ind[i]) - base(lfd,(int)des->ind[i]); des->cf[0] = median(des->res,des->n); for (i=1; ip; i++) des->cf[i] = 0.0; tol = 1.0e-6; return(LF_OK); } int circinit(lfdata *lfd, design *des) /*lfdata *lfd; design *des;*/ { int i, ii; double s0, s1; s0 = s1 = 0.0; for (i=0; in; i++) { ii = des->ind[i]; s0 += des->w[i]*prwt(lfd,ii)*sin(resp(lfd,ii)-base(lfd,ii)); s1 += des->w[i]*prwt(lfd,ii)*cos(resp(lfd,ii)-base(lfd,ii)); } des->cf[0] = atan2(s0,s1); for (i=1; ip; i++) des->cf[i] = 0.0; tol = 1.0e-6; return(LF_OK); } int reginit(lfdata *lfd, design *des) /*lfdata *lfd; design *des;*/ { int i, ii; double sb, link[LLEN]; s0 = s1 = sb = 0; for (i=0; in; i++) { ii = des->ind[i]; links(base(lfd,ii),resp(lfd,ii),fam(lf_sp),LINIT,link,cens(lfd,ii),prwt(lfd,ii),1.0); s1 += des->w[i]*link[ZDLL]; s0 += des->w[i]*prwt(lfd,ii); sb += des->w[i]*prwt(lfd,ii)*base(lfd,ii); } if (s0==0) return(LF_NOPT); /* no observations with W>0 */ setzero(des->cf,des->p); tol = 1.0e-6*s0; switch(link(lf_sp)) { case LIDENT: des->cf[0] = (s1-sb)/s0; return(LF_OK); case LLOG: if (s1<=0.0) { des->cf[0] = -1000; return(LF_INFA); } des->cf[0] = log(s1/s0) - sb/s0; return(LF_OK); case LLOGIT: if (s1<=0.0) { des->cf[0] = -1000; return(LF_INFA); } if (s1>=s0) { des->cf[0] = 1000; return(LF_INFA); } des->cf[0] = logit(s1/s0)-sb/s0; return(LF_OK); case LINVER: if (s1<=0.0) { des->cf[0] = 1000; return(LF_INFA); } des->cf[0] = s0/s1-sb/s0; return(LF_OK); case LSQRT: des->cf[0] = sqrt(s1/s0)-sb/s0; return(LF_OK); case LASIN: des->cf[0] = asin(sqrt(s1/s0))-sb/s0; return(LF_OK); default: ERROR(("reginit: invalid link %d",link(lf_sp))); return(LF_ERR); } } int lfinit(lfdata *lfd, smpar *sp, design *des) /*lfdata *lfd; smpar *sp; design *des;*/ { des->xtwx.sm = (deg0(sp)cf)); case TCAUC: case TROBT: return(robustinit(lfd,des)); case TCIRC: return(circinit(lfd,des)); default: return(reginit(lfd,des)); } } void lfiter(design *des, int maxit) /*design *des; int maxit;*/ { int err; if (lf_debug>1) printf(" lfiter: %8.5f\n",des->cf[0]); max_nr(like, des->cf, des->oc, des->res, des->f1, &des->xtwx, des->p, maxit, tol, &err); switch(err) { case NR_OK: return; case NR_NCON: WARN(("max_nr not converged")); return; case NR_NDIV: WARN(("max_nr reduction problem")); return; } WARN(("max_nr return status %d",err)); } int use_robust_scale(int tg) /*int tg;*/ { if ((tg&64)==0) return(0); /* not quasi - no scale */ if (((tg&128)==0) & (((tg&63)!=TROBT) & ((tg&63)!=TCAUC))) return(0); return(1); } int locfit(lfdata *lfd, design *des, smpar *sp, int noit, int nb, int cv) /*lfdata *lfd; design *des; smpar *sp; int noit, nb, cv;*/ { int i; if (des->xev==NULL) { ERROR(("locfit: NULL evaluation point?")); return(246); } if (lf_debug>0) { printf("locfit: "); for (i=0; id; i++) printf(" %10.6f",des->xev[i]); printf("\n"); } lf_des = des; lf_lfd = lfd; lf_sp = sp; /* the 1e-12 avoids problems that can occur with roundoff */ if (nb) nbhd(lfd,des,(int)(lfd->n*nn(sp)+1e-12),0,sp); lf_status = lfinit(lfd,sp,des); if (lf_status != LF_OK) return(lf_status); if (use_robust_scale(fam(sp))) lf_robust(lfd,sp,des,lf_maxit); else { robscale = 1.0; lfiter(des,lf_maxit); } if (lf_status == LF_OOB) setzero(des->cf,des->p); if ((fam(sp)&63)==TDEN) /* convert from rate to density */ { switch(link(sp)) { case LLOG: des->cf[0] -= log(des->smwt); break; case LIDENT: multmatscal(des->cf,1.0/des->smwt,des->p); break; default: ERROR(("Density adjustment; invalid link")); } } /* variance calculations, if requested */ if (cv) lf_vcov(lfd,sp,des); return(lf_status); } locfit/src/local.h0000754000176200001440000000561614745724400013605 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * Most of the changes formerly needed here are handled through * the Makefiles and #ifdef's. */ #ifndef I_LF_H #define I_LF_H #include /* * DIRSEP: '/' for unix; '\\' for DOS */ #ifdef DOS #define DIRSEP '\\' #else #define DIRSEP '/' #endif /* Some older math libraries have no lgamma() function, and gamma(arg) actually returns log(gamma(arg)). If so, you need to change LGAMMA macro below. If all else fails, you can also use lflgamma(). Use the definitions for erf, erfc and daws only if your math libraries don't include these functions. */ #ifdef DOS #define LGAMMA(arg) lflgamma(arg) #define erf(x) lferf(x) #define erfc(x) lferfc(x) #else #define LGAMMA(arg) lgamma(arg) #endif #define daws(x) lfdaws(x) /******** NOTHING BELOW HERE NEEDS CHANGING **********/ #include #include #include #include #define RVERSION #ifdef SWINVERSION #define SVERSION #include "newredef.h" #endif #ifdef RVERSION /* #typedef int used to be defined in R.h */ typedef int Sint; #include #include #include #define list_elt(ev,i) VECTOR_PTR(ev)[i] #define dval2(ev,i,j) NUMERIC_POINTER(list_elt(ev,i))[j] #define dvec2(ev,i) NUMERIC_POINTER(list_elt(ev,i)) #define ivec2(ev,i) INTEGER_POINTER(list_elt(ev,i)) #undef pmatch #define printf Rprintf #define printe REprintf #else #ifdef SVERSION #include typedef long int Sint; typedef s_object * SEXP; #define list_elt(ev,i) LIST_POINTER(ev)[i] #define dval2(ev,i,j) NUMERIC_POINTER(list_elt(ev,i))[j] #define dvec2(ev,i) NUMERIC_POINTER(list_elt(ev,i)) #define ivec2(ev,i) INTEGER_POINTER(list_elt(ev,i)) #else typedef int Sint; #endif #endif #ifdef RVERSION #undef LGAMMA #define LGAMMA(arg) Rf_lgammafn(arg) extern double Rf_lgammafn(); #define SVERSION #endif #include "mutil.h" #include "tube.h" #include "lfcons.h" typedef char varname[15]; #ifdef CVERSION #include "cversion.h" #endif #include "lfstruc.h" #include "design.h" #include "lffuns.h" #ifdef CVERSION #undef printf #define printf lfprintf extern int lfprintf(const char *format, ...); extern int printe(const char *format, ...); /* #else #define printe printf */ #endif #ifdef ERROR #undef ERROR #endif #ifdef WARN #undef WARN #endif /* #define ERROR(args) {printe("Error: "); printe args; printe("\n"); lf_error= 1;} */ #define ERROR(args) {error args; lf_error=1;} /* #define WARN(args) {printe("Warning: "); printe args; printe("\n"); } */ #define WARN(args) warning args; #define MAX(a,b) (((a)>(b)) ? (a) : (b)) #define MIN(a,b) (((a)<(b)) ? (a) : (b)) #define SGN(x) (((x)>0) ? 1 : -1) #define SQR(x) ((x)*(x)) #define NOSLN 0.1278433 #define GFACT 2.5 #define EFACT 3.0 #define MAXCOLOR 20 #define MAXWIN 5 #define ISWAP(a,b) { int zz; zz = a; a = b; b = zz; } extern int lf_error; #endif /* I_LF_H */ locfit/src/dens_haz.c0000754000176200001440000001222214745733524014277 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * * Integration for hazard rate estimation. The functions in this * file are used to evaluate * sum int_0^{Ti} W_i(t,x) A()A()' exp( P() ) dt * for hazard rate models. * * These routines assume the weight function is supported on [-1,1]. * hasint_sph multiplies by exp(base(lf,i)), which allows estimating * the baseline in a proportional hazards model, when the covariate * effect base(lf,i) is known. * * TODO: * hazint_sph, should be able to reduce mint in some cases with * small integration range. onedint could be used for beta-family * (RECT,EPAN,BISQ,TRWT) kernels. * hazint_prod, restrict terms from the sum based on x values. * I should count obs >= max, and only do that integration once. */ #include "local.h" static double ilim[2*MXDIM], *ff, tmax; static lfdata *haz_lfd; static smpar *haz_sp; /* * hrao returns 0 if integration region is empty. * 1 otherwise. */ int haz_sph_int(double *dfx, double *cf, double h, double *r1) /* double *dfx, *cf, h, *r1; */ { double s, t0, t1, wt, th; int j, dim, p; s = 0; p = npar(haz_sp); dim = haz_lfd->d; for (j=1; jsca[j])); if (s>1) return(0); setzero(r1,p*p); t1 = sqrt(1-s)*h*haz_lfd->sca[0]; t0 = -t1; if (t0ilim[dim]) t1 = ilim[dim]; if (t1>dfx[0]) t1 = dfx[0]; if (t1n; for (i=0; i<=n; i++) { if (i==n) { dfx[0] = tmax-t[0]; for (j=1; jd; j++) dfx[j] = 0.0; eb = exp(sb/n); } else { eb = exp(base(haz_lfd,i)); sb += base(haz_lfd,i); for (j=0; jd; j++) dfx[j] = datum(haz_lfd,j,i)-t[j]; } st = haz_sph_int(dfx,cf,h,r1); if (st) for (j=0; jd; setzero(resp,p*p); hj = hs = h*haz_lfd->sca[0]; ncf[0] = cf[0]; for (i=1; i<=deg(haz_sp); i++) { ncf[i] = hj*cf[(i-1)*d+1]; hj *= hs; } /* for i=0..n.... * First we compute prod_wk[j], j=0..d. * For j=0, this is int_0^T_i (u-t)^k W((u-t)/h) exp(b0*(u-t)) du * For remaining j, (x(i,j)-x(j))^k Wj exp(bj*(x..-x.)) * * Second, we add to the integration (exp(a) incl. in integral) * with the right factorial denominators. */ t_prev = ilim[0]; sb = 0.0; for (i=0; i<=haz_lfd->n; i++) { if (i==haz_lfd->n) { dfx[0] = tmax-t[0]; for (j=1; jn); } else { eb = exp(base(haz_lfd,i)); sb += base(haz_lfd,i); for (j=0; jilim[0]) /* else it doesn't contribute */ { /* time integral */ il1 = (dfx[0]>ilim[d]) ? ilim[d] : dfx[0]; if (il1 != t_prev) /* don't repeat! */ { st = onedint(haz_sp,ncf,ilim[0]/hs,il1/hs,prod_wk[0]); if (st>0) return(st); hj = eb; for (j=0; j<=2*deg(haz_sp); j++) { hj *= hs; prod_wk[0][j] *= hj; } t_prev = il1; } /* covariate terms */ for (j=1; j0; k--) ef = (ef+dfx[j])*cf[1+(k-1)*d+j]; ef = exp(ef); prod_wk[j][0] = ef * W(dfx[j]/(h*haz_lfd->sca[j]),ker(haz_sp)); for (k=1; k<=2*deg(haz_sp); k++) prod_wk[j][k] = prod_wk[j][k-1] * dfx[j]; } /* add to the integration. */ prodintresp(resp,prod_wk,d,deg(haz_sp),p); } /* if dfx0 > ilim0 */ } /* n loop */ /* symmetrize */ for (k=0; kd==1) return(hazint_prod(t,resp,resp1,cf,h)); if (kt(haz_sp)==KPROD) return(hazint_prod(t,resp,resp1,cf,h)); return(hazint_sph(t,resp,resp1,cf,h)); } void haz_init(lfdata *lfd, design *des, smpar *sp, double *il) /* lfdata *lfd; design *des; smpar *sp; double *il; */ { int i; haz_lfd = lfd; haz_sp = sp; tmax = datum(lfd,0,0); for (i=1; in; i++) tmax = MAX(tmax,datum(lfd,0,i)); ff = des->xtwx.wk; for (i=0; i<2*lfd->d; i++) ilim[i] = il[i]; } locfit/src/m_qr.c0000754000176200001440000000403314745736265013450 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include #include #include "mutil.h" /* qr decomposition of X (n*p organized by column). * Take w for the ride, if not NULL. */ void qr(double *X, int n, int p, double *w) /*double *X, *w; int n, p;*/ { int i, j, k, mi; double c, s, mx, nx, t; for (j=0; jmx) { mi = i; mx = fabs(X[j*n+i]); } } for (i=j; i0) { for (i=j; i=0; i--) { for (j=i+1; j0) return(sqrt(-2*res[ZLIK])); else return(-sqrt(-2*res[ZLIK])); case RPEAR: if (res[ZDDLL]<=0) { if (res[ZDLL]==0) return(0); return(NOSLN); } return(res[ZDLL]/sqrt(res[ZDDLL])); case RRAW: return(raw); case RLDOT: return(res[ZDLL]); case RDEV2: return(-2*res[ZLIK]); case RLDDT: return(res[ZDDLL]); case RFIT: return(th); case RMEAN: return(res[ZMEAN]); default: ERROR(("resid: unknown residual type %d",ty)); } return(0.0); } double studentize(double res, double inl, double var, int ty, double *link) /* studentize(res,inl,var,ty,link) double res, inl, var, *link; int ty; */ { double den; inl *= link[ZDDLL]; var = var*var*link[ZDDLL]; if (inl>1) inl = 1; if (var>inl) var = inl; den = 1-2*inl+var; if (den<0) return(0.0); switch(ty) { case RDEV: case RPEAR: case RRAW: case RLDOT: return(res/sqrt(den)); case RDEV2: return(res/den); default: return(res); } } void fitted(lfit *lf, double *fit, int what, int cv, int st, int ty) /* fitted(lf,fit,what,cv,st,ty) lfit *lf; double *fit; int what, cv, st, ty; */ { int i, j, d, n, evo; double xx[MXDIM], th, inl=0.0, var, link[LLEN]; n = lf->lfd.n; d = lf->lfd.d; evo = ev(&lf->evs); cv &= (evo!=ECROS); if ((evo==EDATA)|(evo==ECROS)) evo = EFITP; for (i=0; ilfd,j,i); th = dointpoint(lf,xx,what,evo,i); if ((what==PT0)|(what==PVARI)) th = th*th; if (what==PCOEF) { th += base(&lf->lfd,i); stdlinks(link,&lf->lfd,&lf->sp,i,th,rsc(&lf->fp)); if ((cv)|(st)) { inl = dointpoint(lf,xx,PT0,evo,i); inl = inl*inl; if (cv) { th -= inl*link[ZDLL]; stdlinks(link,&lf->lfd,&lf->sp,i,th,rsc(&lf->fp)); } if (st) var = dointpoint(lf,xx,PNLX,evo,i); } fit[i] = resid(resp(&lf->lfd,i),prwt(&lf->lfd,i),th,fam(&lf->sp),ty,link); if (st) fit[i] = studentize(fit[i],inl,var,ty,link); } else fit[i] = th; if (lf_error) return; } } locfit/src/design.h0000754000176200001440000000217614745724400013762 0ustar liggesusers/* * Copyright (c) 1998-2001 Lucent Technologies. * See README file for details. * * * The design structure used in Locfit, and associated macro definitions. */ typedef struct { int des_init_id; double *wk; Sint *ind; int lwk, lind; double *xev; /* fitting point, length p */ double *X; /* design matrix, length n*p */ double *w, *di, *res, *th, *wd, h; double *V, *P; /* matrices with length p*p */ double *f1, *ss, *oc, *cf; /* work vectors, length p */ double llk, smwt; jacobian xtwx; /* to store X'WVX and decomposition */ int cfn[1+MXDIM], ncoef; Sint *fix; /* integer vector for fixed coefficients. */ int (*itype)(); /* density integration function */ int n, p; int (*vfun)(); /* pointer to the vertex processing function. */ } design; #define cfn(des,i) (des->cfn[i]) #define d_x(des) ((des)->X) #define d_xi(des,i) (&(des)->X[i*((des)->p)]) #define d_xij(des,i,j) ((des)->X[i*((des)->p)+j]) #define is_fixed(des,i) ((des)->fix[i]==1) #define DES_INIT_ID 34988372 extern int des_reqd(), des_reqi(); locfit/src/cversion.h0000754000176200001440000000567014745724400014343 0ustar liggesusers/* * Copyright (c) 1998-2000 Lucent Technologies. * See README file for details. * * * * Structures and function definitions for the C version interface. */ /* typedef char varname[15]; */ /* * Define the vari type for locfit variables and related macros. */ typedef struct { varname name; int n, bytes, mode, stat; double *dpr; } vari; #define checkvarlen(v,n,name,mode) (createvar(name,STSYSTEM,n,mode)) #define vmode(v) ((v)->mode) #define vlength(v) ((v)->n) typedef struct { char *arg, *val; vari *result; int used; } carg; typedef struct { void (*AddColor)(), (*SetColor)(), (*ClearScreen)(), (*TextDim)(), (*DoText)(); void (*DrawPoint)(), (*DrawLine)(), (*DrawPatch)(), (*wrapup)(); int (*makewin)(), ticklength, defth, deftw; } device; typedef struct { vari *data[MXDIM], *fit, *se; int d, wh, gr; } pplot; typedef struct { char cmd; double x, *v, (*f)(); int m, nx[3]; vari *vv; } arstruct; typedef struct { vari *x, *y, *z; char type; int id, t, n, nx, ny, pch; } plxyz; typedef struct { double theta, phi, xl[2], yl[2], zl[2], sl[10]; int id, ty, nsl; char main[50], xlab[50], ylab[50], zlab[50]; vari *track, *xyzs; } plots; #define PLNONE 0 #define PLDATA 1 #define PLFIT 2 #define PLTRK 4 struct lfcol { char name[10]; int n, r, g, b; }; /* FILES IN THE src-c DIRECTORY */ /* arith.c */ extern int arvect(), intitem(); extern double areval(), arith(), darith(), dareval(); extern vari *varith(), *saveresult(), *arbuild(); /* c_args.c */ #define argused(v,i) (((carg *)viptr(v,i))->used) #define setused(v,i) { ((carg *)viptr(v,i))->used = 1; } #define setunused(v,i) { ((carg *)viptr(v,i))->used = 0; } #define argarg(v,i) (((carg *)viptr(v,i))->arg) #define argvalis(v,i,z) (strcmp(argval(v,i),z)==0) extern char *argval(), *getargval(); extern int getarg(), readilist(), getlogic(); /* cmd.c */ extern int dispatch(); extern void setuplf(), recondat(), cmdint(); extern double backtr(), docrit(); /* c_lf.c */ extern vari *vfitted(); extern void cfitted(), cwdiag(); /* c_plot.c */ extern void plotdata(), plotfit(), plottrack(), plotopt(), setplot(); /* help.c */ extern void example(); /* lfd.c */ extern void doreaddata(), dosavedata(), dosavefit(); extern int setfilename(); /* main.c */ extern void SetWinDev(); /* makecmd.c */ extern vari *getcmd(); extern void makecmd(), del_lines(), inc_forvar(), dec_forvar(); /* post.c */ extern void SetPSDev(); /* pout.c */ extern int pretty(); extern void displayplot(); extern void plotmaple(), plotmathe(), plotmatlb(), plotgnup(), plotxwin(); /* random.c */ extern double rnorm(), rexp(), runif(), rpois(); extern void rseed(); /* readfile.c */ extern void readfile(); /* scbmax.c */ extern void cscbmax(); /* vari.c */ extern int vbytes(); extern vari *createvar(), *findvar(), *growvar(); extern void initdb(), deletevar(), deletename(), deleteifhidden(), setvarname(); extern void *viptr(), vassn(); extern double *vdptr(), vitem(); locfit/src/scb.c0000754000176200001440000001767014745736730013271 0ustar liggesusers/* * Copyright (c) 1998-2001 Catherine Loader, Jiayang Sun * See README file for details. * */ #include "local.h" static double scb_crit, *x, c[10], kap[5], kaq[5], max_p2; /* static int side, type; */ static int type; design *scb_des; double covar_par(lfit *lf, design *des, double x1, double x2) /* covar_par(lf,des,x1,x2) lfit *lf; design *des; double x1, x2; */ { double *v1, *v2, *wk; paramcomp *pc; int i, j, p, ispar; v1 = des->f1; v2 = des->ss; wk = des->oc; ispar = (ker(&lf->sp)==WPARM) && (haspc(&lf->pc)); p = npar(&lf->sp); /* for parametric models, the covariance is * A(x1)^T (X^T W V X)^{-1} A(x2) * which we can find easily from the parametric component. */ if (ispar) { pc = &lf->pc; fitfun(&lf->lfd, &lf->sp, &x1,pc->xbar,v1,NULL); fitfun(&lf->lfd, &lf->sp, &x2,pc->xbar,v2,NULL); jacob_hsolve(&lf->pc.xtwx,v1); jacob_hsolve(&lf->pc.xtwx,v2); } /* for non-parametric models, we must use the cholseky decomposition * of M2 = X^T W^2 V X. Courtesy of comp_vari, we already have * des->P = M2^{1/2} M1^{-1}. */ if (!ispar) { fitfun(&lf->lfd, &lf->sp, &x1,des->xev,wk,NULL); for (i=0; iP[i*p+j]*wk[j]; } fitfun(&lf->lfd, &lf->sp, &x2,des->xev,wk,NULL); for (i=0; iP[i*p+j]*wk[j]; } } return(innerprod(v1,v2,p)); } void cumulant(lfit *lf, design *des, double sd) /* cumulant(lf,des,sd) lfit *lf; design *des; double sd; */ { double b3i, b3j, b4i; double ss, si, sj, uii, uij, ujj, k1; int ii, i, j, jj; for (i=1; i<10; i++) c[i] = 0.0; k1 = 0; /* ss = sd*sd; */ ss = covar_par(lf,des,des->xev[0],des->xev[0]); /* * this isn't valid for nonparametric models. At a minimum, * the sums would have to include weights. Still have to work * out the right way. */ for (i=0; ilfd.n; i++) { ii = des->ind[i]; //b2i = b2(des->th[i],fam(&lf->sp),prwt(&lf->lfd,ii)); b3i = b3(des->th[i],fam(&lf->sp),prwt(&lf->lfd,ii)); b4i = b4(des->th[i],fam(&lf->sp),prwt(&lf->lfd,ii)); si = covar_par(lf,des,des->xev[0],datum(&lf->lfd,0,ii)); uii= covar_par(lf,des,datum(&lf->lfd,0,ii),datum(&lf->lfd,0,ii)); if (lf_error) return; c[2] += b4i*si*si*uii; c[6] += b4i*si*si*si*si; c[7] += b3i*si*uii; c[8] += b3i*si*si*si; /* c[9] += b2i*si*si*si*si; c[9] += b2i*b2i*si*si*si*si; */ k1 += b3i*si*(si*si/ss-uii); /* i=j components */ c[1] += b3i*b3i*si*si*uii*uii; c[3] += b3i*b3i*si*si*si*si*uii; c[4] += b3i*b3i*si*si*uii*uii; for (j=i+1; jlfd.n; j++) { jj = des->ind[j]; b3j = b3(des->th[j],fam(&lf->sp),prwt(&lf->lfd,jj)); sj = covar_par(lf,des,des->xev[0],datum(&lf->lfd,0,jj)); uij= covar_par(lf,des,datum(&lf->lfd,0,ii),datum(&lf->lfd,0,jj)); ujj= covar_par(lf,des,datum(&lf->lfd,0,jj),datum(&lf->lfd,0,jj)); c[1] += 2*b3i*b3j*si*sj*uij*uij; c[3] += 2*b3i*b3j*si*si*sj*sj*uij; c[4] += b3i*b3j*uij*(si*si*ujj+sj*sj*uii); if (lf_error) return; } } c[5] = c[1]; c[7] = c[7]*c[8]; c[8] = c[8]*c[8]; c[1] /= ss; c[2] /= ss; c[3] /= ss*ss; c[4] /= ss; c[5] /= ss; c[6] /= ss*ss; c[7] /= ss*ss; c[8] /= ss*ss*ss; c[9] /= ss*ss; /* constants used in p(x,z) computation */ kap[1] = k1/(2*sqrt(ss)); kap[2] = 1 + 0.5*(c[1]-c[2]+c[4]-c[7]) - 3*c[3] + c[6] + 1.75*c[8]; kap[4] = -9*c[3] + 3*c[6] + 6*c[8] + 3*c[9]; /* constants used in q(x,u) computation */ kaq[2] = c[3] - 1.5*c[8] - c[5] - c[4] + 0.5*c[7] + c[6] - c[2]; kaq[4] = -3*c[3] - 6*c[4] - 6*c[5] + 3*c[6] + 3*c[7] - 3*c[8] + 3*c[9]; } /* q2(u) := u+q2(x,u) in paper */ double q2(double u) /* q2(u) double u; */ { return(u-u*(36.0*kaq[2] + 3*kaq[4]*(u*u-3) + c[8]*((u*u-10)*u*u+15))/72.0); } /* p2(u) := p2(x,u) in paper */ double p2(double u) /* p2(u) double u; */ { return( -u*( 36*(kap[2]-1+kap[1]*kap[1]) + 3*(kap[4]+4*kap[1]*sqrt(kap[3]))*(u*u-3) + c[8]*((u*u-10)*u*u+15) ) / 72 ); } extern int likereg(double *, double *, double *, double *); double gldn_like(double a) /* gldn_like(a) double a; */ { int err; scb_des->fix[0] = 1; scb_des->cf[0] = a; max_nr(likereg, scb_des->cf, scb_des->oc, scb_des->res, scb_des->f1, &scb_des->xtwx, scb_des->p, lf_maxit, 1.0e-6, &err); scb_des->fix[0] = 0; return(scb_des->llk); } /* v1/v2 is correct for deg=0 only */ void get_gldn(fitpt *fp, design *des, double *lo, double *hi, int v) /* get_gldn(fp,des,lo,hi,v) fitpt *fp; design *des; double *lo, *hi; int v; */ { double v1, v2, c, tlk; int err; v1 = fp->nlx[v]; v2 = fp->t0[v]; c = scb_crit * v1 / v2; tlk = des->llk - c*c/2; printf("v %8.5f %8.5f c %8.5f tlk %8.5f llk %8.5f\n",v1,v2,c,tlk,des->llk); /* want: { a : l(a) >= l(a-hat) - c*c/2 } */ lo[v] = fp->coef[v] - scb_crit*v1; hi[v] = fp->coef[v] + scb_crit*v1; err = 0; printf("lo %2d\n",v); lo[v] = solve_secant(gldn_like,tlk,lo[v],fp->coef[v],1e-8,BDF_EXPLEFT,&err); if (err>0) printf("solve_secant error\n"); printf("hi %2d\n",v); hi[v] = solve_secant(gldn_like,tlk,fp->coef[v],hi[v],1e-8,BDF_EXPRIGHT,&err); if (err>0) printf("solve_secant error\n"); } int procvscb2(design *des, lfit *lf, int v) /* procvscb2(des,lf,v) design *des; lfit *lf; int v; */ { double sd, *lo, *hi, u; int err, st, tmp; x = des->xev = evpt(&lf->fp,v); tmp = haspc(&lf->pc); /* if ((ker(&lf->sp)==WPARM) && (haspc(&lf->pc))) { lf->coef[v] = thhat = addparcomp(lf,des->xev,PCOEF); lf->nlx[v] = lf->t0[v] = sd = addparcomp(lf,des->xev,PNLX); } else */ { haspc(&lf->pc) = 0; st = procv(des,lf,v); //thhat = lf->fp.coef[v]; sd = lf->fp.nlx[v]; } if ((type==GLM2) | (type==GLM3) | (type==GLM4)) { if (ker(&lf->sp) != WPARM) WARN(("nonparametric fit; correction is invalid")); cumulant(lf,des,sd); } haspc(&lf->pc) = tmp; lo = lf->fp.L; hi = &lo[lf->fp.nvm]; switch(type) { case GLM1: return(st); case GLM2: /* centered scr */ lo[v] = kap[1]; hi[v] = sqrt(kap[2]); return(st); case GLM3: /* corrected 2 */ lo[v] = solve_secant(q2,scb_crit,0.0,2*scb_crit,0.000001,BDF_NONE,&err); return(st); case GLM4: /* corrected 2' */ u = fabs(p2(scb_crit)); max_p2 = MAX(max_p2,u); return(st); case GLDN: get_gldn(&lf->fp,des,lo,hi,v); return(st); } ERROR(("procvscb2: invalid type")); return(st); } void scb(design *des, lfit *lf) /* scb(des,lf) design *des; lfit *lf; */ { double k1, k2; /* kap[10], */ double *lo, *hi, sig, thhat, nlx; int i, nterms; scb_des= des; npar(&lf->sp) = calcp(&lf->sp,lf->lfd.d); des_init(des,lf->lfd.n,npar(&lf->sp)); link(&lf->sp) = defaultlink(link(&lf->sp),fam(&lf->sp)); type = geth(&lf->fp); if (type >= 80) /* simultaneous */ { nterms = constants(des,lf); scb_crit = critval(0.05,lf->fp.kap,nterms,lf->lfd.d,TWO_SIDED,0.0,GAUSS); type -= 10; } else /* pointwise */ { lf->fp.kap[0] = 1; scb_crit = critval(0.05,lf->fp.kap,1,lf->lfd.d,TWO_SIDED,0.0,GAUSS); } max_p2 = 0.0; startlf(des,lf,procvscb2,0); if ((fam(&lf->sp)&64)==64) { i = haspc(&lf->pc); haspc(&lf->pc) = 0; ressumm(lf,des); haspc(&lf->pc) = i; sig = sqrt(rv(&lf->fp)); } else sig = 1.0; lo = lf->fp.L; hi = &lo[lf->fp.nvm]; for (i=0; ifp.nv; i++) { thhat = lf->fp.coef[i]; nlx = lf->fp.nlx[i]; switch(type) { case GLM1: /* basic scb */ lo[i] = thhat - scb_crit * sig * nlx; hi[i] = thhat + scb_crit * sig * nlx; break; case GLM2: k1 = lo[i]; k2 = hi[i]; lo[i] = thhat - k1*nlx - scb_crit*nlx*k2; hi[i] = thhat - k1*nlx + scb_crit*nlx*k2; break; case GLM3: k1 = lo[i]; lo[i] = thhat - k1*nlx; hi[i] = thhat + k1*nlx; case GLM4: /* corrected 2' */ lo[i] = thhat - (scb_crit-max_p2)*lf->fp.nlx[i]; hi[i] = thhat + (scb_crit-max_p2)*lf->fp.nlx[i]; break; case GLDN: break; } } } locfit/src/scb_iface.c0000754000176200001440000000322414745737075014411 0ustar liggesusers/* * * */ #include "local.h" static lfit *lf_scb; static lfdata *lfd_scb; static smpar *scb_sp; static design *des_scb; int scbfitter(double *x, double *l, int reqd) /* scbfitter(x,l,reqd) double *x, *l; int reqd; */ { int m; des_scb->xev = x; if ((ker(scb_sp)!=WPARM) | (!haspc(&lf_scb->pc))) { locfit(lfd_scb,des_scb,&lf_scb->sp,1,1); m = wdiag(lfd_scb, scb_sp, des_scb,l,&lf_scb->dv,reqd,2,0); } else m = wdiagp(lfd_scb, scb_sp, des_scb,l,&lf_scb->pc,&lf_scb->dv,reqd,2,0); return(m); } /* function to test tube_constants with covariance. double ll[5000]; int scbfitter2(x,l,reqd) double *x, *l; int reqd; { double h; int d, m, n, i, j; m = scbfitter(x,ll,reqd); d = lfd_scb->d; n = d*d+d+1; for (i=0; ilfd; scb_sp = &lf->sp; evs = &lf->evs; d = lfd_scb->d; m = lfd_scb->n; if (lf_error) return(0); if ((ker(scb_sp) != WPARM) && (lf->sp.nn>0)) WARN(("constants are approximate for varying h")); npar(scb_sp) = calcp(scb_sp,lf->lfd.d); des_init(des,m,npar(scb_sp)); set_scales(&lf->lfd); set_flim(&lf->lfd,&lf->evs); compparcomp(des,&lf->lfd,&lf->sp,&lf->pc,geth(&lf->fp),ker(scb_sp)!=WPARM); rw = k0_reqd(d,m,0); if (lf->fp.llfp.L = (double *)calloc(rw,sizeof(double)); lf->fp.ll= rw; } nt = tube_constants(scbfitter,d,m,ev(evs),mg(evs),evs->fl, lf->fp.kap,lf->fp.L,(d>3) ? 4 : d+1,0); return(nt); } locfit/src/dens_odi.c0000754000176200001440000003212014745740242014262 0ustar liggesusers/* * Copyright (c) 1996-200 Lucent Technologies. * See README file for details. * * * * Routines for one-dimensional numerical integration * in density estimation. The entry point is * * onedint(cf,mi,l0,l1,resp) * * which evaluates int W(u)u^j exp( P(u) ), j=0..2*deg. * P(u) = cf[0] + cf[1]u + cf[2]u^2/2 + ... + cf[deg]u^deg/deg! * l0 and l1 are the integration limits. * The results are returned through the vector resp. * */ #include "local.h" static int debug; int exbctay(double b, double c, int n, double *z) /* n-term taylor series of e^(bx+cx^2) */ /* double b, c, *z; int n; */ { double ec[20]; int i, j; z[0] = 1; for (i=1; i<=n; i++) z[i] = z[i-1]*b/i; if (c==0.0) return(n); if (n>=40) { WARN(("exbctay limit to n<40")); n = 39; } ec[0] = 1; for (i=1; 2*i<=n; i++) ec[i] = ec[i-1]*c/i; for (i=n; i>1; i--) for (j=1; 2*j<=i; j++) z[i] += ec[j]*z[i-2*j]; return(n); } double explinjtay(double l0, double l1, int j, double *cf) /* int_l0^l1 x^j e^(a+bx+cx^2); exbctay aroud l1 */ /* double l0, l1, *cf; int j; */ { double tc[40], f; int k, n; if ((l0!=0.0) | (l1!=1.0)) WARN(("explinjtay: invalid l0, l1")); n = exbctay(cf[1]+2*cf[2]*l1,cf[2],20,tc); // s = tc[0]/(j+1); f = 1/(j+1); for (k=1; k<=n; k++) { f *= -k/(j+k+1.0); // s += tc[k]*f; } return(f); } void explint1(double l0, double l1, double *cf, double *I, int p) /* int x^j exp(a+bx); j=0..p-1 */ /* double l0, l1, *cf, *I; int p; */ /* int x^j exp(a+bx); j=0..p-1 */ { double y0, y1, f; int j, k, k1; y0 = lf_exp(cf[0]+l0*cf[1]); y1 = lf_exp(cf[0]+l1*cf[1]); if (p<2*fabs(cf[1])) k = p; else k = (int)fabs(cf[1]); if (k>0) { I[0] = (y1-y0)/cf[1]; for (j=1; j1.0e-8)) /* initially Ik = diff(x^{k+1}e^{a+bx}) */ { y1 *= l1; y0 *= l0; I[k] = y1-y0; if (k>=p) f *= fabs(cf[1])/(k+1); k++; } if (k==50) WARN(("explint1: want k>50")); I[k] = 0.0; for (j=k-1; j>=k1; j--) /* now do back step recursion */ I[j] = (I[j]-cf[1]*I[j+1])/(j+1); } void explintyl(double l0, double l1, double *cf, double *I, int p) /* small c, use taylor series and explint1 */ /* double l0, l1, *cf, *I; int p; */ { int i; double c; explint1(l0,l1,cf,I,p+8); c = cf[2]; for (i=0; i=0; i--) { s = X[3*i+2]/X[3*i+4]; X[3*i+2] = 0; y[i] -= s*y[i+1]; } for (i=0; i0) { if (a0>6) I[0] = (y0*ptail(-a0)-y1*ptail(-a1))/c; else I[0] = S2PI*(mut_pnorm(-a0,0.0,1.0)-mut_pnorm(-a1,0.0,1.0))*bi; } else { if (a1< -6) I[0] = (y1*ptail(a1)-y0*ptail(a0))/c; else I[0] = S2PI*(mut_pnorm(a1,0.0,1.0)-mut_pnorm(a0,0.0,1.0))*bi; } } else I[0] = (y1*daws(a1)-y0*daws(a0))/c; I[1] = (y1-y0)/(2*cf[2])+d*I[0]; } void explinsid(double l0, double l1, double *cf, double *I, int p) /* large b; don't use fwd recursion */ /* double l0, l1, *cf, *I; int p; */ { int k, k0, k1, k2; double y0, y1, Z[150]; if (debug) printf("side: %8.5f %8.5f %8.5f limt %8.5f %8.5f p %2d\n",cf[0],cf[1],cf[2],l0,l1,p); k0 = 2; k1 = (int)(fabs(cf[1])+fabs(2*cf[2])); if (k1<2) k1 = 2; if (k1>p+20) k1 = p+20; k2 = p+20; if (debug) printf("k0 %2d k1 %2d k2 %2d p %2d\n",k0,k1,k2,p); y0 = lf_exp(cf[0]+l0*(cf[1]+l0*cf[2])); y1 = lf_exp(cf[0]+l1*(cf[1]+l1*cf[2])); initi0i1(I,cf,y0,y1,l0,l1); if (debug) printf("i0 %8.5f i1 %8.5f\n",I[0],I[1]); y1 *= l1; y0 *= l0; /* should be x^(k1)*exp(..) */ if (k0=k1; k--) I[k] = (I[k]-cf[1]*I[k+1]-2*cf[2]*I[k+2])/(k+1); if (k0=0; k--) I[k] = (I[k]-cf[1]*I[k+1]-2*cf[2]*I[k+2])/(k+1); } void explinfbk0(double l0, double l1, double *cf, double *I, int p) /* fwd and bac recur; b=0; c<0 */ /* double l0, l1, *cf, *I; int p; */ { double y0, y1, f1, f2, f, ml2; int k, ks; y0 = lf_exp(cf[0]+l0*l0*cf[2]); y1 = lf_exp(cf[0]+l1*l1*cf[2]); initi0i1(I,cf,y0,y1,l0,l1); ml2 = MAX(l0*l0,l1*l1); ks = 1+(int)(2*fabs(cf[2])*ml2); if (ks<2) ks = 2; if (ks>p-3) ks = p; /* forward recursion for k < ks */ for (k=2; k1.0e-8) { y1 *= l1; y0 *= l0; if ((k-p)%2==0) /* add to I[p-2] */ { f2 *= -2*cf[2]/(k+1); I[p-2] += (y1-y0)*f2; } else /* add to I[p-1] */ { f1 *= -2*cf[2]/(k+1); I[p-1] += (y1-y0)*f1; f *= 2*fabs(cf[2])*ml2/(k+1); } k++; } /* use back recursion for I[ks..(p-3)] */ for (k=p-3; k>=ks; k--) I[k] = (I[k]-2*cf[2]*I[k+2])/(k+1); } void explinfbk(double l0,double l1, double *cf, double *I, int p) /* fwd and bac recur; b not too large */ /* double l0, l1, *cf, *I; int p; */ { double y0, y1; int k, ks, km; y0 = lf_exp(cf[0]+l0*(cf[1]+l0*cf[2])); y1 = lf_exp(cf[0]+l1*(cf[1]+l1*cf[2])); initi0i1(I,cf,y0,y1,l0,l1); ks = (int)(3*fabs(cf[2])); if (ks<3) ks = 3; if (ks>0.75*p) ks = p; /* stretch the forward recurs as far as poss. */ /* forward recursion for k < ks */ for (k=2; k=ks; k--) I[k] = (I[k]-cf[1]*I[k+1]-2*cf[2]*I[k+2])/(k+1); } void recent(double *I, double *resp, double *wt, int p, int s, double x) /* double *I, *resp, *wt, x; int p, s; */ { int i, j; /* first, use W taylor series I -> resp */ for (i=0; i<=p; i++) { resp[i] = 0.0; for (j=0; j 0 */ if (x==0) return; for (j=0; j<=p; j++) for (i=p; i>j; i--) resp[i] += x*resp[i-1]; } void recurint(double l0, double l2, double *cf, double *resp, int p, int ker) /*double l0, l2, *cf, *resp; int p, ker; */ { int i, s; double l1, d0, d1, d2, dl, z0, z1, z2, wt[20], ncf[3], I[50], r1[5], r2[5]; if (debug) printf("\nrecurint: %8.5f %8.5f %8.5f %8.5f %8.5f\n",cf[0],cf[1],cf[2],l0,l2); if (cf[2]==0) /* go straight to explint1 */ { s = wtaylor(wt,0.0,ker); if (debug) printf("case 1\n"); explint1(l0,l2,cf,I,p+s); recent(I,resp,wt,p,s,0.0); return; } dl = l2-l0; d0 = cf[1]+2*l0*cf[2]; d2 = cf[1]+2*l2*cf[2]; z0 = cf[0]+l0*(cf[1]+l0*cf[2]); z2 = cf[0]+l2*(cf[1]+l2*cf[2]); if ((fabs(cf[1]*dl)<1) && (fabs(cf[2]*dl*dl)<1)) { ncf[0] = z0; ncf[1] = d0; ncf[2] = cf[2]; if (debug) printf("case 2\n"); s = wtaylor(wt,l0,ker); explinbkr(0.0,dl,ncf,I,p+s); recent(I,resp,wt,p,s,l0); return; } if (fabs(cf[2]*dl*dl)<0.001) /* small c, use explint1+tay.ser */ { ncf[0] = z0; ncf[1] = d0; ncf[2] = cf[2]; if (debug) printf("case small c\n"); s = wtaylor(wt,l0,ker); explintyl(0.0,l2-l0,ncf,I,p+s); recent(I,resp,wt,p,s,l0); return; } if (d0*d2<=0) /* max/min in [l0,l2] */ { l1 = -cf[1]/(2*cf[2]); z1 = cf[0]+l1*(cf[1]+l1*cf[2]); d1 = 0.0; if (cf[2]<0) /* peak, integrate around l1 */ { s = wtaylor(wt,l1,ker); ncf[0] = z1; ncf[1] = 0.0; ncf[2] = cf[2]; if (debug) printf("case peak p %2d s %2d\n",p,s); explinfbk0(l0-l1,l2-l1,ncf,I,p+s); recent(I,resp,wt,p,s,l1); return; } } if ((d0-2*cf[2]*dl)*(d2+2*cf[2]*dl)<0) /* max/min is close to [l0,l2] */ { l1 = -cf[1]/(2*cf[2]); z1 = cf[0]+l1*(cf[1]+l1*cf[2]); if (l1l2) { l1 = l2; z1 = z2; } if ((z1>=z0) & (z1>=z2)) /* peak; integrate around l1 */ { s = wtaylor(wt,l1,ker); if (debug) printf("case 4\n"); d1 = cf[1]+2*l1*cf[2]; ncf[0] = z1; ncf[1] = d1; ncf[2] = cf[2]; explinfbk(l0-l1,l2-l1,ncf,I,p+s); recent(I,resp,wt,p,s,l1); return; } /* trough; integrate [l0,l1] and [l1,l2] */ for (i=0; i<=p; i++) r1[i] = r2[i] = 0.0; if (l0z0+3) /* steep increase, expand around l2 */ { s = wtaylor(wt,l2,ker); if (debug) printf("case 7\n"); ncf[0] = z2; ncf[1] = d2; ncf[2] = cf[2]; explinsid(l0-l2,0.0,ncf,I,p+s); recent(I,resp,wt,p,s,l2); if (debug) printf("7 resp: %8.5f %8.5f %8.5f %8.5f\n",resp[0],resp[1],resp[2],resp[3]); return; } /* bias towards expansion around l0, because it's often 0 */ if (debug) printf("case 8\n"); s = wtaylor(wt,l0,ker); ncf[0] = z0; ncf[1] = d0; ncf[2] = cf[2]; explinsid(0.0,l2-l0,ncf,I,p+s); recent(I,resp,wt,p,s,l0); return; } int onedexpl(double *cf, int deg, double *resp) /* double *cf, *resp; int deg; */ { int i; double f0, fr, fl; if (deg>=2) ERROR(("onedexpl only valid for deg=0,1")); if (fabs(cf[1])>=EFACT) return(LF_BADP); f0 = exp(cf[0]); fl = fr = 1.0; for (i=0; i<=2*deg; i++) { f0 *= i+1; fl /=-(EFACT+cf[1]); fr /= EFACT-cf[1]; resp[i] = f0*(fr-fl); } return(LF_OK); } int onedgaus(double *cf, int deg, double *resp) /* double *cf, *resp; int deg; */ { int i; double f0, mu, s2; if (deg==3) { ERROR(("onedgaus only valid for deg=0,1,2")); return(LF_ERR); } if (2*cf[2]>=GFACT*GFACT) return(LF_BADP); s2 = 1/(GFACT*GFACT-2*cf[2]); mu = cf[1]*s2; resp[0] = 1.0; if (deg>=1) { resp[1] = mu; resp[2] = s2+mu*mu; if (deg==2) { resp[3] = mu*(3*s2+mu*mu); resp[4] = 3*s2*s2 + mu*mu*(6*s2+mu*mu); } } f0 = S2PI * exp(cf[0]+mu*mu/(2*s2))*sqrt(s2); for (i=0; i<=2*deg; i++) resp[i] *= f0; return(LF_OK); } int onedint(smpar *sp, double *cf, double l0, double l1, double *resp) /* int W(u)u^j exp(..), j=0..2*deg */ /* smpar *sp; double *cf, l0, l1, *resp; */ { double u, uj, y, ncf[4], rr[5]; int i, j; if (debug) printf("onedint: %f %f %f %f %f\n",cf[0],cf[1],cf[2],l0,l1); if (deg(sp)<=2) { for (i=0; i<3; i++) ncf[i] = (i>deg(sp)) ? 0.0 : cf[i]; ncf[2] /= 2; if (ker(sp)==WEXPL) return(onedexpl(ncf,deg(sp),resp)); if (ker(sp)==WGAUS) return(onedgaus(ncf,deg(sp),resp)); if (l1>0) recurint(MAX(l0,0.0),l1,ncf,resp,2*deg(sp),ker(sp)); else for (i=0; i<=2*deg(sp); i++) resp[i] = 0; if (l0<0) { ncf[1] = -ncf[1]; l0 = -l0; l1 = -l1; recurint(MAX(l1,0.0),l0,ncf,rr,2*deg(sp),ker(sp)); } else for (i=0; i<=2*deg(sp); i++) rr[i] = 0.0; for (i=0; i<=2*deg(sp); i++) resp[i] += (i%2==0) ? rr[i] : -rr[i]; return(LF_OK); } /* For degree >= 3, we use Simpson's rule. */ for (j=0; j<=2*deg(sp); j++) resp[j] = 0.0; for (i=0; i<=de_mint; i++) { u = l0+(l1-l0)*i/de_mint; y = cf[0]; uj = 1; for (j=1; j<=deg(sp); j++) { uj *= u; y += cf[j]*uj/fact[j]; } y = (4-2*(i%2==0)-(i==0)-(i==de_mint)) * W(fabs(u),ker(sp))*exp(MIN(y,300.0)); for (j=0; j<=2*deg(sp); j++) { resp[j] += y; y *= u; } } for (j=0; j<=2*deg(sp); j++) resp[j] = resp[j]*(l1-l0)/(3*de_mint); return(LF_OK); } locfit/src/lfstr.c0000754000176200001440000001103614745735326013642 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * * Functions for converting string arguments to Locfit's numeric values. * Typically, these will be assigned to appopriate place on one of locfit's structures: * fam(sp) = lffamily(z) * ker(sp) = lfkernel(z) * kt(sp) = lfketype(z) * link(sp)= lflink(z) * de_itype= deitype(z) * ev(evs) = lfevstr(z) * acri(sp)= lfacri(z) * sp is a pointer to the smpar structure, &lf->sp. * evs is a pointer to the evaluation structure, &lf->evs. * int ppwhat(str) interprets the preplot what argument. * int restyp(str) interprets the residual type argument. * * return values of -1 indicate failure/unknown string. */ #include "local.h" int ct_match(char *z1, char *z2) /*char *z1, *z2;*/ { int ct = 0; while (z1[ct]==z2[ct]) { if (z1[ct]=='\0') return(ct+1); ct++; } return(ct); } int pmatch(char *z, char **strings, int *vals, int n, int def) /*char *z, **strings; int *vals, n, def;*/ { int i, ct, best, best_ct; best = -1; best_ct = 0; for (i=0; ibest_ct) { best = i; best_ct = ct; } } if (best==-1) return(def); return(vals[best]); } static char *famil[17] = { "density", "ate", "hazard", "gaussian", "binomial", "poisson", "gamma", "geometric", "circular", "obust", "huber", "weibull", "cauchy","probab", "logistic", "nbinomial", "vonmises" }; static int fvals[17] = { TDEN, TRAT, THAZ, TGAUS, TLOGT, TPOIS, TGAMM, TGEOM, TCIRC, TROBT, TROBT, TWEIB, TCAUC, TPROB, TLOGT, TGEOM, TCIRC }; int lffamily(char *z) /*char *z;*/ { int quasi, robu, f; quasi = robu = 0; while ((z[0]=='q') | (z[0]=='r')) { quasi |= (z[0]=='q'); robu |= (z[0]=='r'); z++; } f = pmatch(z,famil,fvals,16,-1); if ((z[0]=='o') | (z[0]=='a')) robu = 0; if (f==-1) { WARN(("unknown family %s",z)); f = TGAUS; } if (quasi) f += 64; if (robu) f += 128; return(f); } static char *wfuns[13] = { "rectangular", "epanechnikov", "bisquare", "tricube", "triweight", "gaussian", "triangular", "ququ", "6cub", "minimax", "exponential", "maclean", "parametric" }; static int wvals[13] = { WRECT, WEPAN, WBISQ, WTCUB, WTRWT, WGAUS, WTRIA, WQUQU, W6CUB, WMINM, WEXPL, WMACL, WPARM }; int lfkernel(char *z) /*char *z;*/ { return(pmatch(z, wfuns, wvals, 13, WTCUB)); } static char *ktype[5] = { "spherical", "product", "center", "lm", "zeon" }; static int kvals[5] = { KSPH, KPROD, KCE, KLM, KZEON }; int lfketype(char *z) /*char *z;*/ { return(pmatch(z, ktype, kvals, 5, KSPH)); } static char *ltype[8] = { "default", "canonical", "identity", "log", "logi", "inverse", "sqrt", "arcsin" }; static int lvals[8] = { LDEFAU, LCANON, LIDENT, LLOG, LLOGIT, LINVER, LSQRT, LASIN }; int lflink(char *z) /*char *z;*/ { return(pmatch(z, ltype, lvals, 8, LDEFAU)); } static char *etype[11]= { "tree", "phull", "data", "grid", "kdtree", "kdcenter", "cross", "preset", "xbar", "none", "sphere" }; static int evals[11]= { ETREE, EPHULL, EDATA, EGRID, EKDTR, EKDCE, ECROS, EPRES, EXBAR, ENONE, ESPHR }; int lfevstr(char *z) /*char *z;*/ { return(pmatch(z, etype, evals, 11, ETREE)); } static char *itype[7] = { "default", "multi", "product", "mlinear", "hazard", "sphere", "monte" }; static int ivals[7] = { IDEFA, IMULT, IPROD, IMLIN, IHAZD, ISPHR, IMONT }; int deitype(char *z) /*char *z;*/ { return(pmatch(z, itype, ivals, 6, IDEFA)); } static char *atype[5] = { "none", "cp", "ici", "mindex", "ok" }; static int avals[5] = { ANONE, ACP, AKAT, AMDI, AOK }; int lfacri(char *z) /*char *z;*/ { return(pmatch(z, atype, avals, 5, ANONE)); } static char *rtype[8] = { "deviance", "d2", "pearson", "raw", "ldot", "lddot", "fit", "mean" }; static int rvals[8] = { RDEV, RDEV2, RPEAR, RRAW, RLDOT, RLDDT, RFIT, RMEAN}; static char *whtyp[8] = { "coef", "nlx", "infl", "band", "degr", "like", "rdf", "vari" }; static int whval[8] = { PCOEF, PNLX, PT0, PBAND, PDEGR, PLIK, PRDF, PVARI }; int restyp(char *z) /*char *z;*/ { int val; val = pmatch(z, rtype, rvals, 8, -1); if (val==-1) ERROR(("Unknown type = %s",z)); return(val); } int ppwhat(char *z) /*char *z;*/ { int val; val = pmatch(z, whtyp, whval, 8, -1); if (val==-1) ERROR(("Unknown what = %s",z)); return(val); } locfit/src/m_jacob.c0000754000176200001440000000504414745736153014103 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include #include "math.h" #include "stdio.h" #include "stdlib.h" #include "mutil.h" #define DEF_METH JAC_EIGD int jac_reqd(int p) { return(2*p*(p+1)); } double *jac_alloc(jacobian *J, int p, double *wk) /*jacobian *J; int p; double *wk;*/ { if (wk==NULL) wk = (double *)calloc(2*p*(p+1),sizeof(double)); J->Z = wk; wk += p*p; J->Q = wk; wk += p*p; J->wk= wk; wk += p; J->dg= wk; wk += p; return(wk); } void jacob_dec(jacobian *J, int meth) /*jacobian *J; int meth;*/ { int i, j, p; if (J->st != JAC_RAW) return; J->sm = J->st = meth; switch(meth) { case JAC_EIG: eig_dec(J->Z,J->Q,J->p); return; case JAC_EIGD: p = J->p; for (i=0; idg[i] = (J->Z[i*(p+1)]<=0) ? 0.0 : 1/sqrt(J->Z[i*(p+1)]); for (i=0; iZ[i*p+j] *= J->dg[i]*J->dg[j]; eig_dec(J->Z,J->Q,J->p); J->st = JAC_EIGD; return; case JAC_CHOL: chol_dec(J->Z,J->p,J->p); return; default: Rprintf("jacob_dec: unknown method %d",meth); } } int jacob_solve(jacobian *J, double *v) /* (X^T W X)^{-1} v */ /*jacobian *J; double *v;*/ { int i, rank; if (J->st == JAC_RAW) jacob_dec(J,DEF_METH); switch(J->st) { case JAC_EIG: return(eig_solve(J,v)); case JAC_EIGD: for (i=0; ip; i++) v[i] *= J->dg[i]; rank = eig_solve(J,v); for (i=0; ip; i++) v[i] *= J->dg[i]; return(rank); case JAC_CHOL: return(chol_solve(J->Z,v,J->p,J->p)); } Rprintf("jacob_solve: unknown method %d",J->st); return(0); } int jacob_hsolve(jacobian *J, double *v) /* J^{-1/2} v */ /*jacobian *J; double *v;*/ { int i; if (J->st == JAC_RAW) jacob_dec(J,DEF_METH); switch(J->st) { case JAC_EIG: return(eig_hsolve(J,v)); case JAC_EIGD: /* eigenvalues on corr matrix */ for (i=0; ip; i++) v[i] *= J->dg[i]; return(eig_hsolve(J,v)); case JAC_CHOL: return(chol_hsolve(J->Z,v,J->p,J->p)); } Rprintf("jacob_hsolve: unknown method %d",J->st); return(0); } double jacob_qf(jacobian *J, double *v) /* vT J^{-1} v */ /*jacobian *J; double *v;*/ { int i; if (J->st == JAC_RAW) jacob_dec(J,DEF_METH); switch (J->st) { case JAC_EIG: return(eig_qf(J,v)); case JAC_EIGD: for (i=0; ip; i++) v[i] *= J->dg[i]; return(eig_qf(J,v)); case JAC_CHOL: return(chol_qf(J->Z,v,J->p,J->p)); default: Rprintf("jacob_qf: invalid method\n"); return(0.0); } } locfit/src/scb_cons.c0000754000176200001440000003046414745736775014320 0ustar liggesusers/* * Copyright (c) 1996-2004 Catherine Loader. * This file contains functions to compute the constants * appearing in the tube formula. */ #include #include #include #include #include #include "tube.h" static double *fd, *ft; static int globm, (*wdf)(), use_covar, kap_terms; int k0_reqd(int d, int n, int uc) { int m; m = d*(d+1)+1; if (uc) return(2*m*m); else return(2*n*m); } void assignk0(double *z, int d, int n) /* z should be n*(2*d*d+2*d+2); */ { ft = z; z += n*(d*(d+1)+1); fd = z; z += n*(d*(d+1)+1); } /* Residual projection of y to the columns of A, * (I - A(R^TR)^{-1}A^T)y * R should be from the QR-decomp. of A. */ void rproject(double *y, double *A, double *R, int n, int p) { double v[1+TUBE_MXDIM]; int i, j; for (i=0; i=2) & (kap_terms >= 3)); m = globm = wdf(x,ft,r); memmove(fd,ft,m*(d+1)*sizeof(double)); if (use_covar) chol_dec(fd,m,d+1); else qr(fd,m,d+1,NULL); det = 1; for (j=1; j<=d; j++) det *= fd[j*(m+1)]/fd[0]; kap[0] = det; if (kap_terms == 1) return(1); kap[1] = 0.0; if ((kap_terms == 2) | (d<=1)) return(2); lij = &ft[(d+1)*m]; nij = &fd[(d+1)*m]; memmove(nij,lij,m*d*d*sizeof(double)); z = (use_covar) ? k2c(nij,ft,m,d,d) : k2x(nij,ft,m,d,d); kap[2] = z*det; if ((kap_terms == 3) | (d==2)) return(3); kap[3] = 0; return(4); } void d1c(double *li, double *ni, int m, int d, double *M) { int i, j, k, l; double t; fd[0] = ft[0]; for (i=0; i0) { t = 0.0; for (j=0; j= 5)) warning("terms = %2d\n", kap_terms); switch(ev) { case IMONTE: monte(k0x,fl,&fl[d],d,k0,mg[0]); break; case ISPHERIC: if (d==2) integ_disc(k0x,l1x,fl,k0,l0,mg); if (d==3) integ_sphere(k0x,l1x,fl,k0,l0,mg); break; case ISIMPSON: if (use_covar) simpson4(k0x,l1x,m0x,n0x,fl,&fl[d],d,k0,l0,m0,n0,mg,z); else simpson4(k0x,l1x,m0x,n0x,fl,&fl[d],d,k0,l0,m0,n0,mg,z); break; case IDERFREE: kodf(fl,&fl[d],mg,k0,l0); break; default: Rprintf("Unknown integration type in tube_constants().\n"); } if (deb>0) { Rprintf("constants:\n"); Rprintf(" k0: %8.5f %8.5f %8.5f %8.5f\n",k0[0],k0[1],k0[2],k0[3]); Rprintf(" l0: %8.5f %8.5f %8.5f\n",l0[0],l0[1],l0[2]); Rprintf(" m0: %8.5f %8.5f\n",m0[0],m0[1]); Rprintf(" n0: %8.5f\n",n0[0]); if (d==2) Rprintf(" check: %8.5f\n",(k0[0]+k0[2]+l0[1]+m0[0])/(2*PI)); if (d==3) Rprintf(" check: %8.5f\n",(l0[0]+l0[2]+m0[1]+n0[0])/(4*PI)); } if (aw) free(wk); kap[0] = k0[0]; if (kap_terms==1) return(1); kap[1] = l0[0]/2; if ((kap_terms==2) | (d==1)) return(2); kap[2] = (k0[2]+l0[1]+m0[0])/(2*PI); if ((kap_terms==3) | (d==2)) return(3); kap[3] = (l0[2]+m0[1]+n0[0])/(4*PI); return(4); } locfit/src/math.c0000754000176200001440000000751314745735532013445 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * miscellaneous functions that may not be defined in the math libraries. The implementations are crude. lflgamma(x) -- log(gamma(x)) lferf(x) -- erf(x) lferfc(x) -- erfc(x) lfdaws(x) -- dawson's function lf_exp(x) -- exp(x), but it won't overflow. where required, these must be #define'd in local.h. also includes ptail(x) -- exp(x*x/2)*int_{-\infty}^x exp(-u^2/2)du for x < -6. logit(x) -- logistic function. expit(x) -- inverse of logit. */ #include double lf_exp(double x) /* double x; */ { if (x>700.0) return(1.014232054735004e+304); return(exp(x)); } #include "local.h" double lferfc(double); double lferf(double x) /* double x; */ { static double val[] = { 0.0, 0.52049987781304674, 0.84270079294971501, 0.96610514647531076, 0.99532226501895282, 0.99959304798255499, 0.99997790950300125 }; double h, xx, y, z, f0, f1, f2; int m, j; if (x<0) return(-lferf(-x)); if (x>3.2) return(1-lferfc(x)); m = (int) (2*x+0.5); xx= ((double)m)/2; h = x-xx; y = h; f0 = val[m]; f1 = 2*exp(-xx*xx)/SQRPI; z = f0+h*f1; j = 0; while (fabs(y)>1.0e-12) { f2 = -2*j*f0-2*xx*f1; f0 = f1; f1 = f2; y *= h/(j+2); z += y*f2; j++; } return(z); } double lferfc(double x) /* double x; */ { if (x<0) return(1+lferf(-x)); if (x<2.5) return(1-lferf(x)); return(exp(-x*x)/(x*SQRPI)); } double lflgamma(double x) /* double x; */ { double x1; static double ilg[] = { 0.0, 0.0, 0.69314718055994529, 1.791759469228055, 3.1780538303479458, 4.7874917427820458, 6.5792512120101012, 8.5251613610654147, 10.604602902745251, 12.801827480081469 }; static double hlg[] = { 0.57236494292470008, -0.12078223763524520, 0.28468287047291918, 1.20097360234707430, 2.45373657084244230, 3.95781396761871650, 5.66256205985714270, 7.53436423675873360, 9.54926725730099870, 11.68933342079726900 }; if (x<=0.0) return(0.0); if (x<10) { if (x==(int)x) return(ilg[(int)x-1]); if ((x-0.5)==(int)(x-0.5)) return(hlg[(int)(x-0.5)]); } if (x<3) return(lflgamma(x+1)-log(x)); x1 = x-1; return(HL2PI+(x1+0.5)*log(x1)-x1+1/(12*x1)); } double lfdaws(double x) /* double x; */ { static double val[] = { 0, 0.24485619356002, 0.46034428261948, 0.62399959848185, 0.72477845900708, 0.76388186132749, 0.75213621001998, 0.70541701910853, 0.63998807456541, 0.56917098836654, 0.50187821196415, 0.44274283060424, 0.39316687916687, 0.35260646480842, 0.31964847250685, 0.29271122077502, 0.27039629581340, 0.25160207761769, 0.23551176224443, 0.22153505358518, 0.20924575719548, 0.19833146819662, 0.18855782729305, 0.17974461154688, 0.17175005072385 }; double h, f0, f1, f2, y, z, xx; int j, m; if (x<0) return(-daws(-x)); if (x>6) { /* Tail series: 1/x + 1/x^3 + 1.3/x^5 + 1.3.5/x^7 + ... */ y = z = 1/x; j = 0; while (((f0=(2*j+1)/(x*x))<1) && (y>1.0e-10*z)) { y *= f0; z += y; j++; } return(z); } m = (int) (4*x); h = x-0.25*m; if (h>0.125) { m++; h = h-0.25; } xx = 0.25*m; f0 = val[m]; f1 = 1-xx*f0; z = f0+h*f1; y = h; j = 2; while (fabs(y)>z*1.0e-10) { f2 = -(j-1)*f0-xx*f1; y *= h/j; z += y*f2; f0 = f1; f1 = f2; j++; } return(z); } double ptail(double x) /* exp(x*x/2)*int_{-\infty}^x exp(-u^2/2)du for x < -6 */ /* double x; */ { double y, z, f0; int j; y = z = -1.0/x; j = 0; while ((fabs(f0= -(2*j+1)/(x*x))<1) && (fabs(y)>1.0e-10*z)) { y *= f0; z += y; j++; } return(z); } double logit(double x) /* double x; */ { return(log(x/(1-x))); } double expit(double x) /* double x; */ { double u; if (x<0) { u = exp(x); return(u/(1+u)); } return(1/(1+exp(-x))); } int factorial(int n) /* int n; */ { if (n<=1) return(1.0); return(n*factorial(n-1)); } locfit/src/startlf.c0000754000176200001440000001044014745737272014167 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * startlf(des,lf,vfun,nopc) -- starting point for locfit. des and lf are pointers to the design and fit structures. vfun is the vertex processing function. nopc=1 inhibits computation of parametric component. lfit_init(lf) -- initialize the lfit structure. lf is pointer to fit. preproc() -- fit preprocessing (limits, scales, paramcomp etc.) set_scales() set_flim() -- compute bounding box. fitoptions() clocfit() -- start point for CLocfit - interpret cmd line etc. */ #include "local.h" void evstruc_init(evstruc *evs) /* evstruc_init(evs) evstruc *evs; */ { int i; ev(evs) = ETREE; mk(evs) = 100; cut(evs) = 0.8; for (i=0; ifl[i] = evs->fl[i+MXDIM] = 0.0; evs->mg[i] = 10; } evs->nce = evs->ncm = 0; } void fitpt_init(fitpt *fp) /* fitpt_init(fp) fitpt *fp; */ { dc(fp) = 0; geth(fp) = GSTD; fp->nv = fp->nvm = 0; } void lfit_init(lfit *lf) /* lfit_init(lf) lfit *lf; */ { lfdata_init(&lf->lfd); evstruc_init(&lf->evs); smpar_init(&lf->sp,&lf->lfd); deriv_init(&lf->dv); fitpt_init(&lf->fp); } void fitdefault(lfit *lf) /* fitdefault(lf) lfit *lf; */ { WARN(("fitdefault deprecated -- use lfit_init()")); lfit_init(lf); } void set_flim(lfdata *lfd, evstruc *evs) /* set_flim(lfd,evs) lfdata *lfd; evstruc *evs; */ { int i, j, d, n; double z, mx, mn, *bx; if (ev(evs)==ESPHR) return; d = lfd->d; n = lfd->n; bx = evs->fl; for (i=0; isty[i]==STANGL) { bx[i] = 0.0; bx[i+d] = 2*PI*lfd->sca[i]; } else { mx = mn = datum(lfd,i,0); for (j=1; jxl[i]xl[i+d]) /* user set xlim; maybe use them. */ { z = mx-mn; if (mn-0.2*z < lfd->xl[i]) mn = lfd->xl[i]; if (mx+0.2*z > lfd->xl[i+d]) mx = lfd->xl[i+d]; } bx[i] = mn; bx[i+d] = mx; } } } double vecsum(double *v, int n) /* vecsum(v,n) double *v; int n; */ { int i; double sum; sum = 0.0; for (i=0; id; i++) if (lfd->sca[i]<=0) /* set automatic scales */ { if (lfd->sty[i]==STANGL) lfd->sca[i] = 1.0; else lfd->sca[i] = sqrt(vvari(lfd->x[i],lfd->n)); } } void startlf(design *des, lfit *lf, int (*vfun)(), int nopc) /* startlf(des,lf,vfun,nopc) design *des; lfit *lf; int (*vfun)(), nopc; */ { int i, d, n; if (lf_debug>0) printf("startlf\n"); n = lf->lfd.n; d = lf->lfd.d; des->vfun = vfun; npar(&lf->sp) = calcp(&lf->sp,lf->lfd.d); des_init(des,n,npar(&lf->sp)); des->smwt = (lf->lfd.w==NULL) ? n : vecsum(lf->lfd.w,n); set_scales(&lf->lfd); set_flim(&lf->lfd,&lf->evs); compparcomp(des,&lf->lfd,&lf->sp,&lf->pc,geth(&lf->fp),nopc); makecfn(&lf->sp,des,&lf->dv,lf->lfd.d); lf->lfd.ord = 0; if ((d==1) && (lf->lfd.sty[0]!=STANGL)) { i = 1; while ((ilfd,0,i)>=datum(&lf->lfd,0,i-1))) i++; lf->lfd.ord = (i==n); } for (i=0; isp); i++) des->fix[i] = 0; lf->fp.d = lf->lfd.d; lf->fp.hasd = (des->ncoef==(1+lf->fp.d)); if (lf_debug>1) printf("call eval structure\n"); switch(ev(&lf->evs)) { case EPHULL: triang_start(des,lf); break; case EDATA: dataf(des,lf); break; case ECROS: crossf(des,lf); break; case EGRID: gridf(des,lf); break; case ETREE: atree_start(des,lf); break; case EKDCE: kt(&lf->sp) = KCE; case EKDTR: kdtre_start(des,lf); break; case EPRES: preset(des,lf); break; case EXBAR: xbarf(des,lf); break; case ENONE: lf->fp.nv = lf->evs.nce = 0; return; case ESPHR: sphere_start(des,lf); break; case ESPEC: lf->evs.espec(des,lf); break; default: ERROR(("startlf: Invalid evaluation structure %d",ev(&lf->evs))); } /* renormalize for family=density */ if ((de_renorm) && (fam(&lf->sp)==TDEN)) dens_renorm(lf,des); } locfit/src/lffuns.h0000754000176200001440000000705414745724400014006 0ustar liggesusers/* * Copyright (c) 1998-2001 Lucent Technologies. * See README file for details. * * * * Function definitions for Locfit. */ /* FILES IN THE src DIRECTORY */ /* adap.c */ extern int alocfit(); /* band.c */ extern void band(), kdeselect(), kdecri(); /* density.c */ extern int densinit(), likeden(); extern int fact[]; extern void prodintresp(), prresp(); extern int de_mint, de_itype, de_renorm; /* dens_haz.c */ extern void haz_init(); extern int hazint(); /* dens_int.c */ extern double dens_integrate(); extern void dens_renorm(), dens_lscv(), lforder(); /* ev_atree.c */ extern void atree_start(), atree_grow(), atree_guessnv(); extern double atree_int(); /* ev_interp.c */ extern double dointpoint(), cubintd(); extern double linear_interp(), cubic_interp(), rectcell_interp(); extern int exvval(); extern void exvvalpv(), hermite2(); /* ev_kdtre.c */ extern void kdtre_start(), kdtre_guessnv(); extern double kdtre_int(); /* ev_sphere.c */ extern void sphere_start(), sphere_guessnv(); extern double sphere_int(); /* ev_main.c */ extern void trchck(), guessnv(), lfit_alloc(); extern void dataf(), gridf(), crossf(), xbarf(), preset(); extern int findpt(), newsplit(), lfit_reqd(), lfit_reqi(); /* ev_trian.c */ extern void triang_start(), triang_grow(), triang_guessnv(); extern double triang_int(); /* family.c */ extern int links(), stdlinks(), defaultlink(), validlinks(); extern double b2(), b3(), b4(), lf_link(), invlink(); /* fitted.c */ extern void fitted(); /* frend.c */ extern void ressumm(); extern double rss(); /* lf_dercor.c */ extern void dercor(); /* lf_fitfun.c */ extern void fitfun(), makecfn(), designmatrix(); extern int calcp(), coefnumber(); /* lf_nbhd.c */ extern double kordstat(), rho(); extern void nbhd(); /* lf_robust.c */ extern double median(); extern void lf_robust(); /* lfstr.c */ extern int lffamily(), lfkernel(), lfketype(), lflink(); extern int deitye(), lfevstr(), lfacri(); extern int ppwhat(), restyp(); /* lf_vari.c */ extern void lf_vcov(), comp_vari(), local_df(); /* locfit.c */ extern int locfit(), des_reqd(), des_reqi(); extern void lfdata_init(), smpar_init(), deriv_init(), des_init(), lfiter(); extern int lf_maxit, lf_debug; /* math.c */ extern double lflgamma(), lferf(), lferfc(), lfdaws(), lf_exp(); extern double ptail(), logit(), expit(); extern double lgamma(), erf(), erfc(); extern int factorial(); /* minmax.c */ extern double ipower(), minmax(); /* odint.c */ extern int onedint(); extern void recurint(); /* pcomp.c */ extern double addparcomp(); extern void compparcomp(), subparcomp(), subparcomp2(), pcchk(); extern int pc_reqd(), noparcomp(); /* preplot.c */ extern void preplot(lfit *lf, double **x, double *f, double *se, char band, Sint *mg, int where, int what); /* extern void cpreplot();*/ /* extern int setpppoints(); */ /* procv.c */ extern int procvhatm(), procv(), procvraw(), procvvord(), calcp(); /* resid.c */ extern double resid(); /* scb.c */ extern void scb(), cscbsim(); /* scb_iface.c */ extern int constants(); /* simul.c */ extern void liksim(), scbsim(), scbmax(), regband(), rband(); /* startlf.c */ extern void set_flim(), set_scales(), startlf(), lfit_init(); extern void fitoptions(), clocfit(), endfit(); extern int nofit(); /* strings.c */ extern int stm(), pmatch(), matchlf(), matchrt(), checkltor(), checkrtol(); extern void strip(); /* wdiag.c */ extern int wdiag(), wdiagp(); /* weight.c */ extern double W(), weight(), weightd(), Wd(), Wdd(), wint(); extern double Wconv(), Wconv1(), Wconv4(), Wconv5(), Wconv6(), Wikk(); extern int iscompact(), wtaylor(); locfit/src/m_chol.c0000754000176200001440000000272014745735573013755 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include #include "mutil.h" /* A is a n*p matrix, find the cholesky decomposition * of the first p rows. In most applications, will want n=p. */ void chol_dec(double *A, int n, int p) /*double *A; int n, p;*/ { int i, j, k; for (j=0; j=0; i--) { for (j=i+1; jfp.lwk = lf->fp.lev = lf->fp.ll = lf->evs.liw = lf->pc.lwk = 0; lf->lf_init_id = LF_INIT_ID; } int lfit_reqd(int d, int nvm, int ncm, int geth) /* lfit_reqd(d,nvm,ncm,geth) int d, nvm, ncm, geth; */ { int z; z = (geth==GSMP) ? d+3 : 3*d+8; return(nvm*z+ncm); } int lfit_reqi(int nvm, int ncm, int vc) /* lfit_reqi(nvm,ncm,vc) int nvm, ncm, vc; */ { return(ncm*vc+3*MAX(ncm,nvm)); } void trchck(lfit *lf, int nvm, int ncm, int vc) /* trchck(lf,nvm,ncm,vc) lfit *lf; int nvm, ncm, vc; */ { int rw, d; Sint *k; double *z; if (lf->lf_init_id != LF_INIT_ID) lfit_alloc(lf); d = lf->lfd.d; if (lf->fp.lev < d*nvm) { lf->fp.xev = (double *)calloc(d*nvm,sizeof(double)); lf->fp.lev = d*nvm; } rw = lfit_reqd(d,nvm,ncm,geth(&lf->fp)); if (lf->fp.lwk < rw) { lf->fp.coef = (double *)calloc(rw,sizeof(double)); lf->fp.lwk = rw; } z = lf->fp.coef; lf->fp.coef= z; z += nvm*(d+1); if (geth(&lf->fp) != GSMP) { lf->fp.nlx = z; z += nvm*(d+1); lf->fp.t0 = z; z += nvm*(d+1); lf->fp.lik = z; z += 3*nvm; } lf->fp.h = z; z += nvm; lf->fp.deg = z; z += nvm; lf->evs.sv = z; z += ncm; rw = lfit_reqi(nvm,ncm,vc); if (lf->evs.liwevs.iwk = (Sint *)calloc(rw,sizeof(Sint)); lf->evs.liw = rw; } k = lf->evs.iwk; lf->evs.ce = k; k += vc*ncm; lf->evs.s = k; k += MAX(ncm,nvm); lf->evs.lo = k; k += MAX(ncm,nvm); lf->evs.hi = k; k += MAX(ncm,nvm); lf->fp.nvm = nvm; lf->evs.ncm = ncm; } void data_guessnv(int *nvm, int *ncm, int *vc, int n) /* data_guessnv(nvm,ncm,vc,n) int *nvm, *ncm, *vc, n; */ { *nvm = n; *ncm = *vc = 0; } void dataf(design *des, lfit *lf) /* dataf(des,lf) design *des; lfit *lf; */ { int d, i, j, ncm, nv, vc; d = lf->lfd.d; data_guessnv(&nv,&ncm,&vc,lf->lfd.n); trchck(lf,nv,ncm,vc); for (i=0; ifp,i,j) = datum(&lf->lfd,j,i); for (i=0; ivfun(des,lf,i); lf->evs.s[i] = 0; } lf->fp.nv = lf->fp.nvm = nv; lf->evs.nce = 0; } void xbar_guessnv(int *nvm, int *ncm, int *vc) /* xbar_guessnv(nvm,ncm,vc) int *nvm, *ncm, *vc; */ { *nvm = 1; *ncm = *vc = 0; return; } void xbarf(design *des, lfit *lf) /* xbarf(des,lf) design *des; lfit *lf; */ { int i, d, nvm, ncm, vc; d = lf->lfd.d; xbar_guessnv(&nvm,&ncm,&vc); trchck(lf,1,0,0); for (i=0; ifp,0,i) = lf->pc.xbar[i]; des->vfun(des,lf,0); lf->evs.s[0] = 0; lf->fp.nv = 1; lf->evs.nce = 0; } void preset(design *des, lfit *lf) /* preset(des,lf) design *des; lfit *lf; */ { int i, nv; nv = lf->fp.nvm; trchck(lf,nv,0,0); for (i=0; ivfun(des,lf,i); lf->evs.s[i] = 0; } lf->fp.nv = nv; lf->evs.nce = 0; } void crossf(design *des, lfit *lf) /* crossf(des,lf) design *des; lfit *lf; */ { int d, i, j, n, nv, ncm, vc; double w; n = lf->lfd.n; d = lf->lfd.d; data_guessnv(&nv,&ncm,&vc,n); trchck(lf,nv,ncm,vc); if (lf->lfd.w==NULL) ERROR(("crossf() needs prior weights")); for (i=0; ifp,i,j) = datum(&lf->lfd,j,i); for (i=0; ievs.s[i] = 0; w = prwt(&lf->lfd,i); lf->lfd.w[i] = 0; des->vfun(des,lf,i); lf->lfd.w[i] = w; } lf->fp.nv = n; lf->evs.nce = 0; } void gridf(design *des, lfit *lf) /* gridf(des,lf) design *des; lfit *lf; */ { int d, i, j, nv, u0, u1, z; nv = 1; d = lf->lfd.d; for (i=0; ievs.mg[i]==0) lf->evs.mg[i] = 2+(int)((lf->evs.fl[i+d]-lf->evs.fl[i])/(lf->lfd.sca[i]*cut(&lf->evs))); nv *= lf->evs.mg[i]; } trchck(lf,nv,0,1<evs.mg[j]; u1 = lf->evs.mg[j]-1-u0; evptx(&lf->fp,i,j) = (lf->evs.mg[j]==1) ? lf->evs.fl[j] : (u1*lf->evs.fl[j]+u0*lf->evs.fl[j+d])/(lf->evs.mg[j]-1); z = z/lf->evs.mg[j]; } lf->evs.s[i] = 0; des->vfun(des,lf,i); } lf->fp.nv = nv; lf->evs.nce = 0; } int findpt(fitpt *fp, evstruc *evs, int i0, int i1) /* findpt(fp,evs,i0,i1) fitpt *fp; evstruc *evs; int i0, i1; */ { int i; if (i0>i1) ISWAP(i0,i1); for (i=i1+1; inv; i++) if ((evs->lo[i]==i0) && (evs->hi[i]==i1)) return(i); return(-1); } /* add a new vertex at the midpoint of (x[i0],x[i1]). return the vertex number. */ int newsplit(design *des, lfit *lf, int i0, int i1, int pv) /* newsplit(des,lf,i0,i1,pv) design *des; lfit *lf; int i0, i1, pv; */ { int i, nv; i = findpt(&lf->fp,&lf->evs,i0,i1); if (i>=0) return(i); if (i0>i1) ISWAP(i0,i1); nv = lf->fp.nv; /* the point is new. Now check we have space for the new point. */ if (nv==lf->fp.nvm) { ERROR(("newsplit: out of vertex space")); return(-1); } /* compute the new point, and evaluate the fit */ lf->evs.lo[nv] = i0; lf->evs.hi[nv] = i1; for (i=0; ifp.d; i++) evptx(&lf->fp,nv,i) = (evptx(&lf->fp,i0,i)+evptx(&lf->fp,i1,i))/2; if (pv) /* pseudo vertex */ { lf->fp.h[nv] = (lf->fp.h[i0]+lf->fp.h[i1])/2; lf->evs.s[nv] = 1; /* pseudo-vertex */ } else /* real vertex */ { des->vfun(des,lf,nv); lf->evs.s[nv] = 0; } lf->fp.nv++; return(nv); } locfit/src/dens_int.c0000754000176200001440000001302214745733612014304 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * The function dens_integrate(lf,des,z) is used to integrate a density * estimate (z=1) or the density squared (z=2). This is used to renormalize * the estimate (function dens_renorm) or in the computation of LSCV * (function dnes_lscv). The implementation is presently for d=1. * * The computation orders the fit points selected by locfit, and * integrates analytically over each interval. For the log-link, * the interpolant used is peicewise quadratic (with one knot in * the middle of each interval); this differs from the cubic interpolant * used elsewhere in Locfit. * * TODO: allow for xlim. What can be done simply in >=2 dimensions? * fix df computation (in lscv) for link=IDENT. */ #include "local.h" /* * Finds the order of observations in the array x, and * stores in integer array ind. * At input, lset l=0 and r=length(x)-1. * At output, x[ind[0]] <= x[ind[1]] <= ... */ void lforder(Sint *ind, double *x, int l, int r) /* Sint *ind; double *x; int l, r; */ { double piv; int i, i0, i1; piv = (x[ind[l]]+x[ind[r]])/2; i0 = l; i1 = r; while (i0<=i1) { while ((i0<=i1) && (x[ind[i0]]<=piv)) i0++; while ((i0<=i1) && (x[ind[i1]]>piv)) i1--; if (i0=l) && (x[ind[i1]]==piv)) i1--; for (i=l; i<=i1; i++) if (x[ind[i]]==piv) { ISWAP(ind[i],ind[i1]); while (x[ind[i1]]==piv) i1--; } if (lfp; if (fp->d >= 2) { WARN(("dens_integrate requires d=1")); return(0.0); } has_deriv = (deg(&lf->sp) > 0); /* not right? */ fit = fp->coef; if (has_deriv) deriv = &fit[fp->nvm]; xev = evp(fp); /* * order the vertices */ nv = fp->nv; if (lf->lfd.nind; for (i=0; isp)==LLOG) { f1 *= 2; d1 *= 2; } else { d1 = 2*d1*f1; f1 = f1*f1; } } term = (link(&lf->sp)==LIDENT) ? f1*f1/(2*d1) : exp(f1)/d1; sum += term; i0 = ind[nv-2]; i1 = ind[nv-1]; f0 = fit[i1]; d0 = (has_deriv) ? deriv[i1] : (fit[i1]-fit[i0])/(xev[i1]-xev[i0]); if (d0 >= 0) WARN(("dens_integrate - ouch!")); if (z==2) { if (link(&lf->sp)==LLOG) { f0 *= 2; d0 *= 2; } else { d0 = 2*d0*f0; f0 = f0*f0; } } term = (link(&lf->sp)==LIDENT) ? -f0*f0/(2*d0) : exp(f0)/d0; sum += term; for (i=1; isp)==LLOG) { f0 *= 2; f1 *= 2; d0 *= 2; d1 *= 2; } else { d0 *= 2*f0; d1 *= 2*f1; f0 = f0*f0; f1 = f1*f1; } } term = estdiv(xev[i0],xev[i1],f0,f1,d0,d1,link(&lf->sp)); sum += term; } return(sum); } void dens_renorm(lfit *lf, design *des) /* lfit *lf; design *des; */ { int i; double sum; sum = dens_integrate(lf,des,1); if (sum==0.0) return; sum = log(sum); for (i=0; ifp.nv; i++) lf->fp.coef[i] -= sum; } void dens_lscv(design *des, lfit *lf) /* design *des; lfit *lf; */ { double df, fh, fh_cv, infl, z0, z1, x[MXDIM]; int i, n, j, evo; z1 = df = 0.0; evo = ev(&lf->evs); n = lf->lfd.n; if ((evo==EDATA) | (evo==ECROS)) evo = EFITP; z0 = dens_integrate(lf,des,2); for (i=0; ilfd.d; j++) x[j] = datum(&lf->lfd,j,i); fh = base(&lf->lfd,i)+dointpoint(lf,x,PCOEF,evo,i); if (link(&lf->sp)==LLOG) fh = exp(fh); infl = dointpoint(lf,x,PT0,evo,i); infl = infl * infl; if (infl>1) infl = 1; fh_cv = (link(&lf->sp) == LIDENT) ? (n*fh - infl) / (n-1.0) : fh*(1-infl)*n/(n-1.0); z1 += fh_cv; df += infl; } lf->fp.L[0] = z0-2*z1/n; lf->fp.L[1] = df; } locfit/src/band.c0000754000176200001440000002075114745725154013416 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include "local.h" /* extern void fitoptions(); */ static double hmin, gmin, sig2, pen, vr, tb; static lfit *blf; static design *bdes; int procvbind(design *des, lfit *lf, int v) /*design *des; lfit *lf; int v;*/ { double s0, s1, bi; int i, ii, k; k = procvraw(des,lf,v); wdiag(&lf->lfd, &lf->sp, des,des->wd,&lf->dv,0,1,0); s0 = s1 = 0.0; for (i=0; in; i++) { ii = des->ind[i]; s0+= prwt(&lf->lfd,ii)*des->wd[i]*des->wd[i]; bi = prwt(&lf->lfd,ii)*fabs(des->wd[i]*ipower(des->di[ii],deg(&lf->sp)+1)); s1+= bi*bi; } vr += s0; tb += s1; return(k); } double bcri(double h, int c, int cri) /*double h; int c, cri;*/ { double num, den; int (*pv)(); if (c==DALP) blf->sp.nn = h; else blf->sp.fixh = h; if ((cri&63)==BIND) { pv = procvbind; vr = tb = 0.0; } else pv = procv; if (cri<64) startlf(bdes,blf,pv,0); switch(cri&63) { case BGCV: ressumm(blf,bdes); num = -2*blf->lfd.n*llk(&blf->fp); den = blf->lfd.n-df0(&blf->fp); return(num/(den*den)); case BCP: ressumm(blf,bdes); return(-2*llk(&blf->fp)/sig2-blf->lfd.n+pen*df0(&blf->fp)); case BIND: return(vr+pen*pen*tb); } ERROR(("bcri: unknown criterion")); return(0.0); } void bsel2(double h0, double g0, double ifact, int c, int cri) /*double h0, g0, ifact; int c, cri;*/ { int done, inc; double h1, g1; h1 = h0; g1 = g0; done = inc = 0; while (!done) { h1 *= 1+ifact; g0 = g1; g1 = bcri(h1,c,cri); if (g1g0) inc++; else inc = 0; switch(cri) { case BIND: done = (inc>=4) & (vrfp.nv); break; default: done = (inc>=4); } } } void bsel3(double h0, double g0, double ifact, int c, int cri) /*double h0, g0, ifact; int c, cri;*/ { double h1, g1; int i; hmin = h0; gmin = g0; for (i=-1; i<=1; i++) if (i!=0) { h1 = h0*(1+i*ifact); g1 = bcri(h1,c,cri); if (g1sp)+1); hmin = h0 = (c==DFXH) ? fixh(&lf->sp) : nn(&lf->sp); if (h0==0) ERROR(("bselect: initial bandwidth is 0")); if (lf_error) return; sig2 = 1.0; gmin = g0 = bcri(h0,c,cri); if (cri==BCP) { sig2 = rv(&lf->fp); g0 = gmin = bcri(h0,c,cri+64); } ifact = 0.3; bsel2(h0,g0,ifact,c,cri); for (i=0; i<5; i++) { ifact = ifact/2; bsel3(hmin,gmin,ifact,c,cri); } if (c==DFXH) fixh(&lf->sp) = hmin; else nn(&lf->sp) = hmin; startlf(des,lf,procv,0); ressumm(lf,des); } double compsda(double *x, double h, int n) /* n/(n-1) * int( fhat''(x)^2 dx ); bandwidth h */ /*double *x, h; int n;*/ { int i, j; double ik, sd, z; ik = wint(1,NULL,0,WGAUS); sd = 0; for (i=0; ifact*h[2])|(h[2]>fact*h[3])) { h[4] = h[3]-d[3]*(h[3]-h[2])/(d[3]-d[2]); if ((h[4]h[1])) h[4] = (h[0]+h[1])/2; kdecri(x,h[4],res,c,j,ker,n); r[4] = res[0]; d[4] = res[1]; if (lf_error) return(0.0); h[2] = h[3]; h[3] = h[4]; d[2] = d[3]; d[3] = d[4]; r[2] = r[3]; r[3] = r[4]; if (d[4]*d[0]>0) { h[0] = h[4]; d[0] = d[4]; r[0] = r[4]; } else { h[1] = h[4]; d[1] = d[4]; r[1] = r[4]; } } if (j>=4) return(h[4]); /* first min for BCV etc */ if (r[4]<=min) { min = r[4]; minh = h[4]; } nc++; } } if (nc==0) minh = (r[5]evs); sphere_guessnv(&nv,&ncm,&vc,mg); trchck(lf,nv,0,0); // d = lf->lfd.d; rmin = lf->evs.fl[0]; rmax = lf->evs.fl[1]; orig = &lf->evs.fl[2]; rmin = 0; rmax = 1; orig[0] = orig[1] = 0.0; ct = 0; for (i=0; ifp,ct,0) = orig[0] + r*c; evptx(&lf->fp,ct,1) = orig[1] + r*s; des->vfun(des,lf,ct); ct++; } } lf->fp.nv = ct; lf->evs.nce = 0; } double sphere_int(lfit *lf, double *x, int what) /* sphere_int(lf,x,what) lfit *lf; double *x; int what; */ { double rmin, rmax, *orig, dx, dy, r, th, th0, th1; double v[64][64], c0, c1, s0, s1, r0, r1, d0, d1; double ll[2], ur[2], xx[2]; int i0, j0, i1, j1, *mg, nc, ce[4]; rmin = lf->evs.fl[0]; rmax = lf->evs.fl[1]; orig = &lf->evs.fl[2]; rmin = 0; rmax = 1; orig[0] = orig[1] = 0.0; mg = mg(&lf->evs); dx = x[0] - orig[0]; dy = x[1] - orig[1]; r = sqrt(dx*dx+dy*dy); th = atan2(dy,dx); /* between -pi and pi */ i0 = (int)floor(mg[1]*th/(2*PI)) % mg[1]; j0 = (int)(mg[0]*(r-rmin)/(rmax-rmin)); i1 = (i0+1) % mg[1]; j1 = j0+1; if (j1>mg[0]) { j0 = mg[0]-1; j1 = mg[0]; } ce[0] = i0*(mg[0]+1)+j0; ce[1] = i0*(mg[0]+1)+j1; ce[2] = i1*(mg[0]+1)+j0; ce[3] = i1*(mg[0]+1)+j1; nc = exvval(&lf->fp,v[0],ce[0],2,what,1); nc = exvval(&lf->fp,v[1],ce[1],2,what,1); nc = exvval(&lf->fp,v[2],ce[2],2,what,1); nc = exvval(&lf->fp,v[3],ce[3],2,what,1); th0 = 2*PI*i0/mg[1]; c0 = cos(th0); s0 = sin(th0); th1 = 2*PI*i1/mg[1]; c1 = cos(th1); s1 = sin(th1); r0 = rmin + j0*(rmax-rmin)/mg[0]; r1 = rmin + j1*(rmax-rmin)/mg[0]; d0 = c0*v[0][1] + s0*v[0][2]; d1 = r0*(c0*v[0][2]-s0*v[0][1]); v[0][1] = d0; v[0][2] = d1; d0 = c0*v[1][1] + s0*v[1][2]; d1 = r1*(c0*v[1][2]-s0*v[1][1]); v[1][1] = d0; v[1][2] = d1; d0 = c1*v[2][1] + s1*v[2][2]; d1 = r0*(c1*v[2][2]-s1*v[2][1]); v[2][1] = d0; v[2][2] = d1; d0 = c1*v[3][1] + s1*v[3][2]; d1 = r1*(c1*v[3][2]-s1*v[3][1]); v[3][1] = d0; v[3][2] = d1; xx[0] = r; xx[1] = th; ll[0] = r0; ll[1] = th0; ur[0] = r1; ur[1] = th1; return(rectcell_interp(xx,v,ll,ur,2,nc)); } locfit/src/imatlb.h0000754000176200001440000000156614745724400013763 0ustar liggesuserstypedef struct { int n; double *dpr; } vari; typedef struct { double *Z, *Q, *dg, *f2; int p, sm; } xtwxstruc; typedef struct { vari *wk; double *coef, *xbar, *f; xtwxstruc xtwx; } paramcomp; typedef struct { vari *dw, *index; double *xev, *X, *w, *di, *res, *th, *wd, h, xb[15]; double *V, *P, *f1, *ss, *oc, *cf, llk; xtwxstruc xtwx; int *ind, n, p, pref, (*itype)(); int (*vfun)(); } design; typedef struct { vari *tw, *L, *iw, *xxev; double *x[15], *y, *w, *base, *c, *xl; double *coef, *nlx, *t0, *lik, *h, *deg; double *sv, *fl, *sca, *dp, kap[3]; int *ce, *s, *lo, *hi, sty[15]; int *mg, nvm, ncm, vc; int nl, nv, nnl, nce, nk, nn, *mi, ord, deriv[9], nd; paramcomp pc; varname yname, xname[15], wname, bname, cname; } lfit; extern void mlbcall( double *x, double *y, double *xx, double *ff, int n); locfit/src/lf_vari.c0000754000176200001440000001045414745735367014142 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * Post-fitting functions to compute the local variance and * influence functions. Also the local degrees of freedom * calculations for adaptive smoothing. */ #include "local.h" extern double robscale; static double tr0, tr1, tr2; /* vmat() computes (after the local fit..) the matrix M2 = X^T W^2 V X. M12 = (X^T W V X)^{-1} M2 Also, for convenience, tr[0] = sum(wi) tr[1] = sum(wi^2). */ void vmat(lfdata *lfd, smpar *sp, design *des, double *M12, double *M2) /*lfdata *lfd; smpar *sp; design *des; double *M12, *M2;*/ { int i, p, nk, ok; double link[LLEN], h, ww; p = des->p; setzero(M2,p*p); nk = -1; /* for density estimation, use integral rather than sum form, if W^2 is programmed... */ if ((fam(sp)<=THAZ) && (link(sp)==LLOG)) { switch(ker(sp)) { case WGAUS: nk = WGAUS; h = des->h/SQRT2; break; case WRECT: nk = WRECT; h = des->h; break; case WEPAN: nk = WBISQ; h = des->h; break; case WBISQ: nk = WQUQU; h = des->h; break; case WTCUB: nk = W6CUB; h = des->h; break; case WEXPL: nk = WEXPL; h = des->h/2; break; } } tr0 = tr1 = 0.0; if (nk != -1) { ok = ker(sp); ker(sp) = nk; /* compute M2 using integration. Use M12 as work matrix. */ (des->itype)(des->xev, M2, M12, des->cf, h); ker(sp) = ok; if (fam(sp)==TDEN) multmatscal(M2,des->smwt,p*p); tr0 = des->ss[0]; tr1 = M2[0]; /* n int W e^ */ } else { for (i=0; in; i++) { stdlinks(link,lfd,sp,(int)des->ind[i],des->th[i],robscale); ww = SQR(des->w[i])*link[ZDDLL]; tr0 += des->w[i]; tr1 += SQR(des->w[i]); addouter(M2,d_xi(des,i),d_xi(des,i),p,ww); } } memmove(M12,M2,p*p*sizeof(double)); for (i=0; ixtwx,&M12[i*p]); } void lf_vcov(lfdata *lfd, smpar *sp, design *des) /*lfdata *lfd; smpar *sp; design *des;*/ { int i, j, k, p; double *M12, *M2; M12 = des->V; M2 = des->P; p = des->p; vmat(lfd,sp,des,M12,M2); /* M2 = X^T W^2 V X tr0=sum(W) tr1=sum(W*W) */ tr2 = m_trace(M12,p); /* tr (XTWVX)^{-1}(XTW^2VX) */ /* * Covariance matrix is M1^{-1} * M2 * M1^{-1} * We compute this using the cholesky decomposition of * M2; premultiplying by M1^{-1} and squaring. This * is more stable than direct computation in near-singular cases. */ chol_dec(M2,p,p); for (i=0; ixtwx,&M2[i*p]); for (i=0; ismwt),p*p); } void comp_vari(lfdata *lfd, smpar *sp, design *des, double *tr, double *t0) /*lfdata *lfd; smpar *sp; design *des; double *tr, *t0;*/ { int i; lf_vcov(lfd,sp,des); tr[0] = tr0; tr[1] = tr1; tr[2] = tr2; /* influence components */ unitvec(des->f1,0,des->p); jacob_solve(&des->xtwx,des->f1); for (i=0; i<=lfd->d; i++) t0[i] = des->f1[i]; } /* local_df computes: * tr[0] = trace(W) * tr[1] = trace(W*W) * tr[2] = trace( M1^{-1} M2 ) * tr[3] = trace( M1^{-1} M3 ) * tr[4] = trace( (M1^{-1} M2)^2 ) * tr[5] = var(theta-hat). */ void local_df(lfdata *lfd, smpar *sp, design *des, double *tr) /*lfdata *lfd; smpar *sp; design *des; double *tr;*/ { int i, j, p; double *m2, *V, ww, link[LLEN]; tr[0] = tr[1] = tr[2] = tr[3] = tr[4] = tr[5] = 0.0; m2 = des->V; V = des->P; p = des->p; vmat(lfd,sp,des,m2,V); /* M = X^T W^2 V X tr0=sum(W) tr1=sum(W*W) */ tr[0] = tr1; tr[1] = tr1; tr[2] = m_trace(m2,p); /* tr (XTWVX)^{-1}(XTW^2VX) */ unitvec(des->f1,0,p); jacob_solve(&des->xtwx,des->f1); for (i=0; if1[i]*V[i*p+j]*des->f1[j]; /* var(thetahat) */ } tr[5] = sqrt(tr[5]); setzero(m2,p*p); for (i=0; in; i++) { stdlinks(link,lfd,sp,(int)des->ind[i],des->th[i],robscale); ww = SQR(des->w[i])*des->w[i]*link[ZDDLL]; addouter(m2,d_xi(des,i),d_xi(des,i),p,ww); } for (i=0; ixtwx,&m2[i*p]); tr[3] += m2[i*(p+1)]; } return; } locfit/src/lfcons.h0000754000176200001440000001403614745724400013773 0ustar liggesusers/* * Copyright (c) 1998-2001 Lucent Technologies. * See README file for details. * * Numeric values for constants used in locfit */ /* MXDIM and MXDEG are maximum dimension and local polynomial degree for Locfit. Note that some parts of the code may be more restrictive. */ #define MXDIM 15 #define MXDEG 7 /* floating point constants */ #ifndef PI #define PI 3.141592653589793238462643 #endif #define S2PI 2.506628274631000502415765 #define SQRT2 1.4142135623730950488 #define LOGPI 1.144729885849400174143427 #define GOLDEN 0.61803398874989484820 #define HL2PI 0.91893853320467267 /* log(2pi)/2 */ #define SQRPI 1.77245385090552 /* sqrt(pi) */ /* Criteria for adaptive local fitting mi[MACRI] 1: localized CP; 2: ICI (katkovnik); 3: curvature model index 4: Increase bandwidth until locfit returns LF_OK */ #define ANONE 0 #define ACP 1 #define AKAT 2 #define AMDI 3 #define AOK 4 /* vector of double precision parameters. 0, 1, 2 are the three components of the smoothing parameter. 3 cut parameter for adaptive evaluation structures. 4-8 are likelihood, degrees of freedom and residual variance, computed as part of the fit. Stored as the lf.dp vector. */ #define DALP 0 #define DFXH 1 #define DADP 2 #define DCUT 3 #define DLK 4 #define DT0 5 #define DT1 6 #define DRV 7 #define DSWT 8 #define DRSC 9 #define LEND 10 /* Evaluation structures mi[MEV] EFITP special for `interpolation' at fit points */ #define ENULL 0 #define ETREE 1 #define EPHULL 2 #define EDATA 3 #define EGRID 4 #define EKDTR 5 #define EKDCE 6 #define ECROS 7 #define EPRES 8 #define EXBAR 9 #define ENONE 10 #define ESPHR 11 #define EFITP 50 #define ESPEC 100 /* integer parameters: sample size; dimension; number of local parameters etc. stored as the lf.mi vector. */ #define MN 0 #define MP 1 #define MDEG0 2 #define MDEG 3 #define MDIM 4 #define MACRI 5 #define MKER 6 #define MKT 7 #define MIT 8 #define MMINT 9 #define MMXIT 10 #define MREN 11 #define MEV 12 #define MTG 13 #define MLINK 14 #define MDC 15 #define MK 16 #define MDEB 17 #define MGETH 18 #define MPC 19 #define MUBAS 20 #define LENM 21 /* Link functions mi[MLINK]. Mostly as in table 4.1 of the book. LDEFAU and LCANON are used to select default and canonical links respectively. LINIT shouldn't be selected by user... */ #define LINIT 0 #define LDEFAU 1 #define LCANON 2 #define LIDENT 3 #define LLOG 4 #define LLOGIT 5 #define LINVER 6 #define LSQRT 7 #define LASIN 8 /* components of vector returned by the links() function in family.c. ZLIK the likelihood; ZMEAN = estimated mean; ZDLL = derivative of log-likelihood; ZDDLL = - second derivative */ #define LLEN 4 #define ZLIK 0 #define ZMEAN 1 #define ZDLL 2 #define ZDDLL 3 /* weight functions mi[MKER]. see Table 3.1 or the function W() in weights.c for definitions. */ #define WRECT 1 #define WEPAN 2 #define WBISQ 3 #define WTCUB 4 #define WTRWT 5 #define WGAUS 6 #define WTRIA 7 #define WQUQU 8 #define W6CUB 9 #define WMINM 10 #define WEXPL 11 #define WMACL 12 #define WPARM 13 /* type of multivariate weight function mi[MKT] KSPH (spherical) KPROD (product) others shouldn't be used at present. */ #define KSPH 1 #define KPROD 2 #define KCE 3 #define KLM 4 #define KZEON 5 #define STANGL 4 #define STLEFT 5 #define STRIGH 6 #define STCPAR 7 /* Local likelihood family mi[MTG] for quasi-likelihood, add 64. */ #define TNUL 0 #define TDEN 1 #define TRAT 2 #define THAZ 3 #define TGAUS 4 #define TLOGT 5 #define TPOIS 6 #define TGAMM 7 #define TGEOM 8 #define TCIRC 9 #define TROBT 10 #define TRBIN 11 #define TWEIB 12 #define TCAUC 13 #define TPROB 14 /* Integration type mi[MIT] for integration in density estimation. */ #define INVLD 0 #define IDEFA 1 #define IMULT 2 #define IPROD 3 #define IMLIN 4 #define IHAZD 5 #define ISPHR 6 #define IMONT 7 /* For prediction functions, what to predict? PCOEF -- coefficients PT0 -- influence function PNLX -- ||l(x)|| PBAND -- bandwidth h(x) PDEGR -- local poly. degree PLIK -- max. local likelihood PRDF -- local res. d.f. PVARI -- ||l(x)||^2 */ #define PCOEF 1 #define PT0 2 #define PNLX 3 #define PBAND 4 #define PDEGR 5 #define PLIK 6 #define PRDF 7 #define PVARI 8 /* Residual Types */ #define RDEV 1 #define RPEAR 2 #define RRAW 3 #define RLDOT 4 #define RDEV2 5 #define RLDDT 6 #define RFIT 7 #define RMEAN 8 /* components of the colour vector */ #define CBAK 0 #define CAXI 1 #define CTEX 2 #define CLIN 3 #define CPOI 4 #define CCON 5 #define CCLA 6 #define CSEG 7 #define CPA1 8 #define CPA2 9 /* variable types: double, int, char, argument list */ #define VDOUBLE 0 #define VINT 1 #define VCHAR 2 #define VARGL 3 #define VPREP 4 #define VARC 5 #define VVARI 6 #define VXYZ 7 /* variable status */ #define STEMPTY 0 #define STREGULAR 1 #define STHIDDEN 3 #define STPLOTVAR 4 #define STSYSTEM 5 #define STSYSPEC 6 #define STREADFI 7 /* return status for the locfit() function */ #define LF_OK 0 #define LF_OOB 2 /* out of bounds, or large unstable parameter */ #define LF_PF 3 /* perfect fit; interpolation; deviance=0 */ #define LF_NCON 4 /* not converged */ #define LF_NOPT 6 /* no or insufficient points with non-zero wt */ #define LF_INFA 7 /* initial failure e.g. log(0) */ #define LF_DEMP 10 /* density -- empty integration region */ #define LF_XOOR 11 /* density -- fit point outside xlim region */ #define LF_DNOP 12 /* density version of 6 */ #define LF_FPROB 80 #define LF_BADP 81 /* bad parameters e.g. neg prob for binomial */ #define LF_LNK 82 /* invalid link */ #define LF_FAM 83 /* invalid family */ #define LF_ERR 99 /* error */ /* * mi[MGETH] codes * scb(), pointwise codes are 71,...,75. * add 10 for simultaneous codes. */ #define GSTD 0 #define GHAT 1 #define GKAP 2 #define GRBD 3 #define GAMF 4 #define GAMP 5 #define GLSC 6 #define GSMP 7 #define GLM1 71 #define GLM2 72 #define GLM3 73 #define GLM4 74 #define GLDN 75 /* bandwidth criteria */ #define BGCV 1 #define BCP 2 #define BIND 3 locfit/src/m_eigen.c0000754000176200001440000000537314745735632014122 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. */ #include #include #include #include "mutil.h" #define E_MAXIT 20 #define E_TOL 1.0e-8 #define SQR(x) ((x)*(x)) double e_tol(double *D, int p) /*double *D; int p;*/ { double mx; int i; if (E_TOL <= 0.0) return(0.0); mx = D[0]; for (i=1; imx) mx = D[i*(p+1)]; return(E_TOL*mx); } void eig_dec(double *X, double *P, int d) /*double *X, *P; int d;*/ { int i, j, k, iter, ms; double c, s, r, u, v; for (i=0; i 1.0e-15*fabs(X[i*d+i]*X[j*d+j])) { c = (X[j*d+j]-X[i*d+i])/2; s = -X[i*d+j]; r = sqrt(c*c+s*s); c /= r; s = sqrt((1-c)/2)*(2*(s>0)-1); c = sqrt((1+c)/2); for (k=0; kZ; P = Q = J->Q; d = J->p; w = J->wk; tol = e_tol(D,d); rank = 0; for (i=0; itol) { w[i] /= D[i*(d+1)]; rank++; } for (i=0; iZ; Q = J->Q; p = J->p; w = J->wk; tol = e_tol(D,p); rank = 0; for (i=0; itol) { v[i] = w[i]/sqrt(D[i*(p+1)]); rank++; } else v[i] = 0.0; } return(rank); } double eig_qf(jacobian *J, double *v) /*jacobian *J; double *v;*/ { int i, j, p; double sum, tol; p = J->p; sum = 0.0; tol = e_tol(J->Z,p); for (i=0; iZ[i*p+i]>tol) { J->wk[i] = 0.0; for (j=0; jwk[i] += J->Q[j*p+i]*v[j]; sum += J->wk[i]*J->wk[i]/J->Z[i*p+i]; } return(sum); } locfit/src/m_isimp.c0000754000176200001440000001073414745736063014150 0ustar liggesusers/* * Copyright (c) 1996-2001 Lucent Technologies. * See README file for details. * * * Multivariate integration of a vector-valued function * using Simpson's rule. */ #include #include #include "mutil.h" extern void setzero(); static double M[(1+MXIDIM)*MXIDIM*MXIDIM]; /* third order corners */ void simp3(int (*fd)(), double *x, int d, double *resd, double *delta, int wt, int i0, int i1, int *mg, int ct, double *res2, int *lfindex) /*int (*fd)(), d, wt, i0, i1, *mg, ct, *lfindex; double *x, *resd, *delta, *res2;*/ { int k, l, m, nrd; double zb; for (k=i1+1; kmg[i]) { lfindex[i] = 0; x[i] = ll[i]; if (i==d-1) /* done */ { z = 1.0; for (j=0; j #ifndef PI #define PI 3.141592653589793238462643 #endif void setM(double *M, double r, double s, double c, int b) /*double *M, r, s, c; int b;*/ { M[0] =-r*s; M[1] = r*c; M[2] = b*c; M[3] = b*s; M[4] =-r*c; M[5] = -s; M[6] = -s; M[7] = 0.0; M[8] =-r*s; M[9] = c; M[10]= c; M[11]= 0.0; } void integ_circ(int (*f)(), double r, double *orig, double *res, int mint, int b) /*int (*f)(), mint, b; double r, *orig, *res;*/ { double y, x[2], theta, tres[MXRESULT], M[12], c, s; int i, j, nr=0; y = 0; for (i=0; i0) ? 0 : 1; i<=mg[0]; i++) { r = rmin + (rmax-rmin)*i/mg[0]; w = (2+2*(i&1)-(i==0)-(i==mg[0])); x[0] = orig[0] + r*c; x[1] = orig[1] + r*s; nr = f(x,2,tres,NULL); if (ct==0) setzero(res,nr); for (k=0; k0) ? 0 : 1; i<=mg[0]; i++) { r = rmin + (rmax-rmin)*i/mg[0]; w = (2+2*(i&1)-(i==0)-(i==mg[0])); for (j=0; j 0), ...) } \arguments{ \item{x}{ locfit object. } \item{xlim}{ Plotting limits. Eg. \code{xlim=c(0,0,1,1)} plots over the unit square in two dimensions. Default is bounding box of the data. } \item{pv}{ Panel variables, to be varied within each panel of a plot. May be specified as a character vector, or variable numbers. There must be one or two panel variables; default is all variables in one or two dimensions; Variable 1 in three or more dimensions. May by specified using either variable numbers or names. } \item{tv}{ Trellis variables, to be varied from panel to panel of the plot. } \item{m}{ Controls the plot resolution (within panels, for trellis displays). Default is 100 points in one dimension; 40 points (per dimension) in two or more dimensions. } \item{mtv}{ Number of points for trellis variables; default 6. } \item{band}{ Type of confidence bands to add to the plot. Default is \code{"none"}. Other choices include \code{"global"} for bands using a global variance estimate; \code{"local"} for bands using a local variance estimate and \code{"pred"} for prediction bands (at present, using a global variance estimate). To obtain the global variance estimate for a fit, use \code{\link{rv}}. This can be changed with \code{\link{rv<-}}. Confidence bands, by default, are 95\%, based on normal approximations and neglecting bias. To change the critical value or confidence level, or to obtain simultaneous instead of pointwise confidence, the critical value stored on the fit must be changed. See the \code{\link{kappa0}} and \code{\link{crit}} functions. } \item{tr}{ Transformation function to use for plotting. Default is the inverse link function, or the identity function if derivatives are requested. } \item{what}{ What to plot. See \code{\link{predict.locfit}}. } \item{get.data}{ If \code{TRUE}, original data is added to the plot. Default: \code{FALSE}. } \item{f3d}{ Force the \code{locfit.3d} class on the prediction object, thereby generating a trellis style plot. Default: \code{FALSE}, unless a \code{tv} argument is' provided. Not available in R. } \item{...}{ Other arguments to \code{plot.locfit.1d}, \code{plot.locfit.2d} or \code{plot.locfit.3d} as appropriate. }} \description{ The \code{plot.locfit} function generates grids of ploting points, followed by a call to \code{\link{preplot.locfit}}. The returned object is then passed to \code{\link{plot.locfit.1d}}, \code{\link{plot.locfit.2d}} or \code{\link{plot.locfit.3d}} as appropriate. } \examples{ x <- rnorm(100) y <- dnorm(x) + rnorm(100) / 5 plot(locfit(y~x), band="global") x <- cbind(rnorm(100), rnorm(100)) plot(locfit(~x), type="persp") } \seealso{ \code{\link{locfit}}, \code{\link{plot.locfit.1d}}, \code{\link{plot.locfit.2d}}, \code{\link{plot.locfit.3d}}, \code{\link{lines.locfit}}, \code{\link{predict.locfit}}, \code{\link{preplot.locfit}} } \keyword{methods} locfit/man/gcv.Rd0000754000176200001440000000203614745724400013365 0ustar liggesusers\name{gcv} \alias{gcv} \title{ Compute generalized cross-validation statistic. } \usage{ gcv(x, \dots) } \arguments{ \item{x, \dots}{Arguments passed on to \code{\link{locfit}} or \code{\link{locfit.raw}}.} } \description{ The calling sequence for \code{gcv} matches those for the \code{\link{locfit}} or \code{\link{locfit.raw}} functions. The fit is not returned; instead, the returned object contains Wahba's generalized cross-validation score for the fit. The GCV score is exact (up to numerical roundoff) if the \code{ev="data"} argument is provided. Otherwise, the residual sum-of-squares and degrees of freedom are computed using locfit's standard interpolation based approximations. For likelihood models, GCV is computed uses the deviance in place of the residual sum of squares. This produces useful results but I do not know of any theory validating this extension. } \seealso{ \code{\link{locfit}}, \code{\link{locfit.raw}}, \code{\link{gcvplot}} } \keyword{htest} % Converted by Sd2Rd version 0.2-a5. locfit/man/cldem.Rd0000754000176200001440000000046414745724400013675 0ustar liggesusers\name{cldem} \alias{cldem} \title{Example data set for classification} \usage{data(cldem)} \format{ Data Frame with x and y variables. } \description{ Observations from Figure 8.7 of Loader (1999). } \references{ Loader, C. (1999). Local Regression and Likelihood. Springer, New York. } \keyword{datasets} locfit/man/expit.Rd0000754000176200001440000000050514745724400013736 0ustar liggesusers\name{expit} \alias{expit} \title{ Inverse logistic link function } \usage{ expit(x) } \description{ Computes \eqn{e^x/(1+e^x)}{\exp(x)/(1+\exp(x))}. This is the inverse of the logistic link function, \eqn{\log(p/(1-p))}. } \arguments{ \item{x}{numeric vector} } \keyword{math} % Converted by Sd2Rd version 0.2-a5. locfit/man/cltest.Rd0000754000176200001440000000124114745724400014101 0ustar liggesusers\name{cltest} \alias{cltest} \title{Test dataset for classification} \usage{data(cltest)} \format{ Data Frame. Three variables x1, x2 and y. The latter indicates class membership. } \description{ 200 observations from a 2 population model. Under population 0, \eqn{x_{1,i}} has a standard normal distribution, and \eqn{x_{2,i} = (2-x_{1,i}^2+z_i)/3}, where \eqn{z_i} is also standard normal. Under population 1, \eqn{x_{2,i} = -(2-x_{1,i}^2+z_i)/3}. The optimal classification regions form a checkerboard pattern, with horizontal boundary at \eqn{x_2=0}, vertical boundaries at \eqn{x_1 = \pm \sqrt{2}}. This is the same model as the cltrain dataset. } \keyword{datasets} locfit/man/rva.Rd0000754000176200001440000000105314745724400013374 0ustar liggesusers\name{rva} \alias{rv<-} \title{ Substitute variance estimate on a locfit object. } \description{ By default, Locfit uses the normalized residual sum of squares as the variance estimate when constructing confidence intervals. In some cases, the user may like to use alternative variance estimates; this function allows the default value to be changed. } \usage{ rv(fit) <- value } \arguments{ \item{fit}{\code{"locfit"} object.} \item{value}{numeric replacement value.} } \seealso{ \link{locfit}(), \link{rv}(), \link{plot.locfit}() } \keyword{smooth} locfit/man/mmsamp.Rd0000754000176200001440000000051014745724400014073 0ustar liggesusers\name{mmsamp} \alias{mmsamp} \title{Test dataset for minimax Local Regression} \usage{data(cltest)} \format{ Data Frame with x and y variables. } \description{ 50 observations, as used in Figure 13.1 of Loader (1999). } \references{ Loader, C. (1999). Local Regression and Likelihood. Springer, New York. } \keyword{datasets} locfit/man/lflim.Rd0000754000176200001440000000070114745724400013706 0ustar liggesusers\name{lflim} \alias{lflim} \title{ Construct Limit Vectors for Locfit fits. } \usage{ lflim(limits, nm, ret) } \description{ This function is used internally to interpret \code{xlim} and \code{flim} arguments. It should not be called directly. } \arguments{ \item{limits}{ Limit argument. } \item{nm}{ Variable names. } \item{ret}{ Initial return vector. } } \value{ Vector with length 2*dim. } \seealso{ \code{\link{locfit}} } \keyword{smooth} locfit/man/print.preplot.locfit.Rd0000754000176200001440000000072014745724400016703 0ustar liggesusers\name{print.preplot.locfit} \alias{print.preplot.locfit} \title{ Print method for preplot.locfit objects. } \usage{ \method{print}{preplot.locfit}(x, ...) } \description{ Print method for objects created by the \code{\link{preplot.locfit}} function. } \arguments{ \item{x}{ \code{"preplot.locfit"} object. } \item{...}{Arguments passed to and from other methods.} } \seealso{ \code{\link{preplot.locfit}}, \code{\link{predict.locfit}} } \keyword{methods} locfit/man/bad.Rd0000754000176200001440000000047014745724400013334 0ustar liggesusers\name{bad} \alias{bad} \title{Example dataset for bandwidth selection} \usage{data(bad)} \format{ Data Frame with x and y variables. } \description{ Example dataset from Loader (1999). } \references{ Loader, C. (1999). Bandwidth Selection: Classical or Plug-in? Annals of Statistics 27. } \keyword{datasets} locfit/man/locfit.raw.Rd0000754000176200001440000001615714745724400014667 0ustar liggesusers\name{locfit.raw} \alias{locfit.raw} \title{ Local Regression, Likelihood and Density Estimation. } \usage{ locfit.raw(x, y, weights=1, cens=0, base=0, scale=FALSE, alpha=0.7, deg=2, kern="tricube", kt="sph", acri="none", basis=list(NULL), deriv=numeric(0), dc=FALSE, family, link="default", xlim, renorm=FALSE, ev=rbox(), maxk=100, itype="default", mint=20, maxit=20, debug=0, geth=FALSE, sty="none") } \description{ \code{locfit.raw} is an interface to Locfit using numeric vectors (for a model-formula based interface, use \code{\link{locfit}}). Although this function has a large number of arguments, most users are likely to need only a small subset. The first set of arguments (\code{x}, \code{y}, \code{weights}, \code{cens}, and \code{base}) specify the regression variables and associated quantities. Another set (\code{scale}, \code{alpha}, \code{deg}, \code{kern}, \code{kt}, \code{acri} and \code{basis}) control the amount of smoothing: bandwidth, smoothing weights and the local model. Most of these arguments are deprecated - they'll currently still work, but should be provided through the \code{lp()} model term instead. \code{deriv} and \code{dc} relate to derivative (or local slope) estimation. \code{family} and \code{link} specify the likelihood family. \code{xlim} and \code{renorm} may be used in density estimation. \code{ev} specifies the evaluation structure or set of evaluation points. \code{maxk}, \code{itype}, \code{mint}, \code{maxit} and \code{debug} control the Locfit algorithms, and will be rarely used. \code{geth} and \code{sty} are used by other functions calling \code{locfit.raw}, and should not be used directly. } \arguments{ \item{x}{ Vector (or matrix) of the independent variable(s). Can be constructed using the \code{lp()} function. } \item{y}{ Response variable for regression models. For density families, \code{y} can be omitted. } \item{weights}{ Prior weights for observations (reciprocal of variance, or sample size). } \item{cens}{ Censoring indicators for hazard rate or censored regression. The coding is \code{1} (or \code{TRUE}) for a censored observation, and \code{0} (or \code{FALSE}) for uncensored observations. } \item{base}{ Baseline parameter estimate. If provided, the local regression model is fitted as \eqn{Y_i = b_i + m(x_i) + \epsilon_i}, with Locfit estimating the \eqn{m(x)} term. For regression models, this effectively subtracts \eqn{b_i} from \eqn{Y_i}. The advantage of the \code{base} formulation is that it extends to likelihood regression models. } \item{scale}{ Deprecated - see \code{\link{lp}()}. } \item{alpha}{Deprecated - see \code{\link{lp}()}. A single number (e.g. \code{alpha=0.7}) is interpreted as a nearest neighbor fraction. With two componentes (e.g. \code{alpha=c(0.7,1.2)}), the first component is a nearest neighbor fraction, and the second component is a fixed component. A third component is the penalty term in locally adaptive smoothing. } \item{deg}{ Degree of local polynomial. Deprecated - see \code{\link{lp}()}. } \item{kern}{ Weight function, default = \code{"tcub"}. Other choices are \code{"rect"}, \code{"trwt"}, \code{"tria"}, \code{"epan"}, \code{"bisq"} and \code{"gauss"}. Choices may be restricted when derivatives are required; e.g. for confidence bands and some bandwidth selectors. } \item{kt}{ Kernel type, \code{"sph"} (default); \code{"prod"}. In multivariate problems, \code{"prod"} uses a simplified product model which speeds up computations. } \item{acri}{Deprecated - see \code{\link{lp}().}} \item{basis}{User-specified basis functions.} %See \code{\link{lfbas}} for more details on this argument.} \item{deriv}{ Derivative estimation. If \code{deriv=1}, the returned fit will be estimating the derivative (or more correctly, an estimate of the local slope). If \code{deriv=c(1,1)} the second order derivative is estimated. \code{deriv=2} is for the partial derivative, with respect to the second variable, in multivariate settings. } \item{dc}{ Derivative adjustment. } \item{family}{ Local likelihood family; \code{"gaussian"}; \code{"binomial"}; \code{"poisson"}; \code{"gamma"} and \code{"geom"}. Density and rate estimation families are \code{"dens"}, \code{"rate"} and \code{"hazard"} (hazard rate). If the family is preceded by a \code{'q'} (for example, \code{family="qbinomial"}), quasi-likelihood variance estimates are used. Otherwise, the residual variance (\code{\link{rv}}) is fixed at 1. The default family is \code{"qgauss"} if a response \code{y} is provided; \code{"density"} if no response is provided. } \item{link}{ Link function for local likelihood fitting. Depending on the family, choices may be \code{"ident"}, \code{"log"}, \code{"logit"}, \code{"inverse"}, \code{"sqrt"} and \code{"arcsin"}. } \item{xlim}{ For density estimation, Locfit allows the density to be supported on a bounded interval (or rectangle, in more than one dimension). The format should be \code{c(ll,ul)} where \code{ll} is a vector of the lower bounds and \code{ur} the upper bounds. Bounds such as \eqn{[0,\infty)} are not supported, but can be effectively implemented by specifying a very large upper bound. } \item{renorm}{Local likelihood density estimates may not integrate exactly to 1. If \code{renorm=T}, the integral will be estimated numerically and the estimate rescaled. Presently this is implemented only in one dimension. } \item{ev}{ The evaluation structure, \code{\link{rbox}()} for tree structures; \code{\link{lfgrid}()} for grids; \code{\link{dat}()} for data points; \code{\link{none}()} for none. A vector or matrix of evaluation points can also be provided, although in this case you may prefer to use the \code{\link{smooth.lf}()} interface to Locfit. Note that arguments \code{flim}, \code{mg} and \code{cut} are now given as arguments to the evaluation structure function, rather than to \code{locfit.raw()} directly (change effective 12/2001). } \item{maxk}{ Controls space assignment for evaluation structures. For the adaptive evaluation structures, it is impossible to be sure in advance how many vertices will be generated. If you get warnings about `Insufficient vertex space', Locfit's default assigment can be increased by increasing \code{maxk}. The default is \code{maxk=100}. } \item{itype}{ Integration type for density estimation. Available methods include \code{"prod"}, \code{"mult"} and \code{"mlin"}; and \code{"haz"} for hazard rate estimation problems. The available integration methods depend on model specification (e.g. dimension, degree of fit). By default, the best available method is used. } \item{mint}{ Points for numerical integration rules. Default 20. } \item{maxit}{ Maximum iterations for local likelihood estimation. Default 20. } \item{debug}{If > 0; prints out some debugging information.} \item{geth}{Don't use!} \item{sty}{ Deprecated - see \code{\link{lp}()}. } } \value{ An object with class "locfit". A standard set of methods for printing, ploting, etc. these objects is provided. } \references{ Loader, C., (1999) Local Regression and Likelihood. } \keyword{smooth} locfit/man/livmet.Rd0000754000176200001440000000105714745724400014110 0ustar liggesusers\name{livmet} \alias{livmet} \title{liver Metastases dataset} \usage{data(livmet)} \format{ Data frame with survival times (\code{t}), censoring indicator (\code{z}) and a number of covariates. } \description{ Survival times for 622 patients diagnosed with Liver Metastases. Beware, the censoring variable is coded as 1 = uncensored, so use \code{cens=1-z} in \code{\link{locfit}()} calls. } \source{ Haupt and Mansmann (1995) } \references{ Haupt, G. and Mansmann, U. (1995) CART for Survival Data. Statlib Archive. } \keyword{datasets} locfit/man/ais.Rd0000754000176200001440000000066614745724400013371 0ustar liggesusers\name{ais} \alias{ais} \title{Australian Institute of Sport Dataset} \usage{data(ais)} \format{ A dataframe. } \description{ The first two columns are the gender of the athlete and their sport. The remaining 11 columns are various measurements made on the athletes. } \source{ Cook and Weisberg (1994). } \references{ Cook and Weisberg (1994). An Introduction to Regression Graphics. Wiley, New York. } \keyword{datasets} locfit/DESCRIPTION0000754000176200001440000000154714750166261013261 0ustar liggesusersPackage: locfit Version: 1.5-9.11 Title: Local Regression, Likelihood and Density Estimation Date: 2025-01-27 Authors@R: c(person("Catherine", "Loader", role = "aut"), person("Jiayang", "Sun", role = "ctb"), person("Lucent Technologies", role = "cph"), person("Andy", "Liaw", role = "cre", email="andy_liaw@merck.com")) Author: Catherine Loader [aut], Jiayang Sun [ctb], Lucent Technologies [cph], Andy Liaw [cre] Maintainer: Andy Liaw Description: Local regression, likelihood and density estimation methods as described in the 1999 book by Loader. Depends: R (>= 4.1.0) Imports: lattice Suggests: interp, gam License: GPL (>= 2) SystemRequirements: USE_C17 NeedsCompilation: yes Packaged: 2025-01-27 17:44:43 UTC; liawand Repository: CRAN Date/Publication: 2025-02-03 16:20:01 UTC