gam/0000755000176200001440000000000014531547262011027 5ustar liggesusersgam/NAMESPACE0000644000176200001440000000332714331341474012246 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(`[`,smooth) S3method(anova,Gam) S3method(anova,Gamlist) S3method(as.data.frame,lo.smooth) S3method(gplot,default) S3method(gplot,factor) S3method(gplot,list) S3method(gplot,matrix) S3method(gplot,numeric) S3method(labels,Gam) S3method(plot,Gam) S3method(plot,preplot.Gam) S3method(predict,Gam) S3method(preplot,Gam) S3method(print,Gam) S3method(print,Gamex) S3method(print,stepanova) S3method(print,summary.Gam) S3method(summary,Gam) export(Gamlist) export(anova.Gam) export(anova.Gamlist) export(as.anova) export(as.data.frame.lo.smooth) export(assign.list) export(gam) export(gam.control) export(gam.exact) export(gam.fit) export(gam.lo) export(gam.match) export(gam.nlchisq) export(gam.random) export(gam.s) export(gam.scope) export(gam.smooth.list) export(gam.smoothers) export(gam.sp) export(general.wam) export(gplot) export(gplot.factor) export(gplot.list) export(gplot.matrix) export(gplot.numeric) export(labels.Gam) export(lo) export(lo.wam) export(na.gam.replace) export(newdata.predict.Gam) export(plot.Gam) export(plot.preplot.Gam) export(polylo) export(predict.Gam) export(preplot.Gam) export(print.Gam) export(print.Gamex) export(print.summary.Gam) export(random) export(s) export(s.wam) export(step.Gam) export(summary.Gam) export(ylim.scale) import(foreach) import(methods) import(splines) import(stats) importFrom(graphics,axis) importFrom(graphics,lines) importFrom(graphics,mtext) importFrom(graphics,persp) importFrom(graphics,plot) importFrom(graphics,points) importFrom(graphics,rug) importFrom(graphics,segments) importFrom(utils,assignInMyNamespace) importFrom(utils,head) importFrom(utils,menu) importFrom(utils,packageDescription) importFrom(utils,tail) useDynLib(gam) gam/ChangeLog0000644000176200001440000000354614531512535012604 0ustar liggesusers2023-11-28 Trevor Hastie version 1.21-3 * character problem in loessc reported by Kurt 2023-03-26 Trevor Hastie version 1.21-2 * Change tests because of discrepancy in family object components. 2023-01-26 Trevor Hastie version 1.21-1 * Change all uses of `sprintf` to `snprintf`. 2022-11-04 Trevor Hastie version 1.21 * Fixes to avoid prototype warnings in C code (`loessc.c`) and corresponding changes to `loessf.f` for logical variables. * Roxygenized the package 2022-06-10 Trevor Hastie version 1.20.2 * minor changes to C code, and replaced akima with interp as suggest 2018-02-06 Trevor Hastie version 1.15 * major change class "gam" to "Gam" to avoid conflict with mgcv (grr!) 2017-06-09 Trevor Hastie version 1.14-5 * fixed bug in na.gam.replace() 2017-04-12 Trevor Hastie version 1.14-2 * changed the mechanism for users to add thir own smoother. New function gam.smoothers() allows one to add to the list * added documentation for random() smoother, and added an argument 2016-09-09 Trevor Hastie version 1.14 * fixed bug in gam when NAs are in data (model.frame does not behave as stated, so I had to make a work around) * gam models with lo(, degree=2) where getting segfaults. Enlarged the work space and this appears to have fixed the problem. 2013-08-02 Trevor Hastie version 1.09 * improved step.gam significantly (it works now for eg, the spam data); added parallel option * man/step.gam updated * R/scope.gam added; an aid for creating a scope object * man/scope.gam added * R/summary.gam split up the anova to two anovas - one for the parametric, and one for nonparametric ### Note that this starts from gam 1.09 gam/README.md0000644000176200001440000000001714216146376012305 0ustar liggesusers# gam gam repo gam/data/0000755000176200001440000000000014216146461011734 5ustar liggesusersgam/data/gam.data.RData0000644000176200001440000001004314216146461014323 0ustar liggesusers \GJJZRSKYr] \Rn)aI-l.E%T"J5蓮$Ts|>}7gZFtӤP(*ru0 e\o I8I#Bhq]D.; V#m۽5#\ er-ű SѸH.%K3mQ^ܱeng!yrKG-WN Y=/GwJvXd72 9v62T$7P^^A >O*A6OH@!ʋBW4izd^%Iq¬hSd?C:Q- 9ho%h Ml7=҄.$ECh~Cu\cu(tx=c\0 Wu;'|BNO"{^},ʼnl'"R5._\w̿\qs8Bq =/NF"]=\q` YT2OI%H6W!d`hje(vQ[( S~^fk!?ksWobd<(BiڬύؖBrXf^5F}qTEyi ~gVx7Yb}4px4 A!H?y_XqޖrI;oV;&ք^ã^DuJwM81$ Ts=G*\qmۓOg eLB#om%ah{V1s>ᓓpgr7Em:]텘)>gcz2%W;6ZwlYH_\9'4kL =RmuVhh}"]E2ͱd*?X[C ŗ ީyqx/;h"p'Z"rs7|`_Fn*Q0aq@RO;ͻejx?Z;p!8!}geDESyu^~cPعN%H-o8;jf _n,-BMWG4tawLzW)^2Ao]uS.v>|f9o}YyaDE/ x܃<ln<Эb[UΒr#OS5Ntkqr"Ƥh{"{A_ٱeB#MXvh|U;3BCZ9jНpKU sY?OT&է "H=Y/큷b Tc} >7I4VC؋Ro7]  hܿ-?Id>{;7u;1h{ͪ7zvm"vX3 ۸ݥ!Niu{/# 9C-MwE|A4]9 =r/C稴ScAԇ mݷylY`O:of#΍y 'x^HNwEڶjyWиXsϞ =r? ֯DB*9?2_oI߾5+sšY:G QCָq|[e;GT3by/?Cӧnyg QH>SI$mAVr;!k{ Ϳ`kdKQ^Kɒ/r-h^EIHvj& =~h( 硡Sd{jqg o)9HCsie{ Re=گ"o"S8ť;8_ѥ~8kD>#=bǓg׽G(eKz +԰#y_12o?E4쳅.<2MMӛ(O2eTݨF;EuGPvmshBU (O|9yaDOêg'9вŠ5ƳsǷ6DǒG=B36:>x*')~RM[~1HNm;9ʢ^Q ޣ#gf?qA ^g i_NOݕ0݁EH/O3DΙҝ~"6drn6әGW\vHL6 qkV~dQϭ%$}Yvž#w5=$x̑/d?,;rOp%:K D02~!:_t/I uF~B8\|NHp\<%/qyS͙&y?xrDtS?e@ WE7 DAw !yI녧^?Aba;YO$~"&-!DN*U*ÛȰ d }fHwqg-T=1^ifVtwLhYrBm57ydĴAO3Y c4Fho/@QuCP;jYwO^+υcR뛁{Q=8 گ/"ʁU%XκE뀗 ^j[:~'<u*̀TVs*xǴDN=GBSKg7ijoMi TM囍|}T6}\L7+݁8|~-mP*[?bȄꈫDR%Xy9PWO*(];lx{<ǀi K3_;C}yԘ|P',cN-[>ɀ=k޳s)`77>~O|௘P;T6ߞ=tnkY^9_ ~F).KMVݕz_b9PuC;ZV|Hab>/nmr4M~V|ot9qWS`1θ4}~PWTl02GAI5zzke>- म{ lnpqf?x/1: 2ҁokS>yV%O6hnx.o͜S/yWMQ=m&~wT>(K1}|ߓrϮ(L~O1ڻg Ll,߀̉e6fnj |fY"T[v,Ѓ%n+ E^*}Wx_?_O|vORwy)Xګ Y+Ng3 -Yk"k55555kqg/Et.K2#&GL19brБ100000000p2:dt*Fy} gam/data/gam.newdata.RData0000644000176200001440000000031114216146461015032 0ustar liggesusers r0b```b`b@& `d`鉹zy)% ` |@es&̲? /M(??KP7g@(^bKM-2 2VUh9pTF01acf09acXBLNMI,U " (gam/man/0000755000176200001440000000000014331606212011567 5ustar liggesusersgam/man/gam.data.Rd0000644000176200001440000000145014331341323013531 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam-package.R \docType{data} \name{gam.data} \alias{gam.data} \alias{gam.newdata} \title{Simulated dataset for gam} \format{ A data frame with 100 observations on the following 6 variables: \describe{ \item{x}{a numeric vector - predictor} \item{y}{a numeric vector - the response} \item{z}{a numeric vector - noise predictor} \item{f}{a numeric vector - true function} \item{probf}{a numeric vector - probability function} \item{ybin}{a numeric vector - binary response} } } \description{ A simple simulated dataset, used to test out the gam functions } \details{ This dataset is artificial, and is used to test out some of the features of gam. } \examples{ data(gam.data) gam(y ~ s(x) + z, data=gam.data) } \keyword{datasets} gam/man/lo.Rd0000644000176200001440000001241514331341323012472 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam.lo.R, R/lo.R \name{gam.lo} \alias{gam.lo} \alias{lo} \title{Specify a loess fit in a GAM formula} \usage{ gam.lo( x, y, w = rep(1, length(y)), span = 0.5, degree = 1, ncols = p, xeval = x ) lo(..., span = 0.5, degree = 1) } \arguments{ \item{x}{for \code{gam.lo}, the appropriate basis of polynomials generated from the arguments to \code{lo}. These are also the variables that receive linear coefficients in the GAM fit.} \item{y}{a response variable passed to \code{gam.lo} during backfitting} \item{w}{weights} \item{span}{the number of observations in a neighborhood. This is the smoothing parameter for a \code{loess} fit. If specified, the full argument name \code{span} must be written.} \item{degree}{the degree of local polynomial to be fit; currently restricted to be \code{1} or \code{2}. If specified, the full argument name \code{degree} must be written.} \item{ncols}{for \code{gam.lo} the number of columns in \code{x} used as the smoothing inputs to local regression. For example, if \code{degree=2}, then \code{x} has two columns defining a degree-2 polynomial basis. Both are needed for the parameteric part of the fit, but \code{ncol=1} telling the local regression routine that the first column is the actually smoothing variable.} \item{xeval}{If this argument is present, then \code{gam.lo} produces a prediction at \code{xeval}.} \item{...}{the unspecified \code{\dots{}} can be a comma-separated list of numeric vectors, numeric matrix, or expressions that evaluate to either of these. If it is a list of vectors, they must all have the same length.} } \value{ \code{lo} returns a numeric matrix. The simplest case is when there is a single argument to \code{lo} and \code{degree=1}; a one-column matrix is returned, consisting of a normalized version of the vector. If \code{degree=2} in this case, a two-column matrix is returned, consisting of a degree-2 polynomial basis. Similarly, if there are two arguments, or the single argument is a two-column matrix, either a two-column matrix is returned if \code{degree=1}, or a five-column matrix consisting of powers and products up to degree \code{2}. Any dimensional argument is allowed, but typically one or two vectors are used in practice. The matrix is endowed with a number of attributes; the matrix itself is used in the construction of the model matrix, while the attributes are needed for the backfitting algorithms \code{general.wam} (weighted additive model) or \code{lo.wam} (currently not implemented). Local-linear curve or surface fits reproduce linear responses, while local-quadratic fits reproduce quadratic curves or surfaces. These parts of the \code{loess} fit are computed exactly together with the other parametric linear parts When two or more smoothing variables are given, the user should make sure they are in a commensurable scale; \code{lo()} does no normalization. This can make a difference, since \code{lo()} uses a spherical (isotropic) neighborhood when establishing the nearest neighbors. Note that \code{lo} itself does no smoothing; it simply sets things up for \code{gam}; \code{gam.lo} does the actual smoothing. of the model. One important attribute is named \code{call}. For example, \code{lo(x)} has a call component \code{gam.lo(data[["lo(x)"]], z, w, span = 0.5, degree = 1, ncols = 1)}. This is an expression that gets evaluated repeatedly in \code{general.wam} (the backfitting algorithm). \code{gam.lo} returns an object with components \item{residuals}{The residuals from the smooth fit. Note that the smoother removes the parametric part of the fit (using a linear fit with the columns in \code{x}), so these residual represent the nonlinear part of the fit.} \item{nl.df}{the nonlinear degrees of freedom} \item{var}{the pointwise variance for the nonlinear fit} When \code{gam.lo} is evaluated with an \code{xeval} argument, it returns a matrix of predictions. } \description{ A symbolic wrapper to indicate a smooth term in a formala argument to gam } \details{ A smoother in gam separates out the parametric part of the fit from the non-parametric part. For local regression, the parametric part of the fit is specified by the particular polynomial being fit locally. The workhorse function \code{gam.lo} fits the local polynomial, then strips off this parametric part. All the parametric pieces from all the terms in the additive model are fit simultaneously in one operation for each loop of the backfitting algorithm. } \examples{ y ~ Age + lo(Start) # fit Start using a loess smooth with a (default) span of 0.5. y ~ lo(Age) + lo(Start, Number) y ~ lo(Age, span=0.3) # the argument name span cannot be abbreviated. } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. } \seealso{ \code{\link{s}}, \code{\link{bs}}, \code{\link{ns}}, \code{\link{poly}}, \code{\link{loess}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/gam.exact.Rd0000644000176200001440000000325414331341323013730 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam.exact.R \name{gam.exact} \alias{gam.exact} \title{A method for gam producing asymptotically exact standard errors for linear estimates} \usage{ gam.exact(Gam.obj) } \arguments{ \item{Gam.obj}{a Gam object} } \value{ A list (of class Gamex) containing a table of coefficients and a variance covariance matrix for the linear terms in the formula of the gam call. } \description{ This function is a "wrapper" for a Gam object, and produces exact standard errors for each linear term in the gam call (except for the intercept). } \details{ Only standard errors for the linear terms are produced. There is a print method for the Gamex class. } \examples{ set.seed(31) n <- 200 x <- rnorm(n) y <- rnorm(n) a <- rep(1:10,length=n) b <- rnorm(n) z <- 1.4 + 2.1*a + 1.2*b + 0.2*sin(x/(3*max(x))) + 0.3*cos(y/(5*max(y))) + 0.5 * rnorm(n) dat <- data.frame(x,y,a,b,z,testit=b*2) ### Model 1: Basic Gam.o <- gam(z ~ a + b + s(x,3) + s(y,5), data=dat) coefficients(summary.glm(Gam.o)) gam.exact(Gam.o) ### Model 2: Poisson Gam.o <- gam(round(abs(z)) ~ a + b + s(x,3) + s(y,5), data=dat,family=poisson) coefficients(summary.glm(Gam.o)) gam.exact(Gam.o) } \references{ Issues in Semiparametric Regression: A Case Study of Time Series Models in Air Pollution and Mortality, Dominici F., McDermott A., Hastie T.J., \emph{JASA}, December 2004, 99(468), 938-948. See \url{https://hastie.su.domains/Papers/dominiciR2.pdf} } \author{ Aidan McDermott, Department of Biostatistics, Johns Hopkins University. Modified by Trevor Hastie for R } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/na.gam.replace.Rd0000644000176200001440000000374314331341323014637 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/na.gam.replace.R \name{na.gam.replace} \alias{na.gam.replace} \title{Missing Data Filter for GAMs} \usage{ na.gam.replace(frame) } \arguments{ \item{frame}{a model or data frame} } \value{ a model or data frame is returned, with the missing observations (NAs) replaced. The following rules are used. A factor with missing data is replaced by a new factor with one more level, labelled \code{"NA"}, which records the missing data. Ordered factors are treated similarly, except the result is an unordered factor. A missing numeric vector has its missing entires replaced by the mean of the non-missing entries. Similarly, a matrix with missing entries has each missing entry replace by the mean of its column. If \code{frame} is a model frame, the response variable can be identified, as can the weights (if present). Any rows for which the response or weight is missing are removed entirely from the model frame. The word \code{"gam"} in the name is relevant, because \code{gam()} makes special use of this filter. All columns of a model frame that were created by a call to \code{lo()} or \code{s()} have an attribute names \code{"NAs"} if NAs are present in their columns. Despite the replacement by means, these attributes remain on the object, and \code{gam()} takes appropriate action when smoothing against these columns. See section 7.3.2 in Hastie (1992) for more details. } \description{ A method for dealing with missing values, friendly to GAM models. } \examples{ data(airquality) gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace) } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. } \seealso{ \code{\link{na.fail}}, \code{\link{na.omit}}, \code{\link{gam}} } \author{ Trevor Hastie } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/step.gam.Rd0000644000176200001440000001362614331606212013604 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/step.gam.R \name{step.Gam} \alias{step.Gam} \title{Stepwise model builder for GAM} \usage{ step.Gam( object, scope, scale, direction = c("both", "backward", "forward"), trace = TRUE, keep = NULL, steps = 1000, parallel = FALSE, ... ) } \arguments{ \item{object}{An object of class \code{Gam} or any of it's inheritants.} \item{scope}{defines the range of models examined in the step-wise search. It is a list of formulas, with each formula corresponding to a term in the model. Each of these formulas specifies a "regimen" of candidate forms in which the particular term may enter the model. For example, a term formula might be \code{~1+ Income + log(Income) + s(Income)}. This means that \code{Income} could either appear not at all, linearly, linearly in its logarithm, or as a smooth function estimated nonparametrically. A \code{1} in the formula allows the additional option of leaving the term out of the model entirely. Every term in the model is described by such a term formula, and the final model is built up by selecting a component from each formula. As an alternative more convenient for big models, each list can have instead of a formula a character vector corresponding to the candidates for that term. Thus we could have \code{c("1","x","s(x,df=5")} rather than \code{~1+x+s(x,df=5)}. The supplied model \code{object} is used as the starting model, and hence there is the requirement that one term from each of the term formulas be present in \code{formula(object)}. This also implies that any terms in \code{formula(object)} \emph{not} contained in any of the term formulas will be forced to be present in every model considered. The function \code{gam.scope} is helpful for generating the scope argument for a large model.} \item{scale}{an optional argument used in the definition of the AIC statistic used to evaluate models for selection. By default, the scaled Chi-squared statistic for the initial model is used, but if forward selection is to be performed, this is not necessarily a sound choice.} \item{direction}{The mode of step-wise search, can be one of \code{"both"}, \code{"backward"}, or \code{"forward"}, with a default of \code{"both"}. If \code{scope} is missing, the default for \code{direction} is "both".} \item{trace}{If \code{TRUE} (the default), information is printed during the running of \code{step.Gam()}. This is an encouraging choice in general, since \code{step.Gam()} can take some time to compute either for large models or when called with an an extensive \code{scope=} argument. A simple one line model summary is printed for each model selected. This argument can also be given as the binary \code{0} or \code{1}. A value \code{trace=2} gives a more verbose trace.} \item{keep}{A filter function whose input is a fitted \code{Gam} object, and anything else passed via \dots{}, and whose output is arbitrary. Typically \code{keep()} will select a subset of the components of the object and return them. The default is not to keep anything.} \item{steps}{The maximum number of steps to be considered. The default is 1000 (essentially as many as required). It is typically used to stop the process early.} \item{parallel}{If \code{TRUE}, use parallel \code{foreach} to fit each trial run. Must register parallel before hand, such as \code{doMC} or others. See the example below.} \item{\dots}{Additional arguments to be passed on to \code{keep}} } \value{ The step-wise-selected model is returned, with up to two additional components. There is an \code{"anova"} component corresponding to the steps taken in the search, as well as a \code{"keep"} component if the \code{keep=} argument was supplied in the call. We describe the most general setup, when \code{direction = "both"}. At any stage there is a current model comprising a single term from each of the term formulas supplied in the \code{scope=} argument. A series of models is fitted, each corrresponding to a formula obtained by moving each of the terms one step up or down in its regimen, relative to the formula of the current model. If the current value for any term is at either of the extreme ends of its regimen, only one rather than two steps can be considered. So if there are \code{p} term formulas, at most \code{2*p - 1} models are considered. A record is kept of all the models ever visited (hence the \code{-1} above), to avoid repetition. Once each of these models has been fit, the "best" model in terms of the AIC statistic is selected and defines the step. The entire process is repeated until either the maximum number of steps has been used, or until the AIC criterion can not be decreased by any of the eligible steps. } \description{ Builds a GAM model in a step-wise fashion. For each "term" there is an ordered list of alternatives, and the function traverses these in a greedy fashion. Note: this is NOT a method for \code{step}, which used to be a generic, so must be invoked with the full name. } \examples{ data(gam.data) Gam.object <- gam(y~x+z, data=gam.data) step.object <-step.Gam(Gam.object, scope=list("x"=~1+x+s(x,4)+s(x,6)+s(x,12),"z"=~1+z+s(z,4))) \dontrun{ # Parallel require(doMC) registerDoMC(cores=2) step.Gam(Gam.object, scope=list("x"=~1+x+s(x,4)+s(x,6)+s(x,12),"z"=~1+z+s(z,4)),parallel=TRUE) } } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. } \seealso{ \code{\link{gam.scope}},\code{\link{step}},\code{\link{glm}}, \code{\link{gam}}, \code{\link{drop1}}, \code{\link{add1}}, \code{\link{anova.Gam}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/gam.s.Rd0000644000176200001440000000650614331341323013071 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam.s.R, R/s.R \name{gam.s} \alias{gam.s} \alias{s} \title{Specify a Smoothing Spline Fit in a GAM Formula} \usage{ gam.s(x, y, w = rep(1, length(x)), df = 4, spar = 1, xeval) s(x, df = 4, spar = 1) } \arguments{ \item{x}{the univariate predictor, or expression, that evaluates to a numeric vector.} \item{y}{a response variable passed to \code{gam.s} during backfitting} \item{w}{weights} \item{df}{the target equivalent degrees of freedom, used as a smoothing parameter. The real smoothing parameter (\code{spar} below) is found such that \code{df=tr(S)-1}, where \code{S} is the implicit smoother matrix. Values for \code{df} should be greater than \code{1}, with \code{df=1} implying a linear fit. If both \code{df} and \code{spar} are supplied, the former takes precedence. Note that \code{df} is not necessarily an integer.} \item{spar}{can be used as smoothing parameter, with values typically in \code{(0,1]}. See \code{\link{smooth.spline}} for more details.} \item{xeval}{If this argument is present, then \code{gam.s} produces a prediction at \code{xeval}.} } \value{ \code{s} returns the vector \code{x}, endowed with a number of attributes. The vector itself is used in the construction of the model matrix, while the attributes are needed for the backfitting algorithms \code{general.wam} (weighted additive model) or \code{s.wam}. Since smoothing splines reproduces linear fits, the linear part will be efficiently computed with the other parametric linear parts of the model. Note that \code{s} itself does no smoothing; it simply sets things up for \code{gam}. One important attribute is named \code{call}. For example, \code{s(x)} has a call component \code{gam.s(data[["s(x)"]], z, w, spar = 1, df = 4)}. This is an expression that gets evaluated repeatedly in \code{general.wam} (the backfitting algorithm). \code{gam.s} returns an object with components \item{residuals}{The residuals from the smooth fit. Note that the smoother removes the parametric part of the fit (using a linear fit in \code{x}), so these residual represent the nonlinear part of the fit.} \item{nl.df}{the nonlinear degrees of freedom} \item{var}{the pointwise variance for the nonlinear fit} When \code{gam.s} is evaluated with an \code{xeval} argument, it returns a vector of predictions. } \description{ A symbolic wrapper to indicate a smooth term in a formala argument to gam } \examples{ # fit Start using a smoothing spline with 4 df. y ~ Age + s(Start, 4) # fit log(Start) using a smoothing spline with 5 df. y ~ Age + s(log(Start), df=5) } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Cantoni, E. and hastie, T. (2002) Degrees-of-freedom tests for smoothing splines, \emph{Biometrika} 89(2), 251-263 } \seealso{ \code{\link{lo}}, \code{\link{smooth.spline}}, \code{\link{bs}}, \code{\link{ns}}, \code{\link{poly}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/gam.Rd0000644000176200001440000002653114331341323012630 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam.R, R/gam.fit.R \name{gam} \alias{gam} \alias{gam.fit} \title{Fitting Generalized Additive Models} \usage{ gam( formula, family = gaussian, data, weights, subset, na.action, start = NULL, etastart, mustart, control = gam.control(...), model = TRUE, method = "glm.fit", x = FALSE, y = TRUE, ... ) gam.fit( x, y, smooth.frame, weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(), control = gam.control() ) } \arguments{ \item{formula}{a formula expression as for other regression models, of the form \code{response ~ predictors}. See the documentation of \code{lm} and \code{formula} for details. Built-in nonparametric smoothing terms are indicated by \code{s} for smoothing splines or \code{lo} for \code{loess} smooth terms. See the documentation for \code{s} and \code{lo} for their arguments. Additional smoothers can be added by creating the appropriate interface functions. Interactions with nonparametric smooth terms are not fully supported, but will not produce errors; they will simply produce the usual parametric interaction.} \item{family}{a description of the error distribution and link function to be used in the model. This can be a character string naming a family function, a family function or the result of a call to a family function. (See \code{\link{family}} for details of family functions.)} \item{data}{an optional data frame containing the variables in the model. If not found in \code{data}, the variables are taken from \code{environment(formula)}, typically the environment from which \code{gam} is called.} \item{weights}{an optional vector of weights to be used in the fitting process.} \item{subset}{an optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. The default is set by the \code{na.action} setting of \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. The \dQuote{factory-fresh} default is \code{\link{na.omit}}. A special method \code{\link{na.gam.replace}} allows for mean-imputation of missing values (assumes missing at random), and works gracefully with \code{gam}} \item{start}{starting values for the parameters in the additive predictor.} \item{etastart}{starting values for the additive predictor.} \item{mustart}{starting values for the vector of means.} \item{control}{a list of parameters for controlling the fitting process. See the documentation for \code{\link{gam.control}} for details. These can also be set as arguments to \code{gam()} itself.} \item{model}{a logical value indicating whether \emph{model frame} should be included as a component of the returned value. Needed if \code{gam} is called and predicted from inside a user function. Default is \code{TRUE}.} \item{method}{the method to be used in fitting the parametric part of the model. The default method \code{"glm.fit"} uses iteratively reweighted least squares (IWLS). The only current alternative is \code{"model.frame"} which returns the model frame and does no fitting.} \item{x, y}{For \code{gam}: logical values indicating whether the response vector and model matrix used in the fitting process should be returned as components of the returned value. For \code{gam.fit}: \code{x} is a model matrix of dimension \code{n * p}, and \code{y} is a vector of observations of length \code{n}.} \item{\dots}{further arguments passed to or from other methods.} \item{smooth.frame}{for \code{gam.fit} only. This is essentially a subset of the model frame corresponding to the smooth terms, and has the ingredients needed for smoothing each variable in the backfitting algorithm. The elements of this frame are produced by the formula functions \code{lo} and \code{s}.} \item{offset}{this can be used to specify an \emph{a priori} known component to be included in the additive predictor during fitting.} } \value{ \code{gam} returns an object of class \code{Gam}, which inherits from both \code{glm} and \code{lm}. Gam objects can be examined by \code{print}, \code{summary}, \code{plot}, and \code{anova}. Components can be extracted using extractor functions \code{predict}, \code{fitted}, \code{residuals}, \code{deviance}, \code{formula}, and \code{family}. Can be modified using \code{update}. It has all the components of a \code{glm} object, with a few more. This also means it can be queried, summarized etc by methods for \code{glm} and \code{lm} objects. Other generic functions that have methods for \code{Gam} objects are \code{step} and \code{preplot}. The following components must be included in a legitimate `Gam' object. The residuals, fitted values, coefficients and effects should be extracted by the generic functions of the same name, rather than by the \code{"$"} operator. The \code{family} function returns the entire family object used in the fitting, and \code{deviance} can be used to extract the deviance of the fit. \item{coefficients}{ the coefficients of the parametric part of the \code{additive.predictors}, which multiply the columns of the model matrix. The names of the coefficients are the names of the single-degree-of-freedom effects (the columns of the model matrix). If the model is overdetermined there will be missing values in the coefficients corresponding to inestimable coefficients. } \item{additive.predictors}{ the additive fit, given by the product of the model matrix and the coefficients, plus the columns of the \code{$smooth} component. } \item{fitted.values}{ the fitted mean values, obtained by transforming the component \code{additive.predictors} using the inverse link function. } \item{smooth, nl.df, nl.chisq, var}{ these four characterize the nonparametric aspect of the fit. \code{smooth} is a matrix of smooth terms, with a column corresponding to each smooth term in the model; if no smooth terms are in the \code{Gam} model, all these components will be missing. Each column corresponds to the strictly nonparametric part of the term, while the parametric part is obtained from the model matrix. \code{nl.df} is a vector giving the approximate degrees of freedom for each column of \code{smooth}. For smoothing splines specified by \code{s(x)}, the approximate \code{df} will be the trace of the implicit smoother matrix minus 2. \code{nl.chisq} is a vector containing a type of score test for the removal of each of the columns of \code{smooth}. \code{var} is a matrix like \code{smooth}, containing the approximate pointwise variances for the columns of \code{smooth}. } \item{smooth.frame}{This is essentially a subset of the model frame corresponding to the smooth terms, and has the ingredients needed for making predictions from a \code{Gam} object} \item{residuals}{ the residuals from the final weighted additive fit; also known as residuals, these are typically not interpretable without rescaling by the weights. } \item{deviance}{ up to a constant, minus twice the maximized log-likelihood. Similar to the residual sum of squares. Where sensible, the constant is chosen so that a saturated model has deviance zero. } \item{null.deviance}{The deviance for the null model, comparable with \code{deviance}. The null model will include the offset, and an intercept if there is one in the model} \item{iter}{ the number of local scoring iterations used to compute the estimates. } \item{bf.iter}{a vector of length \code{iter} giving number of backfitting iterations used at each inner loop.} \item{family}{ a three-element character vector giving the name of the family, the link, and the variance function; mainly for printing purposes. } \item{weights}{the \emph{working} weights, that is the weights in the final iteration of the local scoring fit.} \item{prior.weights}{the case weights initially supplied.} \item{df.residual}{the residual degrees of freedom.} \item{df.null}{the residual degrees of freedom for the null model.} The object will also have the components of a \code{lm} object: \code{coefficients}, \code{residuals}, \code{fitted.values}, \code{call}, \code{terms}, and some others involving the numerical fit. See \code{lm.object}. } \description{ \code{gam} is used to fit generalized additive models, specified by giving a symbolic description of the additive predictor and a description of the error distribution. \code{gam} uses the \emph{backfitting algorithm} to combine different smoothing or fitting methods. The methods currently supported are local regression and smoothing splines. } \details{ The gam model is fit using the local scoring algorithm, which iteratively fits weighted additive models by backfitting. The backfitting algorithm is a Gauss-Seidel method for fitting additive models, by iteratively smoothing partial residuals. The algorithm separates the parametric from the nonparametric part of the fit, and fits the parametric part using weighted linear least squares within the backfitting algorithm. This version of \code{gam} remains faithful to the philosophy of GAM models as outlined in the references below. An object \code{gam.slist} (currently set to \code{c("lo","s","random")}) lists the smoothers supported by \code{gam}. Corresponding to each of these is a smoothing function \code{gam.lo}, \code{gam.s} etc that take particular arguments and produce particular output, custom built to serve as building blocks in the backfitting algorithm. This allows users to add their own smoothing methods. See the documentation for these methods for further information. In addition, the object \code{gam.wlist} (currently set to \code{c("s","lo")}) lists the smoothers for which efficient backfitters are provided. These are invoked if all the smoothing methods are of one kind (either all \code{"lo"} or all \code{"s"}). } \examples{ data(kyphosis) gam(Kyphosis ~ s(Age,4) + Number, family = binomial, data=kyphosis, trace=TRUE) data(airquality) gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace) gam(Kyphosis ~ poly(Age,2) + s(Start), data=kyphosis, family=binomial, subset=Number>2) data(gam.data) Gam.object <- gam(y ~ s(x,6) + z,data=gam.data) summary(Gam.object) plot(Gam.object,se=TRUE) data(gam.newdata) predict(Gam.object,type="terms",newdata=gam.newdata) } \references{ Hastie, T. J. (1991) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics with S.} New York: Springer. } \seealso{ \code{\link{glm}}, \code{\link{family}}, \code{\link{lm}}. } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992), and the philosophy in Hastie and Tibshirani (1991). This version of \code{gam} is adapted from the S version to match the \code{glm} and \code{lm} functions in R. Note that this version of \code{gam} is different from the function with the same name in the R library \code{mgcv}, which uses only smoothing splines with a focus on automatic smoothing parameter selection via GCV. To avoid issues with S3 method handling when both packages are loaded, the object class in package "gam" is now "Gam". } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/predict.gam.Rd0000644000176200001440000001155314331606212014260 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predict.gam.R \name{predict.Gam} \alias{predict.Gam} \title{Predict method for GAM fits} \usage{ \method{predict}{Gam}( object, newdata, type = c("link", "response", "terms"), dispersion = NULL, se.fit = FALSE, na.action = na.pass, terms = labels(object), ... ) } \arguments{ \item{object}{a fitted \code{Gam} object, or one of its inheritants, such as a \code{glm} or \code{lm} object.} \item{newdata}{a data frame containing the values at which predictions are required. This argument can be missing, in which case predictions are made at the same values used to compute the object. Only those predictors, referred to in the right side of the formula in object need be present by name in \code{newdata}.} \item{type}{type of predictions, with choices \code{"link"} (the default), \code{"response"}, or \code{"terms"}. The default produces predictions on the scale of the additive predictors, and with \code{newdata} missing, \code{predict} is simply an extractor function for this component of a \code{Gam} object. If \code{"response"} is selected, the predictions are on the scale of the response, and are monotone transformations of the additive predictors, using the inverse link function. If \code{type="terms"} is selected, a matrix of predictions is produced, one column for each term in the model.} \item{dispersion}{the dispersion of the GLM fit to be assumed in computing the standard errors. If omitted, that returned by 'summary' applied to the object is used} \item{se.fit}{if \code{TRUE}, pointwise standard errors are computed along with the predictions.} \item{na.action}{function determining what should be done with missing values in 'newdata'. The default is to predict 'NA'.} \item{terms}{if \code{type="terms"}, the \code{terms=} argument can be used to specify which terms should be included; the default is \code{labels(object)}.} \item{\dots}{Placemark for additional arguments to predict} } \value{ a vector or matrix of predictions, or a list consisting of the predictions and their standard errors if \code{se.fit = TRUE}. If \code{type="terms"}, a matrix of fitted terms is produced, with one column for each term in the model (or subset of these if the \code{terms=} argument is used). There is no column for the intercept, if present in the model, and each of the terms is centered so that their average over the original data is zero. The matrix of fitted terms has a \code{"constant"} attribute which, when added to the sum of these centered terms, gives the additive predictor. See the documentation of \code{predict} for more details on the components returned. When \code{newdata} are supplied, \code{predict.Gam} simply invokes inheritance and gets \code{predict.glm} to produce the parametric part of the predictions. For each nonparametric term, \code{predict.Gam} reconstructs the partial residuals and weights from the final iteration of the local scoring algorithm. The appropriate smoother is called for each term, with the appropriate \code{xeval} argument (see \code{\link{s}} or \code{\link{lo}}), and the prediction for that term is produced. The standard errors are based on an approximation given in Hastie (1992). Currently \code{predict.Gam} does not produce standard errors for predictions at \code{newdata}. Warning: naive use of the generic \code{predict} can produce incorrect predictions when the \code{newdata} argument is used, if the formula in \code{object} involves transformations such as \code{sqrt(Age - min(Age))}. } \description{ Obtains predictions and optionally estimates standard errors of those predictions from a fitted generalized additive model object. } \examples{ data(gam.data) Gam.object <- gam(y ~ s(x,6) + z, data=gam.data) predict(Gam.object) # extract the additive predictors data(gam.newdata) predict(Gam.object, gam.newdata, type="terms") } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics with S.} New York: Springer. } \seealso{ \code{\link{predict.glm}}, \code{\link{fitted}}, \code{\link{expand.grid}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). This version of \code{predict.Gam} is adapted from the S version to match the corresponding predict methods for \code{glm} and \code{lm} objects in R. The \code{safe.predict.Gam} function in S is no longer required, primarily because a safe prediction method is in place for functions like \code{ns}, \code{bs}, and \code{poly}. } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/gam-package.Rd0000644000176200001440000000101514331341323014207 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam-package.R \docType{package} \name{gam-package} \alias{gam-package} \title{Generalized Additive Models} \description{ This package provides functions for fitting and working with generalized additive models as described in chapter 7 of "Statistical Models in S" (Chambers and Hastie (eds), 1991) and "Generalized Additive Models" (Hastie and Tibshirani, 1990). } \author{ Trevor Hastie } \keyword{models} \keyword{package} \keyword{regression} gam/man/gam-internal.Rd0000644000176200001440000000144514331341323014437 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam-package.R \name{gam-internal} \alias{gam-internal} \alias{.First.lib} \alias{[.smooth} \alias{general.wam} \alias{anova.Gamlist} \alias{as.anova} \alias{as.data.frame.lo.smooth} \alias{assign.list} \alias{Gamlist} \alias{gam.match} \alias{gam.nlchisq} \alias{gam.sp} \alias{gplot} \alias{gplot.default} \alias{gplot.factor} \alias{gplot.list} \alias{gplot.matrix} \alias{gplot.numeric} \alias{labels.Gam} \alias{lo.wam} \alias{newdata.predict.Gam} \alias{polylo} \alias{print.Gam} \alias{print.Gamex} \alias{print.summary.Gam} \alias{s.wam} \alias{ylim.scale} \title{Internal gam functions} \description{ Service functions and as yet undocumented functions for the gam library } \author{ Trevor Hastie } \keyword{internal} gam/man/kyphosis.Rd0000644000176200001440000000152414331341323013730 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam-package.R \docType{data} \name{kyphosis} \alias{kyphosis} \title{A classic example dataset for GAMs} \format{ A data frame with 81 observations on the following 4 variables. \describe{ \item{Kyphosis}{a response factor with levels \code{absent} \code{present}.} \item{Age}{of child in months, a numeric vector} \item{Number}{of vertebra involved in the operation,a numeric vector} \item{Start}{level of the operation, a numeric vector} } } \source{ Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. } \usage{ data(kyphosis) } \description{ Data on the results of a spinal operation "laminectomy" on children, to correct for a condition called "kyphosis"; see Hastie and Tibshirani (1990) for details } \keyword{datasets} gam/man/gam.random.Rd0000644000176200001440000000754314331341323014111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam.random.R, R/random.R \name{gam.random} \alias{gam.random} \alias{random} \title{Specify a Random Effects Fit in a GAM Formula} \usage{ gam.random(f, y, w, df = sum(non.zero), lambda = 0, intercept = TRUE, xeval) random(f, df = NULL, lambda = 0, intercept = TRUE) } \arguments{ \item{f}{factor variable, or expression that evaluates to a factor.} \item{y}{a response variable passed to \code{gam.random} during backfitting} \item{w}{weights} \item{df}{the target equivalent degrees of freedom, used as a smoothing parameter. The real smoothing parameter (\code{lambda} below) is found such that \code{df=tr(S)}, where \code{S} is the implicit smoother matrix. Values for \code{df} should be greater than \code{0} and less than the number of levels of \code{f}. If both \code{df} and \code{lambda} are supplied, the latter takes precedence. Note that \code{df} is not necessarily an integer.} \item{lambda}{the non-negative penalty parameter. This is interpreted as a variance ratio in a mixed effects model - namely the ratio of the noise variance to the random-effect variance.} \item{intercept}{if \code{intercept=TRUE} (the default) then the estimated level effects are centered to average zero, otherwise they are left alone.} \item{xeval}{If this argument is present, then \code{gam.random} produces a prediction at \code{xeval}.} } \value{ \code{random} returns the vector \code{f}, endowed with a number of attributes. The vector itself is used in computing the means in backfitting, while the attributes are needed for the backfitting algorithms \code{general.wam}. Note that \code{random} itself does no smoothing; it simply sets things up for \code{gam}. One important attribute is named \code{call}. For example, \code{random(f, lambda=2)} has a call component \code{gam.random(data[["random(f, lambda = 2)"]], z, w, df = NULL, lambda = 2, intercept = TRUE)}. This is an expression that gets evaluated repeatedly in \code{general.wam} (the backfitting algorithm). \code{gam.random} returns an object with components \item{residuals}{The residuals from the smooth fit. } \item{nl.df}{the degrees of freedom} \item{var}{the pointwise variance for the fit} \item{lambda}{the value of \code{lambda} used in the fit} When \code{gam.random} is evaluated with an \code{xeval} argument, it returns a vector of predictions. } \description{ A symbolic wrapper for a factor term, to specify a random effect term in a formula argument to gam } \details{ This "smoother" takes a factor as input and returns a shrunken-mean fit. If \code{lambda=0}, it simply computes the mean of the response at each level of \code{f}. With \code{lambda>0}, it returns a shrunken mean, where the j'th level is shrunk by \code{nj/(nj+lambda)}, with \code{nj} being the number of observations (or sum of their weights) at level \code{j}. Using such smoother(s) in gam is formally equivalent to fitting a mixed-effect model by generalized least squares. } \examples{ # fit a model with a linear term in Age and a random effect in the factor Level y ~ Age + random(Level, lambda=1) } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Cantoni, E. and hastie, T. (2002) Degrees-of-freedom tests for smoothing splines, \emph{Biometrika} 89(2), 251-263 } \seealso{ \code{\link{lo}}, \code{\link{s}}, \code{\link{bs}}, \code{\link{ns}}, \code{\link{poly}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \keyword{effects} \keyword{mixed} \keyword{models} \keyword{nonparametric} \keyword{random} \keyword{regression} \keyword{smooth} gam/man/gam.control.Rd0000644000176200001440000000277514331341323014313 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam.control.R \name{gam.control} \alias{gam.control} \title{Auxilliary for controlling GAM fitting} \usage{ gam.control( epsilon = 1e-07, bf.epsilon = 1e-07, maxit = 30, bf.maxit = 30, trace = FALSE, ... ) } \arguments{ \item{epsilon}{convergence threshold for local scoring iterations} \item{bf.epsilon}{convergence threshold for backfitting iterations} \item{maxit}{maximum number of local scoring iterations} \item{bf.maxit}{maximum number of backfitting iterations} \item{trace}{should iteration details be printed while \code{gam} is fitting the model.} \item{...}{placemark for additional arguments} } \value{ a list is returned, consisting of the five parameters, conveniently packaged up to supply the \code{control} argument to \code{gam}. The values for \code{gam.control} can be supplied directly in a call to \code{gam}; these are then filtered through \code{gam.control} inside \code{gam}. } \description{ Auxiliary function as user interface for 'gam' fitting. Typically only used when calling 'gam' or 'gam.fit'. } \examples{ \dontrun{gam(formula, family, control = gam.control(bf.maxit=15))} \dontrun{gam(formula, family, bf.maxit = 15) # these are equivalent} } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/gam.scope.Rd0000644000176200001440000000435214331341323013735 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam.scope.R \name{gam.scope} \alias{gam.scope} \title{Generate a scope for step.Gam} \usage{ gam.scope(frame, response = 1, smoother = "s", arg = NULL, form = TRUE) } \arguments{ \item{frame}{a data.frame to be used in \code{step.Gam}. Apart from the response column, all other columns will be used.} \item{response}{The column in \code{frame} used as the response. Default is 1.} \item{smoother}{which smoother to use for the nonlinear terms; i.e. "s" or "lo", or any other supplied smoother. Default is "s".} \item{arg}{a character (vector), which is the argument to \code{smoother}. For example, \code{arg="df=6"} would result in the expression \code{s(x,df=6)} for a column named "x". This can be a vector, for example \code{arg=c("df=4","df=6")}, which would result two smooth terms.} \item{form}{if \code{TRUE}, each term is a formula, else a character vector.} } \value{ a scope list is returned, with either a formula or a character vector for each term, which describes the candidates for that term in the Gam. } \description{ Given a data.frame as an argument, generate a scope list for use in step.Gam, each element of which gives the candidates for that term. } \details{ This function creates a similar scope formula for each variable in the frame. A column named "x" by default will generate a scope term \code{~1+x+s(x)}. With \code{arg=c("df=4","df=6")} we get \code{~1+x+s(x,df=4)+s(x,df=6)}. With form=FALSE, we would get the character vector \code{c("1","x","s(x,df=4)","s(x,df=6")}. } \examples{ data(gam.data) gdata=gam.data[,1:3] gam.scope(gdata,2) gam.scope(gdata,2,arg="df=5") gam.scope(gdata,2,arg="df=5",form=FALSE) gam.scope(gdata,2,arg=c("df=4","df=6")) } \references{ Hastie, T. J. (1991) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. } \seealso{ \code{\link{step.Gam}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). This version of \code{gam.scope} is adapted from the S version. } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/anova.gam.Rd0000644000176200001440000000500414331605303013724 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/anova.gam.R, R/summary.gam.R \name{anova.Gam} \alias{anova.Gam} \alias{summary.Gam} \title{Analysis of Deviance for a Generalized Additive Model} \usage{ \method{anova}{Gam}(object, ..., test = c("Chisq", "F", "Cp")) \method{summary}{Gam}(object, dispersion = NULL, ...) } \arguments{ \item{object}{a fitted Gam} \item{...}{other fitted Gams for \code{anova}} \item{test}{a character string specifying the test statistic to be used. Can be one of '"F"', '"Chisq"' or '"Cp"', with partial matching allowed, or 'NULL' for no test.} \item{dispersion}{a dispersion parameter to be used in computing standard errors} } \description{ Produces an ANODEV table for a set of GAM models, or else a summary for a single GAM model } \details{ These are methods for the functions \code{anova} or \code{summary} for objects inheriting from class \code{Gam}. See \code{\link{anova}} for the general behavior of this function and for the interpretation of \code{test}. When called with a single \code{Gam} object, a special pair of anova tables for \code{Gam} models is returned. This gives a breakdown of the degrees of freedom for all the terms in the model, separating the projection part and nonparametric part of each, and returned as a list of two anova objects. For example, a term specified by \code{s()} is broken down into a single degree of freedom for its linear component, and the remainder for the nonparametric component. In addition, a type of score test is performed for each of the nonparametric terms. The nonparametric component is set to zero, and the linear part is updated, holding the other nonparametric terms fixed. This is done efficiently and simulataneously for all terms. } \examples{ data(gam.data) Gam.object <- gam(y~s(x,6)+z,data=gam.data) anova(Gam.object) Gam.object2 <- update(Gam.object, ~.-z) anova(Gam.object, Gam.object2, test="Chisq") } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics with S.} New York: Springer. } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/plot.gam.Rd0000644000176200001440000001132714331606212013603 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot.gam.R, R/preplot.gam.R \name{plot.Gam} \alias{plot.Gam} \alias{preplot.Gam} \alias{plot.preplot.Gam} \title{Plot Components of a GAM Object} \usage{ \method{plot}{Gam}( x, residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, ask = FALSE, terms = labels.Gam(x), ... ) \method{preplot}{Gam}(object, newdata, terms = labels.Gam(object), ...) } \arguments{ \item{x}{a \code{Gam} object, or a \code{preplot.Gam} object. The first thing \code{plot.Gam()} does is check if \code{x} has a component called \code{preplot}; if not, it computes one using \code{preplot.Gam()}. Either way, it is this \code{preplot.Gam} object that is required for plotting a \code{Gam} object.} \item{residuals}{if \code{TRUE}, partial deviance residuals are plotted along with the fitted terms---default is \code{FALSE}. If \code{residuals} is a vector with the same length as each fitted term in \code{x}, then these are taken to be the overall residuals to be used for constructing the partial residuals.} \item{rugplot}{if \code{TRUE} (the default), a univariate histogram or \code{rugplot} is displayed along the base of each plot, showing the occurrence of each \code{x}; ties are broken by jittering.} \item{se}{if \code{TRUE}, upper and lower pointwise twice-standard-error curves are included for each plot. The default is \code{FALSE}.} \item{scale}{a lower limit for the number of units covered by the limits on the \code{y} for each plot. The default is \code{scale=0}, in which case each plot uses the range of the functions being plotted to create their \code{ylim}. By setting \code{scale} to be the maximum value of \code{diff(ylim)} for all the plots, then all subsequent plots will produced in the same vertical units. This is essential for comparing the importance of fitted terms in additive models.} \item{ask}{if \code{TRUE}, \code{plot.Gam()} operates in interactive mode.} \item{terms}{subsets of the terms can be selected} \item{\dots}{Additonal plotting arguments, not all of which will work (like xlim)} \item{object}{same as \code{x}} \item{newdata}{if supplied to \code{preplot.Gam}, the preplot object is based on them rather than the original.} } \value{ a plot is produced for each of the terms in the object \code{x}. The function currently knows how to plot all main-effect functions of one or two predictors. So in particular, interactions are not plotted. An appropriate \code{x-y} is produced to display each of the terms, adorned with residuals, standard-error curves, and a rugplot, depending on the choice of options. The form of the plot is different, depending on whether the \code{x}-value for each plot is numeric, a factor, or a matrix. When \code{ask=TRUE}, rather than produce each plot sequentially, \code{plot.Gam()} displays a menu listing all the terms that can be plotted, as well as switches for all the options. A \code{preplot.Gam} object is a list of precomputed terms. Each such term (also a \code{preplot.Gam} object) is a list with components \code{x}, \code{y} and others---the basic ingredients needed for each term plot. These are in turn handed to the specialized plotting function \code{gplot()}, which has methods for different classes of the leading \code{x} argument. In particular, a different plot is produced if \code{x} is numeric, a category or factor, a matrix, or a list. Experienced users can extend this range by creating more \code{gplot()} methods for other classes. Graphical parameters (see \code{\link{par}}) may also be supplied as arguments to this function. This function is a method for the generic function \code{plot()} for class \code{"Gam"}. It can be invoked by calling \code{plot(x)} for an object \code{x} of the appropriate class, or directly by calling \code{plot.Gam(x)} regardless of the class of the object. } \description{ A plot method for GAM objects, which can be used on GLM and LM objects as well. It focuses on terms (main-effects), and produces a suitable plot for terms of different types } \examples{ data(gam.data) Gam.object <- gam(y ~ s(x,6) + z,data=gam.data) plot(Gam.object,se=TRUE) data(gam.newdata) preplot(Gam.object,newdata=gam.newdata) } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} London: Chapman and Hall. } \seealso{ \code{\link{preplot}}, \code{\link{predict.Gam}} } \author{ Written by Trevor Hastie, following closely the design in the "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie (1992). } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/man/gam.smoothers.Rd0000644000176200001440000000332014331341323014641 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gam.smoothers.R \name{gam.smoothers} \alias{gam.smoothers} \alias{gam.smooth.list} \title{Smoothers available for backfitting} \usage{ gam.smoothers(slist = c("s", "lo", "random"), wlist = c("s", "lo")) } \arguments{ \item{slist}{character vector giving names of smoothers available for general backfitting. For every entry, eg "lo", there must exist a formula function "lo()" that prepares the data, and a fitting function with the name "gam.lo" which actually does the fitting. Look at "lo" and "s" as examples.} \item{wlist}{character vector (subset of slist) giving names of smoothers for which a special backfitting algorithm is available, when only that smoother appears (multiple times) in the formula, along with other non smooth terms.} } \value{ a list is returned, consisting of the two named vectors. If the function is called with no arguments, it gets the version of "gam.smooth.list"' in the search path, by default from the package name space. Once it is called with either of the arguments, it places a local copy in the users namespace. } \description{ Auxiliary function as user interface for 'gam' fitting. Lists what smoothers are implemented, and allows users to include new smoothers. } \examples{ \dontrun{gam.smoothers()$slist # get the gam.smooth.list, and extract component slist} \dontrun{gam.smoothers(slist=c("s","lo","random","tps") # add a new smoother "tps" to the list} } \references{ Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole. } \keyword{models} \keyword{nonparametric} \keyword{regression} \keyword{smooth} gam/DESCRIPTION0000644000176200001440000000123114531547262012532 0ustar liggesusersPackage: gam Type: Package Title: Generalized Additive Models Date: 2023-11-28 Version: 1.22-3 Author: Trevor Hastie Description: Functions for fitting and working with generalized additive models, as described in chapter 7 of "Statistical Models in S" (Chambers and Hastie (eds), 1991), and "Generalized Additive Models" (Hastie and Tibshirani, 1990). Maintainer: Trevor Hastie Depends: R (>= 4.0), stats, splines, foreach Suggests: interp, testthat License: GPL-2 RoxygenNote: 7.2.1 Encoding: UTF-8 Imports: methods NeedsCompilation: yes Packaged: 2023-11-29 01:39:59 UTC; hastie Repository: CRAN Date/Publication: 2023-11-29 05:40:02 UTC gam/tests/0000755000176200001440000000000014331106043012153 5ustar liggesusersgam/tests/testthat/0000755000176200001440000000000014531547262014031 5ustar liggesusersgam/tests/testthat/test_example.R0000644000176200001440000000264214410415436016643 0ustar liggesusersset.seed(20101) data(kyphosis) fit1=gam(Kyphosis ~ s(Age,4) + Number, family = binomial, data=kyphosis) data(airquality) fit2=gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace) fit3=gam(Kyphosis ~ poly(Age,2) + s(Start), data=kyphosis, family=binomial, subset=Number>2) data(gam.data) fit4=Gam.object <- gam(y ~ s(x,6) + z,data=gam.data) sum1=summary(Gam.object) an1=anova(Gam.object) fit5 <- update(fit4, ~.-z) an2=anova(fit4, fit5, test="Chisq") fit6 <- gam(y~x+z, data=gam.data) step1 <-step.Gam(Gam.object, scope=list("x"=~1+x+s(x,4)+s(x,6)+s(x,12),"z"=~1+z+s(z,4))) data(gam.newdata) pred1=predict(Gam.object,type="terms",newdata=gam.newdata) if (getRversion() >= numeric_version("4.3.0")) { ## Fix to account for changes in family objects for R >= 4.3.0 fit1$family$dispersion <- NULL fit2$family$dispersion <- NULL fit3$family$dispersion <- NULL fit4$family$dispersion <- NULL fit5$family$dispersion <- NULL fit6$family$dispersion <- NULL step1$family$dispersion <- NULL } objects <- list( fit1=fit1, fit2=fit2, fit3=fit3, fit4=fit4, fit5=fit5, fit6=fit6, sum1=sum1, an1=an1, an2=an2, step1=step1) ##saveRDS(objects, "test_results/gam-1.20-results.RDS") expected <- readRDS("test_results/gam-1.20-results.RDS") for (x in names(objects)) { cat(sprintf("Testing %s\n", x)) expect_equal(objects[[x]], expected[[x]]) } gam/tests/testthat/test_results/0000755000176200001440000000000014331106043016553 5ustar liggesusersgam/tests/testthat/test_results/gam-1.20-results.RDS0000644000176200001440000023537014331106043021760 0ustar liggesusers}\Oݭbm0gw` ؉ (H]M[}sfgygr]&d)BZ|$dGk@Rڤ\crHWtIG^IBw>1$ a3 Z(>CI8IpHhJ)$,!AEH$Am$0$ :$'a mHXdr#a5 HFGϳI& By@\#,$a WHP&!=$@4;Ж̒@o2e(jT OGcp5bx#L,e!5~<]x([ `+lhӁd%ℱf ԈϏ.EU$'n,9BCwb3V eLEV?[`~p:,'+ɚ~'{Ɂ~)[єhV4e+Mʖ~yX?qHn_H`tVU is7-~]ѦlX~YbdNd MXq56U-{?}ZEx}Xo6:z4wmxvljtum㝭e/%tV:9Oqw,'Wek=`UEk.ֽ*5=rM> VjW/kmE oGͯN4tMu>[W7ZV۬Ye~ƻySwMP鮔_٬rE)|ag`euWG^ ÃKD5S~=-<*+*3 3ғc9]/G%݌_o+zOWBQkO~gXy0RfXMƓ1]o~4ɴۺ_QC"Ka穄tnC9>;_/q9r=yZ2i|4L;q;_y ~)˧x?Iߌoף-{hAynmA¬U2 BY#NƁ{&ޅsqFx;X$E6߳h:љ[wa"}zզ#Pj rG3pۻsi#ϮTty5ṡIF_#Iw>4ZŃJQ1qwRz 5f^` |=Mmrj4p4A)`4;"RpԘ^@Q@S}@I/<^7W@ε7J /X[&M@<1]b^JN{b׃+ Uť}'~e\8x\@@ XmVI*zwEm̳ ax xt}STn. _7^.i\Zz>}]vDUfs`fnh>/p KG8ٓ+5:˔}a덭=-e%ymg̢C?xqm?’.vr|7/X5yz?SGǁkfhɝ,w>0`&\xtL|]^ay#gPT͗|lS= }E̓YG!oDXke*݂`}]\SC<^M{Cxߩ>Q*xA7,!T 6gWh.|3&(exY7CX&H ^^زmxuh ,o0~#2ateB%鰰Y0̛#frUV^w= >^gd~7RU~kx%t3F շ$P r ˊqw Ba`[ lj~x;7o5>m.tlp`8yC>w-MrzĚA˺3*jȾ;{+~>>$z85tCӴ4_N|+ˈMba #Ah?ެ'K@@d Bi pj-1sȷs87,zbsDp4:Yqpk\zׂ52V]>GFɕ '#_N: ?n39_y=(P\uTKpnI8ʴl)U49m.py 8A>9- cݜbq^ς|r6qe[MwB7|ޭ>}teXi`rݲji0_uN{AvnﭗfMC&/3~k&B< 'R],|շnt>?;fM \:s'V:I|Qo .d6b89iH:drF؛w.%Gq&dH EV6_\9ě/设shmPV Q64f&AuT*Fc7 ^=Kt+j!8s9 '~pdaA7aBN3#ݖIi^v)\閃+}2I_yo6ȽrTC9 wa@pyΏ|%Vבs"yF'~/?bd6r_yypbƊ1A3^.r/5 uOS$»Vb/*vlssV@ vLy7JgMwLo [ P AQEzz/cT]6]z<ee[tZ\hq|ɝ|9L:h xX[d8X7+N]8Oҙhݺg@xz+A@bH9~`v>X={Z*jax_+[rm/:#s}V*{HdM9[rvO r35]BA%ͽSG;~ :;;pzkɟ@V4Ɂ5VC9@Nm\3F0y phķ:\NM\rnU3 2 jh\0w ՝AG,1^듵Q=2)Y;øff`:g]󻀓Z̓>Ch[BKe)y$殩lI;LdIi~8y#L|;&"˱)_W0+p/m 8\nMXӹg,HٻdxթZOV+7$[{<<'}JgԔ]]O4enףj gg O4 B>vc%3c'Xx~EڦoaB;Ռ>a܍zq@I3f擶M{O5,=-9gfyy -@JSmܑ>0iU_ӱcጊ7 #ot W.5xםsd.[ / H??/M ?cAM-'v UՎXud?X=rϴ@9v|T7Jq Ul׺F@~7WBe&=p\e MJ{6cJ HU~?2_;{T%.G&?# 9={O{>Hޚ57M{xQOAo&ٙv1rS}RFvM/2793t8-?8TtkV>Dٵy5L=~w<=v9Y$/e&t7xr{T|7]rɬ GxWޣC98_gg#@fŠ*O >ɵ0X/bZԙ. %ᮍ807rx踭LA6[69 LX.|\C9&mtf)|qM'gvO'8~jQw },{ NxmkG-@5%P( >{M>};wc~nV.⓯+^".ڣy\٦PK{(br'p1R54ξ[,JͲ8(xUYD/PO1(>GQi (x8v |Yq B]ixڤLvo_K7' ΁ [dr (k d\s.H;Xrf J;;%$e/=@Y|qȪ'zkݦ {X.a6NPd}kK/pe^1\Vl#Nw sef:5MO?ѭziӸ޷1j'Aљ -\z?_v⤃G7M/⧵zޕR~ox|wwܴ]uŒ|cL˼(萶~Pw9^>̶KXa|Α|顃J(+U[<>L>*Rr}-Lӗ\dxBb7d̠F/wT.-xܨ"V!MD{O-g|ȗ'xcʬ/j:ktvRV:,{dMKXMLϗYX=VGhU,'|pWw>#Üs}2]~Y؂@39CɎgt=leUF!+OF')eRV19V%hkvMI>)<>ݮQ|-n9rҩ%iOia|p>5g _sAjm`ԨE[}j/Q-*|aYyo+FŏU_i.vORXYj6>*o4q.Vfc!%Q]9/x//;1]}|E͋ڗ<1e_i~?Ȧ)e>~>i\|+M<@*A~#ړ Pz\7#'"^=@ ^m5H( VlΐK兢CQ[|bf֊V0lhEzh#v( KtD8Q|'DǔflEX `Ҙ# +.(o& Qyq%huC4H0dAB9mOބ1^,qhfy|ROP ܤx,LE nsXJuga*K46]vnYd!:8"A@] F@!ixzH{+wCUTv5x5 RrXyf5e?VBMфmY %VRYO/_1ڐ=V*=jKВZtfA^6SeƯC_M$pU$#$ H9aCѴVH3 Ց֕DXDKbT;~d ¼B %Q!7w/`$6żf $88z)g.ߖKyb{͘LgE9`0Zm^nSQ ͚>Qo%A4vX0ěMP %~!I`vQz%D~ۥ&muD rۡd|y KnuX}EXFLh] 2hB[VBl!%b4PM(Xd$YփYz>:JHa ؖUNKc]< ~}%5΢t2ӛ6L>-m0=qIǜhN[A~ ^R %("iηϵS&;M8.p!D4ff`0{zʡ":؏`*(o2,9~ Zد(w~j0FԵ0B𕐫 d~CQP6C914\5)m ݰ6e6t~Ko0̙KjċLg7cȣC0qT GFq%K5OռvHΌ(">Ai01b6 0==?zP .QPuC/2H-~ꑮ-1pW-Ya ]_ab|0J!~-S}PZ 5LL 3H0DfO̻ Qͅ7T|k }XـO1||QaׇE\m2}iGFya}G m" ӛ9o+\%< b!dgz1$:6a!~higp"Da?6DP&XCD͡ rJCH2'3ӿ?g&QC$,E( PB@]- hEZ0h,[+­&me@; Ё$)6 kt]\z50׏`3F0``18|S`?M ~ݳVF Zg:Ԭ1Ҟ^3 -m\T_CqEcAzO(7eJ] |)Bōx)Շ8}?7oPGx( r"j PM-DSl|(~%0)xiB԰(c"[O5hӚ-4k3MqEDCNBƥC;Xd#igWdM_0ѼɌm0"k@q% $lEΓ.f_Т YT"bt5QzcS#\=f AJdrSh*툛p r1IM0 hi`$ESԒH>D9Ud@XVEBk %Kt̐UQI?pbd|vUMҩu 3b/Nbpi Yt1cr /n x7t9c XT":j3Xȴg9 ĵZl B5[>~{45QL = ]-!wgǡ.ZΜ{S ǂ:pbHg<3b]!j~`iv&+Ә5e} DN?P.5DUfХq,]nu,_ʌ!LM yK_ ,zBv,D˶uAĽBrPαA'b?t-EH CHq{(nT1>={ Op_'̘= Wa[-Wl27E:3 bf'~%f.!eaIu u@%\/fNJ₶G" E HN A#M$i&R U 셿)KJa S-qF:u~ft&_HB퇫ĖEOLy|SO&iGBڴOރo1 D,%l_͵e"Τ Z6]B2)~cGw/4flj_Wsry8ٙs qGf۱קGy(vaN_09–5/vӾӾӾӾ}4uvæ g iha6b?i%ѷCGNh3pMĄ U%' XL 1 4Hȫ ?=X2yyкY , I^\uyl!Rs,uoDoNk}A\SIכ;Ս֓7R_zuZ,:ؽt~b4ԐS z^Gw@aT/ &~ z0 &_n탕Hٜ|C fΚEZ  &Qn< >Si[ ͚ԛȌ'*$vaq{rh6iִl܂F-{O<6{x ?wNmW25`cc W?;ψmY gWY mu6Y mu6Yf&x֢YG$# 叵֑O7vbǫwfk֜:Kؚo3q5GR~AӜ-o!._u駥8y~'M_ Y7{ZYwy06Mmz׶PXq:֧G1thYpvX[;2Ὼư;Siƃ;*h:.h|Х~e%D~۶[Wۈ7 ab͖|e!7^eA߯g]m*OhɾKA@v9^hnxq%!~_pŕWh/ zdoxq忠^+Ƌ+/lxq_\Y{$c JJ֓nH}骉:#@őPx%xx%\xewDPy> GE+.]UDsƺMG] xGB~w`K6m <08woT!aWH*hD<4%P}$X??I)~ / W$o@8WFmBg֛$,ؤWgCLnF&3!:B&BAb*-3dt"iK͑!hT'&PT6!l$Mn4v)śn[т<1T |6#G?W7@ rAnׂ+Y+:VcKXM w6,EUH\A԰EOŬL^P_KGE%TA" XPd.~nA1z_#ZXPBV} gf^Ĥ <<ҿ\j/-PMqxh$k$3 8@JFЛ#p @4TPi |UBx'~1hRH̠!G %X4QZMBoR$o&- FZUjp9+򆐑}7Hg!eòao ˰$EI8ݬڙq?sU<_`5z ^<kBm6u%wo3h2!NJ^@67l .c\E0v m$/O3t<__C |O, F~zCKQ<BT_J Eh9 ?c§"|\/ 0='oa=ʬp)~c>[|p`|-e#6ߘ^gVzo8_@wG~lcA\Q|g~â7a#|ŶHc[&06v]¢K'X~,';LJbc9_BzLc=qzב(=#.!] ~;WԥHDGxvr#?zq=zN; 9aѓ`Hcw?ˌu6UHS!%߶V"2$%θ zZ LzEFZ"L"Ŕ"lR _yCjJoE~ԋR$5^*\+B8E&UZE&u,QSoTG<,Pj@TB54%wRiԀZd "NZQ50KMPCjHC "U8s]sI>C-Qp8jn) HXN BU`Z[K:B$l"!,Fn!I.e`-7?~3J}ڵy '&khc4lVR]F6sJ xsO|p -rx}'AGXu~azp7p̒g6Eo}%[wE瘽K=V߉9m{^ͫFF2|m9@lE2wG5)SVupxsUrFs:q-`8W4\yA!G _#-9 s;y j?q8j,~WWx^jqoraJԾy\wp|'W# P|@XDw;&)ònWn>]3z۝ݬU S\>̉^w\JVS8aBVȪnM2e'v};S{/cnKGMQO<Õ#r፱S&r Z/%~#·`{ǃ <4/vw˝ w>L<,}wWi5]dS ?9r7MM _‚߶X*7=[x?Ja>SKSpSC(WbxbV NО+JA|h.ߧS.ǣU/?nC'u |[un L0Y)|8p^Ft7>raRk.蒐{Ut-]d5c8|rckxO.w aA=B0o .I~زU'{8jhqޭj^ x=sIpeOys)eT $e]RzŇ|G67/ YVSGĮ^o7hAk ]٤W5N/3V"տeOJYߣKƁ@s9iz4=G#-#-#ÑHpy8bҖGKᣍVh'|t> Y Y 5|> YX u|ҵҵҵҵҵn%da%da`!̅5ʽd*;5WN)2=BNĕtlM\q:UwΪ]Εx6[џK$--*6y:RG}/WFQWb\kCpr^ôp9;nǕy]+CDTŶ\݉0Wm43i&KkzrevlKDv+x*+<x.*EJѲO-p2&tذF6Wqqg&\ 5W=? i6D+Wy{or+)rU4|r&]v+W:w_y\8;CR\-NNVj\Xq^o KJ*=Ws VjN۸i&W3G.r5K7=n,՘|Ֆ\Y^D)\;{Ӵ"eqxKm.']>>W(lΧ-{mUrHW&y랲\u9cN~r-r)UJO˵|ٍgnhpnt5'3j:N)* 0U•N|UZW3ڋqKiRB$N2\gGU "dZUrH<Տ?+r8+U2Wfi2s߁{qz\SwU^ƕK73K,/ʸQULڠ%WGDWC[\̈́gfj+0~)f~:\r+}y\-ʪ \Cf<{v﹪efDtЉQU O.ڽt8Wk\y;7qۍʍRrUp؞\N-Ӎ ҡr U\ϋMTpvRVƕ+oȒ-4rvܴY\8Bxؐ,7\vj øDa+ oh)ĕc;9+_5\Ez W97Fhk_5=_20RG \.HI>>ۦ~H;Efppmka_3Wo7%ɲSVo/]nދp8xU65~R9Lt43VιzkKX/ds)y!nEWcރ;O"]9^6쪮l<}e6Yڗ+/n 4-5;e}/r#륮 `#y О>J%:n}NQ^{=ex^{Er#9A_ ٮ 'c}ͺN>aUG}sܒmhxamK]>--Nunf|:P./+/oЧ]S3(1+IX_tCp`y-A ork?2uS]W2^/n-pG;A/8SB*&I_Wm'$ؚ ^=Q(fx4~%ڨ=1Ʒ\;%O{G [drxJEI_SvϕE.Y]MÛMԁ]6YKL|Fla$hKp姖2>y0`5/b=M9L*$~f%y^cEVstySaLv{r"B)s@i L< E 개,ܛf\Wړ.'f;1D6Wb D q6}.!vKeA8{8{?:{@#h !1NKStLojL}oFmt{\&i][73iED~~ [T6}ğ26hfh꙰m18׳Nv:>*TM$P~"sot_72=pf9qĴL]s3̷% ]tĊW ?ݠM`æ_B! 6)>NԿ+x&rC~:,WmLk8i9jc09[awWE3#C]չ\%pWyO|m悄yQGC>0&{_Q.{ ,U} fw?b!L2 7`ғe;{\t5J%5}y19SZs69S;LK2-3Zڵv<>ovw~{0`L0_R{,~h-{o឴L) oP9' a"o\U }SJ+pvk撖* {.jp]x9p@1Mtۆ5_Ϋj0YXz/kYVM{dX y O:_Vv? qkd;kҨ=~bY8gP2.8 sޢmX2ʫ-:r[εK|opUpB-bHǻrlj{>6g;CP٭h L(+vr= 5|#ϵKƱպWυs@-ċŮ@b,@Ϡ SgKfcv霪zm1?X+5p7ے;j vKWA荲ua!7MGNM/sn ;nt)81x867ڽ4حp;wݯAMjØ `{ÏZ^pJle#{u͒aU3OVZ^ Sn\#pgm_戾yGg.@քsvm|V<]atO~νsqܙ8=eۼq(4FlgL~9nX(Gwqp ?xxm@xxcWqzASxǘJ^)a+hr \/N=-|wyw]]mC vD^TK=pj7IG;gzO^]^\x&da7/}ԟϬ/<:ۛX;hyrM<2 G ^}fά[~ܧSx,j}-oEq{%>-[:ٖJ*R`df"ZdUL`pU=&N|=k1 ܼL^e2 >*!𗝾Ba6q{'vRp mבA#Z37Cǩŭ;9 g\vr !$mrrrrKr 9E3GQKTrU 4ll9 TZj%MLҦgXkCKxO üI673!:G(RQ cլ` 뀘c+UB 9y_<-yH`"˟>򣿗Ʃ-zE(=Yay͢@ o-bh sҗ?$: 7;n`QjTE|ݸM0WnyPHGIzi+ĔУ`7Ov?>F3 LS*;|eĩAnR5`n>wg{7} y@n} nȀc] V\;\{tm'xr焎n`S ^wmAtG񋥛 o3Ռz d =?K_wy{$,d /~{D,ĭ~3'\* 7j LvhmZc$y\Ϝ Ϭ_tK/w6*Z Lm>\Us]jSFODgT}:9yf{~w{^n2~;&QeasxCSÂWcA4`ˌ\n/ FhOm:.tgݎ'x n=LTe{L8~I |»]{;VS5?a]||>Cg'Ymq7LYݓd/oS J}zf2(l?pIlߌ,ŒT Jˍ}|87 3Ʌ9\.EWA]@f;ƀ Z{M3@N/tS] u7`y헻*ÒngAl.̛ˣdSk/C@wva~&*i9n;[e=MX>S2^-WCfɃW8G{q +xt$ޗ'L~SzN[W5"WZҪ,VT912 />le%Eey= ϡK>6|;f,X| vso|BazHyqN ?~`˅#՞Vgͬƃ--շ ιj Xf z[z2&o=imvZ +~VU랽x1D1Ȝ[9꒵ dcf;ܠ8dw(6DO 0;Eئ|a~ q'6Nhv/•\J }'[Vr|vZV/< iɁ*n9BH6o.} o_2;br2ޏ rA.W-MZ,jt"3sǻXP]GذSxAQ`c&:fƲ`¶Z"_46<317tF`W{`_߇^^U/_;-g_Ylumr/HlK˃˗#y<4OaO˱G3TmEgJa4~4)&$Q֝eD͝=jzgXEג| piVmv5O_6C+6`WpΥ@R[ (GXg"]ɏCdNl~+ywGGCڃ l Usu]͝~XKo;ذӳ$;|680ɉ|'SzP L8p4Ȼ9O[`kqųRkp :ܬPb =Zp72>3d:| jbW+3AJv&.p{fw{ Y1jyEm WQ[*/fmГo{wy`vKS8%Y,bfZ7>=Oonv\h1o-pjoc&`RmW nO4)[o - ?؛59|K,>;8 8>V+w6c|0c7*jXi~B~՛Z}s~eΝwTFx:ĆM|<ň&BV. _l߷3GpٙCg~G9:AB+n`17!489pˉC Ǿwg},fGypE`/zw?JuJq=/6:2l I5؞k.)z#y]Y1КIzBݹ&`gsO@`mM=;/W X~d;2ˤTBDiYάBbthq48i:;kiΚF8i4N |cd/a'=bb <iS}x㌂[hp0:"ed%D/*lKV뫏 U'~Gf۰ez괆6TY~>rxVgޚ__B+dY\~7އc`HxMqD*Jֆ2!Yjd.z ܓMc E)"!SS46 &^d+\8r a/\MЦGmj.'U2N_~F@~Q^'uB1 FzM ÀB^oB3A {>FX}1i"vN xiӔC܂BDe"A#hca0ox \s[\fqҶŐ52!d?!fCB=uŠ#N? Л!֎ k c(y@_/`/@/m#&̲ǒ"TgCjTDuZ(tl[r4B6[BiK1Lo 1_Lp;@p̳J$J)+㱰ȧem9v%O/3>.:VBxd%Ék_hx`9lTݯњ{~xsjoCpoltb[^Uz}\p(~̧~v٬* |gwW}Y]]k| kbɁ/kVs9Õ蝔Q4W|mczCR偅\8ڃahw*"ˡ4LW;pJo[UR%\ V+,$rgD\iq|_1o|KF_oY|j^S*OPw)?6jMgP.:ni8ӭa\Tk󿀫ԩm\U,sp5;\:~]Jn3ZtrU|{u[Y\)0۴hWuEQ洜mUqP{Bͬoxgrhtr]@$]w҇ݑiS{zım\i::֘V2ac9p96Eg&dzq5*f"rnO\uԵW-T^X~NǓ *JmrbyZNȇBhbv^pLc~}m\7usz)aN69/vWO.RFѨi4jFޠLH ڴ_І& \(A4 ]5!Awr Z?7ѵ#7Dnr;OGtgNF!>!uG>D]7$O`G(^ +]a=@||t-~GtF4,o|B7v_DSQ;#<q= DDtx?? x{byP7 D ח%._ڏⱾ&r"WBg(P~#>6(|*r C,tG̦4]k;Q(TL/]QI{@P/ZaRfuhJSr1/#t%PjCRĉW;Ϝ&\_@@TzV-$9Gc'KUAvֵ?.5-~F(·i.pw(]GLk kkJj\}>7d9%OkmQ: V~ʟ7Ga/ca~8KXrc:Xz,?ΟKo{Q:^?./vX_rgcˁ.`N:zc"D\+~Bz犺 (.Zn63vqz\1>X/ t3r!k0srL/dn7"L<6EZ SeCy P_ f C𼴞ZOT5w"wKG˨Ƭ~^A EA[6dXݦZoT ֟(+QW4 !*Nmś^Mx+JĪE+ZOmVmFS`$"v$PJw eZ`IY6H$p zL& t#k ILeN%2@&zS&ePXƑ0jZh" d@]0N T7GԴ:6j:EףI CII CB sIv'a ưE$,&a KIXFrVAJV5$%a n $l$a $l&a HN {ܔSRF!I᣾`̌c#2$33)CƘ5$zbS/qK,!0d(2T9z XІePpB`PrQkQcxPkZU4QDѢ( -ʢ7E4(=xJ(m, h j2 qFYqgdmh2DRuŌ*@TX+BXײ<[-}|r:o9(nq(=HwhZ9= P[sB`0%ğIH2rɡtVEB H?HC8!ˡ^G_Z3K邪oH[QYG+juʇ49IxM ֓dXHpvQd<'P##?22SzC#N;Ah:F) $<@ @!uj{^Pviҗ𖄛l/7$dp$!!PPxF[$k QJ.%/ WMڶKիlB`hSk?D8;~^eZYwhY3dѕ҅7] rVP7$^++!+"ݕ9~0u +ee뫄rlnVp9‡ +}IMP{Ij?C {G>(B'jQJ3 ES(!"T8%8CMތC.5a3G8C=?E $($h+rG"g1c$8;L easfMjk r`QPDH..A٬}QA \\d  (A?'q`NnSc?2-ɞO1A">r뷬UI(͐z9ZۜL,Hjjj $Hi#M ?މfwx|`嘾 +0zJf dC6$~r30rÖ *5~-yKڋB|q*3LpGoo/:,/TƩ[p0VQT=fx^ K)BpJnQӓ›e 2pFFFO{*3'U ɓbdf=g5$ӋΩH%g>VwAd DBfX,,پ^3mbxV~fDňoi4F.ݵчdQc] }!ǧҪ <ځj0pi䐫{I8GO"G/(q1 U_5ďIr ˩!nՑRt3 cJD &#_ԹTmD#C-CVሑ>u42>u$O6r2Yyd}W'i*M)̦}dq>),3_&|3̓>gmiʶ4=[-MŖbGSkirgŞ)=CMS3 AP{zUeK.T|?8VK~d9&=|:Zud5ZAu?4۳upP*ΰyb~ǪhuBFWJoX8w^`k.7CXauGX5a /Ө5Yi]:JeN`ECR X=uM7Aƙ[:t5jmK3|֎kpr> V/VV*Lb,V(/χ O;a'^ʲsX1Xbor6[ ^*mAGL@MbnK 6Ҳs౹rYp B5Wš|^-9jSu`Ź.s{_&w|}Y@\5r;X9`EB5z; aE哧ƁJ5^_uM_|;Ʒ=iZnp/xޛX~6 ['pɇZ8u'2UԎzk ]1og6Vo΅U+uU^mL23v(DW6:7:#)u7yY=1m+8:!xh!>\K1d L&n\GM9o`ƙSߵ<ȚpQSP{nS@Yj940m:c~4] "ۺ2({z}vp8jRK9ߦf맀;=l6퐙T1m#s]h.py /ʣ݊-^ȷ6oͽد@p3eɹG+՟$'_~<<`j)iF3 ;NQf%u00&nCT UWM%Wmknj[ -W <|Uf O}-/bg9 [cq|){ NU4 tv'?N ^]|q\7dVFobz WyaE^v<''F-Kg M > O+R*`֋#*ρG%fAPݴ%wX3W ̻$ lW "prw@)W8Woᮾ+GN'`c‡CtxӱwM^7쾬I]m+okd2Td?54&I7m2{r.#=̃Ǿ:|Zƫ}ںK0=-Psm>5Xn)gUP~`a-068䆵:޻tSRr,r7Q]W{d~fϬ<+O{H<%9dN;ABk ĬzspI}یW! $Oh rI>wNsV`Qh_3=\pbPvlV폪WBw[Jr|pm۹[F$>^@ :#Lpz~X003d;*WFG۟`F6)&SFqµcfu'>pxpeqVSou&^`hFΈc~q9XRά=QOg™mnZޑ VdZXPlkl#|~JKIĄ]R0;*uIZIgJ_|> 8rI=pOǺn$.8w4Ȝݤ5/-<$,Spkn3>[JB.ׂAxծ .G6FJwoJpet 3{+ȟgkc|ߦyp uJM&6cg=Gp|v3g29Kx> wØw7gM>3xjd)HL:E8U|؈]?j9Wz|t;e4}s>8w23*V {4eμ %_Mo& ;~4p=|Y-Py~/gbwc? uT[p6lA4hf҃œ:J1!w6ˁ݆W]c i_Axrᕏ7+o]&] ;~>\@NLi_s]<o3k2;Ӭu@0gWM.* .acP?`r`ѳ^GFjz_Q= ͏QYn` 2,DM* /?]/ѓGz MNjF? &C;?gm6N@Ҙ7Gآ AÅ{`i NIVޯ\`׉\F+㿨$`nDn;BoեY'9f-}{/ aҒ./[ 3eA^=î&B=d_4an6nGpⶻ a4GdFL:{-_=B<5q'tzsx$,80b~}sm>FZ<ΖCp{^1,ʎ[ [nv6̻cYQ6H!H-}%rNUM3VRVM?u ad5Qi_i:bVwU|^^zXOvZ@ 8}ݴD40ԺkmK/ Q$I$1;q<X3.:L\_~ml'8iTZ%Lxʤ!06KGG9N nlڣ^_aڷqMlQ}l>yt3;ޑljU@!E+@Ҍ㟃[.M8\ls{'͓y I3ރ['G+j兀l.>(ｮnD3ƉXG;[S Sxx+IN|ė'O 7.^m ġOܔH%xtlw?^?i~Ooxeݦ C@)xpȇ#|2K'SsgS#,9.1ݷ"x|ǫ¼ArSSWgsOV KMr/6k7CF#{;r"2u+M၎w} _w|:&w=ly`LZv{޴{޴folv S C71<2ʵfjHQmAh*׍  .P־F{dgF:@L:$W sʺ|ߚP=_beC&rk{EZ݃(^4^Ç߻G:;:O֎Gt`R;Y4Gsv.L*|i[ȑl4}62z+lx=bo,MluX$`%Ir=0Qv/-#~Kū5[4O$fڶ'ikO[=ңx?!iQrCWu [77 x;p<׼ezt<i`~քx4_LCaJ6_nGsu`?Fi:;}1/yg9c9p<9p:v~qy$?[./>cϟeeG?{6|1{=TX~sJ]=7zRJOeN}w=4k<l3qJsbyny[9W#erOR ׈Hr;k;5A,H}]dAm4D~qpՉۺV|V_Ï[L7>)|]'zTՃZ5 vs5_;4W޲ ^ϓI2y-P0lkQ%˞𥣧?Od5[XpY4?nW8_}i`SUMs ] _nZӮB s`0)^뒬“|E\+PQHkglt(FXlua`i꘦;kܯo?ǎݍç!+3\مˁR=>|Ylz+~ːúj<̶7L,T<_nNz{nPˡ.C ς;'GGm˿l#;|^x?liNx~Nv. 17_e=Ԯ1 ǝseBD?*)X9R#hWZ[q3N[2xB!sDznKXdg4CNQۡk*,Smq 7"7#<)2[[ =5yxFGi;ꦛ tP^(=Q=^%g/ol ǐTNA"Rv;ѥp:"(Cݚ3! Z"PsDךA#ڡrẗ́#*/oGBpm EhtG:'@wDSˑn{"&ybɍ[TR!Y Y!w0Ð ݌@;D. \W3EwAԉxu&x' 3RyEaN ]P"O8KdwBfТ8QէS0f|Kf<Ŋo¯0KπOZP|!g'+ߺ>g_6yQ(vl~J&xeՑ!:8"ʿ#!4Їyԙ/C?CSix*QfD;E;5zk)_c&Ho}=VrE-KTz~7'ib7ŷf06Mk+7LI9j/lIx(-(._KQxFxzb2;4TN}zJ4މo RtlF=BՖ=nnM^o#߳XƗBH.Cqj+J~o)3!&l B8@@}$kkNY42Tkȏ"Ka) Ӎ/Ymo aѓC`~K3U'rޛC飅@=u_#o"+,wS 5,VLo6__)į~^+}c ~ÜA5\a)y!꾹Ho\cA8][Bk߰<0: o=j}0v?00v(0rKMS/(/,oH!`~W}qM؏6/ꍢIn1b$aD;)Ai /]5Qg8TBzL\b`;bDdNg3_/ELHIImڬ|!V^H~3@:6t ፷i)h l`D hˀv:IS7l`Z823\~ja}g?gaX 0D 0.&#pc1;X3A7"w(a5j߳h_Y<쌞K%TP4fPTJA/R!\sfK=>D-%!>B#PQm_~9LGt ע.JCg!UZ=uVU9uVD묟KƏ`c'>z_^lYY{سW4XFy7ԑ_a;_OS2\Gfl=-AH,–` 3^~+#ja\qտ+)}TItKzgADO-:Q\y;[}:ϲٶ>5aٜDrP>ư>U.CH;n=~=DŽp8CsJ>ݶ7WmOa"7E:2ů[}6:!/~"fW%!`IeO2W bVK15({C0Hg"_)!n \1aSώhº,^ Z<,f\4F2 Lbt7].!1鉋g_d6z*CV^cc(ij_hpasǐ{ y4نܚG1TN%Мސ|۴!2I(7'1B:13Ƴ?㹿0dGGVaAjAvTd-:T6"ϸPQ8]qoHw.:s1EgO<BCj2[ {_ pb~+ yZnyc;ռw&m ;1 \NwsS n- / 9λܡem`zi/!Gz:䗟k7x4 s͡Ɓ &,=s)zx:L}dJ\2px 8ƚ9 =!Gi4w 8i%Z kq~ ӼL;xSRB5]y092ؒg`砬>^O;RΌn$5}EV*R~d++Hx>퇍jr|Tp@|M":ǟzJ? Z4Ŀ0bv!ڱCk?-HLv=$);]ej~8!-d51pEM3+4P? iXbmJUNqn}ļ]Ѓ5~=HYZOdM?Ov=$爟hV4e+MϊgEӳXTi*4k[bMSlhz6t~mh6|64 ÆaCyK6 ixwJ M '*ϝ ht_bEee^l.e._|7*c/ܺq|C \`b )%""ԦA) #y~;s_׾ֽ{ZkZe1uͮU!6x`roa00!fXXV'o3!];F[H`gX,/[ מꖎٛڷ `;UGb|0,~s /w+|B-'tZ$a̪Xz-VQ}sԻnV:mX&avB+bkaaխr,\͡zM v0Kc,,~SXg=>Qϵt s/xtӯb:Dy`<$(g?{{0ն86 'LUlɲOuI;tHn%x,}o*j2zBD̵3g{BaHn*?S_V/7q懈Gzif(?}gsH}{z*/oMB+_3FEGY(.Z$y>%>!Np;Mlr%Y =ho :#L2*Њ 8K8[[b\vuN0bC&J>~t-짺;'oB ]лɨ0+vg vLPW5z *Ol>^?ۙC} .W"~(=`Pp0Ci,*P^5 K0 fY'^NW#PMn ]PAȒsP\ X}Ѫ#;*A˷!YZV/Hv17dU&hzCmqNp% ?q< ۃ㨼( 5c14# ǯ^6J|xҫP^phfOsiŨ(^ڱȀę\B] *K>j[t. 2 W$_G˸Gjڝ(Ze/D~xp l>+?g 1 sBNC (CaU0$9[m~W {w c6E56p!gC,`q-_約5-?xXm UɌ]7v0Ȍ(A^ͣt~;$w^ J^a;y=.v,ta׌>?不Fu^Cqdqu ;ާ b>UrG9QE4N(aF@rF!"M.1{Q%JKs>$> 77#ҹo )闎 w[ FzUm ]?tȏe{E@܇~4ˢbȩQ)Z2PIEg!u[ !ĩ89^܋|Q\T\D)`U~ofz! rj(Xy>W_4mmxatSP̫'duИ3|L\: )KSxW"Cצ;R(fSQ(Pﾸ_Ep(駊B^n!41;3?-zid%}4$ok]Hmb{F&Cv/J4*<Utj[4EqyH6T#aJ[?8 7ߺ:m0 0:~ BoG|V*X۳jtzxTu.k: x=gJ-1n^>2glK{|6 W*Jy6&kz!)-|g%|bA" \F}$xJ)_]rG&C"IQE޾4m1}(5ϯ.jgkC Q/]w gBve^ uK: awEZo+LхF`P(<-> p/^1 4:?:'Z/jDz)d#!Pb.3n62dm'sHȟs)0]{nn=l^3h̝kij!HzC>C\*^cylR}4U${-V+cȝA1(mm ^|-w#Փ /%=5W.GHoO RPm=-Ҏ>|ى`k珯67_A|91Qy wّ[J*R~\>r\t<_V=|Oo ,m9 U2fy%5҄7+<[_LTe3 #~}x(ˣoF^NTHrnB1-_SXg՛oop/ IIIހMk-5]y#6]nXRq,cx0`?:^ 3>b(]H,,5(CiSA[+rzG5Cɣx߃sPPl{&ʩ* Cf3nmA-L )pȊ*DԟDQK8o >gkGP.Egueo8[&ʴקse6dlyj-Ix⓯Aql @)Zm~+`e[n&Jrm(+ܙ 5#9(baA%V,*5}9WuJK"ƈ2RF"Ujښ."|)}׊t 0qT s#[MDAVoQrȦpzxVLgzj㙼"IV\lqrT'hmOy|31voiAmYf7ʙ/oHDs:%o;']Ժ.ye PP.\ro}'S9R> I+îTHWޭ(~,7A_an-[m,ߡ==iP E'Rkg g9ZQ&ȵБ;}M nG"W= RX ^R8#% |t .s8}}J+q \4 wa:^~3OHx3Aewu÷75>J^!i?CfZg,co e{1쀲;7>~(9r̉!fP9uCL(c,{F n!ɷ]Ys%0y+O}>]splݿCeԞgA WbYOLGl``>}9 PP?}R2kѷ[!!NsxwlfeUp.7j!B]q* 厷~2k:UN.[rxզmv[<^闀jgHGaSѽ܌s}+*qɾ>6s4e8ҁe>)VKL\'?.&´gE7mKBdH]4y-=KpJqISE"tf6OWލ?b>;a`,:v3_1ŅnW)a >2;K\ B2VۺXt <_[{J!ee_Ydlqx2.+{^7KS-Å˳EDhJv+P>yL%xxvf>h/]*2< _ uսnsј/}#9&4r?<΢kWS~a',%ƙz_&O?UN=ԁx:oJ:wqBIcě<-,0x>:dcNrh*rh*sM}B}B}B}BeTIeSߠ0.%Q~1&s=ʹ(/%. ,U, W (Քq4ts2mbO?ŏ# M[?LdYdWU"}\r~IIuu_rHJtZ(9`p$$\w+Q `#7!MCR%Ixq8w,R'oib%|,>&t!Ɨx7.ap)n\':?7EwDo ڧ_?N".oYZy9Q=Fߤ}.6IPNG*x[aq6ۀ=ʶ!aOf?,Fĺ,;A$,Y._r;YSӴӓ?7c~7I{җqSi bf >ʴH}PJ&{L.77ʒ71>DI na0Vyde$dv<%%X>Ƃq,@̏PbB0&+n6џ,>>\b>\da\kG nܔo)/E7l؏p~ܤXnVJ:_ϫ:qT4|_̟yAr\}daFPh?F|2㜠VGÅUrև#E[Ό=]cǼty*GOtDH]rYq71 -f*7)ޝXsfܤDC.Ɯ$3qb!"N 3&?䜀2Lһ%dnU4WcS!;NOsSdi;MN8 "DN3)Y&ٍS7R 4 +ߢ8 kǦVHQ^KK[OEMKVäi]OGCY^OOOGYQMŘOO{BYL”|\=I-vied49ͥ!O9'Oܝٸ1eLMobUJZNMEh_ fQR6@>aR41o"3/*!<^qX Tuב '}3n&NH+T։5>B* #>6_z] ntB!r*)4C`,h,ZN +ѴG ϫgx\hv >JyЅrZv`iLѕ[#9`虝.h* ~ۂj7ϮtPga)|{r+Do;Uhڮ/Q :Q]>m[, y8zGg*}P?N]0O? kQoQ†=a7Jۡ -5ZضV_ mulGQ#.bx.( R5FubqQdmԪ%?e>k'((1ځve3d;Vh62l6Y*؉(sGaҼE:(iw88(;7Ge*} 0BQE2Ao=N})r lzx&.(ziL۾7-_B;;^dޤa$z1'3`8VMv&Yg-u.DlS +Tek[tU 2DWC.w'nFzV4*(} ~밇7.^w<<ˬw.&I7e#zH=}KN'旊8=oY{Ó=Z19 RY,%jOjOQ'{'l=VR کb-;aXc8[V>/WØ6dIⵥ&B ` T P."o0Nں7:p[| u׭ =yk¸|J<7SJ◔m!guĎܗKN3 !ժe"hK7#Dt.n2Vam܅XǰБM1آTyBq§i` e, @ Bn OUsvb*C`0]3!դ B\2f| 6xiP7h{C(,߰QL2%# #4z۠s삥P6fʬ S2sZ}z)ô:CAf+,Dqa~čY@FXoX?)/} J31hB2ٯ%0`1<,54J} w9@G0l^E7rx]*`8GO(^C0%b:_e^7u^$4~Q4nq Dj`Hy(@h}b0‘Lt8M44n >_jr̷JA* UuÆaذ3]{5Otd~5J~dH ?a!yuOZq@؅%]W.QwKzZA= f%uGݬJ8I)uPL2WGDԸwrOfb@Ix~aPO 6?`Q. D1~u{ t.-R["wOw@iyq1wt-m^m{_wJyCR\jbZgI"oV[}TEG ? ]+}ʛQgLHa*P_B%k_ f\^D?PxY'dF!N2هVв7pv{b89Udt)y~ b f=pT{V]`%[Dt2dTAi>B(4)^RGnQ^ QJ-{=Y-`OU=wCfJ#zQ-Һ5 )^ɐ.3ePfG *{XQągGӡ{m 8PM~[ybV6yʐ'מ" 6 >ˠ]tkˡI 8W=]J`[{2T39 ىqRk0_? r{4"%g0z9e[76K|]A}Jά94ռeCnu7ڐ+R;$4528[, UeG8ڵf5?4g>0[MۗΪs ?Xt擩A%>РPʺm^_\ "+BW߻ʡsO M5x~J0iX. v=&W2 ո{ fny8r&gKBn׵|Tzޚun7c4+.vo * CB-<4 #1'4 rCU\#:YP-,6Pk_!:sU$7KCV+$hX#͇S@!%.%4@{{o΅Pװ౔*hr_Գr94][5AK=x:/-+;vu,jzwMVpC8 4IȾ&f x~QFeʼnHוծNX0]!vR *ZJ$Ϊ"@‚2)&'R|qD:=Nϩs4='Q,Ï!Ʀ9Qż;:ZyS y+CGY;\QuITϬ%h8CM狞dawH+uz\P 7})@G Jkkux ?}~)9Kae^*J7:|4 :Mtbycd Dz^=vȽZXR" iw~$yʶp 3fU'AAQ'nr.|¡e퓄 4{~Y^q$lqƫk]ʫ.Tu_DA5pkXHk$o Y4 JvC'("[) UIlط9>FSE 60OUL(DOÊP WW^bh-.? ̃Qo uQޡY!uNȱ .>Ѫ ΎPFo[m1ΪF5YK!NZ;J"w 6m ;6? T|Eٱ/;/U!B[.>[ =XD 5Gu8~݅7OC RQ ZPn/ߣ݂]GQ|hwtf(x_… Z)j=gUSyOFh9tl/~r5g}\sGz\7A߼e6І}BǺ|ui}-z`W3*K +P&-P}H4GiЬsm``p7h3(eyğ/,^& )-�% IF Yfq?'ʗJ. vO3PwPJel(m^BnCI5_K0Bd4OE&[p\_lmfg'缻=(Rnqt,aD XkEG% 9v^WaHbY}q0^6C a/JQx{T( //&\Z/EQS`6'T?$; C3~*ONR<1a(gڽsY(髍I4n"T>[QaX<+* < ,+b+AkYn*R|~Ą_vmš#QT62 of/6o|a+uzpѫtts *HSf(w;a0XE=0x#bH'i8 r6sv _=C;17ֆ̫/:"d!ޑv/Q9YJB/;T: t(1ᄡS~; }5_}:l_m1n`Yoqܟvl>YC&a +P9QB(s᷃zCr;rcLH_ L;-evTLHb9[} gdAf7LM :EKQ = *ʞLc7l!z>ςCVwC -C!&^N-6H*K%qdS!xѻ(ρe#y]x3XD>gNCjޑĽeZ*$rC`b[Up8}|&ST1l:O,/ ey@l؇U(\V*jʥ.ߚ2PH7A Z5Penb2}yao;Փ/ xdhf֝E5w-nIv,AIцjƿWB*B‡t ~$$ɰNpHg&SjS! đɣ?*~OA$3&tlHN {ITHR/iP鐢<8|b*]JB mXV9|Fh.,7~vмB.z'0詗/+VBl9eVW2W;1(Qn3XTްopБif,Es%/Շ5/,PLQV),Ns@7,:>>+?g 1 sBNC (CaU0$9[m~W {w c6E56p!gC,`q-_約5-?xXm UɌ]7v0Ȍ(A^ͣt~;$w^ J^a;y=.v,ta׌>?不Fu^Cqdqu ;ާ b>UrG9QE4N(aF@rF!"M.1{Q%JKs>$> 77#ҹo )闎 w[ FzUm ]?tȏe{E@܇~4ˢbȩQ)Z2PIEg!u[ !ĩ89^܋|Q\T\D)`U~ofz! rj(Xy>W_4mmxatSP̫'duИ3|L\: )KSxW"Cצ;R(fSQ(P8ܯҴҴO:{NNyO Y+I"7 הt9V3[ʴS&__ӕ7 =# AfMzH@ /{/A e͠BC(j,Pţ淂P[}[7RZiDG"'Jm}ϐ-󅊸z(t gFQL<6Uށ Su;9PN\M׆":P֨/{jU|Q`ed|i(cAqi$B743ޱ?J]!;P;SzЅK5z}(:Z!9FppʘAg/ʴx_*&Bj{׹ Pz(Wao(g!2L*(S%|W̸Gg4j@F9j>?Eg5hص j}^:r {?MdCiMڌĕfH;r_7Kyo; ȁ I[vݐЧ#e[)) _~X.pWswd5, ϡ(Uw\vf{5XIRH/uV{/,ojBp *eSkJ4Pzȩ͛8; .A[{ Ӭuy(wQ j)]EO=h $$XBsTQZUS%,H=[yQfjerq_{8*[[%ʶUiH$*Wir*׷X5,Y,'}JszV(KS^*ԏo%igkOAV]z趌168=(*W,Kੀț l_I7WbMם tF3p\0[EwߵYf_)eKζaTw!\-rY>;~*Us1xnw%x[%.t&o]^C+]f ?ls;^k^ ϟf]=ܿjurm;Ym2^(L{Y4x6T/O9 EWή޳9ט4enN \$OwmVjt(mpY*泳| 1Ȣow;sc]\=I|#aU_ $ okJEPqc>x_V.\ Eׁ'貲'u4қ<\O*laM!!"N 3&?䜀2Lһ%dnU4WcS!;NOsSdi;MN8 "DN3)Y&ٍS7R 4 +ߢ8 kǦVHQ^KK[OEMKVӗWӺ7.w216@dI)1 | V l ctsn4I22Ґ'jCNIlm:ծgĪn"U[z%/̢l8.$L"1o"3/$<^qء%Yh.uw}~]o~47Z'<V / tHUJUJU*_g3D"_r81Tđnîrò? KK::X*ؿeT-T-8Җ)7h&WMyGKh@,!'͈1es*fMah(^N{?w翨\,J`޷unD„녹M&s{lj34n̔-1EׄN0BػX؟ָyZʺ;?7-Q5Qׁuc=>F? LĜl7=pT>L0ast h.F_-MH&oBljl=62ZK tNoJ21{m6kw'co?"s3YN-5ƻ 6 DwƱ̿ 7&i< 5ayX>% )bKJ3ZGgKC%jՎ1U"hK7#Dt.n2j!/۸ Ka5.ƇbEX@>HSh\6UX-sdp9flq@'#0oxUcܹ]Xʐ5LdL~ax5'a%>q<-L# i-%e B9ڞi'7,Dޖp@_kМm{̽ NCYAdû]h)Q5{SG!!UOI5MJgW?w$ƽo_{64\M.x~RyrIm'񓮇FXCݣV_tiyR3F}JCt$oi hSJWKc$:COysFBݚ.h+H*j?ZlNQZ#Vތ:sdB P"5-_Zp5tgBu$y:~~:uW%3 qʠW>d(G5X?ɡ^B'pK( [U0 x p=nor_x~!__'~-CIY堿YE2eٽ;;tPǶ'JzQwDfO$)D>\] t,[~-'S vn,͗W-=.?C8z P {rZ"DTqC }t[$7as\Qx-쁻*ӵˠv/ْ~ ! $OqBMh7 >r8t۬Z`:WZm jx~Ү鸫7UыnֵE}PPZ(U:%.8;ݫl[ Ɓ:hC B .V?ANTWQ ]W]+]U,M&HT"tZU'kIiNZLfPIЗ;.9G)BY0 rSruf}ϙ ܠݬ(rӅц\')i8(xߢfIR-;5֮4<hھtV[qxȕX{'4LMd~(q]o_UmBf~ZhfYV{:o4B$ݦZ?(;kPftN8lŸHAC^Cc(ԣ}!y;N W;P/(͠ d[͊_ ]h '96 coUB'xꕜ5jf^O'6;,SIr'VCq7BIk4s˛y;$Duo749 \zr丮͇ulAYqK|SViXjٝԤ$X1<0z,u,P7<(Ewسw{u.ԆTA5ˡ]z^uyhYqhޱﰫ3gyU׻OGhڕϷODzĠnYǕg!L2 D54i4k_Vy5gɚU+yv hs>s i(?е1wO|}ϿO?m~oSSG}j_qe9)KIP7xQBt~cgCw> H)1_hF^BgFz5CoSO'_N񆆨׉R > k?MȯQSОLFj$i, *S.!uIh񊆦>Yi(1~}].bUTՔIḠ$6|JE'ʨ8 +y==+Nj -#ZKC@DYTHXRTW&Ť5'r+)* *+)kpq|:d-02ziItႮ]4&7||F_AGI4>+tCUh!=]T8cCjxu+}T~= nSrG蛹4o΁ї<^>}gtʣO}er{UIE/s]|:TX%/D=2GC2.],?u,\gCm9V<×aOs~%.Ju+-:@މiGYPmy>xl–xjB=5dOߌRV1GM;߮GοWEe+)݀VEZWm$fo} U2o !-ӛ UkF/e.P*Ra F=hV׹ Y/@C9t|~B![w$[ᣌoCNBEGד(Pu?Ҩ[ %耛Sٕ3PঽEPo!+wyQ yzuWңw._S9ʆ/^9T%u] M=lAPzw}P(x5# Zv? Kw;YմK긂]ES.CGDo]y.oATsNB\;E<(y| XJ4\U8!y?ч7+N Gx sۅT!WwTV'>*ㇹ 4T/CP)P1ZVUoSb^T|Wq\>07GWνB%{)R_^0%΁#a8/+s]ɹIϾXy ÛTDB˷r(Nh(xv+ вsEMw`}TQ W*̏t=Bj vsq2(g\_X+KYaHnL;:PATc<ኻЙ[T|ɩx޷D.k/nz[' x!dw"[ftYKUAVUKgUG۽UV[4|P0!~AR+rԿY6Bq##UȓR<9 >Gz\Be[vCoW۲(N; awߙScP*ey2}7qsJǰ@~A)9Puc.+ ^VڶPSX jahET0T̑/\Og? Ak9b.o 5|;y6:-TD6';_xW\mV/?TI}7T}C6VodL!vPqbT K5+ _gsn(*_hƤm:o+7̉Eg}gk FK?C-~N>9P@X>h|3bRW;$~<MQW&\ Q^# ?59U^xfٽ'F~짿w%i?|vE˃(v@{VȔ./ғ1n`YÁ8Oi"v3iI8TGjDe-s V;oM;=!-M!j1?lu*&5ZZKpljUIћAP,/}p޹dMGBBl8E_\Gv,s\\7^?`Kz*X"4?[j=B/ 9kG!_‹ׇAACUx7(V^Zh,-%V%XcWD{ DҪK٠ٌWAU^<@/{[%!~؜-PtY/fp\w>lj |RdTmq,Ir̽(jmފC%\_FJ/6XcZz/L8*7 E:댎+'A*_&61eeǦy} ,꾉qn3KQ{/2c㌭˹Qsi D)ȅ2lC dKϗUtE,c=Z^W <*+o?dГa?uJw*,c-֗_<[tO2GQKP[O|($*I,-=zCc%\Vv*ОnJ= <*XK۳ g*V$7*|q>]*\x'Y[kdh{(_0/w[(m` n+A}ϣ D^w^%xPÁў13B*WCEXϸR!NwU.¨"l,I-ԡ3֓'R{*B*z*jz,sML#ICKjf# n3nV>xy <MtRG ʓjhxEE6м3[ N:B#r V[w$\e%\MomE,btzaiǺs$6 8E)W-Ψ)X $ r:hdh@gɁM!G  CN4+O7Ex4opkgnCcZvD9 vx26$]}, eßk̶܊ TmGKiPn nn#+bY{ m4, TvdȌuf}+W(ۊQbx8>=hS~3;b% ^3U)@ܝS,THH O֍O& ժmj"8.D7ֳss֬@v>OIC5!\0JXH*k>lUr:zxB p̞P>%v0;!L[jHU+S!.}'(F7}9 ,́XgQI\)nKw_+Sq} |rlXxHNdK3//غ&Wy,!\ ^ Ά4mww2"}!vۻٲfrSC ҞM啈\%l*ⶹBnn-y7%T ʻZ3 Ny0nɆ:f&2"|Y(?Fa1ѣ(v1 Z'$Kl͆P|9Qy(Q:[^vN%u3K|teN+3 {C^g(\` BmLV]Hœ;+!]p#޶/-^%϶Wj L |u٩18&ݨaU/&M[@G y~Q1_R9;WA@]`*cp+‰6a*(uP:_g6lviiEM\ʺs ^6Oo3rC܃}beg6EqO,dĴ]7$\蒣\?GE4{{~:{ "YYXf/Eko^$$W.},fK ^+їƾ w+Z[< ʤS6S'/¡"sv}P%~g+!RP%H;v%$ݺ2?Uoѧx'og_U;TToQ\]6a/0awڝ SUSU>PU>PUSO'8I#w1;146=SR oxP&#U4){_&T O܈Ja ?&:NFށ@ wz<ոO?, x'э~}z"3*I-#Pw]2uW2nPw˦-#48jbYZϤX -sHD{߾,*`-m&hԹ']v 5`P?N']^\G0I*)rg}1ty',^@IҶжey74{k9-E ,Iu:9(l5]HR}I/`4PY -FE͵ q)q8 J:trifIM~P wJ?Bp ل?=W/;o[(t'PGB^5w1M-,7Cwl_PAA(ɶ&w  <'AN/rlr/O[ +9kx ͼeQNBmSwYzȋO`_o2Z)Pנi7 wHnhrJ?.q]˛G \7:}J}?9@b(Ұ0!Բ;C3II8@9cxZM W8P ȕ=­%99j/bȒlZi 5+B3WEiI;yP8 ?8qc4ykRM5R<|x8a0 Y".MYB8oxP4gf\ u K&E=k.C5nPo|132,ѲмcAaWg Z髆ww衏д+9o?N 7A\+@Cd@khh־WFkC ϒ5V@L !~\yu|(~8Q|tzw)?ߥOSڞf?xL.aL(7'eSM()pg'B xJIwJO(씐"~S*'O7RY<7Ez eDQg$CYNJ;eR@R> ^2]НRGG̗b g-hI/3Bg6L=ROg Q/_‘'NeҔ7R# dQP̈́w!A+HBPW44TJC7q:8G>SQ[YEEMQMYkB:3I=Ɂ ݉(+Njka~n{y==+M dUR eEtWRRW3TUVRS֝Y| ߴʄ9awH+kY 7.R{6aICPΪx'G7mCxQ>ct,Ihė=u`_9?.zKߛZ?0+('s ٞP(dԗ˦,M!"^mqOuf_+hF9 ~CIO5;tC+__3e\]aW58P$nFIN˗8EUsvBit`1[pypo}q^ʋ[Pʬ#O;k$SwơG_Xi+@o[q(ftxG аϮk>ḾTkF8y]t@}sze&b*AԹG۔{XZ2cJYPb.QJTn؀7ŋFQ\3cIP/}p}s@869$D)uCKU%gGsέX 1CNzfMT&<ŗS惒m%3QIj= ѣ{bU /u2yANT%0㫕4Ce K~^=BP˻]a-xt]/_"۟ b-LP\紧ΔJOmR,)yUj>Q3{P޼u䆫W.0Gsț(R *r{_qC&\, ~#=~=Z#@߯꺿< )|Wu\:Y.oAHm[0ɝTƄnж{jxmx$Qx1#;s_l;tuǃxII:!4n:;ga#|;3ɓ_'eSjz:ʺ$+J,r||4XOr'[ٓ/♵̦b3Ԕ5V4_w4]?#N>!uM-rE$wR5RQ43$wWʹz|+0Y,$eə7.ƄͮZ GZr$ABFZ;VI sIRwq95-}=kI 7Ihʼn5:9%D }J u N+h(l8ymggG[|n{lAiV!Z RP`1:%LOBaĽ8:+z? 3(M,JeZssSG%Q?[ 裑 5A/zz$C"PvrPfCV$Ѿdq _= /4+7A180,y(ѴZ4ݒA-nii{!jaQH(>(۶{Åf3wΘkWz[F~H˹ ʖO.HT:5gyAŹ΂ӳo1Ct)ފP}Bt.a#qf7-Pxf]$(^gH Šl0T%aߞ PzMr)=*<W1= +B5_]y&yDBdJ̃_2FU˿5EyR_f͇Ffo8!ǒNƪ0_bߑW)1GBYuQ̞2(~ͼ%EW*$鷞u / gIŷR2P稤4h< TTB.-kOcu>p$ĻZ{F*8;Bzmr8"Kg-岆8Ak\(f]>(شeW+ z2$R1^X.ZXe*v켄Wm me; C*l7$c].(_Vt2\8Ou< %7|KFWNH/tjAW|>w veGѡ$BߣX~ 2PjMUE*//rY;^i-kO% -5oym 7υuc47ZP2VgTėtAR)qW7MZjc:h0wҦYtpngP]?_ CWYLA R[:{'-Jz->ȳj݅!V~N/Ǖ\9ffA36Yy؂Qt5{1ۢ뷽,E6j//\j\``h@L8n%(7 -08َY* 3;X-Il׊ P{gKs5?,=RzŲ`h59RmR ^\o*(PyA^64_L2hCG_?1(m6OH6w >gT@?T~K.xbPϴ{PWgT-]Qv`ƱL{`GĠNsqpç(/l=0s?{fwjc|o0= W_t@EC|#)^}s>>Dw ݅^v:uPPb C^?{vj1puؾf 77Ry#7;ycS?خ}zu/o[>WM8y V+s"Po!~v(E;Ƽ̽ߙvZF/;- ֙Y-Ũsl/@O.nCn=t-빋/{4="a=TX=nB|܇{sZ(C\M`qc[(mT4DJCP%CwQ F :#f|#{ʴTH \pM*btY(^ҿӹ 682nƱ Pùj:TՔK].+5e61n$1at(>jR1 **d4ސw'yV@98[ȏoonhLNv†9k^Fn[=g^4 *"n쟑*3/OA 6*oQ$U2؛rHU]̒;nd@tLY.kO`/ʍ-r_G^cȪjO3Yc# E4xBBL(9JyW 2O.6?E>دF^g>KTCrPѧ[ I eFm8#uWq@m$eİ^vn˵6ߘQ!3w@Ih5qv%(G}^G Q3Ci,;jnZ2#; ݒX܃p BUvCKDc:"z`|%$xU ; r*p~U`#kۿ:qE=ny^52V&%sN((8akˇ =Tv}9s'[||wEbYtw 1tW%32wu"3֮ڒ kPbx17d{y5tFr+yg }Gۍ aCE\3n6r6{ E*q?P87u.xbr0zT<ʭD 8kmQPЋ4 EE<(/t$dXtKy_:2mVy%ta#?qVр/i#>Dzh}@q'9Jm 4Lxa|r/!G=8rQq9h돢YGCT (\K.:CJ`\}ҴeэOA1@AcPq3]pP..M=_^>!\JMEr>Bp>7V>7?O';a;=5BSffȍ3ȱ⦟ْM/@ K#ϥoܝQb]Qiһ.\߰\+UFG1GP|] :{QƃPqNg4W ](G/ {oD? ͘g‡VA͵ʥ( 6:%peu8<}mV2~OT eM.>AîeTґfh" uJmB_f$4@y꾡4\{!̅}heE\HZ Ko͏P܇>MQ(~V^HIY<]rq z'+aYx?G3[صJ:ǐF"MT~a!䬯0}S3r·KȵwT){$r]SQCN%mā<`p *WCfCIMQp0wL0/z\wyF[ &jrק2Ԫ*gAx2V+DCdPr.u.1WJG"YP'OPe7aKe9SֳBYjR~1hxo 3ST:UN3.kCc\nԐ=|I,ȡݕ5XZYB`Z34k35܁FxKή~}pJ=t[F xz~+%Tt a/Ϥ+kC_:g.e\ f_\3**{Z~ U'( } 8ҟ_4wfV\ӹ."NZ^x,ƯS%g[]m*xfJ~ x  ,?K9<7Wܻ<߭k:GY./á|.IiZb๝K5uZ/ʄO.Ȟ_w5`:6qѬ6p/=,i_l'|~@g+gnYxրSkL27xH'.6+yn6p|edс;t1..\ow$J []*/QJֵwǢK81zTb}<\W /+ZG"ctYYj.\m-'"8DSZO[)5c*V+V5{OA+xpRƶ1x,XR+ a/.,15}2-.(w)x}/ө8W"ֹJ#ogS!;s*0CS94CS9sh-z-z-z-z*ˤL*˜ztQ%O3&iCR! a^w5%e-}5}c -7(Jc.x)~\d~?OȏMOO&)Dm|[;sDI"|DI9O$)$׺u 5-u-rIm&Cy |rv: LG0a mBQ 餘/(M'о2}Iy_1z 7$i$[El6IXˈ~ăC1gYY8 #}#n/aʀ1h';~1Ud19D"$Z8bsOy)տ韔g_~+?/?g·aYJ < E9MW.ľߍo0D#xe$_,SxXqcq$_DC_WZ1ĺ̸5)~KOJnoOψb~DHGqO!+n&zl<=0dDdg"fa!DC}>O*laM!!"N 3&?䜀2Lһ%dnU4WcS!;NOsSdi;MN8 "DN3)Y&ٍS7R 4 +ߢ8 kǦVHQ^KK[OEMKVӗWӺ2cBo216,I)1 | IN-Fg1=I4/#i. |rF>y:Dhݦ}MjYI)*谵w+\]ry,JʆゴIɄdO]i)2# hzN"%8SE::u׻>?x>)Xk K}JTG:ClڻT5VC"TSh@YX ViAuWAϜ+B5+@}8 ? G{O[Ә/+: G8s`3;]5юU0no ݟ]<oS=?V<̙Xe҉\աORb$h8TPVa_o]8*6қyxBY6WQ]M(qgWo3D z!N/q۰j,nҒ,b,oY,Ui Ui e _+U|PMCN7ͤoM_TIW7 H)_1tq̨@:߱3AO8/1' qqO!ˎ^_W^ÑtvD?*2ӌBB]URWU%V]J.%uw)O6G-̥:oҋ m ;v1|؊O,'yזj]H E I[@~^nuktO0<,RG%C[ߙat3%!’ҌBpjǘ*TiXˌ": 7Vcm܅Xǰ@M1آTOAH zQ)4.{*,\ʖ9X3]8^AM71{.Y,^eH k2|&S?0ԓ0ؒYABw]&̑4MB2mO}崓Z"soK8G5GhNaA=CK'ql ʬ S2sZ]kTSNE^A+bTm"AZU. yh @ZV ZXVjS  BHTjp zӬ5ٳu̜]*jfVJq[3 }$pSkb85}: !E5H+1RvkRXsЮ^u /Vw%Aj;D>' #r*#)/VdPۮdzŸ˶vSݻd8"k5[pa*-3bLҩc)+èdV'Tt[v}i8` >{nڱ'GJuRY-4>]j8CzʼnaO*-3ef C7}EL1nK D5tBid!.;fxfex;.sL?ivex&]iq̍CAdA{Zl5Nn:- sV}w'oK1աrNb Ԑb['raqL~lIߍPapT6 @{_0P};±ioC%^Oڹ'%뉆$}OL`|đbK[(| {=,}_H-nzQ܉e`>GϦ1S }h%nҼ)pnl(x>bVk5T:_iHF fNUF/2v&yzS`rҩǓG;b^A q-c! =w=Zj5 {"w ]rBh ~=efY M;%C3rp[xHi ˓y%DUVsg=%=@xG +ڲdڐ?n[ "QqAqxll>|-;\_Qrgsy# $C刺gsVBmcע@t:{ #}Oj<bN=U!V!nB{@4kT|i{r->z{PGQAn-ߴ7:&.W@l8'o%ܗ$("yٴzAwyTaG=sX D]n\O1f#.[i.''MS|65LbY.I4۞ 滒`z\0]-\x\ "mA Z2:l8TTaP_ۖ ];@`A 4`h: [ %K6 }+PI =d[mYټ\{zZekhjzȲG=tY^XtRkS^Qhhr=aV7·PEKA1sPy/<ݳs΀R1_ܻ΀Zq4-Xrd|`y$W%s@pȇ9gAat+z@yg4O([|T~]|Sy>-O7־Ox^<'؁r޴Z&ӄ3"QhMO##Bɡ9Id~;Gv!=$IDkAv@nV?ߌ?b%4>ZFS?/,k#a 3|m"}ɓܦP)/s҈9ǎGmcI1Lfk'fj3fVp' B!o/Uv*jH4BkБH#/r%2Pt8[6McxxAჰW3Hk89k-k!>uHӘ8 >^x  Qxe\0V] ;ŵ{ :a01QC :>NDdNd_t]~L8]ZzhriT~.";3I'G1X5IQ:QQS==[gam/tests/testthat.R0000644000176200001440000000006214331106043014134 0ustar liggesuserslibrary(testthat) library(gam) test_check("gam") gam/src/0000755000176200001440000000000014531513157011612 5ustar liggesusersgam/src/gam_init.c0000644000176200001440000000744613077470002013553 0ustar liggesusers// Automatically generated, editing not advised. #ifndef R_GAM_H #define R_GAM_H #include #include #include #ifdef ENABLE_NLS #include #define _(String) dgettext ("gam", String) #else #define _(String) (String) #endif #define FDEF(name) {#name, (DL_FUNC) &F77_SUB(name), sizeof(name ## _t)/sizeof(name ## _t[0]), name ##_t} void F77_SUB(lo0)( double *x, double *y, double *z, int *n, int *d, int *p, int *nvmax, double *span, int *degree, int *match, int *nef, double *dof, double *s, double *var, double *beta, int *iv, int *liv, int *lv, double *v, int *iwork, double *work ); static R_NativePrimitiveArgType lo0_t[] = { REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, REALSXP }; void F77_SUB(lowese)( int *iv, int *liv, int *lv, double *wv, int *m, double *z, double *s ); static R_NativePrimitiveArgType lowese_t[] = { INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, REALSXP, REALSXP }; void F77_SUB(sknotl)( double *x, int *n, double *knot, int *k ); static R_NativePrimitiveArgType sknotl_t[] = { REALSXP, INTSXP, REALSXP, INTSXP }; void F77_SUB(splsm)( double *x, double *y, double *w, int *n, int *match, int *nef, double *spar, double *dof, double *smo, double *s0, double *cov, int *ifcov, double *work ); static R_NativePrimitiveArgType splsm_t[] = { REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, LGLSXP, REALSXP }; void F77_SUB(bvalus)( int *n, double *knot, double *coef, int *nk, double *x, double *s, int *order ); static R_NativePrimitiveArgType bvalus_t[] = { INTSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, INTSXP }; void F77_SUB(baklo)( double *x, double *y, double *w, int *npetc, int *wddnfl, double *spatol, int *match, double *etal, double *s, double *eta, double *beta, double *var, double *dof, double *qr, double *qraux, int *qpivot, double *effect, int *iv, double *v, int *iwork, double *work ); static R_NativePrimitiveArgType baklo_t[] = { REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, REALSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, REALSXP, INTSXP, REALSXP, INTSXP, REALSXP }; void F77_SUB(bakfit)( double *x, int *npetc, double *y, double *w, int *which, double *spar, double *dof, int *match, int *nef, double *etal, double *s, double *eta, double *beta, double *var, double *tol, double *qr, double *qraux, int *qpivot, double *effect, double *work ); static R_NativePrimitiveArgType bakfit_t[] = { REALSXP, INTSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP, INTSXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, REALSXP, REALSXP }; static R_FortranMethodDef fMethods[] = { FDEF(lo0) , FDEF(lowese) , FDEF(sknotl) , FDEF(splsm) , FDEF(bvalus) , FDEF(baklo) , FDEF(bakfit) , {NULL, NULL, 0} }; void R_init_gam(DllInfo *dll){ R_registerRoutines(dll, NULL, NULL, fMethods, NULL); R_useDynamicSymbols(dll, FALSE); } #endif gam/src/modreg.h0000644000176200001440000001225614331106043013234 0ustar liggesusers/* * R : A Computer Language for Statistical Data Analysis * Copyright (C) 2001-2 The R Development Core Team. * Copyright (C) 2003 The R Foundation * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ #ifndef R_MODREG_H #define R_MODREG_H #include #include SEXP R_isoreg(SEXP y); void BDRksmooth(double *x, double *y, int *n, double *xp, double *yp, int *np, int *kern, double *bandwidth); void loess_raw(double *y, double *x, double *weights, double *robust, int *d, int *n, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, double *cell, char **surf_stat, double *surface, int *parameter, int *a, double *xi, double *vert, double *vval, double *diagonal, double *trL, double *one_delta, double *two_delta, int *setLf); void loess_dfit(double *y, double *x, double *x_evaluate, double *weights, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, int *d, int *n, int *m, double *fit); void loess_dfitse(double *y, double *x, double *x_evaluate, double *weights, double *robust, int *family, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, int *d, int *n, int *m, double *fit, double *L); void loess_ifit(int *parameter, int *a, double *xi, double *vert, double *vval, int *m, double *x_evaluate, double *fit); void loess_ise(double *y, double *x, double *x_evaluate, double *weights, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, double *cell, int *d, int *n, int *m, double *fit, double *L); void Srunmed(double *y, double *smo, int *n, int *band, int *end_rule, int *debug); void Trunmed(int *nn,/* = length(data) */ int *kk,/* is odd <= nn */ const double *data, double *median, /* (n) */ int *outlist,/* (k+1) */ int *nrlist,/* (2k+1) */ double *window,/* (2k+1) */ int *end_rule, int *print_level); /* Fortran : */ void F77_SUB(lowesw)(double *res, int *n, double *rw, int *pi); void F77_SUB(lowesp)(int *n, double *y, double *yhat, double *pwgts, double *rwgts, int *pi, double *ytilde); void F77_SUB(setppr)(double *span1, double *alpha1, int *optlevel, int *ism, double *df1, double *gcvpen1); void F77_SUB(smart)(int *m, int *mu, int *p, int * q, int *n, double *w, double *x, double *y, double *ww, double *smod, int *nsmod, double *sp, int *nsp, double *dp, int *ndp, double *edf); void F77_SUB(pppred)(int *np, double *x, double *smod, double *y, double *sc); void F77_SUB(qsbart)(double *penalt, double *dofoff, double *xs, double *ys, double *ws, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *iparms, double *spar, double *parms, int *isetup, double *scrtch, int *ld4, int *ldnk, int *ier); void F77_NAME(sbart) (double *penalt, double *dofoff, double *xs, double *ys, double *ws, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *icrit, double *spar, int *ispar, int *iter, double *lspar, double *uspar, double *tol, double *eps, int *isetup, double *xwy, double *hs0, double *hs1, double *hs2, double *hs3, double *sg0, double *sg1, double *sg2, double *sg3, double *abd, double *p1ip, double *p2ip, int *ld4, int *ldnk, int *ier); void F77_NAME(sgram)(double *sg0, double *sg1, double *sg2, double *sg3, double *tb, int *nb); void F77_NAME(stxwx)(double *x, double *z, double *w, int *k, double *xknot, int *n, double *y, double *hs0, double *hs1, double *hs2, double *hs3); void F77_NAME(sslvrg)(double *penalt, double *dofoff, double *x, double *y, double *w, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *icrit, double *lambda, double *xwy, double *hs0, double *hs1, double *hs2, double *hs3, double *sg0, double *sg1, double *sg2, double *sg3, double *abd, double *p1ip, double *p2ip, int *ld4, int *ldnk, int *info); void F77_SUB(bvalus)(int *n, double *knot, double *coef, int *nk, double *x, double *s, int *order); void F77_SUB(supsmu)(int *n, double *x, double *y, double *w, int *iper, double *span, double *alpha, double *smo, double *sc, double *edf); #endif gam/src/qsbart.f0000644000176200001440000000230313650411627013253 0ustar liggesusersC An interface to sbart() --- fewer arguments BUT unspecified scrtch() dimension C subroutine qsbart(penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, & coef,sz,lev, & crit,iparms,spar,parms, & isetup, scrtch, ld4,ldnk,ier) c integer n,nk,isetup, iparms(3), ld4,ldnk,ier double precision penalt,dofoff, xs(n),ys(n),ws(n),ssw, & knot(nk+4), coef(nk),sz(n),lev(n), & crit, spar, parms(4), & scrtch(*) C ^^^^^^^^ dimension (9+2*ld4+nk)*nk = (17 + nk)*nk call sbart(penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, & coef,sz,lev, crit, & iparms(1),spar,iparms(2),iparms(3), c = icrit spar ispar iter & parms(1),parms(2),parms(3),parms(4), c = lspar uspar tol eps & isetup, scrtch(1), c = 0 xwy & scrtch( nk+1),scrtch(2*nk+1),scrtch(3*nk+1),scrtch(4*nk+1), c = hs0 hs1 hs2 hs3 & scrtch(5*nk+1),scrtch(6*nk+1),scrtch(7*nk+1),scrtch(8*nk+1), c = sg0 sg1 sg2 sg3 & scrtch(9*nk+1),scrtch(9*nk+ ld4*nk+1),scrtch(9*nk+2*ld4*nk), c = abd p1ip p2ip & ld4,ldnk,ier) return end gam/src/sinerp.f0000644000176200001440000000530410543334050013253 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,flag) c C Purpose : Computes Inner Products between columns of L^{-1} C where L = abd is a Banded Matrix with 3 subdiagonals C The algorithm works in two passes: C C Pass 1 computes (cj,ck) k=j,j-1,j-2,j-3 ; j=nk, .. 1 C Pass 2 computes (cj,ck) k <= j-4 (If flag == 1 ). C C A refinement of Elden's trick is used. c Args integer ld4,nk,ldnk,flag DOUBLE precision abd(ld4,nk),p1ip(ld4,nk), p2ip(ldnk,nk) c Locals integer i,j,k DOUBLE precision wjm3(3),wjm2(2),wjm1(1),c0,c1,c2,c3 c c unnecessary initialization of c1 c2 c3 to keep g77 -Wall happy c c1 = 0.0d0 c2 = 0.0d0 c3 = 0.0d0 C C Pass 1 wjm3(1)=0d0 wjm3(2)=0d0 wjm3(3)=0d0 wjm2(1)=0d0 wjm2(2)=0d0 wjm1(1)=0d0 do 100 i=1,nk j=nk-i+1 c0 = 1d0/abd(4,j) if(j.le.nk-3)then c1 = abd(1,j+3)*c0 c2 = abd(2,j+2)*c0 c3 = abd(3,j+1)*c0 else if(j.eq.nk-2)then c1 = 0d0 c2 = abd(2,j+2)*c0 c3 = abd(3,j+1)*c0 else if(j.eq.nk-1)then c1 = 0d0 c2 = 0d0 c3 = abd(3,j+1)*c0 else if(j.eq.nk)then c1 = 0d0 c2 = 0d0 c3 = 0d0 endif p1ip(1,j) = 0d0- (c1*wjm3(1)+c2*wjm3(2)+c3*wjm3(3)) p1ip(2,j) = 0d0- (c1*wjm3(2)+c2*wjm2(1)+c3*wjm2(2)) p1ip(3,j) = 0d0- (c1*wjm3(3)+c2*wjm2(2)+c3*wjm1(1)) p1ip(4,j) = c0**2 + c1**2*wjm3(1) + 2d0*c1*c2*wjm3(2)+ & 2d0*c1*c3*wjm3(3) + c2**2*wjm2(1) + 2d0*c2*c3*wjm2(2) + & c3**2*wjm1(1) wjm3(1)=wjm2(1) wjm3(2)=wjm2(2) wjm3(3)=p1ip(2,j) wjm2(1)=wjm1(1) wjm2(2)=p1ip(3,j) wjm1(1)=p1ip(4,j) 100 continue if(flag.ne.0)then C ____ Pass 2 _____ C Compute p2ip do 120 i=1,nk j=nk-i+1 C for(k=1;k<=4 & j+k-1<=nk;k=k+1) { p2ip(.) = .. }: do 160 k=1,4 if(j+k-1 .gt. nk)goto 120 p2ip(j,j+k-1) = p1ip(5-k,j) 160 continue 120 continue do 170 i=1,nk j=nk-i+1 c for(k=j-4;k>=1;k=k-1){ if(j-4 .ge. 1) then do 210 k= j-4,1, -1 c0 = 1d0/abd(4,k) c1 = abd(1,k+3)*c0 c2 = abd(2,k+2)*c0 c3 = abd(3,k+1)*c0 p2ip(k,j)= 0d0 - ( c1*p2ip(k+3,j) + c2*p2ip(k+2,j) + & c3*p2ip(k+1,j) ) 210 continue endif 170 continue endif return end gam/src/sslvrg.f0000644000176200001440000001010213650411627013273 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine sslvrg(penalt,dofoff,x,y,w,ssw, n, knot,nk,coef, * sz,lev, crit,icrit, lambda, xwy, hs0,hs1,hs2,hs3, * sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,info) C Purpose : C Compute smoothing spline for smoothing parameter lambda C and compute one of three `criteria' (OCV , GCV , "df match"). C See comments in ./sbart.f from which this is called integer n,nk,icrit,ld4,ldnk,info DOUBLE precision penalt,dofoff,x(n),y(n),w(n),ssw, & knot(nk+4), coef(nk),sz(n),lev(n), crit, lambda, * xwy(nk), hs0(nk),hs1(nk),hs2(nk),hs3(nk), * sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(ld4,nk), & p1ip(ld4,nk),p2ip(ldnk,nk) EXTERNAL bvalue double precision bvalue C local variables double precision vnikx(4,1),work(16) integer i,icoef,ileft,j,mflag, lenkno double precision b0,b1,b2,b3,eps, xv,rss,df, sumw c integer interv external interv lenkno = nk+4 ileft = 1 eps = 1d-11 C compute the coefficients coef() of estimated smooth do 1 i=1,nk coef(i) = xwy(i) abd(4,i) = hs0(i)+lambda*sg0(i) 1 continue do 4 i=1,(nk-1) abd(3,i+1) = hs1(i)+lambda*sg1(i) 4 continue do i=1,(nk-2) abd(2,i+2) = hs2(i)+lambda*sg2(i) end do do i=1,(nk-3) abd(1,i+3) = hs3(i)+lambda*sg3(i) end do c factorize banded matrix abd: call dpbfa(abd,ld4,nk,3,info) if(info.ne.0) then C matrix could not be factorized -> ier := info return endif c solve linear system (from factorize abd): call dpbsl(abd,ld4,nk,3,coef) C Value of smooth at the data points icoef = 1 do i=1,n xv = x(i) sz(i) = bvalue(knot,lenkno,coef, nk,4,xv,0) end do C Compute the criterion function if requested if(icrit .eq. 0)then return else C --- Ordinary or Generalized CV or "df match" --- C Get Leverages First call sinerp(abd,ld4,nk,p1ip,p2ip,ldnk,0) do i=1,n xv = x(i) ileft = interv(knot(1), nk+1, xv, 0,0, ileft, mflag) if(mflag .eq. -1) then ileft = 4 xv = knot(4)+eps else if(mflag .eq. 1) then ileft = nk xv = knot(nk+1) - eps endif j=ileft-3 C call bspvd(knot,4,1,xv,ileft,4,vnikx,work) call bsplvd(knot,lenkno,4,xv,ileft,work,vnikx,1) b0=vnikx(1,1) b1=vnikx(2,1) b2=vnikx(3,1) b3=vnikx(4,1) lev(i) = ( & p1ip(4,j)*b0**2 + 2.*p1ip(3,j)*b0*b1 + * 2.*p1ip(2,j)*b0*b2 + 2.*p1ip(1,j)*b0*b3 + * p1ip(4,j+1)*b1**2 + 2.*p1ip(3,j+1)*b1*b2 + * 2.*p1ip(2,j+1)*b1*b3 + p1ip(4,j+2)*b2**2 + & 2.*p1ip(3,j+2)*b2*b3 + p1ip(4,j+3)*b3**2 & )*w(i)**2 end do C Evaluate Criterion if(icrit .eq. 1)then C Generalized CV rss = ssw df = 0d0 sumw = 0d0 c w(i) are sqrt( wt[i] ) weights scaled in ../R/smspline.R such c that sumw = number of observations with w(i) > 0 do i=1,n rss = rss + ((y(i)-sz(i))*w(i))**2 df = df + lev(i) sumw = sumw + w(i)**2 end do crit = (rss/sumw)/((1d0-(dofoff + penalt*df)/sumw)**2) c call dblepr("spar", 4, spar, 1) c call dblepr("crit", 4, crit, 1) else if(icrit .eq. 2) then C Ordinary CV crit = 0d0 do i = 1,n crit = crit + (((y(i)-sz(i))*w(i))/(1-lev(i)))**2 end do crit = crit/n c call dblepr("spar", 4, spar, 1) c call dblepr("crit", 4, crit, 1) else C df matching crit = 0d0 do i=1,n crit = crit+lev(i) end do crit = 3d0 + (dofoff-crit)**2 endif return endif C Criterion evaluation end gam/src/backlo.f0000644000176200001440000001070014247020667013215 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine baklo(x,y,w,npetc,wddnfl,spatol,match, etal,s,eta,beta, *var,dof, qr,qraux,qpivot,effect,iv,v,iwork,work) implicit double precision(a-h,o-z) integer n,p,q,nit,maxit,qrank integer npetc(7),wddnfl(*),match(*),qpivot(*),iv(*),iwork(*) double precision x(*),y(*),w(*),spatol(*), etal(*),s(*),eta(*),bet *a(*),var(*),dof(*), qr(*),qraux(*),v(*),effect(*),work(*) n=npetc(1) p=npetc(2) q=npetc(3) maxit=npetc(5) qrank=npetc(6) call baklo0(x,n,p,y,w,q,wddnfl(1),wddnfl(q+1),wddnfl(2*q+1), spato *l(1),wddnfl(3*q+1),dof,match,wddnfl(4*q+1), etal,s,eta,beta,var,sp *atol(q+1), nit,maxit,qr,qraux,qrank,qpivot,effect, work(1),work(n+ *1),work(2*n+1),work(3*n+1), iv,wddnfl(5*q+1),wddnfl(6*q+1),v,wddnf *l(7*q+1), iwork(1),work(4*n+1)) npetc(4)=nit npetc(6)=qrank return end subroutine baklo0(x,n,p,y,w,q,which,dwhich,pwhich,span,degree,dof, *match,nef, etal,s,eta,beta,var,tol,nit,maxit, qr,qraux,qrank,qpivo *t,effect,z,old,sqwt,sqwti, iv,liv,lv,v,nvmax,iwork,work) implicit double precision(a-h,o-z) integer n,p,q,which(q),dwhich(q),pwhich(q),degree(q),match(n,q),ne *f(q),nit, maxit,qrank,qpivot(p),iv(*),liv(q),lv(q),nvmax(q),iwork( *q) double precision x(n,p),y(n),w(n),span(q),dof(q), etal(n),s(n,q),e *ta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),v(*),effect(n),work(* *) double precision z(*),old(*),dwrss,ratio double precision sqwt(n),sqwti(n) logical anyzwt double precision deltaf, normf,onedm7 integer job,info,slv,sliv,iw,j,dj,pj onedm7=1d-7 job=1101 info=1 if(q.eq.0)then maxit=1 endif ratio=1d0 anyzwt=.false. do23002 i=1,n if(w(i).gt.0d0)then sqwt(i)=dsqrt(w(i)) sqwti(i)=1d0/sqwt(i) else sqwt(i)=0d0 sqwti(i)=0d0 anyzwt=.true. endif 23002 continue continue if(qrank.eq.0)then do23008 i=1,n do23010 j=1,p qr(i,j)=x(i,j)*sqwt(i) 23010 continue continue 23008 continue continue do23012 j=1,p qpivot(j)=j 23012 continue continue call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7) endif do23014 i=1,n eta(i)=0d0 j=1 23016 if(.not.(j.le.q))goto 23018 eta(i)=eta(i)+s(i,j) j=j+1 goto 23016 23018 continue 23014 continue continue nit=0 23019 if((ratio .gt. tol ).and.(nit .lt. maxit))then deltaf=0d0 nit=nit+1 do23021 i=1,n z(i)=(y(i)-eta(i))*sqwt(i) old(i)=etal(i) 23021 continue continue call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),et *al,job,info) do23023 i=1,n etal(i)=etal(i)*sqwti(i) 23023 continue continue sliv=1 slv=1 iw=5*n+1 k=1 23025 if(.not.(k.le.q))goto 23027 j=which(k) dj=dwhich(k) pj=pwhich(k) do23028 i=1,n old(i)=s(i,k) z(i)=y(i)-etal(i)-eta(i)+old(i) 23028 continue continue C Trevor edited this 06/28/2020 call lo1(x(1,j),z,w,n,dj,pj,nvmax(k),span(k),degree(k),match(1,k), * nef(k),nit,dof(k),s(1,k),var(1,k),work(iw), work(iw+pj+1),work(iw *+nef(k)*dj+pj+1), work(iw+nef(k)*(dj+1)+pj+2),work(iw + nef(k)*(dj *+2)+pj+2), work(iw+nef(k)*(dj+3)+pj+2),work(iw+nef(k)*(pj+dj+4)+pj *+2), iwork(1),work(iw+nef(k)*(pj+dj+4)+4+2*pj), iv(sliv),liv(k),lv *(k),v(slv), work(1) ) sliv=sliv+liv(k) slv=slv+lv(k) iw=iw+nef(k)*(pj+dj+4)+5+3*pj do23030 i=1,n eta(i)=eta(i)+s(i,k)-old(i) 23030 continue continue deltaf=deltaf+dwrss(n,old,s(1,k),w) k=k+1 goto 23025 23027 continue normf=0d0 do23032 i=1,n normf=normf+w(i)*eta(i)*eta(i) 23032 continue continue if(normf.gt.0d0)then ratio=dsqrt(deltaf/normf) else ratio = 0d0 endif goto 23019 endif continue do23036 j=1,p work(j)=beta(j) 23036 continue continue do23038 j=1,p beta(qpivot(j))=work(j) 23038 continue continue if(anyzwt)then do23042 i=1,n if(w(i) .le. 0d0)then etal(i)=0d0 do23046 j=1,p etal(i)=etal(i)+beta(j)*x(i,j) 23046 continue continue endif 23042 continue continue endif do23048 i=1,n eta(i)=eta(i)+etal(i) 23048 continue continue return end gam/src/splsm.f0000644000176200001440000001261014332261034013110 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine sknotl(x,n,knot,k) implicit double precision(a-h,o-z) double precision x(n),knot(n+6),a1,a2,a3,a4 integer n,k,ndk,j a1 = log(50d0)/log(2d0) a2 = log(100d0)/log(2d0) a3 = log(140d0)/log(2d0) a4 = log(200d0)/log(2d0) if(n.lt.50)then ndk = n else if(n.ge.50 .and. n.lt.200)then ndk = INT(2.**(a1+(a2-a1)*(n-50.)/150.)) else if(n.ge.200 .and. n.lt.800)then ndk = INT(2.**(a2+(a3-a2)*(n-200.)/600.)) else if(n.ge.800 .and. n.lt.3200)then ndk = INT(2.**(a3+(a4-a3)*(n-800.)/2400.)) else if(n.ge.3200)then ndk = INT(200. + float(n-3200)**.2) endif endif endif endif endif k = ndk + 6 do23010 j=1,3 knot(j) = x(1) 23010 continue continue do23012 j=1,ndk knot(j+3) = x( 1 + (j-1)*(n-1)/(ndk-1) ) 23012 continue continue do23014 j=1,3 knot(ndk+3+j) = x(n) 23014 continue continue return end subroutine splsm(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,work) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,cov(*),work(*) integer n,match(*),nef integer ifcov call splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov, work(1), *work(nef+2),work(2*nef+3),work(3*nef+4), work(3*nef+n+10)) return end subroutine splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin *,yin,win,knot, work) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*),work(*) integer n,match(*),nef integer ifcov double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nef+6) integer nk,ldnk,ld4,k double precision xmin,xrange call suff(n,nef,match,x,y,w,xin,yin,win,work(1)) xmin=xin(1) xrange=xin(nef)-xin(1) do23016 i=1,nef xin(i)=(xin(i)-xmin)/xrange 23016 continue continue call sknotl(xin,nef,knot,k) nk=k-4 ld4=4 ldnk=1 call splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,w *in,knot, work(1), work(nk+1), work(nk+nef+2),work(nk+2*nef+3), wor *k(2*nk+2*nef+3),work(3*nk+2*nef+3),work(4*nk+2*nef+3), work(5*nk+2 **nef+3), work(6*nk+2*nef+3),work(7*nk+2*nef+3),work(8*nk+2*nef+3), * work(9*nk+2*nef+3), work(10*nk+2*nef+3),work((10+ld4)*nk+2*nef+3) *, work((10+2*ld4)*nk+2*nef+3), ld4,ldnk,nk) return end subroutine splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin *,yin,win,knot, coef,sout,levout,xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2, *sg3, abd,p1ip,p2ip,ld4,ldnk,nk) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*) integer n,match(*),nef integer nk,ldnk,ld4 integer ifcov double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nk+4) double precision coef(nk),sout(nef+1),levout(nef+1),xwy(nk), hs0(n *k),hs1(nk),hs2(nk),hs3(nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(l *d4,nk),p1ip(ld4,nk),p2ip(ldnk,*) integer ispar,icrit,isetup,ier double precision lspar,uspar,tol,penalt, sumwin,dofoff,crit,xbar,d *sum,xsbar double precision yssw, eps integer maxit double precision wmean C Initializing ifcov to avoid warnings ifcov = 0 C Touching x to avoid warnings x(1) = x(1) * 1.0 crit=0d0 if(dof .le. 0d0)then ispar=1 icrit=3 dofoff=0d0 else if( dof .lt. 1d0 )then dof=1d0 endif ispar=0 icrit=3 dofoff=dof+1d0 endif isetup=0 ier=1 penalt=1d0 lspar= -1.5 uspar= 2.0 tol=1d-4 eps=2d-8 maxit=200 do23022 i=1,nef sout(i)=yin(i)*yin(i) 23022 continue continue sumwin=0d0 do23024 i=1,nef sumwin=sumwin+win(i) 23024 continue continue yssw=wmean(nef,sout,win) s0=wmean(n,y,w) yssw=yssw*(sumwin-s0*s0) call sbart(penalt,dofoff,xin,yin,win,yssw,nef,knot,nk, coef,sout,l *evout,crit, icrit,spar,ispar,maxit, lspar,uspar,tol,eps, isetup, x *wy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,ier) do23026 i=1,nef win(i)=win(i)*win(i) 23026 continue continue sbar=wmean(nef,sout,win) xbar=wmean(nef,xin,win) do23028 i=1,nef lev(i)=(xin(i)-xbar)*sout(i) 23028 continue continue xsbar=wmean(nef,lev,win) do23030 i=1,nef lev(i)=(xin(i)-xbar)**2 23030 continue continue dsum=wmean(nef,lev,win) do23032 i=1,nef if(win(i).gt.0d0)then lev(i)=levout(i)/win(i)-1d0/sumwin -lev(i)/(sumwin*dsum) else lev(i)=0d0 endif 23032 continue continue dof=0d0 do23036 i=1,nef dof=dof+lev(i)*win(i) 23036 continue continue dof=dof+1d0 do23038 i=1,nef sout(i)=sout(i)-sbar -(xin(i)-xbar)*xsbar/dsum 23038 continue continue call unpck(n,nef,match,sout,smo) return end double precision function wmean(n,y,w) integer n double precision y(n),w(n),wtot,wsum wtot=0d0 wsum=0d0 do23040 i=1,n wsum=wsum+y(i)*w(i) wtot=wtot+w(i) 23040 continue continue if(wtot .gt. 0d0)then wmean=wsum/wtot else wmean=0d0 endif return end gam/src/sbart.c0000644000176200001440000002677510543334050013102 0ustar liggesusers/* sbart.f -- translated by f2c (version 20010821). * ------- and f2c-clean,v 1.9 2000/01/13 * * According to the GAMFIT sources, this was derived from code by * Finbarr O'Sullivan. */ #include #include #include #include "modreg.h" /* sbart() : The cubic spline smoother ------- Calls sgram (sg0,sg1,sg2,sg3,knot,nk) stxwx (xs,ys,ws,n,knot,nk,xwy,hs0,hs1,hs2,hs3) sslvrg (penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, coef,sz,lev,crit,icrit, lambda, xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,ier) is itself called from qsbart() [./qsbart.f] which has only one work array */ void F77_SUB(sbart) (double *penalt, double *dofoff, double *xs, double *ys, double *ws, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *icrit, double *spar, int *ispar, int *iter, double *lspar, double *uspar, double *tol, double *eps, int *isetup, double *xwy, double *hs0, double *hs1, double *hs2, double *hs3, double *sg0, double *sg1, double *sg2, double *sg3, double *abd, double *p1ip, double *p2ip, int *ld4, int *ldnk, int *ier) { /* A Cubic B-spline Smoothing routine. The algorithm minimises: (1/n) * sum ws(i)^2 * (ys(i)-sz(i))^2 + lambda* int ( s"(x) )^2 dx lambda is a function of the spar which is assumed to be between 0 and 1 INPUT ----- penalt A penalty > 1 to be used in the gcv criterion dofoff either `df.offset' for GCV or `df' (to be matched). n number of data points ys(n) vector of length n containing the observations ws(n) vector containing the weights given to each data point xs(n) vector containing the ordinates of the observations ssw `centered weighted sum of y^2' nk number of b-spline coefficients to be estimated nk <= n+2 knot(nk+4) vector of knot points defining the cubic b-spline basis. To obtain full cubic smoothing splines one might have (provided the xs-values are strictly increasing) spar penalised likelihood smoothing parameter ispar indicating if spar is supplied (ispar=1) or to be estimated lspar, uspar lower and upper values for spar search; 0.,1. are good values tol, eps used in Golden Search routine isetup setup indicator [initially 0 icrit indicator saying which cross validation score is to be computed 0: none ; 1: GCV ; 2: CV ; 3: 'df matching' ld4 the leading dimension of abd (ie ld4=4) ldnk the leading dimension of p2ip (not referenced) OUTPUT ------ coef(nk) vector of spline coefficients sz(n) vector of smoothed z-values lev(n) vector of leverages crit either ordinary or generalized CV score spar if ispar != 1 lspar == lambda (a function of spar and the design) iter number of iterations needed for spar search (if ispar != 1) ier error indicator ier = 0 ___ everything fine ier = 1 ___ spar too small or too big problem in cholesky decomposition Working arrays/matrix xwy X'Wy hs0,hs1,hs2,hs3 the diagonals of the X'WX matrix sg0,sg1,sg2,sg3 the diagonals of the Gram matrix SIGMA abd (ld4,nk) [ X'WX + lambda*SIGMA ] in diagonal form p1ip(ld4,nk) inner products between columns of L inverse p2ip(ldnk,nk) all inner products between columns of L inverse where L'L = [X'WX + lambda*SIGMA] NOT REFERENCED */ #define CRIT(FX) (*icrit == 3 ? FX - 3. : FX) /* cancellation in (3 + eps) - 3, but still...informative */ #define BIG_f (1e100) /* c_Gold is the squared inverse of the golden ratio */ static const double c_Gold = 0.381966011250105151795413165634; /* == (3. - sqrt(5.)) / 2. */ /* Local variables */ static double ratio;/* must be static (not needed in R) */ double a, b, d, e, p, q, r, u, v, w, x; double ax, fu, fv, fw, fx, bx, xm; double t1, t2, tol1, tol2; int i, maxit; Rboolean Fparabol = FALSE, tracing = (*ispar < 0); /* unnecessary initializations to keep -Wall happy */ d = 0.; fu = 0.; u = 0.; ratio = 1.; /* Compute SIGMA, X' W X, X' W z, trace ratio, s0, s1. SIGMA -> sg0,sg1,sg2,sg3 X' W X -> hs0,hs1,hs2,hs3 X' W Z -> xwy */ /* trevor fixed this 4/19/88 * Note: sbart, i.e. stxwx() and sslvrg() {mostly, not always!}, use * the square of the weights; the following rectifies that */ for (i = 0; i < *n; ++i) if (ws[i] > 0.) ws[i] = sqrt(ws[i]); if (*isetup == 0) { /* SIGMA[i,j] := Int B''(i,t) B''(j,t) dt {B(k,.) = k-th B-spline} */ F77_CALL(sgram)(sg0, sg1, sg2, sg3, knot, nk); F77_CALL(stxwx)(xs, ys, ws, n, knot, nk, xwy, hs0, hs1, hs2, hs3); /* Compute ratio := tr(X' W X) / tr(SIGMA) */ t1 = t2 = 0.; for (i = 3 - 1; i < (*nk - 3); ++i) { t1 += hs0[i]; t2 += sg0[i]; } ratio = t1 / t2; *isetup = 1; } /* Compute estimate */ if (*ispar == 1) { /* Value of spar supplied */ *lspar = ratio * R_pow(16., *spar * 6. - 2.); F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n, knot, nk, coef, sz, lev, crit, icrit, lspar, xwy, hs0, hs1, hs2, hs3, sg0, sg1, sg2, sg3, abd, p1ip, p2ip, ld4, ldnk, ier); /* got through check 2 */ return; } /* ELSE ---- spar not supplied --> compute it ! --------------------------- Use Forsythe Malcom and Moler routine to MINIMIZE criterion f denotes the value of the criterion an approximation x to the point where f attains a minimum on the interval (ax,bx) is determined. */ ax = *lspar; bx = *uspar; /* INPUT ax left endpoint of initial interval bx right endpoint of initial interval f function subprogram which evaluates f(x) for any x in the interval (ax,bx) tol desired length of the interval of uncertainty of the final result ( >= 0 ) OUTPUT fmin abcissa approximating the point where f attains a minimum */ /* The method used is a combination of golden section search and successive parabolic interpolation. convergence is never much slower than that for a fibonacci search. if f has a continuous second derivative which is positive at the minimum (which is not at ax or bx), then convergence is superlinear, and usually of the order of about 1.324.... the function f is never evaluated at two points closer together than eps*abs(fmin) + (tol/3), where eps is approximately the square root of the relative machine precision. if f is a unimodal function and the computed values of f are always unimodal when separated by at least eps*abs(x) + (tol/3), then fmin approximates the abcissa of the global minimum of f on the interval ax,bx with an error less than 3*eps*abs(fmin) + tol. if f is not unimodal, then fmin may approximate a local, but perhaps non-global, minimum to the same accuracy. this function subprogram is a slightly modified version of the algol 60 procedure localmin given in richard brent, algorithms for minimization without derivatives, prentice - hall, inc. (1973). Double a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,u,v,w Double fu,fv,fw,fx,x */ /* eps is approximately the square root of the relative machine precision. - eps = 1e0 - 10 eps = eps/2e0 - tol1 = 1e0 + eps - if (tol1 > 1e0) go to 10 - eps = sqrt(eps) R Version <= 1.3.x had eps = .000244 ( = sqrt(5.954 e-8) ) -- now eps is passed as argument */ /* initialization */ maxit = *iter; *iter = 0; a = ax; b = bx; v = a + c_Gold * (b - a); w = v; x = v; e = 0.; *spar = x; *lspar = ratio * R_pow(16., *spar * 6. - 2.); F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n, knot, nk, coef, sz, lev, crit, icrit, lspar, xwy, hs0, hs1, hs2, hs3, sg0, sg1, sg2, sg3, abd, p1ip, p2ip, ld4, ldnk, ier); fx = *crit; fv = fx; fw = fx; /* main loop --------- */ while(*ier == 0) { /* L20: */ xm = (a + b) * .5; tol1 = *eps * fabs(x) + *tol / 3.; tol2 = tol1 * 2.; ++(*iter); if(tracing) { if(*iter == 1) {/* write header */ Rprintf("sbart (ratio = %15.8g) iterations;" " initial tol1 = %12.6e :\n" "%11s %14s %9s %11s Kind %11s %12s\n%s\n", ratio, tol1, "spar", ((*icrit == 1) ? "GCV" : (*icrit == 2) ? "CV" : (*icrit == 3) ?"(df0-df)^2" : /*else (should not happen) */"?f?"), "b - a", "e", "NEW lspar", "crit", " ---------------------------------------" "----------------------------------------"); } Rprintf("%11.8f %14.9g %9.4e %11.5g", x, CRIT(fx), b - a, e); Fparabol = FALSE; } /* Check the (somewhat peculiar) stopping criterion: note that the RHS is negative as long as the interval [a,b] is not small:*/ if (fabs(x - xm) <= tol2 - (b - a) * .5 || *iter > maxit) goto L_End; /* is golden-section necessary */ if (fabs(e) <= tol1 || /* if had Inf then go to golden-section */ fx >= BIG_f || fv >= BIG_f || fw >= BIG_f) goto L_GoldenSect; /* Fit Parabola */ if(tracing) { Rprintf(" FP"); Fparabol = TRUE; } r = (x - w) * (fx - fv); q = (x - v) * (fx - fw); p = (x - v) * q - (x - w) * r; q = (q - r) * 2.; if (q > 0.) p = -p; q = fabs(q); r = e; e = d; /* is parabola acceptable? Otherwise do golden-section */ if (fabs(p) >= fabs(.5 * q * r) || q == 0.) /* above line added by BDR; * [the abs(.) >= abs() = 0 should have branched..] * in FTN: COMMON above ensures q is NOT a register variable */ goto L_GoldenSect; if (p <= q * (a - x) || p >= q * (b - x)) goto L_GoldenSect; /* Parabolic Interpolation step */ if(tracing) Rprintf(" PI "); d = p / q; if(!R_FINITE(d)) REprintf(" !FIN(d:=p/q): ier=%d, (v,w, p,q)= %g, %g, %g, %g\n", *ier, v,w, p, q); u = x + d; /* f must not be evaluated too close to ax or bx */ if (u - a < tol2 || b - u < tol2) d = fsign(tol1, xm - x); goto L50; /*------*/ L_GoldenSect: /* a golden-section step */ if(tracing) Rprintf(" GS%s ", Fparabol ? "" : " --"); if (x >= xm) e = a - x; else/* x < xm*/ e = b - x; d = c_Gold * e; L50: u = x + ((fabs(d) >= tol1) ? d : fsign(tol1, d)); /* tol1 check : f must not be evaluated too close to x */ *spar = u; *lspar = ratio * R_pow(16., *spar * 6. - 2.); F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n, knot, nk, coef, sz, lev, crit, icrit, lspar, xwy, hs0, hs1, hs2, hs3, sg0, sg1, sg2, sg3, abd, p1ip, p2ip, ld4, ldnk, ier); fu = *crit; if(tracing) Rprintf("%11g %12g\n", *lspar, CRIT(fu)); if(!R_FINITE(fu)) { REprintf("spar-finding: non-finite value %g; using BIG value\n", fu); fu = 2. * BIG_f; } /* update a, b, v, w, and x */ if (fu <= fx) { if (u >= x) a = x; else b = x; v = w; fv = fw; w = x; fw = fx; x = u; fx = fu; } else { if (u < x) a = u; else b = u; if (fu <= fw || w == x) { /* L70: */ v = w; fv = fw; w = u; fw = fu; } else if (fu <= fv || v == x || v == w) { /* L80: */ v = u; fv = fu; } } }/* end main loop -- goto L20; */ L_End: if(tracing) Rprintf(" >>> %12g %12g\n", *lspar, CRIT(fx)); *spar = x; *crit = fx; return; } /* sbart */ gam/src/backfit.f0000644000176200001440000001011714332261034013355 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine bakfit(x,npetc,y,w,which,spar,dof,match,nef, etal,s,eta *,beta,var,tol, qr,qraux,qpivot,effect,work) implicit double precision(a-h,o-z) integer ifvar integer npetc(7) integer n,p,q,which(*),match(*),nef(*),nit,maxit,qrank,qpivot(*) double precision x(*),y(*),w(*),spar(*),dof(*), etal(*),s(*),eta(* *),beta(*),var(*),tol, qr(*),qraux(*),effect(*),work(*) n=npetc(1) p=npetc(2) q=npetc(3) ifvar=0 if(npetc(4).eq.1)then ifvar=1 endif maxit=npetc(6) qrank=npetc(7) do23002 i=1,q work(i)=dof(i) 23002 continue continue call backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta,beta, *var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,work(q+1),wo *rk(q+n+1), work(q+2*n+1),work(q+3*n+1),work(q+4*n+1)) npetc(7)=qrank return end subroutine backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta *,beta,var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,z,old, *sqwt,sqwti,work) implicit double precision(a-h,o-z) integer ifvar integer n,p,q,which(q),match(n,q),nef(q),nit,maxit,qrank,qpivot(p) double precision x(n,p),y(n),w(n),spar(q),dof(q), etal(n),s(n,q),e *ta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),effect(n),work(*) double precision z(*),old(*),dwrss,ratio double precision sqwt(n),sqwti(n) logical anyzwt double precision deltaf, normf,onedm7 integer job,info onedm7=1d-7 job=1101 info=1 if(q.eq.0)then maxit=1 endif ratio=1d0 anyzwt=.false. do23006 i=1,n if(w(i).gt.0d0)then sqwt(i)=dsqrt(w(i)) sqwti(i)=1d0/sqwt(i) else sqwt(i)=0d0 sqwti(i)=0d0 anyzwt=.true. endif 23006 continue continue if(qrank.eq.0)then do23012 i=1,n do23014 j=1,p qr(i,j)=x(i,j)*sqwt(i) 23014 continue continue 23012 continue continue do23016 j=1,p qpivot(j)=j 23016 continue continue call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7) endif do23018 i=1,n eta(i)=0d0 j=1 23020 if(.not.(j.le.q))goto 23022 eta(i)=eta(i)+s(i,j) j=j+1 goto 23020 23022 continue 23018 continue continue nit=0 23023 if((ratio .gt. tol ).and.(nit .lt. maxit))then deltaf=0d0 nit=nit+1 do23025 i=1,n z(i)=(y(i)-eta(i))*sqwt(i) old(i)=etal(i) 23025 continue continue call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),et *al,job,info) do23027 i=1,n etal(i)=etal(i)*sqwti(i) 23027 continue continue k=1 23029 if(.not.(k.le.q))goto 23031 j=which(k) do23032 i=1,n old(i)=s(i,k) z(i)=y(i)-etal(i)-eta(i)+old(i) 23032 continue continue if(nit.gt.1)then dof(k)=0d0 endif call splsm(x(1,j),z,w,n,match(1,k),nef(k),spar(k), dof(k),s(1,k),s *0,var(1,k),ifvar,work) do23036 i=1,n eta(i)=eta(i)+s(i,k)-old(i) etal(i)=etal(i)+s0 23036 continue continue deltaf=deltaf+dwrss(n,old,s(1,k),w) k=k+1 goto 23029 23031 continue normf=0d0 do23038 i=1,n normf=normf+w(i)*eta(i)*eta(i) 23038 continue continue if(normf.gt.0d0)then ratio=dsqrt(deltaf/normf) else ratio = 0d0 endif goto 23023 endif continue do23042 j=1,p work(j)=beta(j) 23042 continue continue do23044 j=1,p beta(qpivot(j))=work(j) 23044 continue continue if(anyzwt)then do23048 i=1,n if(w(i) .le. 0d0)then etal(i)=0d0 do23052 j=1,p etal(i)=etal(i)+beta(j)*x(i,j) 23052 continue continue endif 23048 continue continue endif do23054 i=1,n eta(i)=eta(i)+etal(i) 23054 continue continue do23056 j=1,q call unpck(n,nef(j),match(1,j),var(1,j),old) do23058 i=1,n var(i,j)=old(i) 23058 continue continue 23056 continue continue return end gam/src/Makevars0000644000176200001440000000004312762422537013310 0ustar liggesusersPKG_LIBS = $(BLAS_LIBS) $(FLIBS) gam/src/bsplvd.f0000644000176200001440000002130314332261034013243 0ustar liggesusers subroutine bsplvd ( t, lent, k, x, left, a, dbiatx, nderiv ) c -------- ------ c implicit none C calculates value and deriv.s of all b-splines which do not vanish at x C calls bsplvb c c****** i n p u t ****** c t the knot array, of length left+k (at least) c k the order of the b-splines to be evaluated c x the point at which these values are sought c left an integer indicating the left endpoint of the interval of c interest. the k b-splines whose support contains the interval c (t(left), t(left+1)) c are to be considered. c a s s u m p t i o n - - - it is assumed that c t(left) < t(left+1) c division by zero will result otherwise (in b s p l v b ). c also, the output is as advertised only if c t(left) <= x <= t(left+1) . c nderiv an integer indicating that values of b-splines and their c derivatives up to but not including the nderiv-th are asked c for. ( nderiv is replaced internally by the integer in (1,k) c closest to it.) c c****** w o r k a r e a ****** c a an array of order (k,k), to contain b-coeff.s of the derivat- c ives of a certain order of the k b-splines of interest. c c****** o u t p u t ****** c dbiatx an array of order (k,nderiv). its entry (i,m) contains c value of (m-1)st derivative of (left-k+i)-th b-spline of c order k for knot sequence t , i=m,...,k; m=1,...,nderiv. c c****** m e t h o d ****** c values at x of all the relevant b-splines of order k,k-1,..., c k+1-nderiv are generated via bsplvb and stored temporarily c in dbiatx . then, the b-coeffs of the required derivatives of the c b-splines of interest are generated by differencing, each from the c preceding one of lower order, and combined with the values of b- c splines of corresponding order in dbiatx to produce the desired c values. C Args integer lent,k,left,nderiv double precision t(lent),x, dbiatx(k,nderiv), a(k,k) C Locals double precision factor,fkp1mm,sum integer i,ideriv,il,j,jlow,jp1mid, kp1,kp1mm,ldummy,m,mhigh mhigh = max0(min0(nderiv,k),1) c mhigh is usually equal to nderiv. kp1 = k+1 call bsplvb(t,lent,kp1-mhigh,1,x,left,dbiatx) if (mhigh .eq. 1) return c the first column of dbiatx always contains the b-spline values c for the current order. these are stored in column k+1-current c order before bsplvb is called to put values for the next c higher order on top of it. ideriv = mhigh do m=2,mhigh jp1mid = 1 do j=ideriv,k dbiatx(j,ideriv) = dbiatx(jp1mid,1) jp1mid = jp1mid + 1 end do ideriv = ideriv - 1 call bsplvb(t,lent,kp1-ideriv,2,x,left,dbiatx) end do c c at this point, b(left-k+i, k+1-j)(x) is in dbiatx(i,j) for c i=j,...,k and j=1,...,mhigh ('=' nderiv). in particular, the c first column of dbiatx is already in final form. to obtain cor- c responding derivatives of b-splines in subsequent columns, gene- c rate their b-repr. by differencing, then evaluate at x. c jlow = 1 do i=1,k do j=jlow,k a(j,i) = 0e0 end do jlow = i a(i,i) = 1e0 end do c at this point, a(.,j) contains the b-coeffs for the j-th of the c k b-splines of interest here. c do m=2,mhigh kp1mm = kp1 - m fkp1mm = dble(kp1mm) il = left i = k c c for j=1,...,k, construct b-coeffs of (m-1)st derivative of c b-splines from those for preceding derivative by differencing c and store again in a(.,j) . the fact that a(i,j) = 0 for c i < j is used.sed. do ldummy=1,kp1mm factor = fkp1mm/(t(il+kp1mm) - t(il)) c the assumption that t(left) < t(left+1) makes denominator c in factor nonzero. do j=1,i a(i,j) = (a(i,j) - a(i-1,j))*factor end do il = il - 1 i = i - 1 end do c c for i=1,...,k, combine b-coeffs a(.,i) with b-spline values c stored in dbiatx(.,m) to get value of (m-1)st derivative of c i-th b-spline (of interest here) at x , and store in c dbiatx(i,m). storage of this value over the value of a b-spline c of order m there is safe since the remaining b-spline derivat- c ive of the same order do not use this value due to the fact c that a(j,i) = 0 for j < i . do i=1,k sum = 0. jlow = max0(i,m) do j=jlow,k sum = a(j,i)*dbiatx(j,m) + sum end do dbiatx(i,m) = sum end do end do return end subroutine bsplvb ( t, lent,jhigh, index, x, left, biatx ) c implicit none c ------------- calculates the value of all possibly nonzero b-splines at x of order c c jout = dmax( jhigh , (j+1)*(index-1) ) c c with knot sequence t . c c****** i n p u t ****** c t.....knot sequence, of length left + jout , assumed to be nonde- c creasing. c a s s u m p t i o n : t(left) < t(left + 1) c d i v i s i o n b y z e r o will result if t(left) = t(left+1) c c jhigh, c index.....integers which determine the order jout = max(jhigh, c (j+1)*(index-1)) of the b-splines whose values at x are to c be returned. index is used to avoid recalculations when seve- c ral columns of the triangular array of b-spline values are nee- c ded (e.g., in bvalue or in bsplvd ). precisely, c if index = 1 , c the calculation starts from scratch and the entire triangular c array of b-spline values of orders 1,2,...,jhigh is generated c order by order , i.e., column by column . c if index = 2 , c only the b-spline values of order j+1, j+2, ..., jout are ge- c nerated, the assumption being that biatx , j , deltal , deltar c are, on entry, as they were on exit at the previous call. c in particular, if jhigh = 0, then jout = j+1, i.e., just c the next column of b-spline values is generated. c c w a r n i n g . . . the restriction jout <= jmax (= 20) is c imposed arbitrarily by the dimension statement for deltal and c deltar below, but is n o w h e r e c h e c k e d for . c c x.....the point at which the b-splines are to be evaluated. c left.....an integer chosen (usually) so that c t(left) <= x <= t(left+1) . c c****** o u t p u t ****** c biatx.....array of length jout , with biatx(i) containing the val- c ue at x of the polynomial of order jout which agrees with c the b-spline b(left-jout+i,jout,t) on the interval (t(left), c t(left+1)) . c c****** m e t h o d ****** c the recurrence relation c c x - t(i) t(i+j+1) - x c b(i,j+1)(x) = ----------- b(i,j)(x) + --------------- b(i+1,j)(x) c t(i+j)-t(i) t(i+j+1)-t(i+1) c c is used (repeatedly) to generate the c (j+1)-vector b(left-j,j+1)(x),...,b(left,j+1)(x) c from the j-vector b(left-j+1,j)(x),...,b(left,j)(x), c storing the new values in biatx over the old. the facts that c b(i,1) = 1 if t(i) <= x < t(i+1) c and that c b(i,j)(x) = 0 unless t(i) <= x < t(i+j) c are used. the particular organization of the calculations follows c algorithm (8) in chapter x of the text. c C Arguments integer lent, jhigh, index, left double precision t(lent),x, biatx(jhigh) c dimension t(left+jout), biatx(jout) c ----------------------------------- c current fortran standard makes it impossible to specify the length of c t and of biatx precisely without the introduction of otherwise c superfluous additional arguments. C Local Variables integer jmax parameter(jmax = 20) integer i,j,jp1 double precision deltal(jmax), deltar(jmax),saved,term save j,deltal,deltar data j/1/ c Naras replaced computed goto exactly as it worked c even though it can cause error! c go to (10,20), index if (index.eq.1) goto 10 if (index.eq.2) goto 20 call intpr1('Error in bsplvb index value', 27, index) 10 j = 1 biatx(1) = 1e0 if (j .ge. jhigh) return c 20 jp1 = j + 1 deltar(j) = t(left+j) - x deltal(j) = x - t(left+1-j) saved = 0e0 do i=1,j term = biatx(i)/(deltar(i) + deltal(jp1-i)) biatx(i) = saved + deltar(i)*term saved = deltal(jp1-i)*term end do biatx(jp1) = saved j = jp1 if (j .lt. jhigh) go to 20 c return end gam/src/Makevars.win0000644000176200001440000000004114247020667014100 0ustar liggesusersPKG_LIBS = $(BLAS_LIBS) $(FLIBS) gam/src/loessf.f0000644000176200001440000015712314332261034013256 0ustar liggesusersC C The authors of this software are Cleveland, Grosse, and Shyu. C Copyright (c) 1989, 1992 by AT&T. C Permission to use, copy, modify, and distribute this software for any C purpose without fee is hereby granted, provided that this entire notice C is included in all copies of any software which is or includes a copy C or modification of this software and in all copies of the supporting C documentation for such software. C THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED C WARRANTY. IN PARTICULAR, NEITHER THE AUTHORS NOR AT&T MAKE ANY C REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY C OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE. C altered by B.D. Ripley to C C remove unused variables C make phi in ehg139 double precision to match calling sequence C C Note that ehg182(errormsg_code) is in ./loessc.c subroutine ehg126(d,n,vc,x,v,nvmax) integer d,execnt,i,j,k,n,nvmax,vc DOUBLE PRECISION machin,alpha,beta,mu,t DOUBLE PRECISION v(nvmax,d),x(n,d) DOUBLE PRECISION D1MACH external D1MACH save machin,execnt data execnt /0/ c MachInf -> machin execnt=execnt+1 if(execnt.eq.1)then c initialize d1mach(2) === DBL_MAX: machin=D1MACH(2) end if c fill in vertices for bounding box of $x$ c lower left, upper right do 3 k=1,d alpha=machin beta=-machin do 4 i=1,n t=x(i,k) alpha=min(alpha,t) beta=max(beta,t) 4 continue c expand the box a little mu=0.005D0*max(beta-alpha,1.d-10*max(DABS(alpha),DABS(beta))+ + 1.d-30) alpha=alpha-mu beta=beta+mu v(1,k)=alpha v(vc,k)=beta 3 continue c remaining vertices do 5 i=2,vc-1 j=i-1 do 6 k=1,d v(i,k)=v(1+mod(j,2)*(vc-1),k) j=INT(DBLE(j)/2.D0) 6 continue 5 continue return end subroutine ehg125(p,nv,v,vhit,nvmax,d,k,t,r,s,f,l,u) logical i1,i2,match integer d,execnt,h,i,i3,j,k,m,mm,nv,nvmax,p,r,s integer f(r,0:1,s),l(r,0:1,s),u(r,0:1,s),vhit(nvmax) DOUBLE PRECISION t DOUBLE PRECISION v(nvmax,d) external ehg182 save execnt data execnt /0/ execnt=execnt+1 h=nv do 3 i=1,r do 4 j=1,s h=h+1 do 5 i3=1,d v(h,i3)=v(f(i,0,j),i3) 5 continue v(h,k)=t c check for redundant vertex match=.false. m=1 c top of while loop 6 if(.not.match)then i1=(m.le.nv) else i1=.false. end if if(.not.(i1))goto 7 match=(v(m,1).eq.v(h,1)) mm=2 c top of while loop 8 if(match)then i2=(mm.le.d) else i2=.false. end if if(.not.(i2))goto 9 match=(v(m,mm).eq.v(h,mm)) mm=mm+1 goto 8 c bottom of while loop 9 m=m+1 goto 6 c bottom of while loop 7 m=m-1 if(match)then h=h-1 else m=h if(vhit(1).ge.0)then vhit(m)=p end if end if l(i,0,j)=f(i,0,j) l(i,1,j)=m u(i,0,j)=m u(i,1,j)=f(i,1,j) 4 continue 3 continue nv=h if(.not.(nv.le.nvmax))then call ehg182(180) end if return end integer function ehg138(i,z,a,xi,lo,hi,ncmax) logical i1 integer execnt,i,j,ncmax integer a(ncmax),hi(ncmax),lo(ncmax) DOUBLE PRECISION xi(ncmax),z(8) save execnt data execnt /0/ execnt=execnt+1 c descend tree until leaf or ambiguous j=i c top of while loop 3 if(a(j).ne.0)then i1=(z(a(j)).ne.xi(j)) else i1=.false. end if if(.not.(i1))goto 4 if(z(a(j)).lt.xi(j))then j=lo(j) else j=hi(j) end if goto 3 c bottom of while loop 4 ehg138=j return end subroutine ehg106(il,ir,k,nk,p,pi,n) c Partial sorting of p(1, il:ir) returning the sort indices pi() only c such that p(1, pi(k)) is correct c implicit none c Arguments c Input: integer il,ir,k,nk,n DOUBLE PRECISION p(nk,n) c using only p(1, pi(*)) c Output: integer pi(n) c Variables DOUBLE PRECISION t integer i,ii,j,l,r c find the $k$-th smallest of $n$ elements c Floyd+Rivest, CACM Mar '75, Algorithm 489 l=il r=ir c while (l < r ) 3 if(.not.(l.lt.r))goto 4 c to avoid recursion, sophisticated partition deleted c partition $x sub {l..r}$ about $t$ t=p(1,pi(k)) i=l j=r ii=pi(l) pi(l)=pi(k) pi(k)=ii if(t.lt.p(1,pi(r)))then ii=pi(l) pi(l)=pi(r) pi(r)=ii end if c top of while loop 5 if(.not.(i.lt.j))goto 6 ii=pi(i) pi(i)=pi(j) pi(j)=ii i=i+1 j=j-1 c top of while loop 7 if(.not.(p(1,pi(i)).lt.t))goto 8 i=i+1 goto 7 c bottom of while loop 8 continue c top of while loop 9 if(.not.(t.lt.p(1,pi(j))))goto 10 j=j-1 goto 9 c bottom of while loop 10 goto 5 c bottom of while loop 6 if(p(1,pi(l)).eq.t)then ii=pi(l) pi(l)=pi(j) pi(j)=ii else j=j+1 ii=pi(r) pi(r)=pi(j) pi(j)=ii end if if(j.le.k)then l=j+1 end if if(k.le.j)then r=j-1 end if goto 3 c bottom of while loop 4 return end subroutine ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w, + rcond,sing,sigma,u,e,dgamma,qraux,work,tol,dd,tdeg,cdeg,s) integer column,d,dd,execnt,i,i3,i9,info,inorm2,j,jj,jpvt,k,kernel, + n,nf,od,sing,tdeg integer cdeg(8),psi(n) double precision machep,f,i1,i10,i2,i4,i5,i6,i7,i8,rcond,rho,scal, + tol double precision g(15),sigma(15),u(15,15),e(15,15),b(nf,k), + colnor(15),dist(n),eta(nf),dgamma(15),q(d),qraux(15),rw(n), + s(0:od),w(nf),work(15),x(n,d),y(n) integer idamax double precision d1mach, ddot external ehg106,ehg182,ehg184,dqrdc,dqrsl,dsvdc external idamax, d1mach, ddot save machep,execnt data execnt /0/ c colnorm -> colnor c E -> g c MachEps -> machep c V -> e c X -> b execnt=execnt+1 if(execnt.eq.1)then c initialize d1mach(4) === 1 / DBL_EPSILON === 2^52 : machep=d1mach(4) end if c sort by distance do 3 i3=1,n dist(i3)=0 3 continue do 4 j=1,dd i4=q(j) do 5 i3=1,n dist(i3)=dist(i3)+(x(i3,j)-i4)**2 5 continue 4 continue call ehg106(1,n,nf,1,dist,psi,n) rho=dist(psi(nf))*max(1.d0,f) if(rho .le. 0)then call ehg182(120) end if c compute neighborhood weights if(kernel.eq.2)then do 6 i=1,nf if(dist(psi(i)).lt.rho)then i1=dsqrt(rw(psi(i))) else i1=0 end if w(i)=i1 6 continue else do 7 i3=1,nf w(i3)=dsqrt(dist(psi(i3))/rho) 7 continue do 8 i3=1,nf w(i3)=dsqrt(rw(psi(i3))*(1-w(i3)**3)**3) 8 continue end if if(dabs(w(idamax(nf,w,1))).eq.0)then call ehg184('at ',q(1),dd,1) call ehg184('radius ',rho,1,1) if(.not..false.)then call ehg182(121) end if end if c fill design matrix column=1 do 9 i3=1,nf b(i3,column)=w(i3) 9 continue if(tdeg.ge.1)then do 10 j=1,d if(cdeg(j).ge.1)then column=column+1 i5=q(j) do 11 i3=1,nf b(i3,column)=w(i3)*(x(psi(i3),j)-i5) 11 continue end if 10 continue end if if(tdeg.ge.2)then do 12 j=1,d if(cdeg(j).ge.1)then if(cdeg(j).ge.2)then column=column+1 i6=q(j) do 13 i3=1,nf b(i3,column)=w(i3)*(x(psi(i3),j)-i6)**2 13 continue end if do 14 jj=j+1,d if(cdeg(jj).ge.1)then column=column+1 i7=q(j) i8=q(jj) do 15 i3=1,nf b(i3,column)=w(i3)*(x(psi(i3),j)-i7)*(x(psi(i3), +jj)-i8) 15 continue end if 14 continue end if 12 continue k=column end if do 16 i3=1,nf eta(i3)=w(i3)*y(psi(i3)) 16 continue c equilibrate columns do 17 j=1,k scal=0 do 18 inorm2=1,nf scal=scal+b(inorm2,j)**2 18 continue scal=dsqrt(scal) if(0.lt.scal)then do 19 i3=1,nf b(i3,j)=b(i3,j)/scal 19 continue colnor(j)=scal else colnor(j)=1 end if 17 continue c singular value decomposition call dqrdc(b,nf,nf,k,qraux,jpvt,work,0) call dqrsl(b,nf,nf,k,qraux,eta,work,eta,eta,work,work,1000,info) do 20 i9=1,k do 21 i3=1,k u(i3,i9)=0 21 continue 20 continue do 22 i=1,k do 23 j=i,k u(i,j)=b(i,j) 23 continue 22 continue call dsvdc(u,15,k,k,sigma,g,u,15,e,15,work,21,info) if(.not.(info.eq.0))then call ehg182(182) end if tol=sigma(1)*(100*machep) rcond=min(rcond,sigma(k)/sigma(1)) if(sigma(k).le.tol)then sing=sing+1 if(sing.eq.1)then call ehg184('pseudoinverse used at',q(1),d,1) call ehg184('neighborhood radius',dsqrt(rho),1,1) call ehg184('reciprocal condition number ',rcond,1,1) else if(sing.eq.2)then call ehg184('There are other near singularities as well.' +,rho,1,1) end if end if end if c compensate for equilibration do 24 j=1,k i10=colnor(j) do 25 i3=1,k e(j,i3)=e(j,i3)/i10 25 continue 24 continue c solve least squares problem do 26 j=1,k if(tol.lt.sigma(j))then i2=ddot(k,u(1,j),1,eta,1)/sigma(j) else i2=0.d0 end if dgamma(j)=i2 26 continue do 27 j=0,od s(j)=ddot(k,e(j+1,1),15,dgamma,1) 27 continue return end subroutine ehg131(x,y,rw,trl,diagl,kernel,k,n,d,nc,ncmax,vc,nv, + nvmax,nf,f,a,c,hi,lo,pi,psi,v,vhit,vval,xi,dist,eta,b,ntol, + fd,w,vval2,rcond,sing,dd,tdeg,cdeg,lq,lf,setlf) logical setlf integer identi,d,dd,execnt,i1,i2,j,k,kernel,n,nc,ncmax,nf,ntol,nv, + nvmax,sing,tdeg,vc integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),cdeg(8),hi(ncmax), + lo(ncmax),pi(n),psi(n),vhit(nvmax) double precision f,fd,rcond,trl double precision lf(0:d,nvmax,nf),b(*),delta(8),diagl(n),dist(n), + eta(nf),rw(n),v(nvmax,d),vval(0:d,nvmax),vval2(0:d,nvmax), + w(nf),x(n,d),xi(ncmax),y(n) external ehg126,ehg182,ehg139,ehg124 double precision dnrm2 external dnrm2 save execnt data execnt /0/ c Identity -> identi c X -> b execnt=execnt+1 if(.not.(d.le.8))then call ehg182(101) end if c build $k$-d tree call ehg126(d,n,vc,x,v,nvmax) nv=vc nc=1 do 3 j=1,vc c(j,nc)=j vhit(j)=0 3 continue do 4 i1=1,d delta(i1)=v(vc,i1)-v(1,i1) 4 continue fd=fd*dnrm2(d,delta,1) do 5 identi=1,n pi(identi)=identi 5 continue call ehg124(1,n,d,n,nv,nc,ncmax,vc,x,pi,a,xi,lo,hi,c,v,vhit,nvmax, +ntol,fd,dd) c smooth if(trl.ne.0)then do 6 i2=1,nv do 7 i1=0,d vval2(i1,i2)=0 7 continue 6 continue end if call ehg139(v,nvmax,nv,n,d,nf,f,x,pi,psi,y,rw,trl,kernel,k,dist, + dist,eta,b,d,w,diagl,vval2,nc,vc,a,xi,lo,hi,c,vhit,rcond, + sing,dd,tdeg,cdeg,lq,lf,setlf,vval) return end subroutine ehg133(n,d,vc,nvmax,nc,ncmax,a,c,hi,lo,v,vval,xi,m,z,s) integer n,d,vc,nvmax,nc,ncmax, m integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax) double precision v(nvmax,d),vval(0:d,nvmax),xi(ncmax),z(m,d),s(m) c Var double precision delta(8) integer i,i1 double precision ehg128 external ehg128 C Using n, nc to avoid warnings n = n + 0 nc = nc + 0 do 3 i=1,m do 4 i1=1,d delta(i1)=z(i,i1) 4 continue s(i)=ehg128(delta,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax,vval) 3 continue return end subroutine ehg140(iw,i,j) integer execnt,i,j integer iw(i) save execnt data execnt /0/ execnt=execnt+1 iw(i)=j return end subroutine ehg141(trl,n,deg,k,d,nsing,dk,delta1,delta2) double precision trl,delta1,delta2 integer n,deg,k,d,nsing,dk double precision c(48), c1, c2, c3, c4, corx,z integer i external ehg176 double precision ehg176 double precision ourz(1) c coef, d, deg, del data c / .2971620d0,.3802660d0,.5886043d0,.4263766d0,.3346498d0, +.6271053d0,.5241198d0,.3484836d0,.6687687d0,.6338795d0,.4076457d0, +.7207693d0,.1611761d0,.3091323d0,.4401023d0,.2939609d0,.3580278d0, +.5555741d0,.3972390d0,.4171278d0,.6293196d0,.4675173d0,.4699070d0, +.6674802d0,.2848308d0,.2254512d0,.2914126d0,.5393624d0,.2517230d0, +.3898970d0,.7603231d0,.2969113d0,.4740130d0,.9664956d0,.3629838d0, +.5348889d0,.2075670d0,.2822574d0,.2369957d0,.3911566d0,.2981154d0, +.3623232d0,.5508869d0,.3501989d0,.4371032d0,.7002667d0,.4291632d0, +.4930370d0 / if(deg.eq.0) dk=1 if(deg.eq.1) dk=d+1 if(deg.eq.2) dk=INT(dble((d+2)*(d+1))/2.d0) corx=dsqrt(k/dble(n)) z=(dsqrt(k/trl)-corx)/(1-corx) if(nsing .eq. 0 .and. 1 .lt. z) call ehg184('Chernobyl! trLn',trl,1,1) z=min(1.0d0,max(0.0d0,z)) ourz(1) = z c4=dexp(ehg176(ourz)) i=1+3*(min(d,4)-1+4*(deg-1)) if(d.le.4)then c1=c(i) c2=c(i+1) c3=c(i+2) else c1=c(i)+(d-4)*(c(i)-c(i-3)) c2=c(i+1)+(d-4)*(c(i+1)-c(i-2)) c3=c(i+2)+(d-4)*(c(i+2)-c(i-1)) endif delta1=n-trl*dexp(c1*z**c2*(1-z)**c3*c4) i=i+24 if(d.le.4)then c1=c(i) c2=c(i+1) c3=c(i+2) else c1=c(i)+(d-4)*(c(i)-c(i-3)) c2=c(i+1)+(d-4)*(c(i+1)-c(i-2)) c3=c(i+2)+(d-4)*(c(i+2)-c(i-1)) endif delta2=n-trl*dexp(c1*z**c2*(1-z)**c3*c4) return end subroutine lowesc(n,l,ll,trl,delta1,delta2) integer execnt,i,j,n double precision delta1,delta2,trl double precision l(n,n),ll(n,n) double precision ddot external ddot save execnt data execnt /0/ execnt=execnt+1 c compute $LL~=~(I-L)(I-L)'$ do 3 i=1,n l(i,i)=l(i,i)-1 3 continue do 4 i=1,n do 5 j=1,i ll(i,j)=ddot(n,l(i,1),n,l(j,1),n) 5 continue 4 continue do 6 i=1,n do 7 j=i+1,n ll(i,j)=ll(j,i) 7 continue 6 continue do 8 i=1,n l(i,i)=l(i,i)+1 8 continue c accumulate first two traces trl=0 delta1=0 do 9 i=1,n trl=trl+l(i,i) delta1=delta1+ll(i,i) 9 continue c $delta sub 2 = "tr" LL sup 2$ delta2=0 do 10 i=1,n delta2=delta2+ddot(n,ll(i,1),n,ll(1,i),1) 10 continue return end subroutine ehg169(d,vc,nc,ncmax,nv,nvmax,v,a,xi,c,hi,lo) integer d,vc,nc,ncmax,nv,nvmax integer a(ncmax), c(vc,ncmax), hi(ncmax), lo(ncmax) DOUBLE PRECISION v(nvmax,d),xi(ncmax) integer novhit(1),i,j,k,mc,mv,p external ehg125,ehg182 integer ifloor external ifloor c as in bbox c remaining vertices do 3 i=2,vc-1 j=i-1 do 4 k=1,d v(i,k)=v(1+mod(j,2)*(vc-1),k) j=ifloor(DBLE(j)/2.D0) 4 continue 3 continue c as in ehg131 mc=1 mv=vc novhit(1)=-1 do 5 j=1,vc c(j,mc)=j 5 continue c as in rbuild p=1 c top of while loop 6 if(.not.(p.le.nc))goto 7 if(a(p).ne.0)then k=a(p) c left son mc=mc+1 lo(p)=mc c right son mc=mc+1 hi(p)=mc call ehg125(p,mv,v,novhit,nvmax,d,k,xi(p),2**(k-1),2**(d-k), + c(1,p),c(1,lo(p)),c(1,hi(p))) end if p=p+1 goto 6 c bottom of while loop 7 if(.not.(mc.eq.nc))then call ehg182(193) end if if(.not.(mv.eq.nv))then call ehg182(193) end if return end DOUBLE PRECISION function ehg176(z) c DOUBLE PRECISION z(*) c integer d,vc,nv,nc integer a(17), c(2,17) integer hi(17), lo(17) DOUBLE PRECISION v(10,1) DOUBLE PRECISION vval(0:1,10) DOUBLE PRECISION xi(17) double precision ehg128 external ehg128 data d,vc,nv,nc /1,2,10,17/ data a(1) /1/ data hi(1),lo(1),xi(1) /3,2,0.3705D0/ data c(1,1) /1/ data c(2,1) /2/ data a(2) /1/ data hi(2),lo(2),xi(2) /5,4,0.2017D0/ data c(1,2) /1/ data c(2,2) /3/ data a(3) /1/ data hi(3),lo(3),xi(3) /7,6,0.5591D0/ data c(1,3) /3/ data c(2,3) /2/ data a(4) /1/ data hi(4),lo(4),xi(4) /9,8,0.1204D0/ data c(1,4) /1/ data c(2,4) /4/ data a(5) /1/ data hi(5),lo(5),xi(5) /11,10,0.2815D0/ data c(1,5) /4/ data c(2,5) /3/ data a(6) /1/ data hi(6),lo(6),xi(6) /13,12,0.4536D0/ data c(1,6) /3/ data c(2,6) /5/ data a(7) /1/ data hi(7),lo(7),xi(7) /15,14,0.7132D0/ data c(1,7) /5/ data c(2,7) /2/ data a(8) /0/ data c(1,8) /1/ data c(2,8) /6/ data a(9) /0/ data c(1,9) /6/ data c(2,9) /4/ data a(10) /0/ data c(1,10) /4/ data c(2,10) /7/ data a(11) /0/ data c(1,11) /7/ data c(2,11) /3/ data a(12) /0/ data c(1,12) /3/ data c(2,12) /8/ data a(13) /0/ data c(1,13) /8/ data c(2,13) /5/ data a(14) /0/ data c(1,14) /5/ data c(2,14) /9/ data a(15) /1/ data hi(15),lo(15),xi(15) /17,16,0.8751D0/ data c(1,15) /9/ data c(2,15) /2/ data a(16) /0/ data c(1,16) /9/ data c(2,16) /10/ data a(17) /0/ data c(1,17) /10/ data c(2,17) /2/ data vval(0,1) /-9.0572D-2/ data v(1,1) /-5.D-3/ data vval(1,1) /4.4844D0/ data vval(0,2) /-1.0856D-2/ data v(2,1) /1.005D0/ data vval(1,2) /-0.7736D0/ data vval(0,3) /-5.3718D-2/ data v(3,1) /0.3705D0/ data vval(1,3) /-0.3495D0/ data vval(0,4) /2.6152D-2/ data v(4,1) /0.2017D0/ data vval(1,4) /-0.7286D0/ data vval(0,5) /-5.8387D-2/ data v(5,1) /0.5591D0/ data vval(1,5) /0.1611D0/ data vval(0,6) /9.5807D-2/ data v(6,1) /0.1204D0/ data vval(1,6) /-0.7978D0/ data vval(0,7) /-3.1926D-2/ data v(7,1) /0.2815D0/ data vval(1,7) /-0.4457D0/ data vval(0,8) /-6.4170D-2/ data v(8,1) /0.4536D0/ data vval(1,8) /3.2813D-2/ data vval(0,9) /-2.0636D-2/ data v(9,1) /0.7132D0/ data vval(1,9) /0.3350D0/ data vval(0,10) /4.0172D-2/ data v(10,1) /0.8751D0/ data vval(1,10) /-4.1032D-2/ ehg176=ehg128(z,d,nc,vc,a,xi,lo,hi,c,v,nv,vval) end subroutine lowesa(trl,n,d,tau,nsing,delta1,delta2) integer n,d,tau,nsing double precision trl, delta1,delta2 integer dka,dkb double precision alpha,d1a,d1b,d2a,d2b external ehg141 call ehg141(trl,n,1,tau,d,nsing,dka,d1a,d2a) call ehg141(trl,n,2,tau,d,nsing,dkb,d1b,d2b) alpha=dble(tau-dka)/dble(dkb-dka) delta1=(1-alpha)*d1a+alpha*d1b delta2=(1-alpha)*d2a+alpha*d2b return end subroutine ehg191(m,z,l,d,n,nf,nv,ncmax,vc,a,xi,lo,hi,c,v,nvmax, + vval2,lf,lq) c Args integer m,d,n,nf,nv,ncmax,nvmax,vc double precision z(m,d), l(m,n), xi(ncmax), v(nvmax,d), + vval2(0:d,nvmax), lf(0:d,nvmax,nf) integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),lo(ncmax),hi(ncmax) c Var integer lq1,execnt,i,i1,i2,j,p double precision zi(8) double precision ehg128 external ehg128 save execnt data execnt /0/ execnt=execnt+1 do 3 j=1,n do 4 i2=1,nv do 5 i1=0,d vval2(i1,i2)=0 5 continue 4 continue do 6 i=1,nv c linear search for i in Lq lq1=lq(i,1) lq(i,1)=j p=nf c top of while loop 7 if(.not.(lq(i,p).ne.j))goto 8 p=p-1 goto 7 c bottom of while loop 8 lq(i,1)=lq1 if(lq(i,p).eq.j)then do 9 i1=0,d vval2(i1,i)=lf(i1,i,p) 9 continue end if 6 continue do 10 i=1,m do 11 i1=1,d zi(i1)=z(i,i1) 11 continue l(i,j)=ehg128(zi,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax,vval2) 10 continue 3 continue return end subroutine ehg196(tau,d,f,trl) integer d,dka,dkb,execnt,tau double precision alpha,f,trl,trla,trlb external ehg197 save execnt data execnt /0/ execnt=execnt+1 call ehg197(1,tau,d,f,dka,trla) call ehg197(2,tau,d,f,dkb,trlb) alpha=dble(tau-dka)/dble(dkb-dka) trl=(1-alpha)*trla+alpha*trlb return end subroutine ehg197(deg,tau,d,f,dk,trl) integer deg,tau,d,dk double precision f, trl double precision g1 dk = 0 C Initializing tau to avoid warnings tau = tau + 0 if(deg.eq.1) dk=d+1 if(deg.eq.2) dk=INT(dble((d+2)*(d+1))/2.d0) g1 = (-0.08125d0*d+0.13d0)*d+1.05d0 trl = dk*(1+max(0.d0,(g1-f)/f)) return end subroutine ehg192(y,d,n,nf,nv,nvmax,vval,lf,lq) integer d,i,i1,i2,j,n,nf,nv,nvmax integer lq(nvmax,nf) DOUBLE PRECISION i3 DOUBLE PRECISION lf(0:d,nvmax,nf),vval(0:d,nvmax),y(n) do 3 i2=1,nv do 4 i1=0,d vval(i1,i2)=0 4 continue 3 continue do 5 i=1,nv do 6 j=1,nf i3=y(lq(i,j)) do 7 i1=0,d vval(i1,i)=vval(i1,i)+i3*lf(i1,i,j) 7 continue 6 continue 5 continue return end DOUBLE PRECISION function ehg128(z,d,ncmax,vc,a,xi,lo,hi,c,v, + nvmax,vval) c implicit none c Args integer d,ncmax,nvmax,vc integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax) DOUBLE PRECISION z(d),xi(ncmax),v(nvmax,d), vval(0:d,nvmax) c Vars logical i2,i3,i4,i5,i6,i7,i8,i9,i10 integer execnt,i,i1,i11,i12,ig,ii,j,lg,ll,m,nt,ur integer t(20) DOUBLE PRECISION ge,gn,gs,gw,gpe,gpn,gps,gpw,h,phi0,phi1, + psi0,psi1,s,sew,sns,v0,v1,xibar DOUBLE PRECISION g(0:8,256),g0(0:8),g1(0:8) external ehg182,ehg184 save execnt data execnt /0/ execnt=execnt+1 c locate enclosing cell nt=1 t(nt)=1 j=1 c top of while loop 3 if(.not.(a(j).ne.0))goto 4 nt=nt+1 if(z(a(j)).lt.xi(j))then i1=lo(j) else i1=hi(j) end if t(nt)=i1 if(.not.(nt.lt.20))then call ehg182(181) end if j=t(nt) goto 3 c bottom of while loop 4 continue c tensor do 5 i12=1,vc do 6 i11=0,d g(i11,i12)=vval(i11,c(i12,j)) 6 continue 5 continue lg=vc ll=c(1,j) ur=c(vc,j) do 7 i=d,1,-1 h=(z(i)-v(ll,i))/(v(ur,i)-v(ll,i)) if(h.lt.-.001D0)then call ehg184('eval ',z(1),d,1) call ehg184('lowerlimit ',v(ll,1),d,nvmax) else if(1.001D0.lt.h)then call ehg184('eval ',z(1),d,1) call ehg184('upperlimit ',v(ur,1),d,nvmax) end if end if if(-.001D0.le.h)then i2=(h.le.1.001D0) else i2=.false. end if if(.not.i2)then call ehg182(122) end if lg=INT(DBLE(lg)/2.D0) do 8 ig=1,lg c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) g(0,ig)=phi0*g(0,ig) + phi1*g(0,ig+lg) + + (psi0*g(i,ig)+psi1*g(i,ig+lg)) * (v(ur,i)-v(ll,i)) do 9 ii=1,i-1 g(ii,ig)=phi0*g(ii,ig)+phi1*g(ii,ig+lg) 9 continue 8 continue 7 continue s=g(0,1) c blending if(d.eq.2)then c ----- North ----- v0=v(ll,1) v1=v(ur,1) do 10 i11=0,d g0(i11)=vval(i11,c(3,j)) 10 continue do 11 i11=0,d g1(i11)=vval(i11,c(4,j)) 11 continue xibar=v(ur,2) m=nt-1 c top of while loop 12 if(m.eq.0)then i4=.true. else if(a(t(m)).eq.2)then i3=(xi(t(m)).eq.xibar) else i3=.false. end if i4=i3 end if if(.not.(.not.i4))goto 13 m=m-1 c voidp junk goto 12 c bottom of while loop 13 if(m.ge.1)then m=hi(t(m)) c top of while loop 14 if(.not.(a(m).ne.0))goto 15 if(z(a(m)).lt.xi(m))then m=lo(m) else m=hi(m) end if goto 14 c bottom of while loop 15 if(v0.lt.v(c(1,m),1))then v0=v(c(1,m),1) do 16 i11=0,d g0(i11)=vval(i11,c(1,m)) 16 continue end if if(v(c(2,m),1).lt.v1)then v1=v(c(2,m),1) do 17 i11=0,d g1(i11)=vval(i11,c(2,m)) 17 continue end if end if h=(z(1)-v0)/(v1-v0) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) gn=phi0*g0(0)+phi1*g1(0)+(psi0*g0(1)+psi1*g1(1))*(v1-v0) gpn=phi0*g0(2)+phi1*g1(2) c ----- South ----- v0=v(ll,1) v1=v(ur,1) do 18 i11=0,d g0(i11)=vval(i11,c(1,j)) 18 continue do 19 i11=0,d g1(i11)=vval(i11,c(2,j)) 19 continue xibar=v(ll,2) m=nt-1 c top of while loop 20 if(m.eq.0)then i6=.true. else if(a(t(m)).eq.2)then i5=(xi(t(m)).eq.xibar) else i5=.false. end if i6=i5 end if if(.not.(.not.i6))goto 21 m=m-1 c voidp junk goto 20 c bottom of while loop 21 if(m.ge.1)then m=lo(t(m)) c top of while loop 22 if(.not.(a(m).ne.0))goto 23 if(z(a(m)).lt.xi(m))then m=lo(m) else m=hi(m) end if goto 22 c bottom of while loop 23 if(v0.lt.v(c(3,m),1))then v0=v(c(3,m),1) do 24 i11=0,d g0(i11)=vval(i11,c(3,m)) 24 continue end if if(v(c(4,m),1).lt.v1)then v1=v(c(4,m),1) do 25 i11=0,d g1(i11)=vval(i11,c(4,m)) 25 continue end if end if h=(z(1)-v0)/(v1-v0) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) gs=phi0*g0(0)+phi1*g1(0)+(psi0*g0(1)+psi1*g1(1))*(v1-v0) gps=phi0*g0(2)+phi1*g1(2) c ----- East ----- v0=v(ll,2) v1=v(ur,2) do 26 i11=0,d g0(i11)=vval(i11,c(2,j)) 26 continue do 27 i11=0,d g1(i11)=vval(i11,c(4,j)) 27 continue xibar=v(ur,1) m=nt-1 c top of while loop 28 if(m.eq.0)then i8=.true. else if(a(t(m)).eq.1)then i7=(xi(t(m)).eq.xibar) else i7=.false. end if i8=i7 end if if(.not.(.not.i8))goto 29 m=m-1 c voidp junk goto 28 c bottom of while loop 29 if(m.ge.1)then m=hi(t(m)) c top of while loop 30 if(.not.(a(m).ne.0))goto 31 if(z(a(m)).lt.xi(m))then m=lo(m) else m=hi(m) end if goto 30 c bottom of while loop 31 if(v0.lt.v(c(1,m),2))then v0=v(c(1,m),2) do 32 i11=0,d g0(i11)=vval(i11,c(1,m)) 32 continue end if if(v(c(3,m),2).lt.v1)then v1=v(c(3,m),2) do 33 i11=0,d g1(i11)=vval(i11,c(3,m)) 33 continue end if end if h=(z(2)-v0)/(v1-v0) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) ge=phi0*g0(0)+phi1*g1(0)+(psi0*g0(2)+psi1*g1(2))*(v1-v0) gpe=phi0*g0(1)+phi1*g1(1) c ----- West ----- v0=v(ll,2) v1=v(ur,2) do 34 i11=0,d g0(i11)=vval(i11,c(1,j)) 34 continue do 35 i11=0,d g1(i11)=vval(i11,c(3,j)) 35 continue xibar=v(ll,1) m=nt-1 c top of while loop 36 if(m.eq.0)then i10=.true. else if(a(t(m)).eq.1)then i9=(xi(t(m)).eq.xibar) else i9=.false. end if i10=i9 end if if(.not.(.not.i10))goto 37 m=m-1 c voidp junk goto 36 c bottom of while loop 37 if(m.ge.1)then m=lo(t(m)) c top of while loop 38 if(.not.(a(m).ne.0))goto 39 if(z(a(m)).lt.xi(m))then m=lo(m) else m=hi(m) end if goto 38 c bottom of while loop 39 if(v0.lt.v(c(2,m),2))then v0=v(c(2,m),2) do 40 i11=0,d g0(i11)=vval(i11,c(2,m)) 40 continue end if if(v(c(4,m),2).lt.v1)then v1=v(c(4,m),2) do 41 i11=0,d g1(i11)=vval(i11,c(4,m)) 41 continue end if end if h=(z(2)-v0)/(v1-v0) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) gw=phi0*g0(0)+phi1*g1(0)+(psi0*g0(2)+psi1*g1(2))*(v1-v0) gpw=phi0*g0(1)+phi1*g1(1) c NS h=(z(2)-v(ll,2))/(v(ur,2)-v(ll,2)) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) sns=phi0*gs+phi1*gn+(psi0*gps+psi1*gpn)*(v(ur,2)-v(ll,2)) c EW h=(z(1)-v(ll,1))/(v(ur,1)-v(ll,1)) c Hermite basis phi0=(1-h)**2*(1+2*h) phi1=h**2*(3-2*h) psi0=h*(1-h)**2 psi1=h**2*(h-1) sew=phi0*gw+phi1*ge+(psi0*gpw+psi1*gpe)*(v(ur,1)-v(ll,1)) s=(sns+sew)-s end if ehg128=s return end integer function ifloor(x) DOUBLE PRECISION x ifloor=INT(x) if(ifloor.gt.x) ifloor=ifloor-1 end c DSIGN is unused, causes conflicts on some platforms c DOUBLE PRECISION function DSIGN(a1,a2) c DOUBLE PRECISION a1, a2 c DSIGN=DABS(a1) c if(a2.ge.0)DSIGN=-DSIGN c end c ehg136() is the workhorse of lowesf(.) c n = number of observations c m = number of x values at which to evaluate c f = span c nf = min(n, floor(f * n)) subroutine ehg136(u,lm,m,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b, + od,o,ihat,w,rcond,sing,dd,tdeg,cdeg,s) integer identi,d,dd,execnt,i,i1,ihat,info,j,k,kernel,l,lm,m,n,nf, + od,sing,tdeg integer cdeg(8),psi(n) double precision f,i2,rcond,scale,tol double precision o(m,n),sigma(15),e(15,15),g(15,15),b(nf,k), $ dist(n),eta(nf),dgamma(15),q(8),qraux(15),rw(n),s(0:od,m), $ u(lm,d),w(nf),work(15),x(n,d),y(n) external ehg127,ehg182,dqrsl double precision ddot external ddot save execnt data execnt /0/ c V -> g c U -> e c Identity -> identi c L -> o c X -> b execnt=execnt+1 if(k .gt. nf-1) call ehg182(104) if(k .gt. 15) call ehg182(105) do 3 identi=1,n psi(identi)=identi 3 continue do 4 l=1,m do 5 i1=1,d q(i1)=u(l,i1) 5 continue call ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w, + rcond,sing,sigma,e,g,dgamma,qraux,work,tol,dd,tdeg,cdeg, + s(0,l)) if(ihat.eq.1)then c $L sub {l,l} = c V sub {1,:} SIGMA sup {+} U sup T c (Q sup T W e sub i )$ if(.not.(m.eq.n))then call ehg182(123) end if c find $i$ such that $l = psi sub i$ i=1 c top of while loop 6 if(.not.(l.ne.psi(i)))goto 7 i=i+1 if(.not.(i.lt.nf))then call ehg182(123) goto 7 end if goto 6 c bottom of while loop 7 do 8 i1=1,nf eta(i1)=0 8 continue eta(i)=w(i) c $eta = Q sup T W e sub i$ call dqrsl(b,nf,nf,k,qraux,eta,eta,eta,eta,eta,eta,1000, + info) c $gamma = U sup T eta sub {1:k}$ do 9 i1=1,k dgamma(i1)=0 9 continue do 10 j=1,k i2=eta(j) do 11 i1=1,k dgamma(i1)=dgamma(i1)+i2*e(j,i1) 11 continue 10 continue c $gamma = SIGMA sup {+} gamma$ do 12 j=1,k if(tol.lt.sigma(j))then dgamma(j)=dgamma(j)/sigma(j) else dgamma(j)=0.d0 end if 12 continue c voidp junk c voidp junk o(l,1)=ddot(k,g(1,1),15,dgamma,1) else if(ihat.eq.2)then c $L sub {l,:} = c V sub {1,:} SIGMA sup {+} c ( U sup T Q sup T ) W $ do 13 i1=1,n o(l,i1)=0 13 continue do 14 j=1,k do 15 i1=1,nf eta(i1)=0 15 continue do 16 i1=1,k eta(i1)=e(i1,j) 16 continue call dqrsl(b,nf,nf,k,qraux,eta,eta,work,work,work,work + ,10000,info) if(tol.lt.sigma(j))then scale=1.d0/sigma(j) else scale=0.d0 end if do 17 i1=1,nf eta(i1)=eta(i1)*(scale*w(i1)) 17 continue do 18 i=1,nf o(l,psi(i))=o(l,psi(i))+g(1,j)*eta(i) 18 continue 14 continue end if end if 4 continue return end c called from lowesb() ... compute fit ..?..?... c somewhat similar to ehg136 subroutine ehg139(v,nvmax,nv,n,d,nf,f,x,pi,psi,y,rw,trl,kernel,k, + dist,phi,eta,b,od,w,diagl,vval2,ncmax,vc,a,xi,lo,hi,c,vhit, + rcond,sing,dd,tdeg,cdeg,lq,lf,setlf,s) logical setlf integer identi,d,dd,execnt,i,i2,i3,i5,i6,ii,ileaf,info,j,k,kernel, + l,n,ncmax,nf,nleaf,nv,nvmax,od,sing,tdeg,vc integer lq(nvmax,nf),a(ncmax),c(vc,ncmax),cdeg(8),hi(ncmax), + leaf(256),lo(ncmax),pi(n),psi(n),vhit(nvmax) DOUBLE PRECISION f,i1,i4,i7,rcond,scale,term,tol,trl DOUBLE PRECISION lf(0:d,nvmax,nf),sigma(15),u(15,15),e(15,15), + b(nf,k),diagl(n),dist(n),eta(nf),DGAMMA(15),q(8),qraux(15), + rw(n),s(0:od,nv),v(nvmax,d),vval2(0:d,nv),w(nf),work(15), + x(n,d),xi(ncmax),y(n),z(8) DOUBLE PRECISION phi(n) external ehg127,ehg182,DQRSL,ehg137 DOUBLE PRECISION ehg128 external ehg128 DOUBLE PRECISION DDOT external DDOT save execnt data execnt /0/ c V -> e c Identity -> identi c X -> b execnt=execnt+1 c l2fit with trace(L) if(k .gt. nf-1) call ehg182(104) if(k .gt. 15) call ehg182(105) if(trl.ne.0) then do 3 i5=1,n diagl(i5)=0 3 continue do 4 i6=1,nv do 5 i5=0,d vval2(i5,i6)=0 5 continue 4 continue end if do 6 identi=1,n psi(identi)=identi 6 continue do 7 l=1,nv do 8 i5=1,d q(i5)=v(l,i5) 8 continue call ehg127(q,n,d,nf,f,x,psi,y,rw,kernel,k,dist,eta,b,od,w, + rcond,sing,sigma,u,e,DGAMMA,qraux,work,tol,dd,tdeg,cdeg, + s(0,l)) if(trl.ne.0)then c invert $psi$ do 9 i5=1,n phi(i5)=0 9 continue do 10 i=1,nf phi(psi(i))=i 10 continue do 11 i5=1,d z(i5)=v(l,i5) 11 continue call ehg137(z,vhit(l),leaf,nleaf,d,nv,nvmax,ncmax,a,xi, + lo,hi) do 12 ileaf=1,nleaf do 13 ii=lo(leaf(ileaf)),hi(leaf(ileaf)) i=INT(phi(pi(ii))) if(i.ne.0)then if(.not.(psi(i).eq.pi(ii)))then call ehg182(194) end if do 14 i5=1,nf eta(i5)=0 14 continue eta(i)=w(i) c $eta = Q sup T W e sub i$ call DQRSL(b,nf,nf,k,qraux,eta,work,eta,eta,work, + work,1000,info) do 15 j=1,k if(tol.lt.sigma(j))then i4=DDOT(k,u(1,j),1,eta,1)/sigma(j) else i4=0.D0 end if DGAMMA(j)=i4 15 continue do 16 j=1,d+1 vval2(j-1,l)=DDOT(k,e(j,1),15,DGAMMA,1) 16 continue do 17 i5=1,d z(i5)=x(pi(ii),i5) 17 continue term=ehg128(z,d,ncmax,vc,a,xi,lo,hi,c,v,nvmax, + vval2) diagl(pi(ii))=diagl(pi(ii))+term do 18 i5=0,d vval2(i5,l)=0 18 continue end if 13 continue 12 continue end if if(setlf)then c $Lf sub {:,l,:} = V SIGMA sup {+} U sup T Q sup T W$ if(.not.(k.ge.d+1))then call ehg182(196) end if do 19 i5=1,nf lq(l,i5)=psi(i5) 19 continue do 20 i6=1,nf do 21 i5=0,d lf(i5,l,i6)=0 21 continue 20 continue do 22 j=1,k do 23 i5=1,nf eta(i5)=0 23 continue do 24 i5=1,k eta(i5)=u(i5,j) 24 continue call DQRSL(b,nf,nf,k,qraux,eta,eta,work,work,work,work, + 10000,info) if(tol.lt.sigma(j))then scale=1.D0/sigma(j) else scale=0.D0 end if do 25 i5=1,nf eta(i5)=eta(i5)*(scale*w(i5)) 25 continue do 26 i=1,nf i7=eta(i) do 27 i5=0,d lf(i5,l,i)=lf(i5,l,i)+e(1+i5,j)*i7 27 continue 26 continue 22 continue end if 7 continue if(trl.ne.0)then if(n.le.0)then trl=0.D0 else i3=n i1=diagl(i3) do 28 i2=i3-1,1,-1 i1=diagl(i2)+i1 28 continue trl=i1 end if end if return end subroutine lowesb(xx,yy,ww,diagl,infl,iv,liv,lv,wv) c logical infl integer infl integer liv, lv integer iv(*) DOUBLE PRECISION xx(*),yy(*),ww(*),diagl(*),wv(*) c Var DOUBLE PRECISION trl logical setlf integer execnt integer ifloor external ifloor external ehg131,ehg182,ehg183 save execnt data execnt /0/ C Modifying lv, liv to avoid warnings lv = lv + 0 liv = liv + 0 execnt=execnt+1 if(.not.(iv(28).ne.173))then call ehg182(174) end if if(iv(28).ne.172)then if(.not.(iv(28).eq.171))then call ehg182(171) end if end if iv(28)=173 if(infl.ne.0)then trl=1.D0 else trl=0.D0 end if setlf=(iv(27).ne.iv(25)) call ehg131(xx,yy,ww,trl,diagl,iv(20),iv(29),iv(3),iv(2),iv(5), + iv(17),iv(4),iv(6),iv(14),iv(19),wv(1),iv(iv(7)),iv(iv(8)), + iv(iv(9)),iv(iv(10)),iv(iv(22)),iv(iv(27)),wv(iv(11)), + iv(iv(23)),wv(iv(13)),wv(iv(12)),wv(iv(15)),wv(iv(16)), + wv(iv(18)),ifloor(iv(3)*wv(2)),wv(3),wv(iv(26)),wv(iv(24)), + wv(4),iv(30),iv(33),iv(32),iv(41),iv(iv(25)),wv(iv(34)), + setlf) if(iv(14).lt.iv(6)+DBLE(iv(4))/2.D0)then call ehg183('k-d tree limited by memory; nvmax=', + iv(14),1,1) else if(iv(17).lt.iv(5)+2)then call ehg183('k-d tree limited by memory. ncmax=', + iv(17),1,1) end if end if return end clowesd() : Initialize iv(*) and v(1:4) c ------ called only by loess_workspace() in ./loessc.c subroutine lowesd(versio,iv,liv,lv,v,d,n,f,ideg,nvmax,setlf) integer versio,liv,lv,d,n,ideg,nvmax integer iv(liv) c logical setlf integer setlf double precision f, v(lv) integer bound,execnt,i,i1,i2,j,ncmax,nf,vc external ehg182 integer ifloor external ifloor save execnt data execnt /0/ c c unnecessary initialization of i1 to keep g77 -Wall happy c i1 = 0 c version -> versio execnt=execnt+1 if(.not.(versio.eq.106))then call ehg182(100) end if iv(28)=171 iv(2)=d iv(3)=n vc=2**d iv(4)=vc if(.not.(0.lt.f))then call ehg182(120) end if nf=min(n,ifloor(n*f)) iv(19)=nf iv(20)=1 if(ideg.eq.0)then i1=1 else if(ideg.eq.1)then i1=d+1 else if(ideg.eq.2)then i1=INT(dble((d+2)*(d+1))/2.d0) end if end if end if iv(29)=i1 iv(21)=1 iv(14)=nvmax ncmax=nvmax iv(17)=ncmax iv(30)=0 iv(32)=ideg if(.not.(ideg.ge.0))then call ehg182(195) end if if(.not.(ideg.le.2))then call ehg182(195) end if iv(33)=d do 3 i2=41,49 iv(i2)=ideg 3 continue iv(7)=50 iv(8)=iv(7)+ncmax iv(9)=iv(8)+vc*ncmax iv(10)=iv(9)+ncmax iv(22)=iv(10)+ncmax c initialize permutation j=iv(22)-1 do 4 i=1,n iv(j+i)=i 4 continue iv(23)=iv(22)+n iv(25)=iv(23)+nvmax if(setlf.ne.0)then iv(27)=iv(25)+nvmax*nf else iv(27)=iv(25) end if bound=iv(27)+n if(.not.(bound-1.le.liv))then call ehg182(102) end if iv(11)=50 iv(13)=iv(11)+nvmax*d iv(12)=iv(13)+(d+1)*nvmax iv(15)=iv(12)+ncmax iv(16)=iv(15)+n iv(18)=iv(16)+nf iv(24)=iv(18)+iv(29)*nf iv(34)=iv(24)+(d+1)*nvmax if(setlf.ne.0)then iv(26)=iv(34)+(d+1)*nvmax*nf else iv(26)=iv(34) end if bound=iv(26)+nf if(.not.(bound-1.le.lv))then call ehg182(103) end if v(1)=f v(2)=0.05d0 v(3)=0.d0 v(4)=1.d0 return end subroutine lowese(iv,liv,lv,wv,m,z,s) integer liv,lv,m integer iv(*) double precision s(m),wv(*),z(m,1) integer execnt external ehg133,ehg182 save execnt data execnt /0/ C Initializing lv, liv to avoid warnings lv = lv + 0 liv = liv + 0 execnt=execnt+1 if(.not.(iv(28).ne.172))then call ehg182(172) end if if(.not.(iv(28).eq.173))then call ehg182(173) end if call ehg133(iv(3),iv(2),iv(4),iv(14),iv(5),iv(17),iv(iv(7)),iv(iv( +8)),iv(iv(9)),iv(iv(10)),wv(iv(11)),wv(iv(13)),wv(iv(12)),m,z,s) return end c "direct" (non-"interpolate") fit aka predict() : subroutine lowesf(xx,yy,ww,iv,liv,lv,wv,m,z,l,ihat,s) integer liv,lv,m,ihat c m = number of x values at which to evaluate integer iv(*) double precision xx(*),yy(*),ww(*),wv(*),z(m,1),l(m,*),s(m) logical i1 integer execnt external ehg182,ehg136 save execnt data execnt /0/ C Modifying lv, liv to avoid warnings lv = lv + 0 liv = liv + 0 execnt=execnt+1 if(171.le.iv(28))then i1=(iv(28).le.174) else i1=.false. end if if(.not.i1)then call ehg182(171) end if iv(28)=172 if(.not.(iv(14).ge.iv(19)))then call ehg182(186) end if c do the work; in ehg136() give the argument names as they are there: c ehg136(u,lm,m, n, d, nf, f, x, psi, y ,rw, call ehg136(z,m,m,iv(3),iv(2),iv(19),wv(1),xx,iv(iv(22)),yy,ww, c kernel, k, dist, eta, b, od,o,ihat, + iv(20),iv(29),wv(iv(15)),wv(iv(16)),wv(iv(18)),0,l,ihat, c w, rcond,sing, dd, tdeg,cdeg, s) + wv(iv(26)),wv(4),iv(30),iv(33),iv(32),iv(41),s) return end subroutine lowesl(iv,liv,lv,wv,m,z,l) integer liv,lv,m integer iv(*) double precision l(m,*),wv(*),z(m,1) integer execnt external ehg182,ehg191 save execnt data execnt /0/ C Modifying lv, liv to avoid warnings lv = lv + 0 liv = liv + 0 execnt=execnt+1 if(.not.(iv(28).ne.172))then call ehg182(172) end if if(.not.(iv(28).eq.173))then call ehg182(173) end if if(.not.(iv(26).ne.iv(34)))then call ehg182(175) end if call ehg191(m,z,l,iv(2),iv(3),iv(19),iv(6),iv(17),iv(4),iv(iv(7)), + wv(iv(12)),iv(iv(10)),iv(iv(9)),iv(iv(8)),wv(iv(11)),iv(14), + wv(iv(24)),wv(iv(34)),iv(iv(25))) return end subroutine lowesr(yy,iv,liv,lv,wv) integer liv,lv integer iv(*) DOUBLE PRECISION yy(*),wv(*) integer execnt external ehg182,ehg192 save execnt data execnt /0/ C Initializing lv, liv to avoid warnings lv = lv + 0 liv = liv + 0 execnt=execnt+1 if(.not.(iv(28).ne.172))then call ehg182(172) end if if(.not.(iv(28).eq.173))then call ehg182(173) end if call ehg192(yy,iv(2),iv(3),iv(19),iv(6),iv(14),wv(iv(13)), + wv(iv(34)),iv(iv(25))) return end subroutine lowesw(res,n,rw,pi) c Tranliterated from Devlin's ratfor c implicit none c Args integer n double precision res(n),rw(n) integer pi(n) c Var integer identi,i,i1,nh double precision cmad,rsmall integer ifloor double precision d1mach external ehg106 external ifloor external d1mach c Identity -> identi c find median of absolute residuals do 3 i1=1,n rw(i1)=dabs(res(i1)) 3 continue do 4 identi=1,n pi(identi)=identi 4 continue nh=ifloor(dble(n)/2.d0)+1 c partial sort to find 6*mad call ehg106(1,n,nh,1,rw,pi,n) if((n-nh)+1.lt.nh)then call ehg106(1,nh-1,nh-1,1,rw,pi,n) cmad=3*(rw(pi(nh))+rw(pi(nh-1))) else cmad=6*rw(pi(nh)) end if rsmall=d1mach(1) if(cmad.lt.rsmall)then do 5 i1=1,n rw(i1)=1 5 continue else do 6 i=1,n if(cmad*0.999d0.lt.rw(i))then rw(i)=0 else if(cmad*0.001d0.lt.rw(i))then rw(i)=(1-(rw(i)/cmad)**2)**2 else rw(i)=1 end if end if 6 continue end if return end subroutine lowesp(n,y,yhat,pwgts,rwgts,pi,ytilde) integer n integer pi(n) double precision y(n),yhat(n),pwgts(n),rwgts(n),ytilde(n) c Var double precision c,i1,i4,mad integer identi,execnt,i2,i3,i5,m external ehg106 integer ifloor external ifloor save execnt data execnt /0/ c Identity -> identi execnt=execnt+1 c median absolute deviation do 3 i5=1,n ytilde(i5)=dabs(y(i5)-yhat(i5))*dsqrt(pwgts(i5)) 3 continue do 4 identi=1,n pi(identi)=identi 4 continue m=ifloor(dble(n)/2.d0)+1 call ehg106(1,n,m,1,ytilde,pi,n) if((n-m)+1.lt.m)then call ehg106(1,m-1,m-1,1,ytilde,pi,n) mad=(ytilde(pi(m-1))+ytilde(pi(m)))/2 else mad=ytilde(pi(m)) end if c magic constant c=(6*mad)**2/5 do 5 i5=1,n ytilde(i5)=1-((y(i5)-yhat(i5))**2*pwgts(i5))/c 5 continue do 6 i5=1,n ytilde(i5)=ytilde(i5)*dsqrt(rwgts(i5)) 6 continue if(n.le.0)then i4=0.d0 else i3=n i1=ytilde(i3) do 7 i2=i3-1,1,-1 i1=ytilde(i2)+i1 7 continue i4=i1 end if c=n/i4 c pseudovalues do 8 i5=1,n ytilde(i5)=yhat(i5)+(c*rwgts(i5))*(y(i5)-yhat(i5)) 8 continue return end subroutine ehg124(ll,uu,d,n,nv,nc,ncmax,vc,x,pi,a,xi,lo,hi,c,v, + vhit,nvmax,fc,fd,dd) integer ll,uu,d,n,nv,nc,ncmax,vc,nvmax,fc,dd integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax),pi(n),vhit(nvmax) DOUBLE PRECISION fd, v(nvmax,d),x(n,d),xi(ncmax) logical i1,i2,i3,leaf integer execnt,i4,inorm2,k,l,m,p,u DOUBLE PRECISION diam,diag(8),sigma(8) external ehg125,ehg106,ehg129 integer IDAMAX external IDAMAX save execnt data execnt /0/ execnt=execnt+1 p=1 l=ll u=uu lo(p)=l hi(p)=u c top of while loop 3 if(.not.(p.le.nc))goto 4 do 5 i4=1,dd diag(i4)=v(c(vc,p),i4)-v(c(1,p),i4) 5 continue diam=0 do 6 inorm2=1,dd diam=diam+diag(inorm2)**2 6 continue diam=DSQRT(diam) if((u-l)+1.le.fc)then i1=.true. else i1=(diam.le.fd) end if if(i1)then leaf=.true. else if(ncmax.lt.nc+2)then i2=.true. else i2=(nvmax.lt.nv+DBLE(vc)/2.D0) end if leaf=i2 end if if(.not.leaf)then call ehg129(l,u,dd,x,pi,n,sigma) k=IDAMAX(dd,sigma,1) m=INT(DBLE(l+u)/2.D0) call ehg106(l,u,m,1,x(1,k),pi,n) c all ties go with hi son c top of while loop 7 if(1.lt.m)then i3=(x(pi(m-1),k).eq.x(pi(m),k)) else i3=.false. end if if(.not.(i3))goto 8 m=m-1 goto 7 c bottom of while loop 8 if(v(c(1,p),k).eq.x(pi(m),k))then leaf=.true. else leaf=(v(c(vc,p),k).eq.x(pi(m),k)) end if end if if(leaf)then a(p)=0 else a(p)=k xi(p)=x(pi(m),k) c left son nc=nc+1 lo(p)=nc lo(nc)=l hi(nc)=m c right son nc=nc+1 hi(p)=nc lo(nc)=m+1 hi(nc)=u call ehg125(p,nv,v,vhit,nvmax,d,k,xi(p),2**(k-1),2**(d-k), + c(1,p),c(1,lo(p)),c(1,hi(p))) end if p=p+1 l=lo(p) u=hi(p) goto 3 c bottom of while loop 4 return end subroutine ehg129(l,u,d,x,pi,n,sigma) integer d,execnt,i,k,l,n,u integer pi(n) DOUBLE PRECISION machin,alpha,beta,t DOUBLE PRECISION sigma(d),x(n,d) DOUBLE PRECISION D1MACH external D1MACH save machin,execnt data execnt /0/ c MachInf -> machin execnt=execnt+1 if(execnt.eq.1)then c initialize d1mach(2) === DBL_MAX: machin=D1MACH(2) end if do 3 k=1,d alpha=machin beta=-machin do 4 i=l,u t=x(pi(i),k) alpha=min(alpha,x(pi(i),k)) beta=max(beta,t) 4 continue sigma(k)=beta-alpha 3 continue return end c {called only from ehg127} purpose...?... subroutine ehg137(z,kappa,leaf,nleaf,d,nv,nvmax,ncmax,a,xi,lo,hi) integer kappa,d,nv,nvmax,ncmax,nleaf integer leaf(256),a(ncmax),hi(ncmax),lo(ncmax),pstack(20) DOUBLE PRECISION z(d),xi(ncmax) integer execnt,p,stackt external ehg182 save execnt data execnt /0/ C Modifying kappa, nv, nvmax to avoid warnings kappa = kappa + 0 nv = nv + 0 nvmax = nvmax + 0 c stacktop -> stackt execnt=execnt+1 c find leaf cells affected by $z$ stackt=0 p=1 nleaf=0 c top of while loop 3 if(.not.(0.lt.p))goto 4 if(a(p).eq.0)then c leaf nleaf=nleaf+1 leaf(nleaf)=p c Pop if(stackt.ge.1)then p=pstack(stackt) else p=0 end if stackt=max(0,stackt-1) else if(z(a(p)).eq.xi(p))then c Push stackt=stackt+1 if(.not.(stackt.le.20))then call ehg182(187) end if pstack(stackt)=hi(p) p=lo(p) else if(z(a(p)).lt.xi(p))then p=lo(p) else p=hi(p) end if end if end if goto 3 c bottom of while loop 4 if(.not.(nleaf.le.256))then call ehg182(185) end if return end C-- For Error messaging, call the "a" routines at the bottom of ./loessc.c : subroutine ehg183(s, i, n, inc) character s*(*) integer i, n, inc call ehg183a(s, len(s), i, n, inc) end subroutine ehg184(s, x, n, inc) character s*(*) double precision x integer n, inc call ehg184a(s, len(s), x, n, inc) end gam/src/lo.f0000644000176200001440000001475714332261034012402 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine lo0(x,y,w,n,d,p,nvmax,span,degree,match,nef,dof,s,var, *beta,iv,liv,lv,v,iwork,work) integer n,d,p,nvmax,degree,match(*),nef,liv,lv,iv(liv),iwork(*) double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),v(lv),work( **) double precision beta(p+1) double precision zrank c Initializing zrank to avoid warnings zrank = 0.0 call lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,0,dof,s,var,beta, * work(1),work(nef*d+1),work(nef*(d+1)+2),work(nef*(d+2)+2), work(n *ef*(d+3)+2),zrank,iwork(1),work(nef*(p+d+4)+3+p), iv,liv,lv,v, wor *k(nef*(p+d+4)+4+2*p) ) return end subroutine lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,v *ar,beta, xin,win,sqwin,sqwini,xqr,zrank,qpivot,qraux, iv,liv,lv,v, * work) integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1) integer iv(liv),liv,lv C Trevor did some fiddling here 6/30/2020 C made qrank zrank so lto errors go away C make it integer qrank, use it, then convert back to double double precision zrank double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1), *xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p *+1),v(lv), work(*) C Naras did some fiddling here to initialize zrank zrank = zrank * 1.0 qrank=int(zrank) call lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,bet *a, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, work( *1),work(nef+2),work(2*nef+3),work(3*nef+4)) zrank=dble(qrank) return end subroutine lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,v *ar,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, * levout,sout,yin,work) integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1) integer iv(liv),liv,lv double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1), *xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p *+1),v(lv), levout(nef+1), sout(nef+1),yin(nef+1),work(*) double precision junk(1), onedm7 integer job, info c logical setlf, ifvar integer setlf, ifvar job=110 info=1 ifvar=1 onedm7=1d-7 if(nit.le.1)then call pck(n,nef,match,w,win) do23002 i=1,nef if(win(i).gt.0d0)then sqwin(i)=dsqrt(win(i)) sqwini(i)=1d0/sqwin(i) else sqwin(i)=1d-5 sqwini(i)=1d5 endif 23002 continue continue do23006 i=1,n k=match(i) if(k.le.nef)then do23010 j=1,d xin(k,j)=x(i,j) 23010 continue continue j=d+1 23012 if(.not.(j.le.p))goto 23014 xqr(k,j+1)=x(i,j) j=j+1 goto 23012 23014 continue endif 23006 continue continue do23015 i=1,nef xqr(i,1)=sqwin(i) do23017 j=1,d xqr(i,j+1)=xin(i,j)*sqwin(i) 23017 continue continue j=d+2 23019 if(.not.(j.le.p+1))goto 23021 xqr(i,j)=xqr(i,j)*sqwin(i) j=j+1 goto 23019 23021 continue 23015 continue continue j=1 23022 if(.not.(j.le.p+1))goto 23024 qpivot(j)=j j=j+1 goto 23022 23024 continue call dqrdca(xqr,nef,nef,p+1,qraux,qpivot,work,qrank,onedm7) if (nit.eq.1) then setlf = 1 else setlf = 0 endif call lowesd(106,iv,liv,lv,v,d,nef,span,degree,nvmax,setlf) v(2)=span/5d0 endif do23025 i=1,n work(i)=y(i)*w(i) 23025 continue continue call pck(n,nef,match,work,yin) do23027 i=1,nef yin(i)=yin(i)*sqwini(i)*sqwini(i) 23027 continue continue if(nit.le.1)then call lowesb(xin,yin,win,levout,ifvar,iv,liv,lv,v) else call lowesr(yin,iv,liv,lv,v) endif call lowese(iv,liv,lv,v,nef,xin,sout) do23031 i=1,nef sout(i)=sout(i)*sqwin(i) 23031 continue continue call dqrsl(xqr,nef,nef,qrank,qraux,sout,work(1),work(1),beta, sout *,work(1),job,info) do23033 i=1,nef sout(i)=sout(i)*sqwini(i) 23033 continue continue if(nit.le.1)then job=10000 j=1 23037 if(.not.(j.le.p+1))goto 23039 do23040 i=1,nef work(i)=0d0 23040 continue continue work(j)=1d0 call dqrsl(xqr,nef,nef,qrank,qraux,work,var,junk,junk, * junk,junk,job,info) do23042 i=1,nef levout(i)=levout(i) - var(i)**2 23042 continue continue j=j+1 goto 23037 23039 continue dof=0d0 do23044 i=1,nef if(win(i).gt.0d0)then levout(i)=levout(i)/win(i) else levout(i)=0d0 endif 23044 continue continue do23048 i=1,nef dof=dof+levout(i)*win(i) 23048 continue continue call unpck(n,nef,match,levout,var) j=1 23050 if(.not.(j.le.p+1))goto 23052 work(j)=beta(j) j=j+1 goto 23050 23052 continue j=1 23053 if(.not.(j.le.p+1))goto 23055 beta(qpivot(j))=work(j) j=j+1 goto 23053 23055 continue endif call unpck(n,nef,match,sout,s) return end subroutine pck(n,p,match,x,xbar) integer match(n),p,n double precision x(n),xbar(n) do23056 i=1,p xbar(i)=0d0 23056 continue continue do23058 i=1,n xbar(match(i))=xbar(match(i))+x(i) 23058 continue continue return end subroutine suff(n,p,match,x,y,w,xbar,ybar,wbar,work) integer match(n),p,n double precision x(n),xbar(n),y(n),ybar(n),w(n),wbar(n),work(n) call pck(n,p,match,w,wbar) do23060 i=1,n xbar(match(i))=x(i) 23060 continue continue do23062 i=1,n work(i)=y(i)*w(i) 23062 continue continue call pck(n,p,match,work,ybar) do23064 i=1,p if(wbar(i).gt.0d0)then ybar(i)=ybar(i)/wbar(i) else ybar(i)=0d0 endif 23064 continue continue return end subroutine unpck(n,p,match,xbar,x) integer match(n),p,n double precision x(n),xbar(p+1) if(p.lt.n)then xbar(p+1)=0d0 endif do23070 i = 1,n x(i)=xbar(match(i)) 23070 continue continue return end double precision function dwrss(n,y,eta,w) integer n double precision y(n),w(n),wtot,wsum,work,eta(n) wsum=0d0 wtot=0d0 do23072 i = 1,n work=y(i)-eta(i) wsum=wsum+w(i)*work*work wtot=wtot+w(i) 23072 continue continue if(wtot .gt. 0d0)then dwrss=wsum/wtot else dwrss=0d0 endif return end gam/src/bvalus.f0000644000176200001440000000054210543334050013246 0ustar liggesusers subroutine bvalus(n,knot,coef,nk,x,s,order) C Args integer n, nk, order double precision knot(*),coef(*),x(*),s(*) C Local double precision bvalue integer i do 10 i=1,n s(i)=bvalue(knot,n+4,coef,nk,4,x(i),order) C ---- typo corrected from gamfit 10 continue return end gam/src/linear.f0000644000176200001440000015337514332261034013242 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine dqrls(x,dx,pivot,qraux,y,dy,beta,res,qt,tol,scrtch,rank *) integer pivot(*),dx(2),dy(2),rank double precision x(*), qraux(*), y(*), beta(*),res(*),qt(*),tol(*) *, scrtch(*) integer n,p,q,kn,kp,k,info n=dx(1) p=dx(2) q=dy(2) call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1)) kn=1 kp=1 if(rank.gt.0)then k=1 23002 if(.not.(k.le.q))goto 23004 call dqrsl(x,n,n,rank,qraux,y(kn),scrtch,qt(kn),beta(kp), res(kn), *scrtch,00110,info) kn = kn+n kp=kp+p k=k+1 goto 23002 23004 continue endif return end subroutine dqrsl1(qr,dq,qra,rank,y,k,qy,qb,job,info) double precision qr(*),qra(*),y(*),qy(*),qb(*) integer dq(2),job,k,rank integer n,kn,kb,j double precision ourqty(1), ourqy(1), ourb(1), ourrsd(1), ourxb(1) ourqty(1) = 0d0 ourqy(1) = 0d0 ourb(1) = 0d0 ourrsd(1) = 0d0 ourxb(1) = 0d0 n = dq(1) kn = 1 kb = 1 I23005=(job) goto 23005 23007 continue j=0 23008 if(.not.(j.lt.k))goto 23010 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),qy(kn),ourqty,ourb,ourrsd *,ourxb,job,info) kn = kn +n j = j+1 goto 23008 23010 continue goto 23006 23011 continue j=0 23012 if(.not.(j.lt.k))goto 23014 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,ourrsd, *ourxb,job,info) kn = kn +n j = j+1 goto 23012 23014 continue goto 23006 23015 continue j=0 23016 if(.not.(j.lt.k))goto 23018 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),qb(kb),ourrs *d,ourxb,job,info) kn = kn +n kb = kb +rank j = j+1 goto 23016 23018 continue goto 23006 23019 continue j=0 23020 if(.not.(j.lt.k))goto 23022 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,qb(kn), *ourxb,job,info) kn = kn +n j = j+1 goto 23020 23022 continue goto 23006 23023 continue j=0 23024 if(.not.(j.lt.k))goto 23026 call dqrsl(qr,dq(1),dq(1),rank,qra,y(kn),ourqy,qy(kn),ourb,ourrsd, *qb(kn),job,info) kn = kn +n j = j+1 goto 23024 23026 continue goto 23006 23027 continue info = -1 goto 23006 23005 continue if (I23005.eq.1)goto 23023 if (I23005.eq.10)goto 23019 if (I23005.eq.100)goto 23015 if (I23005.eq.1000)goto 23011 if (I23005.eq.10000)goto 23007 goto 23027 23006 continue return end subroutine dqr(x,dx,pivot,qraux,tol,scrtch,rank) integer pivot(*),dx(2),rank double precision x(*), qraux(*), tol(*), scrtch(*) integer n,p n=dx(1) p=dx(2) call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1)) return end subroutine dqrdca(x,ldx,n,p,qraux,jpvt,work,rank,eps) integer ldx,n,p,rank integer jpvt(*) double precision x(ldx,*),qraux(*),work(*),eps integer j,jj,jp,l,lup,curpvt double precision dnrm2,tt double precision ddot,nrmxl,t,ww do23028 j=1,p qraux(j) = dnrm2(n,x(1,j),1) work(j) = qraux(j) work(j+p) = qraux(j) 23028 continue continue l=1 lup = min0(n,p) curpvt = p 23030 if(l.le.lup)then qraux(l) = 0.0d0 nrmxl = dnrm2(n-l+1,x(l,l),1) t = work(l+p) if(t .gt. 0.)then t = nrmxl/t endif if(t .lt. eps)then call dshift(x,ldx,n,l,curpvt) jp = jpvt(l) t=qraux(l) tt=work(l) ww = work(l+p) j=l+1 23036 if(.not.(j.le.curpvt))goto 23038 jj=j-1 jpvt(jj)=jpvt(j) qraux(jj)=qraux(j) work(jj)=work(j) work(jj+p) = work(j+p) j=j+1 goto 23036 23038 continue jpvt(curpvt)=jp qraux(curpvt)=t work(curpvt)=tt work(curpvt+p) = ww curpvt=curpvt-1 if(lup.gt.curpvt)then lup=curpvt endif else if(l.eq.n)then goto 23031 endif if(x(l,l).ne.0.0d0)then nrmxl = dsign(nrmxl,x(l,l)) endif call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1) x(l,l) = 1.0d0+x(l,l) j=l+1 23045 if(.not.(j.le.curpvt))goto 23047 t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) if(qraux(j).ne.0.0d0)then tt = 1.0d0-(dabs(x(l,j))/qraux(j))**2 tt = dmax1(tt,0.0d0) t = tt tt = 1.0d0+0.05d0*tt*(qraux(j)/work(j))**2 if(tt.ne.1.0d0)then qraux(j) = qraux(j)*dsqrt(t) else qraux(j) = dnrm2(n-l,x(l+1,j),1) work(j) = qraux(j) endif endif j=j+1 goto 23045 23047 continue qraux(l) = x(l,l) x(l,l) = -nrmxl l=l+1 endif goto 23030 endif 23031 continue rank = lup return end subroutine dchdc(a,lda,p,work,jpvt,job,info) integer lda,p,jpvt(p),job,info double precision a(lda,p),work(p) integer pu,pl,plp1,j,jp,jt,k,kb,km1,kp1,l,maxl double precision temp double precision maxdia logical swapk,negk pl = 1 pu = 0 info = p if(job.ne.0)then do23054 k = 1,p swapk = jpvt(k).gt.0 negk = jpvt(k).lt.0 jpvt(k) = k if(negk)then jpvt(k) = -jpvt(k) endif if(swapk)then if(k.ne.pl)then call dswap(pl-1,a(1,k),1,a(1,pl),1) temp = a(k,k) a(k,k) = a(pl,pl) a(pl,pl) = temp plp1 = pl+1 if(p.ge.plp1)then do23064 j = plp1,p if(j.lt.k)then temp = a(pl,j) a(pl,j) = a(j,k) a(j,k) = temp else if(j.ne.k)then temp = a(k,j) a(k,j) = a(pl,j) a(pl,j) = temp endif endif 23064 continue continue endif jpvt(k) = jpvt(pl) jpvt(pl) = k endif pl = pl+1 endif 23054 continue continue pu = p if(p.ge.pl)then do23072 kb = pl,p k = p-kb+pl if(jpvt(k).lt.0)then jpvt(k) = -jpvt(k) if(pu.ne.k)then call dswap(k-1,a(1,k),1,a(1,pu),1) temp = a(k,k) a(k,k) = a(pu,pu) a(pu,pu) = temp kp1 = k+1 if(p.ge.kp1)then do23080 j = kp1,p if(j.lt.pu)then temp = a(k,j) a(k,j) = a(j,pu) a(j,pu) = temp else if(j.ne.pu)then temp = a(k,j) a(k,j) = a(pu,j) a(pu,j) = temp endif endif 23080 continue continue endif jt = jpvt(k) jpvt(k) = jpvt(pu) jpvt(pu) = jt endif pu = pu-1 endif 23072 continue continue endif endif do23086 k = 1,p maxdia = a(k,k) kp1 = k+1 maxl = k if(k.ge.pl.and.k.lt.pu)then do23090 l = kp1,pu if(a(l,l).gt.maxdia)then maxdia = a(l,l) maxl = l endif 23090 continue continue endif if(maxdia.le.0.0d0)then go to 10 endif if(k.ne.maxl)then km1 = k-1 call dswap(km1,a(1,k),1,a(1,maxl),1) a(maxl,maxl) = a(k,k) a(k,k) = maxdia jp = jpvt(maxl) jpvt(maxl) = jpvt(k) jpvt(k) = jp endif work(k) = dsqrt(a(k,k)) a(k,k) = work(k) if(p.ge.kp1)then do23100 j = kp1,p if(k.ne.maxl)then if(j.lt.maxl)then temp = a(k,j) a(k,j) = a(j,maxl) a(j,maxl) = temp else if(j.ne.maxl)then temp = a(k,j) a(k,j) = a(maxl,j) a(maxl,j) = temp endif endif endif a(k,j) = a(k,j)/work(k) work(j) = a(k,j) temp = -a(k,j) call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1) 23100 continue continue endif 23086 continue continue return 10 info = k-1 return end double precision function epslon(x) double precision x double precision a,b,c,eps a = 4.0d0/3.0d0 23108 continue b = a-1.0d0 c = b+b+b eps = dabs(c-1.0d0) if(.not.(eps.ne.0.0d0))goto 23108 continue epslon = eps*dabs(x) return end double precision function pythag(a,b) double precision a,b double precision p,r,s,t,u p = dmax1(dabs(a),dabs(b)) if(p.ne.0.0d0)then r = (dmin1(dabs(a),dabs(b))/p)**2 23113 continue t = 4.0d0+r if(t.eq.4.0d0)then goto 23115 endif s = r/t u = 1.0d0+2.0d0*s p = u*p r = (s/u)**2*r goto 23113 23115 continue endif pythag = p return end subroutine rg(nm,n,a,wr,wi,matz,z,iv1,fv1,ierr) integer n,nm,is1,is2,ierr,matz double precision a(nm,n),wr(n),wi(n),z(nm,n),fv1(n) integer iv1(n) if(n.gt.nm)then ierr = 10*n else call balanc(nm,n,a,is1,is2,fv1) call elmhes(nm,n,is1,is2,a,iv1) if(matz.eq.0)then call hqr(nm,n,is1,is2,a,wr,wi,ierr) else call eltran(nm,n,is1,is2,a,iv1,z) call hqr2(nm,n,is1,is2,a,wr,wi,z,ierr) if(ierr.eq.0)then call balbak(nm,n,is1,is2,fv1,n,z) endif endif endif return end subroutine chol(a,p,work,jpvt,job,info) integer p,jpvt(*),job,info(*) double precision a(p,*),work(*) integer i,j j =2 23124 if(.not.(j.le.p))goto 23126 i=1 23127 if(.not.(i.lt.j))goto 23129 if(a(i,j).ne.a(j,i))then info(1) = -1 return endif i = i+1 goto 23127 23129 continue j = j+1 goto 23124 23126 continue call dchdc(a,p,p,work,jpvt,job,info(1)) j =2 23132 if(.not.(j.le.p))goto 23134 i=1 23135 if(.not.(i.lt.j))goto 23137 a(j,i) = 0. i = i+1 goto 23135 23137 continue j = j+1 goto 23132 23134 continue return end subroutine crs(x,dmx,matz,w,z,fv1,fv2,ierr) double precision x(*),w(*),z(*),fv1(*),fv2(*) integer dmx(2),nx,nv,ierr,matz nx=dmx(1) nv=dmx(2) call rs(nx,nv,x,w,matz,z,fv1,fv2,ierr) return end subroutine dqrls2(x,dx,pivot,qraux,y,dy,beta,res,qt,scrtch,eps) integer pivot(*),dx(2),dy(2) double precision x(*), qraux(*), y(*), beta(*),res(*),qt(*), scrtc *h(*),eps integer n,p,q,kn,kp,k,info,rank n=dx(1) p=dx(2) q=dy(2) call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,eps) kn=1 kp=1 k=1 23138 if(.not.(k.le.q))goto 23140 call dqrsl(x,n,n,p,qraux,y(kn),scrtch,qt(kn),beta(kp), res(kn),scr *tch,00110,info) kn = kn+n kp=kp+p k=k+1 goto 23138 23140 continue return end subroutine dsvdc1(x,dmx,job,work,e,s,u,v,info) double precision x(*),work(*),s(*),e(*),u(*),v(*) integer dmx(2),nx,nv,job,info nx=dmx(1) nv=dmx(2) call dsvdc(x,nx,nx,nv,s,e,u,nx,v,nv,work,job,info) return end subroutine balanc(nm,n,a,low,igh,scale) integer i,j,k,l,m,n,nm,igh,low,iexc double precision a(nm,n),scale(n) double precision c,f,g,r,s,b2,radix logical noconv radix = 16.0d0 b2 = radix*radix k = 1 l = n 23141 continue j=l 23144 if(.not.(j.gt.0))goto 23146 do23147 i = 1,l if(i.ne.j)then if(a(j,i).ne.0.0d0)then goto 23145 endif endif 23147 continue continue go to 10 23145 j=j-1 goto 23144 23146 continue go to 20 10 m = l iexc = 1 23153 continue scale(m) = j if(j.ne.m)then do23158 i = 1,l f = a(i,j) a(i,j) = a(i,m) a(i,m) = f 23158 continue continue do23160 i = k,n f = a(j,i) a(j,i) = a(m,i) a(m,i) = f 23160 continue continue endif I23162=(iexc) goto 23162 23164 continue if(l.eq.1)then go to 40 endif l = l-1 goto 23155 goto 23163 23167 continue k = k+1 20 do23168 j = k,l do23170 i = k,l if(i.ne.j)then if(a(i,j).ne.0.0d0)then goto 23168 endif endif 23170 continue continue go to 30 23168 continue continue goto 23143 30 m = k iexc = 2 goto 23163 23162 continue if (I23162.eq.1)goto 23164 if (I23162.eq.2)goto 23167 23163 continue goto 23153 23155 continue goto 23141 23143 continue do23176 i = k,l scale(i) = 1.0d0 23176 continue continue 23178 continue noconv = .false. do23181 i = k,l c = 0.0d0 r = 0.0d0 do23183 j = k,l if(j.ne.i)then c = c+dabs(a(j,i)) r = r+dabs(a(i,j)) endif 23183 continue continue if(c.ne.0.0d0.and.r.ne.0.0d0)then g = r/radix f = 1.0d0 s = c+r 23189 if(c.lt.g)then f = f*radix c = c*b2 goto 23189 endif continue g = r*radix 23191 if(c.ge.g)then f = f/radix c = c/b2 goto 23191 endif continue if((c+r)/f.lt.0.95d0*s)then g = 1.0d0/f scale(i) = scale(i)*f noconv = .true. do23195 j = k,n a(i,j) = a(i,j)*g 23195 continue continue do23197 j = 1,l a(j,i) = a(j,i)*f 23197 continue continue endif endif 23181 continue continue if(.not.(.not.noconv))goto 23178 continue 40 low = k igh = l return end subroutine balbak(nm,n,low,igh,scale,m,z) integer i,j,k,m,n,ii,nm,igh,low double precision scale(n),z(nm,m) double precision s if(m.ne.0)then if(igh.ne.low)then do23203 i = low,igh s = scale(i) do23205 j = 1,m z(i,j) = z(i,j)*s 23205 continue continue 23203 continue continue endif do23207 ii = 1,n i = ii if(i.lt.low.or.i.gt.igh)then if(i.lt.low)then i = low-ii endif k = int(scale(i)) if(k.ne.i)then do23215 j = 1,m s = z(i,j) z(i,j) = z(k,j) z(k,j) = s 23215 continue continue endif endif 23207 continue continue endif return end subroutine elmhes(nm,n,low,igh,a,int) integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1 double precision a(nm,n) double precision x,y integer int(igh) la = igh-1 kp1 = low+1 if(la.ge.kp1)then do23219 m = kp1,la mm1 = m-1 x = 0.0d0 i = m do23221 j = m,igh if(dabs(a(j,mm1)).gt.dabs(x))then x = a(j,mm1) i = j endif 23221 continue continue int(m) = i if(i.ne.m)then do23227 j = mm1,n y = a(i,j) a(i,j) = a(m,j) a(m,j) = y 23227 continue continue do23229 j = 1,igh y = a(j,i) a(j,i) = a(j,m) a(j,m) = y 23229 continue continue endif if(x.ne.0.0d0)then mp1 = m+1 do23233 i = mp1,igh y = a(i,mm1) if(y.ne.0.0d0)then y = y/x a(i,mm1) = y do23237 j = m,n a(i,j) = a(i,j)-y*a(m,j) 23237 continue continue do23239 j = 1,igh a(j,m) = a(j,m)+y*a(j,i) 23239 continue continue endif 23233 continue continue endif 23219 continue continue endif return end subroutine eltran(nm,n,low,igh,a,int,z) integer i,j,n,kl,mp,nm,igh,low,mp1 double precision a(nm,igh),z(nm,n) integer int(igh) do23241 j = 1,n do23243 i = 1,n z(i,j) = 0.0d0 23243 continue continue z(j,j) = 1.0d0 23241 continue continue kl = igh-low-1 if(kl.ge.1)then mp = igh-1 23247 if(.not.(mp .gt. low))goto 23249 mp1 = mp+1 do23250 i = mp1,igh z(i,mp) = a(i,mp-1) 23250 continue continue i = int(mp) if(i.ne.mp)then do23254 j = mp,igh z(mp,j) = z(i,j) z(i,j) = 0.0d0 23254 continue continue z(i,mp) = 1.0d0 endif mp = mp -1 goto 23247 23249 continue endif return end subroutine hqr(nm,n,low,igh,h,wr,wi,ierr) integer i,j,k,l,m,n,en,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr double precision h(nm,n),wr(n),wi(n) double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2 logical notlas c Initializing zz, b, s, r, q, m, p, zrank to avoid warnings zz = 0d0 b = 0d0 s = 0d0 r = 0d0 q = 0d0 m = 0 p = 0d0 zrank = 0d0 ierr = 0 norm = 0.0d0 k = 1 do23256 i = 1,n do23258 j = k,n norm = norm+dabs(h(i,j)) 23258 continue continue k = i if(i.lt.low.or.i.gt.igh)then wr(i) = h(i,i) wi(i) = 0.0d0 endif 23256 continue continue en = igh t = 0.0d0 itn = 30*n 23262 continue if(en.lt.low)then return endif its = 0 na = en-1 enm2 = na-1 23267 continue l=en 23270 if(.not.(l .gt. low))goto 23272 s = dabs(h(l-1,l-1))+dabs(h(l,l)) if(s.eq.0.0d0)then s = norm endif tst1 = s tst2 = tst1+dabs(h(l,l-1)) if(tst2.eq.tst1)then goto 23272 endif l = l-1 goto 23270 23272 continue x = h(en,en) if(l.eq.en)then go to 50 endif y = h(na,na) w = h(en,na)*h(na,en) if(l.eq.na)then goto 23269 endif if(itn.eq.0)then goto 23264 endif if(its.eq.10.or.its.eq.20)then t = t+x do23285 i = low,en h(i,i) = h(i,i)-x 23285 continue continue s = dabs(h(en,na))+dabs(h(na,enm2)) x = 0.75d0*s y = x w = -0.4375d0*s*s endif its = its+1 itn = itn-1 do23287 mm = l,enm2 m = enm2+l-mm zz = h(m,m) r = x-zz s = y-zz p = (r*s-w)/h(m+1,m)+h(m,m+1) q = h(m+1,m+1)-zz-r-s r = h(m+2,m+1) s = dabs(p)+dabs(q)+dabs(r) p = p/s q = q/s r = r/s if(m.eq.l)then goto 23288 endif tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1))) tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r)) if(tst2.eq.tst1)then goto 23288 endif 23287 continue 23288 continue mp2 = m+2 do23293 i = mp2,en h(i,i-2) = 0.0d0 if(i.ne.mp2)then h(i,i-3) = 0.0d0 endif 23293 continue continue do23297 k = m,na notlas = k.ne.na if(k.ne.m)then p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if(notlas)then r = h(k+2,k-1) endif x = dabs(p)+dabs(q)+dabs(r) if(x.eq.0.0d0)then goto 23297 endif p = p/x q = q/x r = r/x endif s = dsign(dsqrt(p*p+q*q+r*r),p) if(k.ne.m)then h(k,k-1) = -s*x else if(l.ne.m)then h(k,k-1) = -h(k,k-1) endif endif p = p+s x = p/s y = q/s zz = r/s q = q/p r = r/p if(.not.notlas)then do23311 j = k,n p = h(k,j)+q*h(k+1,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y 23311 continue continue j = min0(en,k+3) do23313 i = 1,j p = x*h(i,k)+y*h(i,k+1) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q 23313 continue continue else do23315 j = k,n p = h(k,j)+q*h(k+1,j)+r*h(k+2,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y h(k+2,j) = h(k+2,j)-p*zz 23315 continue continue j = min0(en,k+3) do23317 i = 1,j p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q h(i,k+2) = h(i,k+2)-p*r 23317 continue continue endif 23297 continue continue goto 23267 23269 continue p = (y-x)/2.0d0 q = p*p+w zz = dsqrt(dabs(q)) x = x+t if(q.lt.0.0d0)then wr(na) = x+p wr(en) = x+p wi(na) = zz wi(en) = -zz else zz = p+dsign(zz,p) wr(na) = x+zz wr(en) = wr(na) if(zz.ne.0.0d0)then wr(en) = x-w/zz endif wi(na) = 0.0d0 wi(en) = 0.0d0 endif en = enm2 goto 23263 50 wr(en) = x+t wi(en) = 0.0d0 en = na 23263 goto 23262 23264 continue ierr = en return end subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr) integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn,igh,itn,its,low,mp2,en *m2,ierr double precision h(nm,n),wr(n),wi(n),z(nm,n) double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2 logical notlas c Setting zz, r, s, q, p, m, l to zero to avoid warnings zz = 0d0 r = 0d0 s = 0d0 q = 0d0 p = 0d0 m = 0 l = 0 ierr = 0 norm = 0.0d0 k = 1 do23323 i = 1,n do23325 j = k,n norm = norm+dabs(h(i,j)) 23325 continue continue k = i if(i.lt.low.or.i.gt.igh)then wr(i) = h(i,i) wi(i) = 0.0d0 endif 23323 continue continue en = igh t = 0.0d0 itn = 30*n 23329 continue if(en.lt.low)then go to 70 endif its = 0 na = en-1 enm2 = na-1 23334 continue do23337 ll = low,en l = en+low-ll if(l.eq.low)then goto 23338 endif s = dabs(h(l-1,l-1))+dabs(h(l,l)) if(s.eq.0.0d0)then s = norm endif tst1 = s tst2 = tst1+dabs(h(l,l-1)) if(tst2.eq.tst1)then goto 23338 endif 23337 continue 23338 continue x = h(en,en) if(l.eq.en)then go to 60 endif y = h(na,na) w = h(en,na)*h(na,en) if(l.eq.na)then goto 23336 endif if(itn.eq.0)then goto 23331 endif if(its.eq.10.or.its.eq.20)then t = t+x do23353 i = low,en h(i,i) = h(i,i)-x 23353 continue continue s = dabs(h(en,na))+dabs(h(na,enm2)) x = 0.75d0*s y = x w = -0.4375d0*s*s endif its = its+1 itn = itn-1 do23355 mm = l,enm2 m = enm2+l-mm zz = h(m,m) r = x-zz s = y-zz p = (r*s-w)/h(m+1,m)+h(m,m+1) q = h(m+1,m+1)-zz-r-s r = h(m+2,m+1) s = dabs(p)+dabs(q)+dabs(r) p = p/s q = q/s r = r/s if(m.eq.l)then goto 23356 endif tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1))) tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r)) if(tst2.eq.tst1)then goto 23356 endif 23355 continue 23356 continue mp2 = m+2 do23361 i = mp2,en h(i,i-2) = 0.0d0 if(i.ne.mp2)then h(i,i-3) = 0.0d0 endif 23361 continue continue do23365 k = m,na notlas = k.ne.na if(k.ne.m)then p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if(notlas)then r = h(k+2,k-1) endif x = dabs(p)+dabs(q)+dabs(r) if(x.eq.0.0d0)then goto 23365 endif p = p/x q = q/x r = r/x endif s = dsign(dsqrt(p*p+q*q+r*r),p) if(k.ne.m)then h(k,k-1) = -s*x else if(l.ne.m)then h(k,k-1) = -h(k,k-1) endif endif p = p+s x = p/s y = q/s zz = r/s q = q/p r = r/p if(.not.notlas)then do23379 j = k,n p = h(k,j)+q*h(k+1,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y 23379 continue continue j = min0(en,k+3) do23381 i = 1,j p = x*h(i,k)+y*h(i,k+1) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q 23381 continue continue do23383 i = low,igh p = x*z(i,k)+y*z(i,k+1) z(i,k) = z(i,k)-p z(i,k+1) = z(i,k+1)-p*q 23383 continue continue else do23385 j = k,n p = h(k,j)+q*h(k+1,j)+r*h(k+2,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y h(k+2,j) = h(k+2,j)-p*zz 23385 continue continue j = min0(en,k+3) do23387 i = 1,j p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q h(i,k+2) = h(i,k+2)-p*r 23387 continue continue do23389 i = low,igh p = x*z(i,k)+y*z(i,k+1)+zz*z(i,k+2) z(i,k) = z(i,k)-p z(i,k+1) = z(i,k+1)-p*q z(i,k+2) = z(i,k+2)-p*r 23389 continue continue endif 23365 continue continue goto 23334 23336 continue p = (y-x)/2.0d0 q = p*p+w zz = dsqrt(dabs(q)) h(en,en) = x+t x = h(en,en) h(na,na) = y+t if(q.lt.0.0d0)then wr(na) = x+p wr(en) = x+p wi(na) = zz wi(en) = -zz else zz = p+dsign(zz,p) wr(na) = x+zz wr(en) = wr(na) if(zz.ne.0.0d0)then wr(en) = x-w/zz endif wi(na) = 0.0d0 wi(en) = 0.0d0 x = h(en,na) s = dabs(x)+dabs(zz) p = x/s q = zz/s r = dsqrt(p*p+q*q) p = p/r q = q/r do23395 j = na,n zz = h(na,j) h(na,j) = q*zz+p*h(en,j) h(en,j) = q*h(en,j)-p*zz 23395 continue continue do23397 i = 1,en zz = h(i,na) h(i,na) = q*zz+p*h(i,en) h(i,en) = q*h(i,en)-p*zz 23397 continue continue do23399 i = low,igh zz = z(i,na) z(i,na) = q*zz+p*z(i,en) z(i,en) = q*z(i,en)-p*zz 23399 continue continue endif en = enm2 goto 23330 60 h(en,en) = x+t wr(en) = h(en,en) wi(en) = 0.0d0 en = na 23330 goto 23329 23331 continue ierr = en return 70 if(norm.ne.0.0d0)then do23403 nn = 1,n en = n+1-nn p = wr(en) q = wi(en) na = en-1 if(q.lt.0)then m = na if(dabs(h(en,na)).le.dabs(h(na,en)))then call cdiv(0.0d0,-h(na,en),h(na,na)-p,q,h(na,na),h(na,en)) else h(na,na) = q/h(en,na) h(na,en) = -(h(en,en)-p)/h(en,na) endif h(en,na) = 0.0d0 h(en,en) = 1.0d0 enm2 = na-1 if(enm2.ne.0)then do23411 ii = 1,enm2 i = na-ii w = h(i,i)-p ra = 0.0d0 sa = 0.0d0 do23413 j = m,en ra = ra+h(i,j)*h(j,na) sa = sa+h(i,j)*h(j,en) 23413 continue continue if(wi(i).lt.0.0d0)then zz = w r = ra s = sa else m = i if(wi(i).eq.0.0d0)then call cdiv(-ra,-sa,w,q,h(i,na),h(i,en)) else x = h(i,i+1) y = h(i+1,i) vr = (wr(i)-p)*(wr(i)-p)+wi(i)*wi(i)-q*q vi = (wr(i)-p)*2.0d0*q if(vr.eq.0.0d0.and.vi.eq.0.0d0)then tst1 = norm*(dabs(w)+dabs(q)+dabs(x)+dabs(y)+dabs(zz)) vr = tst1 23421 continue vr = 0.01d0*vr tst2 = tst1+vr if(.not.(tst2.le.tst1))goto 23421 continue endif call cdiv(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi,h(i,na),h(i,en)) if(dabs(x).le.dabs(zz)+dabs(q))then call cdiv(-r-y*h(i,na),-s-y*h(i,en),zz,q,h(i+1,na),h(i+1,en)) else h(i+1,na) = (-ra-w*h(i,na)+q*h(i,en))/x h(i+1,en) = (-sa-w*h(i,en)-q*h(i,na))/x endif endif t = dmax1(dabs(h(i,na)),dabs(h(i,en))) if(t.ne.0.0d0)then tst1 = t tst2 = tst1+1.0d0/tst1 if(tst2.le.tst1)then do23430 j = i,en h(j,na) = h(j,na)/t h(j,en) = h(j,en)/t 23430 continue continue endif endif endif 23411 continue continue endif else if(q.eq.0)then m = en h(en,en) = 1.0d0 if(na.ne.0)then do23436 ii = 1,na i = en-ii w = h(i,i)-p r = 0.0d0 do23438 j = m,en r = r+h(i,j)*h(j,en) 23438 continue continue if(wi(i).lt.0.0d0)then zz = w s = r else m = i if(wi(i).ne.0.0d0)then x = h(i,i+1) y = h(i+1,i) q = (wr(i)-p)*(wr(i)-p)+wi(i)*wi(i) t = (x*s-zz*r)/q h(i,en) = t if(dabs(x).le.dabs(zz))then h(i+1,en) = (-s-y*t)/zz else h(i+1,en) = (-r-w*t)/x endif else t = w if(t.eq.0.0d0)then tst1 = norm t = tst1 23448 continue t = 0.01d0*t tst2 = norm+t if(.not.(tst2.le.tst1))goto 23448 continue endif h(i,en) = -r/t endif t = dabs(h(i,en)) if(t.ne.0.0d0)then tst1 = t tst2 = tst1+1.0d0/tst1 if(tst2.le.tst1)then do23455 j = i,en h(j,en) = h(j,en)/t 23455 continue continue endif endif endif 23436 continue continue endif endif endif 23403 continue continue do23457 i = 1,n if(i.lt.low.or.i.gt.igh)then do23461 j = i,n z(i,j) = h(i,j) 23461 continue continue endif 23457 continue continue do23463 jj = low,n j = n+low-jj m = min0(j,igh) do23465 i = low,igh zz = 0.0d0 do23467 k = low,m zz = zz+z(i,k)*h(k,j) 23467 continue continue z(i,j) = zz 23465 continue continue 23463 continue continue endif return end subroutine cdiv(ar,ai,br,bi,cr,ci) double precision ar,ai,br,bi,cr,ci double precision s,ars,ais,brs,bis s = dabs(br)+dabs(bi) ars = ar/s ais = ai/s brs = br/s bis = bi/s s = brs**2+bis**2 cr = (ars*brs+ais*bis)/s ci = (ais*brs-ars*bis)/s return end subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr) integer n,nm,ierr,matz double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n) if(n.gt.nm)then ierr = 10*n else if(matz.ne.0)then call tred2(nm,n,a,w,fv1,z) call tql2(nm,n,w,fv1,z,ierr) else call tred1(nm,n,a,w,fv1,fv2) call tqlrat(n,w,fv2,ierr) endif endif return end subroutine tql2(nm,n,d,e,z,ierr) integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr double precision d(n),e(n),z(nm,n) double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag C Initializing s2, c3 and ensuring ierr is not clobbered s2 = 0.0 c3 = 0.0 ierr = 0 if(n.ne.1)then do23475 i = 2,n e(i-1) = e(i) 23475 continue continue f = 0.0d0 tst1 = 0.0d0 e(n) = 0.0d0 do23477 l = 1,n j = 0 h = dabs(d(l))+dabs(e(l)) if(tst1.lt.h)then tst1 = h endif do23481 m = l,n tst2 = tst1+dabs(e(m)) if(tst2.eq.tst1)then goto 23482 endif 23481 continue 23482 continue if(m.ne.l)then 23487 continue if(j.eq.30)then go to 10 endif j = j+1 l1 = l+1 l2 = l1+1 g = d(l) p = (d(l1)-g)/(2.0d0*e(l)) r = pythag(p,1.0d0) d(l) = e(l)/(p+dsign(r,p)) d(l1) = e(l)*(p+dsign(r,p)) dl1 = d(l1) h = g-d(l) if(l2.le.n)then do23494 i = l2,n d(i) = d(i)-h 23494 continue continue endif f = f+h p = d(m) c = 1.0d0 c2 = c el1 = e(l1) s = 0.0d0 mml = m-l do23496 ii = 1,mml c3 = c2 c2 = c s2 = s i = m-ii g = c*e(i) h = c*p r = pythag(p,e(i)) e(i+1) = s*r s = e(i)/r c = p/r p = c*d(i)-s*g d(i+1) = h+s*(c*g+s*d(i)) do23498 k = 1,n h = z(k,i+1) z(k,i+1) = s*z(k,i)+c*h z(k,i) = c*z(k,i)-s*h 23498 continue continue 23496 continue continue p = -s*s2*c3*el1*e(l)/dl1 e(l) = s*p d(l) = c*p tst2 = tst1+dabs(e(l)) if(.not.(tst2.le.tst1))goto 23487 continue endif d(l) = d(l)+f 23477 continue continue do23500 ii = 2,n i = ii-1 k = i p = d(i) do23502 j = ii,n if(d(j).lt.p)then k = j p = d(j) endif 23502 continue continue if(k.ne.i)then d(k) = d(i) d(i) = p do23508 j = 1,n p = z(j,i) z(j,i) = z(j,k) z(j,k) = p 23508 continue continue endif 23500 continue continue return 10 ierr = l endif return end subroutine tqlrat(n,d,e2,ierr) integer i,j,l,m,n,ii,l1,mml,ierr double precision d(n),e2(n) double precision b,c,f,g,h,p,r,s,t,epslon,pythag C Initializing b, c and making sure ierr is not globbered c = 0.0 b = 0.0 ierr = 0 if(n.ne.1)then do23512 i = 2,n e2(i-1) = e2(i) 23512 continue continue f = 0.0d0 t = 0.0d0 e2(n) = 0.0d0 do23514 l = 1,n j = 0 h = dabs(d(l))+dsqrt(e2(l)) if(t.le.h)then t = h b = epslon(t) c = b*b endif do23518 m = l,n if(e2(m).le.c)then goto 23519 endif 23518 continue 23519 continue if(m.ne.l)then 23524 continue if(j.eq.30)then go to 20 endif j = j+1 l1 = l+1 s = dsqrt(e2(l)) g = d(l) p = (d(l1)-g)/(2.0d0*s) r = pythag(p,1.0d0) d(l) = s/(p+dsign(r,p)) h = g-d(l) do23529 i = l1,n d(i) = d(i)-h 23529 continue continue f = f+h g = d(m) if(g.eq.0.0d0)then g = b endif h = g s = 0.0d0 mml = m-l do23533 ii = 1,mml i = m-ii p = g*h r = p+e2(i) e2(i+1) = s*r s = e2(i)/r d(i+1) = h+s*(h+d(i)) g = d(i)-e2(i)/g if(g.eq.0.0d0)then g = b endif h = g*p/r 23533 continue continue e2(l) = s*g d(l) = h if(h.eq.0.0d0)then goto 23526 endif if(dabs(e2(l)).le.dabs(c/h))then goto 23526 endif e2(l) = h*e2(l) if(.not.(e2(l).eq.0.0d0))goto 23524 23526 continue endif p = d(l)+f if(l.ne.1)then do23543 ii = 2,l i = l+2-ii if(p.ge.d(i-1))then go to 10 endif d(i) = d(i-1) 23543 continue continue endif i = 1 10 d(i) = p 23514 continue continue return 20 ierr = l endif return end subroutine tred1(nm,n,a,d,e,e2) integer i,j,k,l,n,ii,nm,jp1 double precision a(nm,n),d(n),e(n),e2(n) double precision f,g,h,scale do23547 i = 1,n d(i) = a(n,i) a(n,i) = a(i,i) 23547 continue continue do23549 ii = 1,n i = n+1-ii l = i-1 h = 0.0d0 scale = 0.0d0 if(l.ge.1)then do23553 k = 1,l scale = scale+dabs(d(k)) 23553 continue continue if(scale.eq.0.0d0)then do23557 j = 1,l d(j) = a(l,j) a(l,j) = a(i,j) a(i,j) = 0.0d0 23557 continue continue else do23559 k = 1,l d(k) = d(k)/scale h = h+d(k)*d(k) 23559 continue continue e2(i) = scale*scale*h f = d(l) g = -dsign(dsqrt(h),f) e(i) = scale*g h = h-f*g d(l) = f-g if(l.ne.1)then do23563 j = 1,l e(j) = 0.0d0 23563 continue continue do23565 j = 1,l f = d(j) g = e(j)+a(j,j)*f jp1 = j+1 if(l.ge.jp1)then do23569 k = jp1,l g = g+a(k,j)*d(k) e(k) = e(k)+a(k,j)*f 23569 continue continue endif e(j) = g 23565 continue continue f = 0.0d0 do23571 j = 1,l e(j) = e(j)/h f = f+e(j)*d(j) 23571 continue continue h = f/(h+h) do23573 j = 1,l e(j) = e(j)-h*d(j) 23573 continue continue do23575 j = 1,l f = d(j) g = e(j) do23577 k = j,l a(k,j) = a(k,j)-f*e(k)-g*d(k) 23577 continue continue 23575 continue continue endif do23579 j = 1,l f = d(j) d(j) = a(l,j) a(l,j) = a(i,j) a(i,j) = f*scale 23579 continue continue goto 23549 endif endif e(i) = 0.0d0 e2(i) = 0.0d0 23549 continue continue return end subroutine tred2(nm,n,a,d,e,z) integer i,j,k,l,n,ii,nm,jp1 double precision a(nm,n),d(n),e(n),z(nm,n) double precision f,g,h,hh,scale do23581 i = 1,n do23583 j = i,n z(j,i) = a(j,i) 23583 continue continue d(i) = a(n,i) 23581 continue continue if(n.ne.1)then do23587 ii = 2,n i = n+2-ii l = i-1 h = 0.0d0 scale = 0.0d0 if(l.ge.2)then do23591 k = 1,l scale = scale+dabs(d(k)) 23591 continue continue if(scale.ne.0.0d0)then do23595 k = 1,l d(k) = d(k)/scale h = h+d(k)*d(k) 23595 continue continue f = d(l) g = -dsign(dsqrt(h),f) e(i) = scale*g h = h-f*g d(l) = f-g do23597 j = 1,l e(j) = 0.0d0 23597 continue continue do23599 j = 1,l f = d(j) z(j,i) = f g = e(j)+z(j,j)*f jp1 = j+1 if(l.ge.jp1)then do23603 k = jp1,l g = g+z(k,j)*d(k) e(k) = e(k)+z(k,j)*f 23603 continue continue endif e(j) = g 23599 continue continue f = 0.0d0 do23605 j = 1,l e(j) = e(j)/h f = f+e(j)*d(j) 23605 continue continue hh = f/(h+h) do23607 j = 1,l e(j) = e(j)-hh*d(j) 23607 continue continue do23609 j = 1,l f = d(j) g = e(j) do23611 k = j,l z(k,j) = z(k,j)-f*e(k)-g*d(k) 23611 continue continue d(j) = z(l,j) z(i,j) = 0.0d0 23609 continue continue go to 10 endif endif e(i) = d(l) do23613 j = 1,l d(j) = z(l,j) z(i,j) = 0.0d0 z(j,i) = 0.0d0 23613 continue continue 10 d(i) = h 23587 continue continue do23615 i = 2,n l = i-1 z(n,l) = z(l,l) z(l,l) = 1.0d0 h = d(i) if(h.ne.0.0d0)then do23619 k = 1,l d(k) = z(k,i)/h 23619 continue continue do23621 j = 1,l g = 0.0d0 do23623 k = 1,l g = g+z(k,i)*z(k,j) 23623 continue continue do23625 k = 1,l z(k,j) = z(k,j)-g*d(k) 23625 continue continue 23621 continue continue endif do23627 k = 1,l z(k,i) = 0.0d0 23627 continue continue 23615 continue continue endif do23629 i = 1,n d(i) = z(n,i) z(n,i) = 0.0d0 23629 continue continue z(n,n) = 1.0d0 e(1) = 0.0d0 return end subroutine dmatp(x,dx,y,dy,z) integer dx(2),dy(2) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j n=dx(1) p=dx(2) q=dy(2) do23631 i = 1,n jj = 1 ij = i do23633 j = 1, q z(ij) = ddot(p,x(i),n,y(jj),1) if(j.lt.q)then jj = jj + p ij = ij + n endif 23633 continue continue 23631 continue continue return end subroutine dmatpt(x,dx,y,dy,z) integer dx(2),dy(2) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j,ii n=dx(1) p=dx(2) q=dy(2) ii=1 do23637 i = 1,p jj = 1 ij = i do23639 j = 1, q z(ij) = ddot(n,x(ii),1,y(jj),1) if(j.lt.q)then jj = jj + n ij = ij + p endif 23639 continue continue ii = ii +n 23637 continue continue return end subroutine matpm(x,dx,mmx,mx,y,dy,mmy,my,z) integer dx(2),dy(2) integer mmx(*), mmy(*) integer mx(*), my(*) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j n=dx(1) p=dx(2) q=dy(2) call rowmis(mmx,dx(1),dx(2),mx) call colmis(mmy,dy(1),dy(2),my) do23643 i = 1,n jj = 1 ij = i do23645 j = 1, q if(.not.(mx(i).ne.0 .or. my(j).ne.0))then z(ij) = ddot(p,x(i),n,y(jj),1) endif if(j.lt.q)then jj = jj + p ij = ij + n endif 23645 continue continue 23643 continue continue return end subroutine matptm(x,dx,mmx,mx,y,dy,mmy,my,z) integer dx(2),dy(2) integer mmx(*), mmy(*) integer mx(*), my(*) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j call colmis(mmx,dx(1),dx(2),mx) call colmis(mmy,dy(1),dy(2),my) n=dx(1) p=dx(2) q=dy(2) ii=1 do23651 i = 1,p jj = 1 ij = i do23653 j = 1, q if(.not.(mx(i).ne.0 .or. my(j).ne.0))then z(ij) = ddot(n,x(ii),1,y(jj),1) endif if(j.lt.q)then jj = jj + n ij = ij + p endif 23653 continue continue ii = ii +n 23651 continue continue return end subroutine rowmis(m,n,p,vec) integer n,p integer m(n,p) integer vec(*) do23659 i = 1,n vec(i)=0 do23661 j = 1,p if(m(i,j).ne.0)then vec(i) = 1 endif 23661 continue continue 23659 continue continue return end subroutine colmis(m,n,p,vec) integer n,p integer m(n,p) integer vec(*) do23665 j = 1,p vec(j)=0 do23667 i = 1,n if(m(i,j).ne.0)then vec(j) = 1 endif 23667 continue continue 23665 continue continue return end subroutine dshift(x,ldx,n,j,k) integer ldx,n,j,k double precision x(ldx,k),tt integer i,jj if(k.gt.j)then do23790 i = 1,n tt = x(i,j) do23792 jj = j+1,k x(i,jj-1) = x(i,jj) 23792 continue continue x(i,k) = tt 23790 continue continue endif return end subroutine rtod(dx,dy,n) real dx(*) double precision dy(*) integer i,m,mp1,n if(n.gt.0)then m = mod(n,7) if(m.ne.0)then do23798 i = 1,m dy(i) = dx(i) 23798 continue continue if(n.lt.7)then return endif endif mp1 = m+1 do23802 i = mp1,n,7 dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) 23802 continue continue endif return end subroutine dtor(dx,dy,n) double precision dx(*) real dy(*) integer i,m,mp1,n if(n.gt.0)then m = mod(n,7) if(m.ne.0)then do23808 i = 1,m dy(i) = real(dx(i)) 23808 continue continue if(n.lt.7)then return endif endif mp1 = m+1 do23812 i = mp1,n,7 dy(i) = real(dx(i)) dy(i+1) = real(dx(i+1)) dy(i+2) = real(dx(i+2)) dy(i+3) = real(dx(i+3)) dy(i+4) = real(dx(i+4)) dy(i+5) = real(dx(i+5)) dy(i+6) = real(dx(i+6)) 23812 continue continue endif return end subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) integer ldx,n,k,job,info double precision x(ldx,*),qraux(*),y(*),qy(*),qty(*),b(*),rsd(*),x *b(*) integer i,j,jj,ju,kp1 double precision ddot,t,temp logical cb,cqy,cqty,cr,cxb info = 0 cqy = job/10000.ne.0 cqty = mod(job,10000).ne.0 cb = mod(job,1000)/100.ne.0 cr = mod(job,100)/10.ne.0 cxb = mod(job,10).ne.0 ju = min0(k,n-1) if(ju.eq.0)then if(cqy)then qy(1) = y(1) endif if(cqty)then qty(1) = y(1) endif if(cxb)then xb(1) = y(1) endif if(cb)then if(x(1,1).ne.0.0d0)then b(1) = y(1)/x(1,1) else info = 1 endif endif if(cr)then rsd(1) = 0.0d0 endif else if(cqy)then call dcopy(n,y,1,qy,1) endif if(cqty)then call dcopy(n,y,1,qty,1) endif if(cqy)then do23854 jj = 1,ju j = ju-jj+1 if(qraux(j).ne.0.0d0)then temp = x(j,j) x(j,j) = qraux(j) t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,qy(j),1) x(j,j) = temp endif 23854 continue continue endif if(cqty)then do23860 j = 1,ju if(qraux(j).ne.0.0d0)then temp = x(j,j) x(j,j) = qraux(j) t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,qty(j),1) x(j,j) = temp endif 23860 continue continue endif if(cb)then call dcopy(k,qty,1,b,1) endif kp1 = k+1 if(cxb)then call dcopy(k,qty,1,xb,1) endif if(cr.and.k.lt.n)then call dcopy(n-k,qty(kp1),1,rsd(kp1),1) endif if(cxb.and.kp1.le.n)then do23872 i = kp1,n xb(i) = 0.0d0 23872 continue continue endif if(cr)then do23876 i = 1,k rsd(i) = 0.0d0 23876 continue continue endif if(cb)then do23880 jj = 1,k j = k-jj+1 if(x(j,j).eq.0.0d0)then go to 130 endif b(j) = b(j)/x(j,j) if(j.ne.1)then t = -b(j) call daxpy(j-1,t,x(1,j),1,b,1) endif 23880 continue continue go to 140 130 info = j endif 140 if(cr.or.cxb)then do23888 jj = 1,ju j = ju-jj+1 if(qraux(j).ne.0.0d0)then temp = x(j,j) x(j,j) = qraux(j) if(cr)then t = -ddot(n-j+1,x(j,j),1,rsd(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,rsd(j),1) endif if(cxb)then t = -ddot(n-j+1,x(j,j),1,xb(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,xb(j),1) endif x(j,j) = temp endif 23888 continue continue endif endif return end subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info) integer ldx,n,p,ldu,ldv,job,info double precision x(ldx,*),s(*),e(*),u(ldu,*),v(ldv,*),work(*) integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit,mm, *mm1,mp1,nct,nctp1,ncu,nrt,nrtp1 double precision ddot,t double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn,smm *1,t1,test,ztest logical wantu,wantv c Setting l, ls, c, g, b to zero just to initialize and avoid warnings l = 0 ls = 0 c = 0d0 g = 0d0 b = 0d0 maxit = 30 wantu = .false. wantv = .false. jobu = mod(job,100)/10 ncu = n if(jobu.gt.1)then ncu = min0(n,p) endif if(jobu.ne.0)then wantu = .true. endif if(mod(job,10).ne.0)then wantv = .true. endif info = 0 nct = min0(n-1,p) nrt = max0(0,min0(p-2,n)) lu = max0(nct,nrt) if(lu.ge.1)then do23904 l = 1,lu lp1 = l+1 if(l.le.nct)then s(l) = dnrm2(n-l+1,x(l,l),1) if(s(l).ne.0.0d0)then if(x(l,l).ne.0.0d0)then s(l) = dsign(s(l),x(l,l)) endif call dscal(n-l+1,1.0d0/s(l),x(l,l),1) x(l,l) = 1.0d0+x(l,l) endif s(l) = -s(l) endif if(p.ge.lp1)then do23914 j = lp1,p if(l.le.nct)then if(s(l).ne.0.0d0)then t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) endif endif e(j) = x(l,j) 23914 continue continue endif if(wantu.and.l.le.nct)then do23922 i = l,n u(i,l) = x(i,l) 23922 continue continue endif if(l.le.nrt)then e(l) = dnrm2(p-l,e(lp1),1) if(e(l).ne.0.0d0)then if(e(lp1).ne.0.0d0)then e(l) = dsign(e(l),e(lp1)) endif call dscal(p-l,1.0d0/e(l),e(lp1),1) e(lp1) = 1.0d0+e(lp1) endif e(l) = -e(l) if(lp1.le.n.and.e(l).ne.0.0d0)then do23932 i = lp1,n work(i) = 0.0d0 23932 continue continue do23934 j = lp1,p call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) 23934 continue continue do23936 j = lp1,p call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1) 23936 continue continue endif if(wantv)then do23940 i = lp1,p v(i,l) = e(i) 23940 continue continue endif endif 23904 continue continue endif m = min0(p,n+1) nctp1 = nct+1 nrtp1 = nrt+1 if(nct.lt.p)then s(nctp1) = x(nctp1,nctp1) endif if(n.lt.m)then s(m) = 0.0d0 endif if(nrtp1.lt.m)then e(nrtp1) = x(nrtp1,m) endif e(m) = 0.0d0 if(wantu)then if(ncu.ge.nctp1)then do23952 j = nctp1,ncu do23954 i = 1,n u(i,j) = 0.0d0 23954 continue continue u(j,j) = 1.0d0 23952 continue continue endif if(nct.ge.1)then do23958 ll = 1,nct l = nct-ll+1 if(s(l).eq.0.0d0)then do23962 i = 1,n u(i,l) = 0.0d0 23962 continue continue u(l,l) = 1.0d0 else lp1 = l+1 if(ncu.ge.lp1)then do23966 j = lp1,ncu t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) call daxpy(n-l+1,t,u(l,l),1,u(l,j),1) 23966 continue continue endif call dscal(n-l+1,-1.0d0,u(l,l),1) u(l,l) = 1.0d0+u(l,l) lm1 = l-1 if(lm1.ge.1)then do23970 i = 1,lm1 u(i,l) = 0.0d0 23970 continue continue endif endif 23958 continue continue endif endif if(wantv)then do23974 ll = 1,p l = p-ll+1 lp1 = l+1 if(l.le.nrt)then if(e(l).ne.0.0d0)then do23980 j = lp1,p t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) 23980 continue continue endif endif do23982 i = 1,p v(i,l) = 0.0d0 23982 continue continue v(l,l) = 1.0d0 23974 continue continue endif mm = m iter = 0 23984 continue if(m.eq.0)then return endif if(iter.ge.maxit)then goto 23986 endif do23991 ll = 1,m l = m-ll if(l.eq.0)then goto 23992 endif test = dabs(s(l))+dabs(s(l+1)) ztest = test+dabs(e(l)) if(ztest.eq.test)then go to 150 endif 23991 continue 23992 continue go to 160 150 e(l) = 0.0d0 160 if(l.eq.m-1)then kase = 4 else lp1 = l+1 mp1 = m+1 do23999 lls = lp1,mp1 ls = m-lls+lp1 if(ls.eq.l)then goto 24000 endif test = 0.0d0 if(ls.ne.m)then test = test+dabs(e(ls)) endif if(ls.ne.l+1)then test = test+dabs(e(ls-1)) endif ztest = test+dabs(s(ls)) if(ztest.eq.test)then go to 170 endif 23999 continue 24000 continue go to 180 170 s(ls) = 0.0d0 180 if(ls.eq.l)then kase = 3 else if(ls.eq.m)then kase = 1 else kase = 2 l = ls endif endif endif l = l+1 I24013=(kase) goto 24013 24015 continue mm1 = m-1 f = e(m-1) e(m-1) = 0.0d0 do24016 kk = l,mm1 k = mm1-kk+l t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 if(k.ne.l)then f = -sn*e(k-1) e(k-1) = cs*e(k-1) endif if(wantv)then call drot(p,v(1,k),1,v(1,m),1,cs,sn) endif 24016 continue continue goto 24014 24022 continue f = e(l-1) e(l-1) = 0.0d0 do24023 k = l,m t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 f = -sn*e(k) e(k) = cs*e(k) if(wantu)then call drot(n,u(1,k),1,u(1,l-1),1,cs,sn) endif 24023 continue continue goto 24014 24027 continue scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)),dabs(s(l)),dabs *(e(l))) sm = s(m)/scale smm1 = s(m-1)/scale emm1 = e(m-1)/scale sl = s(l)/scale el = e(l)/scale b = ((smm1+sm)*(smm1-sm)+emm1**2)/2.0d0 c = (sm*emm1)**2 shift = 0.0d0 if(b.ne.0.0d0.or.c.ne.0.0d0)then shift = dsqrt(b**2+c) if(b.lt.0.0d0)then shift = -shift endif shift = c/(b+shift) endif f = (sl+sm)*(sl-sm)+shift g = sl*el mm1 = m-1 do24032 k = l,mm1 call drotg(f,g,cs,sn) if(k.ne.l)then e(k-1) = f endif f = cs*s(k)+sn*e(k) e(k) = cs*e(k)-sn*s(k) g = sn*s(k+1) s(k+1) = cs*s(k+1) if(wantv)then call drot(p,v(1,k),1,v(1,k+1),1,cs,sn) endif call drotg(f,g,cs,sn) s(k) = f f = cs*e(k)+sn*s(k+1) s(k+1) = -sn*e(k)+cs*s(k+1) g = sn*e(k+1) e(k+1) = cs*e(k+1) if(wantu.and.k.lt.n)then call drot(n,u(1,k),1,u(1,k+1),1,cs,sn) endif 24032 continue continue e(m-1) = f iter = iter+1 goto 24014 24040 continue if(s(l).lt.0.0d0)then s(l) = -s(l) if(wantv)then call dscal(p,-1.0d0,v(1,l),1) endif endif 24045 if(l.ne.mm)then if(s(l).ge.s(l+1))then goto 24046 endif t = s(l) s(l) = s(l+1) s(l+1) = t if(wantv.and.l.lt.p)then call dswap(p,v(1,l),1,v(1,l+1),1) endif if(wantu.and.l.lt.n)then call dswap(n,u(1,l),1,u(1,l+1),1) endif l = l+1 goto 24045 endif 24046 continue iter = 0 m = m-1 goto 24014 24013 continue if (I24013.eq.1)goto 24015 if (I24013.eq.2)goto 24022 if (I24013.eq.3)goto 24027 if (I24013.eq.4)goto 24040 24014 continue goto 23984 23986 continue info = m return end subroutine dbksl(x,p,k,b,q,info) integer p,k,q,info double precision x(p,p),b(p,q) double precision t integer j,l info = 0 j=k 24053 if(.not.(j.gt.0))goto 24055 if(x(j,j).eq.0.0d0)then info = j goto 24055 endif l=1 24058 if(.not.(l.le.q))goto 24060 b(j,l) = b(j,l)/x(j,j) if(j.ne.1)then t = -b(j,l) call daxpy(j-1,t,x(1,j),1,b(1,l),1) endif l = l+1 goto 24058 24060 continue j = j-1 goto 24053 24055 continue return end subroutine dtrsl(t,ldt,n,b,job,info) integer ldt,n,job,info double precision t(ldt,*),b(*) double precision ddot,temp integer which,j,jj do24063 info = 1,n if(t(info,info).eq.0.0d0)then return endif 24063 continue continue info = 0 which = 1 if(mod(job,10).ne.0)then which = 2 endif if(mod(job,100)/10.ne.0)then which = which+2 endif I24071=(which) goto 24071 24073 continue b(1) = b(1)/t(1,1) if(n.ge.2)then do24076 j = 2,n temp = -b(j-1) call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1) b(j) = b(j)/t(j,j) 24076 continue continue endif goto 24072 24078 continue b(n) = b(n)/t(n,n) if(n.ge.2)then do24081 jj = 2,n j = n-jj+1 temp = -b(j+1) call daxpy(j,temp,t(1,j+1),1,b(1),1) b(j) = b(j)/t(j,j) 24081 continue continue endif goto 24072 24083 continue b(n) = b(n)/t(n,n) if(n.ge.2)then do24086 jj = 2,n j = n-jj+1 b(j) = b(j)-ddot(jj-1,t(j+1,j),1,b(j+1),1) b(j) = b(j)/t(j,j) 24086 continue continue endif goto 24072 24088 continue b(1) = b(1)/t(1,1) if(n.ge.2)then do24091 j = 2,n b(j) = b(j)-ddot(j-1,t(1,j),1,b(1),1) b(j) = b(j)/t(j,j) 24091 continue continue endif goto 24072 24071 continue if (I24071.eq.1)goto 24073 if (I24071.eq.2)goto 24078 if (I24071.eq.3)goto 24083 if (I24071.eq.4)goto 24088 24072 continue return end gam/src/loessc.c0000644000176200001440000003317614531502410013246 0ustar liggesusers/* * The authors of this software are Cleveland, Grosse, and Shyu. * Copyright (c) 1989, 1992 by AT&T. * Permission to use, copy, modify, and distribute this software for any * purpose without fee is hereby granted, provided that this entire notice * is included in all copies of any software which is or includes a copy * or modification of this software and in all copies of the supporting * documentation for such software. * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED * WARRANTY. IN PARTICULAR, NEITHER THE AUTHORS NOR AT&T MAKE ANY * REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY * OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE. */ /* * Altered by B.D. Ripley to use F77_*, declare routines before use. * * 'protoize'd to ANSI C headers; indented: M.Maechler */ #include #define USE_FC_LEN_T #include /* Forward declarations */ static void loess_workspace(int *d, int *n, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, int *setLf); static void loess_prune(int *parameter, int *a, double *xi, double *vert, double *vval); static void loess_grow (int *parameter, int *a, double *xi, double *vert, double *vval); /* These (and many more) are in ./loessf.f : */ void F77_NAME(lowesa)(double*, int*, int*, int*, int*, double*, double*); void F77_NAME(lowesb)(double*, double*, double*, double*, int*, int*, int*, int*, double*); void F77_NAME(lowesc)(int*, double*, double*, double*, double*, double*); void F77_NAME(lowesd)(int*, int*, int*, int*, double*, int*, int*, double*, int*, int*, int*); void F77_NAME(lowese)(int*, int*, int*, double*, int*, double*, double*); void F77_NAME(lowesf)(double*, double*, double*, int*, int*, int*, double*, int*, double*, double*, int*, double*); void F77_NAME(lowesl)(int*, int*, int*, double*, int*, double*, double*); void F77_NAME(ehg169)(int*, int*, int*, int*, int*, int*, double*, int*, double*, int*, int*, int*); void F77_NAME(ehg196)(int*, int*, double*, double*); /* exported (for loessf.f) : */ void F77_SUB(ehg182)(int *i); #ifdef FC_LEN_T # include void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc, FC_LEN_T c1); void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc, FC_LEN_T c1); #else void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc); void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc); #endif #undef min #undef max #define min(x,y) ((x) < (y) ? (x) : (y)) #define max(x,y) ((x) > (y) ? (x) : (y)) #define GAUSSIAN 1 #define SYMMETRIC 0 static int *iv, liv, lv, tau; static double *v; /* these are set in an earlier call to loess_workspace or loess_grow */ static void loess_free(void) { Free(v); Free(iv); } void loess_raw(double *y, double *x, double *weights, double *robust, int *d, int *n, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, double *cell, char **surf_stat, double *surface, int *parameter, int *a, double *xi, double *vert, double *vval, double *diagonal, double *trL, double *one_delta, double *two_delta, int *setLf) { int zero = 0, one = 1, two = 2, nsing, i, k; double dzero = 0; double *hat_matrix, *LL; *trL = 0; loess_workspace(d, n, span, degree, nonparametric, drop_square, sum_drop_sqr, setLf); v[1] = *cell;/* = v(2) in Fortran (!) */ if(!strcmp(*surf_stat, "interpolate/none")) { F77_CALL(lowesb)(x, y, robust, &dzero, &zero, iv, &liv, &lv, v); F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface); loess_prune(parameter, a, xi, vert, vval); } else if (!strcmp(*surf_stat, "direct/none")) { F77_CALL(lowesf)(x, y, robust, iv, &liv, &lv, v, n, x, &dzero, &zero, surface); } else if (!strcmp(*surf_stat, "interpolate/1.approx")) { F77_CALL(lowesb)(x, y, weights, diagonal, &one, iv, &liv, &lv, v); F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface); nsing = iv[29]; for(i = 0; i < (*n); i++) *trL = *trL + diagonal[i]; F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta); loess_prune(parameter, a, xi, vert, vval); } else if (!strcmp(*surf_stat, "interpolate/2.approx")) { F77_CALL(lowesb)(x, y, robust, &dzero, &zero, iv, &liv, &lv, v); F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface); nsing = iv[29]; F77_CALL(ehg196)(&tau, d, span, trL); F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta); loess_prune(parameter, a, xi, vert, vval); } else if (!strcmp(*surf_stat, "direct/approximate")) { F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, n, x, diagonal, &one, surface); nsing = iv[29]; for(i = 0; i < (*n); i++) *trL = *trL + diagonal[i]; F77_CALL(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta); } else if (!strcmp(*surf_stat, "interpolate/exact")) { hat_matrix = (double *) R_alloc((*n)*(*n), sizeof(double)); LL = (double *) R_alloc((*n)*(*n), sizeof(double)); F77_CALL(lowesb)(x, y, weights, diagonal, &one, iv, &liv, &lv, v); F77_CALL(lowesl)(iv, &liv, &lv, v, n, x, hat_matrix); F77_CALL(lowesc)(n, hat_matrix, LL, trL, one_delta, two_delta); F77_CALL(lowese)(iv, &liv, &lv, v, n, x, surface); loess_prune(parameter, a, xi, vert, vval); } else if (!strcmp(*surf_stat, "direct/exact")) { hat_matrix = (double *) R_alloc((*n)*(*n), sizeof(double)); LL = (double *) R_alloc((*n)*(*n), sizeof(double)); F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, n, x, hat_matrix, &two, surface); F77_CALL(lowesc)(n, hat_matrix, LL, trL, one_delta, two_delta); k = (*n) + 1; for(i = 0; i < (*n); i++) diagonal[i] = hat_matrix[i * k]; } loess_free(); } void loess_dfit(double *y, double *x, double *x_evaluate, double *weights, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, int *d, int *n, int *m, double *fit) { int zero = 0; double dzero = 0; loess_workspace(d, n, span, degree, nonparametric, drop_square, sum_drop_sqr, &zero); F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m, x_evaluate, &dzero, &zero, fit); loess_free(); } void loess_dfitse(double *y, double *x, double *x_evaluate, double *weights, double *robust, int *family, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, int *d, int *n, int *m, double *fit, double *L) { int zero = 0, two = 2; double dzero = 0; loess_workspace(d, n, span, degree, nonparametric, drop_square, sum_drop_sqr, &zero); if(*family == GAUSSIAN) F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m, x_evaluate, L, &two, fit); else if(*family == SYMMETRIC) { F77_CALL(lowesf)(x, y, weights, iv, &liv, &lv, v, m, x_evaluate, L, &two, fit); F77_CALL(lowesf)(x, y, robust, iv, &liv, &lv, v, m, x_evaluate, &dzero, &zero, fit); } loess_free(); } void loess_ifit(int *parameter, int *a, double *xi, double *vert, double *vval, int *m, double *x_evaluate, double *fit) { loess_grow(parameter, a, xi, vert, vval); F77_CALL(lowese)(iv, &liv, &lv, v, m, x_evaluate, fit); loess_free(); } void loess_ise(double *y, double *x, double *x_evaluate, double *weights, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, double *cell, int *d, int *n, int *m, double *fit, double *L) { int zero = 0, one = 1; double dzero = 0; loess_workspace(d, n, span, degree, nonparametric, drop_square, sum_drop_sqr, &one); v[1] = *cell; F77_CALL(lowesb)(x, y, weights, &dzero, &zero, iv, &liv, &lv, v); F77_CALL(lowesl)(iv, &liv, &lv, v, m, x_evaluate, L); loess_free(); } void loess_workspace(int *d, int *n, double *span, int *degree, int *nonparametric, int *drop_square, int *sum_drop_sqr, int *setLf) { int D, N, tau0, nvmax, nf, version = 106, i; D = *d; N = *n; nvmax = max(200, N); nf = min(N, (int) floor(N * (*span) + 1e-5)); if(nf <= 0) error("span is too small"); tau0 = ((*degree) > 1) ? (int)((D + 2) * (D + 1) * 0.5) : (D + 1); tau = tau0 - (*sum_drop_sqr); lv = 50 + (3 * D + 3) * nvmax + N + (tau0 + 2) * nf; liv = 50 + ((int)pow((double)2, (double)D) + 4) * nvmax + 2 * N; if(*setLf) { lv = lv + (D + 1) * nf * nvmax; liv = liv + nf * nvmax; } iv = Calloc(liv, int); v = Calloc(lv, double); F77_CALL(lowesd)(&version, iv, &liv, &lv, v, d, n, span, degree, &nvmax, setLf); iv[32] = *nonparametric; for(i = 0; i < D; i++) iv[i + 40] = drop_square[i]; } static void loess_prune(int *parameter, int *a, double *xi, double *vert, double *vval) { int d, vc, a1, v1, xi1, vv1, nc, nv, nvmax, i, k; d = iv[1]; vc = iv[3] - 1; nc = iv[4]; nv = iv[5]; a1 = iv[6] - 1; v1 = iv[10] - 1; xi1 = iv[11] - 1; vv1 = iv[12] - 1; nvmax = iv[13]; for(i = 0; i < 5; i++) parameter[i] = iv[i + 1]; parameter[5] = iv[21] - 1; parameter[6] = iv[14] - 1; for(i = 0; i < d; i++){ k = nvmax * i; vert[i] = v[v1 + k]; vert[i + d] = v[v1 + vc + k]; } for(i = 0; i < nc; i++) { xi[i] = v[xi1 + i]; a[i] = iv[a1 + i]; } k = (d + 1) * nv; for(i = 0; i < k; i++) vval[i] = v[vv1 + i]; } static void loess_grow(int *parameter, int *a, double *xi, double *vert, double *vval) { int d, vc, nc, nv, a1, v1, xi1, vv1, i, k; d = parameter[0]; vc = parameter[2]; nc = parameter[3]; nv = parameter[4]; liv = parameter[5]; lv = parameter[6]; iv = Calloc(liv, int); v = Calloc(lv, double); iv[1] = d; iv[2] = parameter[1]; iv[3] = vc; iv[5] = iv[13] = nv; iv[4] = iv[16] = nc; iv[6] = 50; iv[7] = iv[6] + nc; iv[8] = iv[7] + vc * nc; iv[9] = iv[8] + nc; iv[10] = 50; iv[12] = iv[10] + nv * d; iv[11] = iv[12] + (d + 1) * nv; iv[27] = 173; v1 = iv[10] - 1; xi1 = iv[11] - 1; a1 = iv[6] - 1; vv1 = iv[12] - 1; for(i = 0; i < d; i++) { k = nv * i; v[v1 + k] = vert[i]; v[v1 + vc - 1 + k] = vert[i + d]; } for(i = 0; i < nc; i++) { v[xi1 + i] = xi[i]; iv[a1 + i] = a[i]; } k = (d + 1) * nv; for(i = 0; i < k; i++) v[vv1 + i] = vval[i]; F77_CALL(ehg169)(&d, &vc, &nc, &nc, &nv, &nv, v+v1, iv+a1, v+xi1, iv+iv[7]-1, iv+iv[8]-1, iv+iv[9]-1); } /* begin ehg's FORTRAN-callable C-codes */ void F77_SUB(ehg182)(int *i) { char *msg, msg2[100]; #define MSG(_m_) msg = _m_ ; break ; switch(*i){ case 100:MSG("wrong version number in lowesd. Probably typo in caller.") case 101:MSG("d>dMAX in ehg131. Need to recompile with increased dimensions.") case 102:MSG("liv too small. (Discovered by lowesd)") case 103:MSG("lv too small. (Discovered by lowesd)") case 104:MSG("span too small. fewer data values than degrees of freedom.") case 105:MSG("k>d2MAX in ehg136. Need to recompile with increased dimensions.") case 106:MSG("lwork too small") case 107:MSG("invalid value for kernel") case 108:MSG("invalid value for ideg") case 109:MSG("lowstt only applies when kernel=1.") case 110:MSG("not enough extra workspace for robustness calculation") case 120:MSG("zero-width neighborhood. make span bigger") case 121:MSG("all data on boundary of neighborhood. make span bigger") case 122:MSG("extrapolation not allowed with blending") case 123:MSG("ihat=1 (diag L) in l2fit only makes sense if z=x (eval=data).") case 171:MSG("lowesd must be called first.") case 172:MSG("lowesf must not come between lowesb and lowese, lowesr, or lowesl.") case 173:MSG("lowesb must come before lowese, lowesr, or lowesl.") case 174:MSG("lowesb need not be called twice.") case 175:MSG("need setLf=.true. for lowesl.") case 180:MSG("nv>nvmax in cpvert.") case 181:MSG("nt>20 in eval.") case 182:MSG("svddc failed in l2fit.") case 183:MSG("didnt find edge in vleaf.") case 184:MSG("zero-width cell found in vleaf.") case 185:MSG("trouble descending to leaf in vleaf.") case 186:MSG("insufficient workspace for lowesf.") case 187:MSG("insufficient stack space") case 188:MSG("lv too small for computing explicit L") case 191:MSG("computed trace L was negative; something is wrong!") case 192:MSG("computed delta was negative; something is wrong!") case 193:MSG("workspace in loread appears to be corrupted") case 194:MSG("trouble in l2fit/l2tr") case 195:MSG("only constant, linear, or quadratic local models allowed") case 196:MSG("degree must be at least 1 for vertex influence matrix") case 999:MSG("not yet implemented") default: snprintf(msg=msg2, sizeof(msg2), "Assert failed; error code %d\n",*i); } warning("%s",msg); } #undef MSG #ifdef FC_LEN_T void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc, FC_LEN_T c1) #else void F77_SUB(ehg183a)(char *s, int *nc,int *i,int *n,int *inc) #endif { char mess[4000], num[20]; int j; strncpy(mess,s,*nc); mess[*nc] = '\0'; for (j=0; j<*n; j++) { snprintf(num, sizeof(num), " %d",i[j * *inc]); strcat(mess,num); } strcat(mess,"\n"); warning("%s",mess); } #ifdef FC_LEN_T void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc, FC_LEN_T c1) #else void F77_SUB(ehg184a)(char *s, int *nc, double *x, int *n, int *inc) #endif { char mess[4000], num[30]; int j; strncpy(mess,s,*nc); mess[*nc] = '\0'; for (j=0; j<*n; j++) { snprintf(num, sizeof(num), " %.5g",x[j * *inc]); strcat(mess,num); } strcat(mess,"\n"); warning("%s",mess); } gam/src/bvalue.f0000644000176200001440000001350714332261034013236 0ustar liggesusers double precision function bvalue(t,lent,bcoef,n,k,x,jderiv) c Calculates value at x of jderiv-th derivative of spline from B-repr. c The spline is taken to be continuous from the right. c C calls interv c c****** i n p u t ****** c t, bcoef, n, k......forms the b-representation of the spline f to c be evaluated. specifically, c t.....knot sequence, of length n+k, assumed nondecreasing. c bcoef.....b-coefficient sequence, of length n . c n.....length of bcoef and dimension of s(k,t), c a s s u m e d positive . c k.....order of the spline . c c w a r n i n g . . . the restriction k <= kmax (=20) is imposed c arbitrarily by the dimension statement for aj, dm, dm below, c but is n o w h e r e c h e c k e d for. c however in R, this is only called from bvalus() with k=4 anyway! c c x.....the point at which to evaluate . c jderiv.....integer giving the order of the derivative to be evaluated c a s s u m e d to be zero or positive. c c****** o u t p u t ****** c bvalue.....the value of the (jderiv)-th derivative of f at x . c c****** m e t h o d ****** c the nontrivial knot interval (t(i),t(i+1)) containing x is lo- c cated with the aid of interv(). the k b-coeffs of f relevant for c this interval are then obtained from bcoef (or taken to be zero if c not explicitly available) and are then differenced jderiv times to c obtain the b-coeffs of (d^jderiv)f relevant for that interval. c precisely, with j = jderiv, we have from x.(12) of the text that c c (d^j)f = sum ( bcoef(.,j)*b(.,k-j,t) ) c c where c / bcoef(.), , j .eq. 0 c / c bcoef(.,j) = / bcoef(.,j-1) - bcoef(.-1,j-1) c / ----------------------------- , j > 0 c / (t(.+k-j) - t(.))/(k-j) c c then, we use repeatedly the fact that c c sum ( a(.)*b(.,m,t)(x) ) = sum ( a(.,x)*b(.,m-1,t)(x) ) c with c (x - t(.))*a(.) + (t(.+m-1) - x)*a(.-1) c a(.,x) = --------------------------------------- c (x - t(.)) + (t(.+m-1) - x) c c to write (d^j)f(x) eventually as a linear combination of b-splines c of order 1 , and the coefficient for b(i,1,t)(x) must then c be the desired number (d^j)f(x). (see x.(17)-(19) of text). c C Arguments integer lent, n,k, jderiv DOUBLE precision t(*),bcoef(n),x c dimension t(n+k) c current fortran standard makes it impossible to specify the length of c t precisely without the introduction of otherwise superfluous c additional arguments. C Local Variables integer kmax parameter(kmax = 20) DOUBLE precision aj(kmax),dm(kmax),dp(kmax),fkmj integer i,ilo,imk,j,jc,jcmin,jcmax,jj,km1,kmj,mflag,nmi, jdrvp1 c integer interv external interv c initialize data i/1/ c Just setting lent to avoid warnings of unusued variable lent = 1 bvalue = 0. if (jderiv .ge. k) go to 99 c c *** find i s.t. 1 <= i < n+k and t(i) < t(i+1) and c t(i) <= x < t(i+1) . if no such i can be found, x lies c outside the support of the spline f and bvalue = 0. c {this case is handled in the calling R code} c (the asymmetry in this choice of i makes f rightcontinuous) if( (x.ne.t(n+1)) .or. (t(n+1).ne.t(n+k)) ) then i = interv ( t, n+k, x, 0, 0, i, mflag) if (mflag .ne. 0) then call rwarn("bvalue() mflag != 0: should never happen!") go to 99 endif else i = n endif c *** if k = 1 (and jderiv = 0), bvalue = bcoef(i). km1 = k - 1 if (km1 .le. 0) then bvalue = bcoef(i) go to 99 endif c c *** store the k b-spline coefficients relevant for the knot interval c (t(i),t(i+1)) in aj(1),...,aj(k) and compute dm(j) = x - t(i+1-j), c dp(j) = t(i+j) - x, j=1,...,k-1 . set any of the aj not obtainable c from input to zero. set any t.s not obtainable equal to t(1) or c to t(n+k) appropriately. jcmin = 1 imk = i - k if (imk .ge. 0) then do 9 j=1,km1 dm(j) = x - t(i+1-j) 9 continue else jcmin = 1 - imk do 5 j=1,i dm(j) = x - t(i+1-j) 5 continue do 6 j=i,km1 aj(k-j) = 0. dm(j) = dm(i) 6 continue endif c jcmax = k nmi = n - i if (nmi .ge. 0) then do 19 j=1,km1 C the following if() happens; e.g. in pp <- predict(cars.spl, xx) c - if( (i+j) .gt. lent) write(6,9911) i+j,lent c - 9911 format(' i+j, lent ',2(i6,1x)) dp(j) = t(i+j) - x 19 continue else jcmax = k + nmi do 15 j=1,jcmax dp(j) = t(i+j) - x 15 continue do 16 j=jcmax,km1 aj(j+1) = 0. dp(j) = dp(jcmax) 16 continue endif c do 21 jc=jcmin,jcmax aj(jc) = bcoef(imk + jc) 21 continue c c *** difference the coefficients jderiv times. if (jderiv .ge. 1) then do 23 j=1,jderiv kmj = k-j fkmj = dble(kmj) ilo = kmj do 24 jj=1,kmj aj(jj) = ((aj(jj+1) - aj(jj))/(dm(ilo) + dp(jj)))*fkmj ilo = ilo - 1 24 continue 23 continue endif c c *** compute value at x in (t(i),t(i+1)) of jderiv-th derivative, c given its relevant b-spline coeffs in aj(1),...,aj(k-jderiv). if (jderiv .ne. km1) then jdrvp1 = jderiv + 1 do 33 j=jdrvp1,km1 kmj = k-j ilo = kmj do 34 jj=1,kmj aj(jj) = (aj(jj+1)*dm(ilo) + aj(jj)*dp(jj)) / * (dm(ilo)+dp(jj)) ilo = ilo - 1 34 continue 33 continue endif bvalue = aj(1) c 99 return end gam/src/stxwx.f0000644000176200001440000000374510543334050013157 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 subroutine stxwx(x,z,w,k,xknot,n,y,hs0,hs1,hs2,hs3) c implicit none integer k,n DOUBLE precision x(k),z(k),w(k), xknot(n+4),y(n), & hs0(n),hs1(n),hs2(n),hs3(n) C local DOUBLE precision eps,vnikx(4,1),work(16) integer lenxk, i,j, ileft,mflag c integer interv external interv lenxk=n+4 C Initialise the output vectors do 1 i=1,n y(i)=0d0 hs0(i)=0d0 hs1(i)=0d0 hs2(i)=0d0 hs3(i)=0d0 1 continue C Compute X' W^2 X -> hs0,hs1,hs2,hs3 and X' W^2 Z -> y C Note that here the weights w(i) == sqrt(wt[i]) where wt[] where original weights ileft=1 eps= .1d-9 do 100 i=1,k ileft= interv(xknot(1), n+1, x(i), 0,0, ileft, mflag) C if(mflag==-1) {write(6,'("Error in hess ",i2)')mflag;stop} C if(mflag==-1) {return} if(mflag.eq. 1)then if(x(i).le.(xknot(ileft)+eps))then ileft=ileft-1 else return endif C else{write(6,'("Error in hess ",i2)')mflag;stop}} endif call bsplvd (xknot,lenxk,4,x(i),ileft,work,vnikx,1) j= ileft-4+1 y(j) = y(j)+w(i)**2*z(i)*vnikx(1,1) hs0(j)=hs0(j)+w(i)**2*vnikx(1,1)**2 hs1(j)=hs1(j)+w(i)**2*vnikx(1,1)*vnikx(2,1) hs2(j)=hs2(j)+w(i)**2*vnikx(1,1)*vnikx(3,1) hs3(j)=hs3(j)+w(i)**2*vnikx(1,1)*vnikx(4,1) j= ileft-4+2 y(j) = y(j)+w(i)**2*z(i)*vnikx(2,1) hs0(j)=hs0(j)+w(i)**2*vnikx(2,1)**2 hs1(j)=hs1(j)+w(i)**2*vnikx(2,1)*vnikx(3,1) hs2(j)=hs2(j)+w(i)**2*vnikx(2,1)*vnikx(4,1) j= ileft-4+3 y(j) = y(j)+w(i)**2*z(i)*vnikx(3,1) hs0(j)=hs0(j)+w(i)**2*vnikx(3,1)**2 hs1(j)=hs1(j)+w(i)**2*vnikx(3,1)*vnikx(4,1) j= ileft-4+4 y(j) = y(j)+w(i)**2*z(i)*vnikx(4,1) hs0(j)=hs0(j)+w(i)**2*vnikx(4,1)**2 100 continue return end gam/src/sgram.f0000644000176200001440000001156510543334050013072 0ustar liggesusersC Output from Public domain Ratfor, version 1.0 C PURPOSE C Calculation of the cubic B-spline smoothness prior C for "usual" interior knot setup. C Uses BSPVD and INTRV in the CMLIB C sgm[0-3](nb) Symmetric matrix C whose (i,j)'th element contains the integral of C B''(i,.) B''(j,.) , i=1,2 ... nb and j=i,...nb. C Only the upper four diagonals are computed. subroutine sgram(sg0,sg1,sg2,sg3,tb,nb) c implicit none C indices integer nb DOUBLE precision sg0(nb),sg1(nb),sg2(nb),sg3(nb), tb(nb+4) c ------------- integer ileft,mflag, i,ii,jj, lentb DOUBLE precision vnikx(4,3),work(16),yw1(4),yw2(4), wpt c integer interv external interv lentb=nb+4 C Initialise the sigma vectors do 1 i=1,nb sg0(i)=0. sg1(i)=0. sg2(i)=0. sg3(i)=0. 1 continue ileft = 1 do 2 i=1,nb C Calculate a linear approximation to the C second derivative of the non-zero B-splines C over the interval [tb(i),tb(i+1)]. C call intrv(tb(1),(nb+1),tb(i),ilo,ileft,mflag) ileft = interv(tb(1), nb+1,tb(i), 0,0, ileft, mflag) C Left end second derivatives C call bspvd (tb,4,3,tb(i),ileft,4,vnikx,work) call bsplvd (tb,lentb,4,tb(i),ileft,work,vnikx,3) C Put values into yw1 do 4 ii=1,4 yw1(ii) = vnikx(ii,3) 4 continue C Right end second derivatives C call bspvd (tb,4,3,tb(i+1),ileft,4,vnikx,work) call bsplvd (tb,lentb,4,tb(i+1),ileft,work,vnikx,3) C Slope*(length of interval) in Linear Approximation to B'' do 6 ii=1,4 yw2(ii) = vnikx(ii,3) - yw1(ii) 6 continue wpt = tb(i+1) - tb(i) C Calculate Contributions to the sigma vectors if(ileft.ge.4) then do 10 ii=1,4 jj=ii sg0(ileft-4+ii) = sg0(ileft-4+ii) + & wpt*(yw1(ii)*yw1(jj)+ & (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & + yw2(ii)*yw2(jj)*.3330) jj=ii+1 if(jj.le.4)then sg1(ileft+ii-4) = sg1(ileft+ii-4) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif jj=ii+2 if(jj.le.4)then sg2(ileft+ii-4) = sg2(ileft+ii-4) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif jj=ii+3 if(jj.le.4)then sg3(ileft+ii-4) = sg3(ileft+ii-4) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif 10 continue else if(ileft.eq.3)then do 20 ii=1,3 jj=ii sg0(ileft-3+ii) = sg0(ileft-3+ii) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) jj=ii+1 if(jj.le.3)then sg1(ileft+ii-3) = sg1(ileft+ii-3) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif jj=ii+2 if(jj.le.3)then sg2(ileft+ii-3) = sg2(ileft+ii-3) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif 20 continue else if(ileft.eq.2)then do 28 ii=1,2 jj=ii sg0(ileft-2+ii) = sg0(ileft-2+ii) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) jj=ii+1 if(jj.le.2)then sg1(ileft+ii-2) = sg1(ileft+ii-2) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) endif 28 continue else if(ileft.eq.1)then do 34 ii=1,1 jj=ii sg0(ileft-1+ii) = sg0(ileft-1+ii) + & wpt* (yw1(ii)*yw1(jj) + * (yw2(ii)*yw1(jj) + yw2(jj)*yw1(ii))*.50 & +yw2(ii)*yw2(jj)*.3330 ) 34 continue endif 2 continue return end gam/R/0000755000176200001440000000000014331605303011215 5ustar liggesusersgam/R/summary.gam.R0000644000176200001440000000665614331341323013614 0ustar liggesusers#' @rdname anova.Gam #' @method summary Gam #' @export #' @export summary.Gam "summary.Gam" <- function (object, dispersion = NULL, ...) { object.lm=object class(object.lm)="lm" paod=anova(object.lm,...) attr(paod,"heading")="Anova for Parametric Effects" save.na.action <- object$na.action object$na.action <- NULL fun <- function(assign, coeff) sum(!is.na(coeff[assign])) wt <- object$weights coef <- object$coef dresid <- residuals(object, "deviance") resid <- object$residuals n <- length(resid) s <- object$s nl.chisq <- object$nl.chisq assg <- object$assign if (is.null(assg)) assg <- attributes(object$terms)$assign df <- rep(1, length(assg)) df[is.na(object$coef)] <- 0 df <- tapply(df, assg, sum) dfnames <- attr(object$terms, "term.labels") if (attr(object$terms, "intercept")) dfnames <- c("(Intercept)", dfnames) names(df) <- dfnames df <- unlist(df) nldf <- object$nl.df n <- length(object$residuals) if (is.null(rdf <- object$df.resid)) { rdf <- n - sum(df) if (!is.null(nldf)) rdf <- rdf - sum(nldf) } if (!is.null(wt)) { wt <- wt^0.5 resid <- resid * wt excl <- wt == 0 if (any(excl)) { warning(paste(sum(excl), "rows with zero weights not counted")) resid <- resid[!excl] dresid <- dresid[!excl] if (is.null(object$df.residual)) rdf <- rdf - sum(excl) } } if (rdf > 0) phihat <- sum(resid^2)/rdf else { phihat <- Inf warning("Residual degrees of freedom are negative or zero. This occurs when the sum of the parametric and nonparametric degrees of freedom exceeds the number of observations. The model is probably too complex for the amount of data available.") } famname <- object$family[["family"]] if (is.null(famname)) famname <- "gaussian" chiorf <- TRUE if (!is.null(dispersion) && dispersion == 0) dispersion <- phihat if (is.null(dispersion)) dispersion <- switch(famname, poisson = 1, binomial = 1, { chiorf <- FALSE phihat }) names(dispersion) <- famname if (length(nldf)) { aod <- as.matrix(round(df, 1)) dimnames(aod) <- list(names(df), "Df") if (!is.null(nl.chisq)) { aod <- cbind(aod, NA, NA, NA) nl.chisq <- nl.chisq/dispersion snames <- names(nldf) aod[snames, 2] <- round(nldf, 1) aod[snames, 3] <- if (!chiorf) nl.chisq/nldf else nl.chisq aod[snames, 4] <- if (chiorf) 1 - pchisq(nl.chisq, nldf) else if (rdf > 0) 1 - pf(nl.chisq/nldf, nldf, rdf) else NA rnames <- c("Df", "Npar Df", "Npar Chisq", "P(Chi)") if (!chiorf) rnames[3:4] <- c("Npar F", "Pr(F)") dimnames(aod) <- list(names(df), rnames) heading <- "Anova for Nonparametric Effects" } else heading <- "DF for Nonparametric Terms" aod <- as.anova(data.frame(aod[,-1], check.names = FALSE), heading) } else aod <- NULL structure(list(call = object$call, terms = object$terms, anova = aod, parametric.anova=paod, dispersion = dispersion, df = c(sum(df) + sum(nldf), rdf), deviance.resid = dresid, deviance = deviance(object), null.deviance = object$null.deviance, aic = object$aic, iter = object$iter, na.action = save.na.action), class = "summary.Gam") } gam/R/gam.fit.R0000644000176200001440000001306714331341323012673 0ustar liggesusers#' @rdname gam #' @export "gam.fit" <- function (x, y, smooth.frame, weights = rep(1, nobs), start = NULL, etastart = NULL, mustart = NULL, offset = rep(0, nobs), family = gaussian(), control = gam.control()) { ynames <- if (is.matrix(y)) dimnames(y)[[1]] else names(y) xnames <- dimnames(x)[[2]] nobs <- NROW(y) nvars <- ncol(x) maxit <- control$maxit bf.maxit <- control$bf.maxit epsilon <- control$epsilon bf.epsilon <- control$bf.epsilon trace <- control$trace digits <- -log10(epsilon) + 1 if (is.null(weights)) weights <- rep.int(1, nobs) if (is.null(offset)) offset <- rep.int(0, nobs) variance <- family$variance dev.resids <- family$dev.resids aic <- family$aic linkinv <- family$linkinv mu.eta <- family$mu.eta if (!is.function(variance) || !is.function(linkinv)) stop("illegal `family' argument") valideta <- family$valideta if (is.null(valideta)) valideta <- function(eta) TRUE validmu <- family$validmu if (is.null(validmu)) validmu <- function(mu) TRUE eval(family$initialize) if (is.null(mustart)) { eval(family$initialize) } else { mukeep <- mustart eval(family$initialize) mustart <- mukeep } eta <- if (!is.null(etastart)) etastart else if (!is.null(start)) if (length(start) != nvars) stop("Length of start should equal ", nvars, " and correspond to initial coefs for ", deparse(xnames)) else { coefold <- start offset + as.vector(if (NCOL(x) == 1) x * start else x %*% start) } else family$linkfun(mustart) mu <- linkinv(eta) if (!(validmu(mu) && valideta(eta))) stop("Can't find valid starting values: please specify some") new.dev <- sum(dev.resids(y, mu, weights)) a <- attributes(attr(smooth.frame, "terms")) smoothers <- a$specials if (length(smoothers) > 0) { smoothers <- smoothers[sapply(smoothers, length) > 0] for (i in seq(along = smoothers)) { tt <- smoothers[[i]] ff <- apply(a$factors[tt, , drop = FALSE], 2, any) smoothers[[i]] <- if (any(ff)) seq(along = ff)[a$order == 1 & ff] else NULL } } if (length(smoothers) > 0) { gam.wlist=gam.smoothers()$wlist smooth.labels <- a$term.labels[unlist(smoothers)] assignx <- attr(x, "assign") assignx <- assign.list(assignx, a$term.labels) which <- assignx[smooth.labels] if (length(smoothers) > 1) bf <- "general.wam" else { sbf <- match(names(smoothers), gam.wlist, FALSE) bf <- if (sbf) paste(gam.wlist[sbf], "wam", sep = ".") else "general.wam" } bf.call <- parse(text = paste(bf, "(x, z, wz, fit$smooth, which, fit$smooth.frame,bf.maxit,bf.epsilon, trace)", sep = ""))[[1]] s <- matrix(0, length(y), length(which)) dimnames(s) <- list(names(y), names(which)) fit <- list(smooth = s, smooth.frame = smooth.frame) } else { bf.call <- expression(lm.wfit(x, z, wz, method = "qr", singular.ok = TRUE)) bf <- "lm.wfit" } old.dev <- 10 * new.dev + 10 bf.iter=integer(0) for (iter in 1:maxit) { good <- weights > 0 varmu <- variance(mu) if (any(is.na(varmu[good]))) stop("NAs in V(mu)") if (any(varmu[good] == 0)) stop("0s in V(mu)") mu.eta.val <- mu.eta(eta) if (any(is.na(mu.eta.val[good]))) stop("NAs in d(mu)/d(eta)") good <- (weights > 0) & (mu.eta.val != 0) z <- eta - offset z[good] <- z[good] + (y - mu)[good]/mu.eta.val[good] wz <- weights wz[!good] <- 0 wz[good] <- wz[good] * mu.eta.val[good]^2/varmu[good] fit <- eval(bf.call) bf.iter=c(bf.iter,fit$iter) eta <- fit$fitted.values + offset mu <- linkinv(eta) old.dev <- new.dev new.dev <- sum(dev.resids(y, mu, weights)) if (trace) cat("GAM ", bf, " loop ", iter, ": deviance = ", format(round(new.dev, digits)), " \n", sep = "") if (is.na(new.dev)) { one.more <- FALSE warning("iterations terminated prematurely because of singularities") } else one.more <- abs(old.dev - new.dev)/(old.dev + 0.1) > epsilon if (!one.more) break } fitqr <- fit$qr xxnames <- xnames[fitqr$pivot] nr <- min(sum(good), nvars) if (nr < nvars) { Rmat <- diag(nvars) Rmat[1:nr, 1:nvars] <- fitqr$qr[1:nr, 1:nvars] } else Rmat <- fitqr$qr[1:nvars, 1:nvars] Rmat <- as.matrix(Rmat) Rmat[row(Rmat) > col(Rmat)] <- 0 dimnames(Rmat) <- list(xxnames, xxnames) names(fit$residuals) <- ynames names(mu) <- ynames names(eta) <- ynames fit$additive.predictors <- eta fit$fitted.values <- mu names(fit$weights) <- ynames names(fit$effects) <- c(xxnames[seq(len = fitqr$rank)], rep.int("", sum(good) - fitqr$rank)) if (length(fit$smooth) > 0) fit$smooth.frame <- smooth.frame[smooth.labels] wtdmu <- if (a$intercept) sum(weights * y)/sum(weights) else linkinv(offset) nulldev <- sum(dev.resids(y, wtdmu, weights)) n.ok <- nobs - sum(weights == 0) nulldf <- n.ok - as.integer(a$intercept) rank <- n.ok - fit$df.residual aic.model <- aic(y, nobs, mu, weights, new.dev) + 2 * rank if (!is.null(fit$smooth)) { nonzeroWt <- (wz > 0) nl.chisq <- gam.nlchisq(fit$qr, fit$residuals, wz, fit$smooth) } else nl.chisq <- NULL fit <- c(fit, list(R = Rmat, rank = fitqr$rank, family = family, deviance = new.dev, aic = aic.model, null.deviance = nulldev, iter = iter,bf.iter=bf.iter, prior.weights = weights, y = y, df.null = nulldf, nl.chisq = nl.chisq)) fit } gam/R/general.wam.R0000644000176200001440000000564114331341323013545 0ustar liggesusers#' @export "general.wam" <- function(x, y, w, s, which, smooth.frame, maxit = 30, tol = 1e-7, trace = FALSE, se = TRUE, ...) { if(inherits(smooth.frame, "data.frame")) { data <- smooth.frame ### Note; the lev component of the smooths is the diagonal hat matrix elements ### for the NONLINEAR part of the fit. ###The smoother can return both the linear and nonlinear parts, although only ### the nonlinear part is strictly necessary. ### oldClass(data) <- NULL names.calls <- names(which) smooth.calls <- lapply(data[names.calls], attr, "call") names(smooth.calls) <- names.calls smooth.frame <- list(data = data, smooth.calls = smooth.calls) } else { data <- smooth.frame$data smooth.calls <- smooth.frame$smooth.calls } names.calls <- names(smooth.calls) y <- as.vector(y) residuals <- as.vector(y - s %*% rep(1., ncol(s))) n <- length(y) fit <- list(fitted.values = 0.) rss <- weighted.mean(residuals^2., w) rssold <- rss * 10. nit <- 0. df <- rep(NA, length(which)) var <- s if(trace) cat("\nWAM iter rss/n term\n") ndig <- - log10(tol) + 1. RATIO <- tol + 1. while(RATIO > tol & nit < maxit) { rssold <- rss nit <- nit + 1. z <- residuals + fit$fitted.values fit <- lm.wfit(x, z, w, method = "qr", singular.ok = TRUE, ...) residuals <- fit$residuals rss <- weighted.mean(residuals^2., w) if(trace) cat("\n ", nit, " ", format(round(rss, ndig)), " Parametric -- lm.wfit\n", sep = "") deltaf <- 0. for(j in seq(names.calls)) { old <- s[, j] z <- residuals + s[, j] fit.call <- eval(smooth.calls[[j]]) residuals <- as.double(fit.call$residuals) if(length(residuals) != n) stop(paste(names.calls[j], "returns a vector of the wrong length") ) s[, j] <- z - residuals deltaf <- deltaf + weighted.mean((s[, j] - old)^2., w) rss <- weighted.mean(residuals^2., w) if(trace) { cat(" ", nit, " ", format(round( rss, ndig)), " Nonparametric -- ", names.calls[j], "\n", sep = "") } df[j] <- fit.call$nl.df if(se) var[, j] <- fit.call$var } RATIO <- sqrt(deltaf/sum(w * apply(s, 1., sum)^2.)) if(trace) cat("Relative change in functions:", format(round( RATIO, ndig)), "\n") } if((nit == maxit) & maxit > 1.) warning(paste("general.wam convergence not obtained in ", maxit, " iterations")) names(df) <- names.calls if(trace) cat("\n") fit$fitted.values <- y - residuals rl <- c(fit, list(smooth = s, nl.df = df)) rl$df.residual <- rl$df.residual - sum(df) rl$iter=nit if(se) rl <- c(rl, list(var = var)) c(list(smooth.frame = smooth.frame), rl) } gam/R/na.gam.replace.R0000644000176200001440000000623514331341323014120 0ustar liggesusers#' Missing Data Filter for GAMs #' #' A method for dealing with missing values, friendly to GAM models. #' #' @param frame a model or data frame #' @return a model or data frame is returned, with the missing observations #' (NAs) replaced. The following rules are used. A factor with missing data is #' replaced by a new factor with one more level, labelled \code{"NA"}, which #' records the missing data. Ordered factors are treated similarly, except the #' result is an unordered factor. A missing numeric vector has its missing #' entires replaced by the mean of the non-missing entries. Similarly, a matrix #' with missing entries has each missing entry replace by the mean of its #' column. If \code{frame} is a model frame, the response variable can be #' identified, as can the weights (if present). Any rows for which the response #' or weight is missing are removed entirely from the model frame. #' #' The word \code{"gam"} in the name is relevant, because \code{gam()} makes #' special use of this filter. All columns of a model frame that were created #' by a call to \code{lo()} or \code{s()} have an attribute names \code{"NAs"} #' if NAs are present in their columns. Despite the replacement by means, #' these attributes remain on the object, and \code{gam()} takes appropriate #' action when smoothing against these columns. See section 7.3.2 in Hastie #' (1992) for more details. #' @author Trevor Hastie #' @seealso \code{\link{na.fail}}, \code{\link{na.omit}}, \code{\link{gam}} #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' @keywords models regression nonparametric smooth #' @examples #' #' data(airquality) #' gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace) #' #' @export na.gam.replace na.gam.replace <- function (frame) { vars <- names(frame) ##See if there is a response if(!is.null(tt <- attr(frame, "terms"))){ if (0 < (resp <- attr(tt, "response"))) { vars <- vars[-resp] x <- frame[[resp]] pos <- is.na(x) if (any(pos)) { frame <- frame[!pos, , drop = FALSE] warning(paste(sum(pos), "observations omitted due to missing values in the response")) } } } for (j in vars) { x <- frame[[j]] pos <- is.na(x) if (any(pos)) { if (length(levels(x))) { xx <- as.character(x) xx[pos] <- "NA" x <- factor(xx, exclude = NULL) } else if (is.matrix(x)) { ats <- attributes(x) w <- !pos x[pos] <- 0 n <- nrow(x) TT <- array(1, c(1, n)) xbar <- (TT %*% x)/(TT %*% w) xbar <- t(TT) %*% xbar x[pos] <- xbar[pos] attributes(x) <- ats } else { ats <- attributes(x) x[pos] <- mean(x[!pos]) attributes(x) <- ats } frame[[j]] <- x } } frame } gam/R/subset.smooth.R0000644000176200001440000000111114331341323014146 0ustar liggesusers#' @method `[` smooth #' @export "[.smooth" <- 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] if(!is.null(nas <- ats$NAs)) { if(is.null(d <- dim(x))) d <- c(length(x), 1) navec <- array(logical(d[1]), d) navec[nas, ] <- TRUE navec <- navec[...] nas <- if(is.null(dim(navec))) navec else navec[, 1] nas <- seq(nas)[nas] if(length(nas))ats$NAs <- nas else ats$NAs=NULL } attributes(y) <- c(attributes(y), ats) oldClass(y) <- cl y } gam/R/gam.control.R0000644000176200001440000000421514331341323013564 0ustar liggesusers#' Auxilliary for controlling GAM fitting #' #' Auxiliary function as user interface for 'gam' fitting. Typically only used #' when calling 'gam' or 'gam.fit'. #' #' @param epsilon convergence threshold for local scoring iterations #' @param bf.epsilon convergence threshold for backfitting iterations #' @param maxit maximum number of local scoring iterations #' @param bf.maxit maximum number of backfitting iterations #' @param trace should iteration details be printed while \code{gam} is fitting #' the model. #' @param ... placemark for additional arguments #' @return a list is returned, consisting of the five parameters, conveniently #' packaged up to supply the \code{control} argument to \code{gam}. The values #' for \code{gam.control} can be supplied directly in a call to \code{gam}; #' these are then filtered through \code{gam.control} inside \code{gam}. #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' @keywords models regression nonparametric smooth #' @examples #' #' \dontrun{gam(formula, family, control = gam.control(bf.maxit=15))} #' \dontrun{gam(formula, family, bf.maxit = 15) # these are equivalent} #' #' @export gam.control "gam.control" <- function(epsilon = 9.9999999999999995e-08, bf.epsilon = 9.9999999999999995e-08, maxit = 30, bf.maxit = 30, trace = FALSE, ...) { if(epsilon <= 0) { warning("the value of epsilon supplied is zero or negative; the default value of 1e-7 was used instead" ) epsilon <- 9.9999999999999995e-08 } if(maxit < 1) { warning("the value of maxit supplied is too small; the default value of 30 was used instead" ) maxit <- 30 } if(bf.epsilon <= 0) { warning("the value of bf.epsilon supplied is zero or negative; the default value of 1e-7 was used instead" ) bf.epsilon <- 9.9999999999999995e-08 } if(bf.maxit < 1) { warning("the value of bf.maxit supplied is too small; the default value of 30 was used instead" ) bf.maxit <- 30 } list(epsilon = epsilon, maxit = maxit, bf.epsilon = bf.epsilon, bf.maxit = bf.maxit, trace = as.logical(trace)[1]) } gam/R/gplot.default.R0000644000176200001440000000213314331341323014106 0ustar liggesusers#' @method gplot default #' @export "gplot.default" <- function(x, y, se.y = NULL, xlab = "", ylab = "", residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, fit = TRUE, ...) switch(data.class(x)[1], AsIs = { class(x)<-NULL gplot.default(x , y = y, se.y = se.y, xlab = xlab, ylab = ylab, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = fit, ...) }, logical = gplot.factor(x = factor(x), y = y, se.y = se.y, xlab = xlab, ylab = ylab, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = fit, ...), list = gplot.list(x = x, y = y, se.y = se.y, xlab = xlab, ylab = ylab, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = fit, ...), if(is.numeric(x)) gplot.numeric(x = as.vector(x), y = y, se.y = se.y, xlab = xlab, ylab = ylab, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = fit, ...) else warning(paste("The \"x\" component of \"", ylab, "\" has class \"", paste(class(x), collapse = "\", \""), "\"; no gplot() methods available", sep = "" ))) gam/R/gam.lo.R0000644000176200001440000000324114331341323012514 0ustar liggesusers#' @rdname lo #' @export "gam.lo" <- function(x, y, w = rep(1, length(y)), span = 0.5, degree = 1, ncols = p, xeval = x) { storage.mode(x) <- storage.mode(y) <- storage.mode(w) <- storage.mode( span) <- "double" storage.mode(degree) <- "integer" if(is.null(np <- dim(x))) { n <- as.integer(length(x)) p <- as.integer(1) } else { np <- as.integer(np) n <- np[1] p <- np[2] } storage.mode(ncols) <- "integer" o <- gam.match(x) nef <- o$nef # nvmax <- max(200,nef) nvmax <- as.integer(200 + 300 * (1 - 1/log(max(c(nef - 200, 3))))) # liv <- as.integer(50 + (2^ncols + 4) * nvmax + 2 * nef) # lv <- as.integer(50 + (3 * ncols + 3) * nvmax + nef + (ifelse(degree == # 2, ((ncols + 2) * (ncols + 1))/2, ncols + 1) + 2) * (nef * span + # 1)) liv <- as.integer(100 + (2^ncols + 4) * nvmax + 2 * nef) lv <- as.integer(100 + (3 * ncols + 3) * nvmax + nef + (ifelse(degree == 2, ((ncols + 2) * (ncols + 1))/2, ncols + 1) + 2) * (nef * span + 1)) fit <- .Fortran("lo0", x, y, w, n, ncols, p, nvmax, span, degree, o$o, nef, df = double(1), s = double(n), var = double(n), beta = double(p + 1), iv = integer(liv), liv, lv, v = double(lv), integer(2*ncols), double(nef * (p + ncols + 8) + 2 * p + n + 9), PACKAGE="gam") if(!missing(xeval)) { storage.mode(xeval) <- "double" m <- as.integer(dim(xeval)[1]) if(length(m) == 0) m <- as.integer(length(xeval)) .Fortran("lowese", fit$iv, liv, lv, fit$v, m, xeval, s = double(m), PACKAGE="gam")$s - cbind(1, xeval) %*% fit$beta } else list(residuals = y - fit$s, var = fit$var, nl.df = fit$df) } gam/R/newdata.predict.gam.R0000644000176200001440000000456414331341323015167 0ustar liggesusers#' @export "newdata.predict.Gam" <- function(object, newdata, type = c("link", "response", "terms"), dispersion=NULL, se.fit = FALSE, na.action=na.pass,terms=labels(object), ...) { out.attrs <- attr(newdata, "out.attrs") is.Gam<-inherits(object, "Gam") && !is.null(object$smooth) if(is.Gam) { if(se.fit){ se.fit<-FALSE warning("No standard errors (currently) for gam predictions with newdata") } ##First get the linear predictions type <- match.arg(type) local.type<-type if(type=="response")local.type<-"link" pred<-predict.glm(object,newdata,type=local.type,dispersion=dispersion,se.fit=FALSE,terms=terms) ##Build up the smooth.frame for the new data tt <- terms(object) Terms <- delete.response(tt) smooth.frame <- model.frame(Terms, newdata, na.action = na.action, xlev = object$xlevels) nrows<-nrow(smooth.frame) old.smooth<-object$smooth data<-object$smooth.frame # this was the old smooth frame smooth.labels<-names(data) n.smooths<-length(smooth.labels) if (!is.null(cl <- attr(Terms, "dataClasses"))) .checkMFClasses(cl, smooth.frame) out.attrs <- attr(newdata, "out.attrs") w <- object$weights pred.s <- array(0, c(nrows, n.smooths), list(row.names(smooth.frame), smooth.labels)) smooth.wanted <- smooth.labels[match(smooth.labels, terms, 0) > 0] pred.s<-pred.s[,smooth.wanted,drop=FALSE] residuals <- object$residuals for(TT in smooth.wanted) { Call <- attr(data[[TT]], "call") Call$xeval <- substitute(smooth.frame[[TT]], list(TT = TT)) z <- residuals + object$smooth[, TT] pred.s[, TT] <- eval(Call) } if(type == "terms") pred[, smooth.wanted] <- pred[, smooth.wanted] + pred.s[ , smooth.wanted] else pred <- pred + rowSums(pred.s) if(type == "response") { famob <- family(object) pred <- famob$linkinv(pred) } } else { pred<-predict.glm(object,newdata,type=type,dispersion=dispersion,se.fit=se.fit,terms=terms) } if(type != "terms" && !is.null(out.attrs)) { if(!is.null(out.attrs)) { if(se.fit) { attributes(pred$fit) <- out.attrs attributes(pred$se.fit) <- out.attrs } else attributes(pred) <- out.attrs } } pred } gam/R/as.anova.R0000644000176200001440000000066314331341323013052 0ustar liggesusers#' @export "as.anova" <- function(df, heading) { if(!inherits(df, "data.frame")) stop("df must be a data frame") attr(df, "heading") <- heading #if the "class" attribute of df already starts with "anova" return(df) if(inherits(df, "anova")) { dfClasses <- attr(df, "class") if(dfClasses[1] == "anova") return(df) } class(df) <- unique(c("anova", class(df))) df } gam/R/labels.gam.R0000644000176200001440000000020714331341323013343 0ustar liggesusers#' @method labels Gam #' @export #' @export labels.Gam labels.Gam<-function(object,...){ attr(object$terms, "term.labels") } gam/R/preplot.gam.R0000644000176200001440000000642114331341323013572 0ustar liggesusers#' @rdname plot.Gam #' @method preplot Gam #' @export #' @export preplot.Gam "preplot.Gam" <- function(object, newdata, terms = labels.Gam(object),...) { ## this labels.Gam above is because there does not seem to be a label method for glms Terms <- object$terms a <- attributes(Terms) Call <- object$call all.terms <- labels(Terms) xvars <- parse(text=all.terms) names(xvars) <- all.terms terms <- sapply(terms,match.arg, all.terms) Interactions <- a$order > 1 if(any(Interactions)) { all.terms <- all.terms[!Interactions] TM <- match(terms, all.terms, 0) if(!all(TM)) { terms <- terms[TM > 0] warning("No terms saved for \"a:b\" style interaction terms" ) } } xvars <- xvars[terms] xnames <- as.list(terms) names(xnames) <- terms modes <- sapply(xvars, mode) for(term in terms[modes != "name"]) { evars <- all.names(xvars[term], functions = FALSE, unique = TRUE) if(!length(evars)) next xnames[[term]] <- evars evars <- parse(text = evars) if(length(evars) == 1) evars <- evars[[1]] else { evars <- c(as.name("list"), evars) mode(evars) <- "call" } xvars[[term]] <- evars } xvars <- c(as.name("list"), xvars) mode(xvars) <- "call" if(!missing(newdata)) xvars <- eval(xvars, newdata) else { if(!is.null(Call$subset) | !is.null(Call$na.action) | !is.null( options("na.action")[[1]])) { Rownames <- names(object$fitted) if(!(Rl <- length(Rownames))) stop("need to have names for fitted.values when call has a subset or na.action argument" ) form<-paste("~",unlist(xnames),collapse="+") Mcall <- c(as.name("model.frame"), list(formula = terms(as.formula(form)), subset = Rownames, na.action = function(x) x)) mode(Mcall) <- "call" Mcall$data <- Call$data env <- environment(Terms)##added 7/28/13 if (is.null(env)) ## env <- parent.frame()## xvars <- eval(xvars, eval(Mcall,env)) } else { ecall <- substitute(eval(expression(xvars))) ecall$local <- Call$data xvars <- eval(ecall) } } if(missing(newdata)) pred <- predict(object, type = "terms", terms = terms, se.fit = TRUE) else pred <- predict(object, newdata, type = "terms", terms = terms, se.fit = TRUE) if(is.list(pred)){# oneday predict might return se.fit with newdata fits <- pred$fit se.fits <- pred$se.fit } else{ fits <- pred se.fits <- NULL } gamplot <- xnames for(term in terms) { x <- xvars[[term]] ## oldClass(x) <- unique(c(oldClass(x), data.class(unclass(x)))) xlab <- xnames[[term]] ## Fix ylab for linear terms: ylab <- if(length(xlab) == 1 && term == xlab) paste( "partial for", term) else term TT <- list(x = x, y = fits[, term], se.y = if(is.null(se.fits) ) NULL else se.fits[, term], xlab = xlab, ylab = ylab) oldClass(TT) <- "preplot.Gam" gamplot[[term]] <- TT } oldClass(gamplot) <- "preplot.Gam" gamplot } gam/R/plot.gam.R0000644000176200001440000001764214331341323013072 0ustar liggesusers#' Plot Components of a GAM Object #' #' A plot method for GAM objects, which can be used on GLM and LM objects as #' well. It focuses on terms (main-effects), and produces a suitable plot for #' terms of different types #' #' #' @aliases plot.Gam preplot.Gam plot.preplot.Gam #' @param x a \code{Gam} object, or a \code{preplot.Gam} object. The #' first thing \code{plot.Gam()} does is check if \code{x} has a #' component called \code{preplot}; if not, it computes one using #' \code{preplot.Gam()}. Either way, it is this \code{preplot.Gam} #' object that is required for plotting a \code{Gam} object. #' @param object same as \code{x} #' @param residuals if \code{TRUE}, partial deviance residuals are #' plotted along with the fitted terms---default is \code{FALSE}. If #' \code{residuals} is a vector with the same length as each fitted #' term in \code{x}, then these are taken to be the overall #' residuals to be used for constructing the partial residuals. #' @param rugplot if \code{TRUE} (the default), a univariate histogram #' or \code{rugplot} is displayed along the base of each plot, #' showing the occurrence of each `x`; ties are broken by jittering. #' @param se if \code{TRUE}, upper and lower pointwise #' twice-standard-error curves are included for each plot. The #' default is \code{FALSE}. #' @param scale a lower limit for the number of units covered by the #' limits on the `y` for each plot. The default is \code{scale=0}, #' in which case each plot uses the range of the functions being #' plotted to create their \code{ylim}. By setting \code{scale} to #' be the maximum value of \code{diff(ylim)} for all the plots, then #' all subsequent plots will produced in the same vertical #' units. This is essential for comparing the importance of fitted #' terms in additive models. #' @param ask if `TRUE`, `plot.Gam()` operates in interactive mode. #' @param newdata if supplied to `preplot.Gam`, the preplot object is based on them rather than the original. #' @param terms subsets of the terms can be selected #' @param \dots Additonal plotting arguments, not all of which will #' work (like xlim) #' @return a plot is produced for each of the terms in the object #' \code{x}. The function currently knows how to plot all #' main-effect functions of one or two predictors. So in particular, #' interactions are not plotted. An appropriate `x-y` is produced to #' display each of the terms, adorned with residuals, standard-error #' curves, and a rugplot, depending on the choice of options. The #' form of the plot is different, depending on whether the `x`-value #' for each plot is numeric, a factor, or a matrix. #' #' When \code{ask=TRUE}, rather than produce each plot sequentially, #' \code{plot.Gam()} displays a menu listing all the terms that can be plotted, #' as well as switches for all the options. #' #' A \code{preplot.Gam} object is a list of precomputed terms. Each such term #' (also a \code{preplot.Gam} object) is a list with components \code{x}, #' \code{y} and others---the basic ingredients needed for each term plot. These #' are in turn handed to the specialized plotting function \code{gplot()}, #' which has methods for different classes of the leading \code{x} argument. In #' particular, a different plot is produced if \code{x} is numeric, a category #' or factor, a matrix, or a list. Experienced users can extend this range by #' creating more \code{gplot()} methods for other classes. Graphical #' parameters (see \code{\link{par}}) may also be supplied as arguments to this #' function. This function is a method for the generic function \code{plot()} #' for class \code{"Gam"}. #' #' It can be invoked by calling \code{plot(x)} for an object \code{x} of the #' appropriate class, or directly by calling \code{plot.Gam(x)} regardless of #' the class of the object. #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992). #' @seealso \code{\link{preplot}}, \code{\link{predict.Gam}} #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' #' Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} #' London: Chapman and Hall. #' @keywords models regression nonparametric smooth #' @examples #' #' data(gam.data) #' Gam.object <- gam(y ~ s(x,6) + z,data=gam.data) #' plot(Gam.object,se=TRUE) #' data(gam.newdata) #' preplot(Gam.object,newdata=gam.newdata) #' #' @method plot Gam #' @export #' @export plot.Gam "plot.Gam" <- function(x, residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, ask = FALSE, terms=labels.Gam(x), ...) { if(!is.null(x$na.action)) x$na.action <- NULL preplot.object <- x$preplot if(is.null(preplot.object)) preplot.object <- preplot.Gam(x,terms=terms) x$preplot <- preplot.object Residuals <- resid(x) if(!is.null(residuals)) { if(length(residuals) == 1) if(residuals) residuals <- Residuals else residuals <- NULL else Residuals <- residuals } if(!ask) { plot.preplot.Gam(preplot.object, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = TRUE, ...) invisible(x) } else{ nterms <- names(preplot.object) tterms <- substring(nterms, 1, 40) #truncate long names residualsmenu <- if(!is.null(residuals)) "residuals off" else "residuals on" rugmenu <- if(rugplot) "rug off" else "rug on" semenu <- if(se) "se off" else "se on" scalemenu <- paste("scale (", round(scale, 1), ")", sep = "") scales <- numeric() tmenu <- c(paste("plot:", tterms), "plot all terms", residualsmenu, rugmenu, semenu, scalemenu) tnames <- character() pick <- 1 while(pick > 0 && pick <= length(tmenu)) { pick <- menu(tmenu, title = "Make a plot selection (or 0 to exit):\n") if(pick > 0 && pick <= length(nterms)) { tscale <- plot.preplot.Gam(preplot.object[[pick]], residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = TRUE, ...) names(tscale) <- nterms[pick] scales <- c(scales, tscale) cat("Plots performed:\n ") print(scales) } else switch(pick - length(nterms), { scales <- plot.preplot.Gam( preplot.object, residuals = residuals, rugplot = rugplot, scale = scale, se = se, fit = TRUE, ...) print(scales) } , { residuals <- if(is.null(residuals)) Residuals else NULL residualsmenu <- if(!is.null(residuals) ) "residuals off" else "residuals on" } , { rugplot <- !rugplot rugmenu <- if(rugplot) "rug off" else "rug on" } , { se <- !se semenu <- if(se) "se off" else "se on" } , { cat("Type in a new scale\n") scale <- eval(parse(n=1)) scalemenu <- paste("scale (", round( scale, 1), ")", sep = "") } , invisible(return(x))) tmenu <- c(paste("plot:", tterms), "plot all terms", residualsmenu, rugmenu, semenu, scalemenu) } invisible(x) } } gam/R/s.wam.R0000644000176200001440000000524714331341323012374 0ustar liggesusers#' @export "s.wam" <- function(x, y, w, s, which, smooth.frame, maxit = 30, tol = 1e-7, trace = FALSE, se = TRUE, ...) { if(is.data.frame(smooth.frame)) { first <- TRUE # first call to wam; set up some things #on first entry, smooth.frame is a data frame with elements the terms to be #smoothed in which data <- smooth.frame[, names(which), drop = FALSE] smooth.frame <- gam.match(data) dx <- as.integer(dim(x)) smooth.frame$n <- dx[1] smooth.frame$p <- dx[2] oldClass(data) <- NULL smooth.frame$spar <- unlist(lapply(data, attr, "spar")) smooth.frame$df <- unlist(lapply(data, attr, "df")) } else first <- FALSE storage.mode(tol) <- "double" storage.mode(maxit) <- "integer" which <- unlist(which) storage.mode(which) <- "integer" storage.mode(y) <- "double" storage.mode(w) <- "double" p <- smooth.frame$p n <- smooth.frame$n ### Need to do the signif hack on the which columns of x for(ich in which)x[,ich]=signif(x[,ich],6) ### fit <- .Fortran("bakfit", x, npetc = as.integer(c(n, p, length(which), se, 0, maxit, 0)), y = y, w = w, which, spar = as.double(smooth.frame$spar), df = as.double(smooth.frame$df), as.integer(smooth.frame$o), as.integer(smooth.frame$nef), etal = double(n), s = s, eta = double(n), beta = double(p), var = s, tol, qr = x, qraux = double(p), qpivot = as.integer(1:p), effects=double(n), double((10 + 2 * 4 + 5) * (max(smooth.frame$nef) + 2) + 15 * n + 15 + length(which)), PACKAGE="gam") nit <- fit$npetc[5] qrank <- fit$npetc[7] if((nit == maxit) & maxit > 1) warning(paste("s.wam convergence not obtained in ", maxit, " iterations")) if(first) { smooth.frame$spar <- fit$spar first <- FALSE } names(fit$df) <- dimnames(s)[[2]] names(fit$beta) <- labels(x)[[2]] qrx <- structure(list(qr = fit$qr,qraux = fit$qraux, rank = qrank, pivot = fit$qpivot,tol=1e-7),class="qr") effects<-fit$effects #qr.qty(qrx,fit$y) r1 <- seq(len = qrx$rank) dn <- colnames(x) if (is.null(dn)) dn <- paste("x", 1:p, sep = "") names(effects) <- c(dn[qrx$pivot[r1]], rep.int("", n - qrx$rank)) rl <- list(coefficients = fit$beta, residuals = fit$y - fit$eta, fitted.values = fit$eta, effects=effects, weights=w, rank=qrank, assign=attr(x,"assign"), qr=qrx, smooth = fit$s, nl.df = fit$df - 1 ) rl$df.residual <- n - qrank - sum(rl$nl.df) - sum(fit$w == 0.) rl$iter=NA if(se) rl <- c(rl, list(var = fit$var)) c(list(smooth.frame = smooth.frame), rl) } gam/R/as.data.frame.lo.smooth.R0000644000176200001440000000127314331341323015667 0ustar liggesusers#' @method as.data.frame lo.smooth #' @export #' @export as.data.frame.lo.smooth "as.data.frame.lo.smooth" <- function(x, row.names = NULL, optional = FALSE,...) { d <- dim(x) nrows <- d[[1.]] dn <- dimnames(x) row.names <- dn[[1.]] value <- list(x) if(length(row.names)) { row.names <- as.character(row.names) if(length(row.names) != nrows) stop(paste("supplied", length(row.names), "names for a data frame with", nrows, "rows")) } else if(optional) row.names <- character(nrows) else row.names <- as.character(seq(length = nrows)) if(!optional) names(value) <- deparse(substitute(x))[[1.]] attr(value, "row.names") <- row.names oldClass(value) <- "data.frame" value } gam/R/gam.smoothers.R0000644000176200001440000000401014331341323014120 0ustar liggesusers#' @export "gam.smooth.list"=list( slist=c("s","lo","random"), wlist=c("s","lo") ) #' Smoothers available for backfitting #' #' Auxiliary function as user interface for 'gam' fitting. Lists what smoothers #' are implemented, and allows users to include new smoothers. #' #' #' @aliases gam.smoothers gam.smooth.list #' @param slist character vector giving names of smoothers available for #' general backfitting. For every entry, eg "lo", there must exist a formula #' function "lo()" that prepares the data, and a fitting function with the name #' "gam.lo" which actually does the fitting. Look at "lo" and "s" as examples. #' @param wlist character vector (subset of slist) giving names of smoothers #' for which a special backfitting algorithm is available, when only that #' smoother appears (multiple times) in the formula, along with other non #' smooth terms. #' @return a list is returned, consisting of the two named vectors. If the #' function is called with no arguments, it gets the version of #' "gam.smooth.list"' in the search path, by default from the package name #' space. Once it is called with either of the arguments, it places a local #' copy in the users namespace. #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' @keywords models regression nonparametric smooth #' @examples #' #' \dontrun{gam.smoothers()$slist # get the gam.smooth.list, and extract component slist} #' \dontrun{gam.smoothers(slist=c("s","lo","random","tps") # add a new smoother "tps" to the list} #' #' @export gam.smoothers "gam.smoothers" <- function(slist=c("s","lo","random"), wlist=c("s","lo")){ smooth.list=gam.smooth.list if(!missing(slist)){ smooth.list$slist <- slist assignInMyNamespace("gam.smooth.list", smooth.list) } if(!missing(wlist)){ smooth.list$wlist <- wlist assignInMyNamespace("gam.smooth.list", smooth.list) } smooth.list } gam/R/print.gam.R0000644000176200001440000000110114331341323013227 0ustar liggesusers#' @method print Gam #' @export #' @export print.Gam "print.Gam" <- function(x, digits = 5, ...) { if(!is.null(cl <- x$call)) { cat("Call:\n") dput(cl) } n <- x$df.null if(is.null(df.resid <- x$df.resid)) df.resid <- n - sum(!is.na(x$coef)) - sum(x$nl.df) cat("\nDegrees of Freedom:", n, "total;", format(round(df.resid, digits )), "Residual\n") if(!is.null(x$na.action)) cat(naprint(x$na.action), "\n") cat("Residual Deviance:", format(round(x$deviance, digits)), "\n") invisible(x) } gam/R/print.stepanova.R0000644000176200001440000000111314331341323014466 0ustar liggesusers#' @method print stepanova #' @export "print.stepanova"<- function(x, digits = .Options$digits, quote = F, drop = F, ...) { heading <- attr(x, "heading") if(!is.null(heading)) cat(heading, sep = "\n") attr(x, "heading") <- NULL d <- dim(x) for(i in 1:d[2]) { xx <- x[[i]] if(!length(levels(xx)) && is.numeric(xx)) { xna <- is.na(xx) xx <- format(zapsmall(xx, digits)) xx[xna] <- "" x[[i]] <- xx } } if(d[1] == 1 && drop) { x <- t(as.matrix(x)) dn <- dimnames(x) dn <- paste(dn[[1]], ":", sep = "") dimnames(x) <- list(dn, "") } NextMethod("print") } gam/R/print.summary.gam.R0000644000176200001440000000244714331341323014741 0ustar liggesusers#' @method print summary.Gam #' @export #' @export print.summary.Gam "print.summary.Gam" <- function(x, digits = max(3, getOption("digits") - 3), quote = TRUE, prefix = "", ...) { cat("\nCall: ") dput(x$call) dresid <- x$deviance.resid n <- length(dresid) rdf <- x$df[2] if(rdf > 5) { cat("Deviance Residuals:\n") rq <- quantile(as.vector(dresid)) names(rq) <- c("Min", "1Q", "Median", "3Q", "Max") print(rq, digits = digits) } else if(rdf > 0) { cat("Deviance Residuals:\n") print(dresid, digits = digits) } cat(paste("\n(Dispersion Parameter for ", names(x$dispersion), " family taken to be ", format(round(x$dispersion, digits)), ")\n",sep="")) int <- attr(x$terms, "intercept") cat("\n Null Deviance:", format(round(x$null.deviance, digits)), "on", n - int, "degrees of freedom") cat("\nResidual Deviance:", format(round(x$deviance, digits)), "on", format(round(rdf, digits)), "degrees of freedom") cat("\nAIC:", format(round(x$aic, digits)),"\n") if(!is.null(x$na.action)) cat(naprint(x$na.action), "\n") cat("\nNumber of Local Scoring Iterations:", format(trunc(x$iter)), "\n") aod=x$parametric.anova cat("\n") if(!is.null(aod)) print(aod) aod=x$anova cat("\n") if(!is.null(aod)) print(aod) } gam/R/onAttach.R0000644000176200001440000000021214216146461013103 0ustar liggesusers.onAttach=function(libname,pkgname){ packageStartupMessage("Loaded gam ", as.character(packageDescription("gam")[["Version"]]),"\n") } gam/R/ylim.scale.R0000644000176200001440000000025414331341323013400 0ustar liggesusers#' @export "ylim.scale" <- function(ylim, scale = 0.) { scale2 <- diff(ylim) if(scale2 < scale) rep(mean(ylim), 2.) + ((ylim - mean(ylim)) * scale)/scale2 else ylim } gam/R/gplot.list.R0000644000176200001440000000102414331341323013433 0ustar liggesusers#' @method gplot list #' @export #' @export gplot.list "gplot.list" <- function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, fit = TRUE, ...) { if(length(x) != 2) { warning(paste("A perspective plot was requested for \"", ylab, "\" but the \"x\" variable has dimension other than 2", sep = "")) invisible(return(0)) } names(x) <- xlab x <- data.matrix(data.frame(x)) # UseMethod("gplot") gplot.matrix(x, y, se.y, xlab, ylab, residuals, rugplot, scale, se, fit, ...) } gam/R/gam.R0000644000176200001440000003524614331341323012115 0ustar liggesusers#' Fitting Generalized Additive Models #' #' \code{gam} is used to fit generalized additive models, specified by giving a #' symbolic description of the additive predictor and a description of the #' error distribution. \code{gam} uses the \emph{backfitting algorithm} to #' combine different smoothing or fitting methods. The methods currently #' supported are local regression and smoothing splines. #' #' The gam model is fit using the local scoring algorithm, which iteratively #' fits weighted additive models by backfitting. The backfitting algorithm is a #' Gauss-Seidel method for fitting additive models, by iteratively smoothing #' partial residuals. The algorithm separates the parametric from the #' nonparametric part of the fit, and fits the parametric part using weighted #' linear least squares within the backfitting algorithm. This version of #' \code{gam} remains faithful to the philosophy of GAM models as outlined in #' the references below. #' #' An object \code{gam.slist} (currently set to \code{c("lo","s","random")}) #' lists the smoothers supported by \code{gam}. Corresponding to each of these #' is a smoothing function \code{gam.lo}, \code{gam.s} etc that take particular #' arguments and produce particular output, custom built to serve as building #' blocks in the backfitting algorithm. This allows users to add their own #' smoothing methods. See the documentation for these methods for further #' information. In addition, the object \code{gam.wlist} (currently set to #' \code{c("s","lo")}) lists the smoothers for which efficient backfitters are #' provided. These are invoked if all the smoothing methods are of one kind #' (either all \code{"lo"} or all \code{"s"}). #' #' @aliases gam gam.fit #' @param formula a formula expression as for other regression models, of the #' form \code{response ~ predictors}. See the documentation of \code{lm} and #' \code{formula} for details. Built-in nonparametric smoothing terms are #' indicated by \code{s} for smoothing splines or \code{lo} for \code{loess} #' smooth terms. See the documentation for \code{s} and \code{lo} for their #' arguments. Additional smoothers can be added by creating the appropriate #' interface functions. Interactions with nonparametric smooth terms are not #' fully supported, but will not produce errors; they will simply produce the #' usual parametric interaction. #' @param family a description of the error distribution and link function to #' be used in the model. This can be a character string naming a family #' function, a family function or the result of a call to a family function. #' (See \code{\link{family}} for details of family functions.) #' @param data an optional data frame containing the variables in the model. #' If not found in \code{data}, the variables are taken from #' \code{environment(formula)}, typically the environment from which \code{gam} #' is called. #' @param weights an optional vector of weights to be used in the fitting #' process. #' @param subset an optional vector specifying a subset of observations to be #' used in the fitting process. #' @param na.action a function which indicates what should happen when the data #' contain \code{NA}s. The default is set by the \code{na.action} setting of #' \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. The #' \dQuote{factory-fresh} default is \code{\link{na.omit}}. A special method #' \code{\link{na.gam.replace}} allows for mean-imputation of missing values #' (assumes missing at random), and works gracefully with \code{gam} #' @param start starting values for the parameters in the additive predictor. #' @param etastart starting values for the additive predictor. #' @param mustart starting values for the vector of means. #' @param offset this can be used to specify an \emph{a priori} known component #' to be included in the additive predictor during fitting. #' @param control a list of parameters for controlling the fitting process. #' See the documentation for \code{\link{gam.control}} for details. These can #' also be set as arguments to \code{gam()} itself. #' @param model a logical value indicating whether \emph{model frame} should be #' included as a component of the returned value. Needed if \code{gam} is #' called and predicted from inside a user function. Default is \code{TRUE}. #' @param method the method to be used in fitting the parametric part of the #' model. The default method \code{"glm.fit"} uses iteratively reweighted #' least squares (IWLS). The only current alternative is \code{"model.frame"} #' which returns the model frame and does no fitting. #' @param x,y For \code{gam}: logical values indicating whether the response #' vector and model matrix used in the fitting process should be returned as #' components of the returned value. #' #' For \code{gam.fit}: \code{x} is a model matrix of dimension \code{n * p}, #' and \code{y} is a vector of observations of length \code{n}. #' @param smooth.frame for \code{gam.fit} only. This is essentially a subset of #' the model frame corresponding to the smooth terms, and has the ingredients #' needed for smoothing each variable in the backfitting algorithm. The #' elements of this frame are produced by the formula functions \code{lo} and #' \code{s}. #' @param \dots further arguments passed to or from other methods. #' @return \code{gam} returns an object of class \code{Gam}, which inherits #' from both \code{glm} and \code{lm}. #' #' Gam objects can be examined by \code{print}, \code{summary}, \code{plot}, #' and \code{anova}. Components can be extracted using extractor functions #' \code{predict}, \code{fitted}, \code{residuals}, \code{deviance}, #' \code{formula}, and \code{family}. Can be modified using \code{update}. It #' has all the components of a \code{glm} object, with a few more. This also #' means it can be queried, summarized etc by methods for \code{glm} and #' \code{lm} objects. Other generic functions that have methods for \code{Gam} #' objects are \code{step} and \code{preplot}. #' #' The following components must be included in a legitimate `Gam' object. The #' residuals, fitted values, coefficients and effects should be extracted by #' the generic functions of the same name, rather than by the \code{"$"} #' operator. The \code{family} function returns the entire family object used #' in the fitting, and \code{deviance} can be used to extract the deviance of #' the fit. #' #' \item{coefficients}{ the coefficients of the parametric part of the #' \code{additive.predictors}, which multiply the columns of the model matrix. #' The names of the coefficients are the names of the single-degree-of-freedom #' effects (the columns of the model matrix). If the model is overdetermined #' there will be missing values in the coefficients corresponding to #' inestimable coefficients. } \item{additive.predictors}{ the additive fit, #' given by the product of the model matrix and the coefficients, plus the #' columns of the \code{$smooth} component. } \item{fitted.values}{ the fitted #' mean values, obtained by transforming the component #' \code{additive.predictors} using the inverse link function. } \item{smooth, #' nl.df, nl.chisq, var}{ these four characterize the nonparametric aspect of #' the fit. \code{smooth} is a matrix of smooth terms, with a column #' corresponding to each smooth term in the model; if no smooth terms are in #' the \code{Gam} model, all these components will be missing. Each column #' corresponds to the strictly nonparametric part of the term, while the #' parametric part is obtained from the model matrix. \code{nl.df} is a vector #' giving the approximate degrees of freedom for each column of \code{smooth}. #' For smoothing splines specified by \code{s(x)}, the approximate \code{df} #' will be the trace of the implicit smoother matrix minus 2. \code{nl.chisq} #' is a vector containing a type of score test for the removal of each of the #' columns of \code{smooth}. \code{var} is a matrix like \code{smooth}, #' containing the approximate pointwise variances for the columns of #' \code{smooth}. } \item{smooth.frame}{This is essentially a subset of the #' model frame corresponding to the smooth terms, and has the ingredients #' needed for making predictions from a \code{Gam} object} \item{residuals}{ #' the residuals from the final weighted additive fit; also known as residuals, #' these are typically not interpretable without rescaling by the weights. } #' \item{deviance}{ up to a constant, minus twice the maximized log-likelihood. #' Similar to the residual sum of squares. Where sensible, the constant is #' chosen so that a saturated model has deviance zero. } #' \item{null.deviance}{The deviance for the null model, comparable with #' \code{deviance}. The null model will include the offset, and an intercept if #' there is one in the model} \item{iter}{ the number of local scoring #' iterations used to compute the estimates. } \item{bf.iter}{a vector of #' length \code{iter} giving number of backfitting iterations used at each #' inner loop.} \item{family}{ a three-element character vector giving the name #' of the family, the link, and the variance function; mainly for printing #' purposes. } \item{weights}{the \emph{working} weights, that is the weights #' in the final iteration of the local scoring fit.} \item{prior.weights}{the #' case weights initially supplied.} \item{df.residual}{the residual degrees of #' freedom.} \item{df.null}{the residual degrees of freedom for the null #' model.} #' #' The object will also have the components of a \code{lm} object: #' \code{coefficients}, \code{residuals}, \code{fitted.values}, \code{call}, #' \code{terms}, and some others involving the numerical fit. See #' \code{lm.object}. #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992), and the philosophy in Hastie and Tibshirani (1991). This version of #' \code{gam} is adapted from the S version to match the \code{glm} and #' \code{lm} functions in R. #' #' Note that this version of \code{gam} is different from the function with the #' same name in the R library \code{mgcv}, which uses only smoothing splines #' with a focus on automatic smoothing parameter selection via GCV. To avoid #' issues with S3 method handling when both packages are loaded, the object #' class in package "gam" is now "Gam". #' #' @seealso \code{\link{glm}}, \code{\link{family}}, \code{\link{lm}}. #' @references Hastie, T. J. (1991) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' #' Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} #' London: Chapman and Hall. #' #' Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics #' with S.} New York: Springer. #' @keywords models regression nonparametric smooth #' @examples #' #' data(kyphosis) #' gam(Kyphosis ~ s(Age,4) + Number, family = binomial, data=kyphosis, #' trace=TRUE) #' data(airquality) #' gam(Ozone^(1/3) ~ lo(Solar.R) + lo(Wind, Temp), data=airquality, na=na.gam.replace) #' gam(Kyphosis ~ poly(Age,2) + s(Start), data=kyphosis, family=binomial, subset=Number>2) #' data(gam.data) #' Gam.object <- gam(y ~ s(x,6) + z,data=gam.data) #' summary(Gam.object) #' plot(Gam.object,se=TRUE) #' data(gam.newdata) #' predict(Gam.object,type="terms",newdata=gam.newdata) #' #' @export gam "gam" <- function(formula, family = gaussian, data, weights, subset, na.action, start = NULL, etastart, mustart, control = gam.control(...), model = TRUE, method="glm.fit", x = FALSE, y = TRUE, ...) { call <- match.call() if (is.character(family)) family <- get(family, mode = "function", envir = parent.frame()) if (is.function(family)) family <- family() if (is.null(family$family)) { print(family) stop("`family' not recognized") } if (missing(data)) data <- environment(formula) mf <- match.call(expand.dots = FALSE) ## m <- match(c("formula", "data", "subset", "weights", "na.action", ## "etastart", "mustart", "offset"), names(mf), 0L) m <- match(c("formula", "data", "subset", "weights", "etastart", "mustart", "offset"), names(mf), 0L) mf <- mf[c(1L, m)] mf$na.action=quote(na.pass)## need to do this because model frame is not subsetting properly mf$drop.unused.levels <- TRUE mf[[1L]] <- quote(stats::model.frame) gam.slist <- gam.smoothers()$slist mt <- if(missing(data)) terms(formula, gam.slist) else terms(formula,gam.slist,data = data) mf$formula<-mt mf <- eval(mf, parent.frame()) if(missing(na.action)){ naa=getOption("na.action","na.fail") na.action=get(naa) } mf=na.action(mf)###because this was not done properly before mt=attributes(mf)[["terms"]]# the predvars are added here, while not before switch(method, model.frame = return(mf), glm.fit = 1, glm.fit.null = 1, stop("invalid `method': ", method)) Y <- model.response(mf, "any") X <- if (!is.empty.model(mt)) ### model.matrix(mt, mf, contrasts) #not sure why the contrasts argument? model.matrix(mt, mf) else matrix(, NROW(Y), 0) weights <- model.weights(mf) offset <- model.offset(mf) if (!is.null(weights) && any(weights < 0)) stop("Negative wts not allowed") if (!is.null(offset) && length(offset) != NROW(Y)) stop("Number of offsets is ", length(offset), ", should equal ", NROW(Y), " (number of observations)") mustart <- model.extract(mf, "mustart") etastart <- model.extract(mf, "etastart") fit<-gam.fit(x=X,y=Y,smooth.frame=mf,weights=weights,start=start, etastart=etastart,mustart=mustart, offset=offset,family=family,control=control) ### If both an offset and intercept are present, iterations are needed to ### compute the Null deviance; these are done here ### if(length(offset) && attr(mt, "intercept")>0) { fit$null.dev <- glm.fit(x = X[, "(Intercept)", drop = FALSE], y = Y, weights = weights, offset = offset, family = family, control = control[c("epsilon","maxit","trace")], intercept = TRUE)$deviance } if(model) fit$model <- mf fit$na.action <- attr(mf, "na.action") if(x) fit$x <- X if(!y) fit$y <- NULL fit <- c(fit, list(call = call, formula = formula, terms = mt, data = data, offset = offset, control = control, method = method, contrasts = attr(X, "contrasts"), xlevels = .getXlevels(mt, mf))) class(fit) <- c("Gam","glm", "lm") if(!is.null(fit$df.residual) && !(fit$df.residual > 0)) warning("Residual degrees of freedom are negative or zero. This occurs when the sum of the parametric and nonparametric degrees of freedom exceeds the number of observations. The model is probably too complex for the amount of data available." ) fit } gam/R/predict.gam.R0000644000176200001440000001631114331341323013536 0ustar liggesusers#' Predict method for GAM fits #' #' Obtains predictions and optionally estimates standard errors of those #' predictions from a fitted generalized additive model object. #' #' @param object a fitted \code{Gam} object, or one of its #' inheritants, such as a \code{glm} or \code{lm} object. #' @param newdata a data frame containing the values at which #' predictions are required. This argument can be missing, in which #' case predictions are made at the same values used to compute the #' object. Only those predictors, referred to in the right side of #' the formula in object need be present by name in \code{newdata}. #' @param type type of predictions, with choices \code{"link"} (the #' default), \code{"response"}, or \code{"terms"}. The default #' produces predictions on the scale of the additive predictors, and #' with \code{newdata} missing, \code{predict} is simply an #' extractor function for this component of a \code{Gam} object. If #' \code{"response"} is selected, the predictions are on the scale #' of the response, and are monotone transformations of the additive #' predictors, using the inverse link function. If #' \code{type="terms"} is selected, a matrix of predictions is #' produced, one column for each term in the model. #' @param se.fit if \code{TRUE}, pointwise standard errors are #' computed along with the predictions. #' @param dispersion the dispersion of the GLM fit to be assumed in #' computing the standard errors. If omitted, that returned by #' 'summary' applied to the object is used #' @param terms if \code{type="terms"}, the \code{terms=} argument can #' be used to specify which terms should be included; the default is #' \code{labels(object)}. #' @param na.action function determining what should be done with #' missing values in 'newdata'. The default is to predict 'NA'. #' @param \dots Placemark for additional arguments to predict #' @return a vector or matrix of predictions, or a list consisting of #' the predictions and their standard errors if \code{se.fit = #' TRUE}. If \code{type="terms"}, a matrix of fitted terms is #' produced, with one column for each term in the model (or subset #' of these if the \code{terms=} argument is used). There is no #' column for the intercept, if present in the model, and each of #' the terms is centered so that their average over the original #' data is zero. The matrix of fitted terms has a \code{"constant"} #' attribute which, when added to the sum of these centered terms, #' gives the additive predictor. See the documentation of #' \code{predict} for more details on the components returned. #' #' When \code{newdata} are supplied, \code{predict.Gam} simply invokes #' inheritance and gets \code{predict.glm} to produce the parametric part of #' the predictions. For each nonparametric term, \code{predict.Gam} #' reconstructs the partial residuals and weights from the final iteration of #' the local scoring algorithm. The appropriate smoother is called for each #' term, with the appropriate \code{xeval} argument (see \code{\link{s}} or #' \code{\link{lo}}), and the prediction for that term is produced. #' #' The standard errors are based on an approximation given in Hastie (1992). #' Currently \code{predict.Gam} does not produce standard errors for #' predictions at \code{newdata}. #' #' Warning: naive use of the generic \code{predict} can produce incorrect #' predictions when the \code{newdata} argument is used, if the formula in #' \code{object} involves transformations such as \code{sqrt(Age - min(Age))}. #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992). This version of \code{predict.Gam} is adapted from the S version to #' match the corresponding predict methods for \code{glm} and \code{lm} objects #' in R. The \code{safe.predict.Gam} function in S is no longer required, #' primarily because a safe prediction method is in place for functions like #' \code{ns}, \code{bs}, and \code{poly}. #' @seealso \code{\link{predict.glm}}, \code{\link{fitted}}, #' \code{\link{expand.grid}} #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' #' Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} #' London: Chapman and Hall. #' #' Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics #' with S.} New York: Springer. #' @keywords models regression nonparametric smooth #' @examples #' #' data(gam.data) #' Gam.object <- gam(y ~ s(x,6) + z, data=gam.data) #' predict(Gam.object) # extract the additive predictors #' data(gam.newdata) #' predict(Gam.object, gam.newdata, type="terms") #' @method predict Gam #' @export #' @export predict.Gam "predict.Gam" <- function(object, newdata, type = c("link", "response", "terms"), dispersion=NULL, se.fit = FALSE, na.action=na.pass, terms = labels(object),...) { type <- match.arg(type) if(missing(newdata)) { if(inherits(object, "Gam") && !is.null(object$smooth)) { if(se.fit) switch(type, response = { out <- predict.Gam(object, type = "link", se.fit = TRUE, ...) famob <- family(object) out$se.fit <- drop(out$se.fit*abs(famob$mu.eta(out$fit))) out$fit <- fitted(object) out } , link = { out <- NextMethod("predict") out$fit <- object$additive.predictors TS <- out$residual.scale^2 TT <- ncol(object$var) out$se.fit <- sqrt(out$se.fit^ 2 + TS * object$var %*% rep(1, TT)) out } , terms = { out <- NextMethod("predict") TT <- dimnames(s <- object$smooth)[[2]] TT=intersect(terms,TT)##added to protect subsets out$fit[, TT] <- out$fit[, TT] + s[,TT] TS <- out$residual.scale^2 out$se.fit[, TT] <- sqrt(out$ se.fit[, TT]^2 + TS * object$var[,TT]) out } ) else switch(type, terms = { out <- NextMethod("predict") TT <- dimnames(s <- object$smooth)[[2]] TT=intersect(terms,TT)##added to protect subsets out[, TT] <- out[, TT] + s[,TT] out } , link = object$additive.predictors, response = object$fitted) } else { if(inherits(object, "Gam")) { if(type == "link" && !se.fit) object$additive.predictors else NextMethod("predict") } else UseMethod("predict") } } else newdata.predict.Gam(object, newdata, type, dispersion,se.fit, na.action, terms, ...) } gam/R/gam.random.R0000644000176200001440000001123514331341323013364 0ustar liggesusers#' Specify a Random Effects Fit in a GAM Formula #' #' A symbolic wrapper for a factor term, to specify a random effect term in a #' formula argument to gam #' #' This "smoother" takes a factor as input and returns a shrunken-mean fit. If #' \code{lambda=0}, it simply computes the mean of the response at each level #' of \code{f}. With \code{lambda>0}, it returns a shrunken mean, where the #' j'th level is shrunk by \code{nj/(nj+lambda)}, with \code{nj} being the #' number of observations (or sum of their weights) at level \code{j}. Using #' such smoother(s) in gam is formally equivalent to fitting a mixed-effect #' model by generalized least squares. #' #' @aliases random gam.random #' @param f factor variable, or expression that evaluates to a factor. #' @param y a response variable passed to \code{gam.random} during backfitting #' @param w weights #' @param df the target equivalent degrees of freedom, used as a smoothing #' parameter. The real smoothing parameter (\code{lambda} below) is found such #' that \code{df=tr(S)}, where \code{S} is the implicit smoother matrix. Values #' for \code{df} should be greater than \code{0} and less than the number of #' levels of \code{f}. If both \code{df} and \code{lambda} are supplied, the #' latter takes precedence. Note that \code{df} is not necessarily an integer. #' @param lambda the non-negative penalty parameter. This is interpreted as a #' variance ratio in a mixed effects model - namely the ratio of the noise #' variance to the random-effect variance. #' @param intercept if \code{intercept=TRUE} (the default) then the estimated #' level effects are centered to average zero, otherwise they are left alone. #' @param xeval If this argument is present, then \code{gam.random} produces a #' prediction at \code{xeval}. #' @return \code{random} returns the vector \code{f}, endowed with a number of #' attributes. The vector itself is used in computing the means in backfitting, #' while the attributes are needed for the backfitting algorithms #' \code{general.wam}. Note that \code{random} itself does no smoothing; it #' simply sets things up for \code{gam}. #' #' One important attribute is named \code{call}. For example, \code{random(f, #' lambda=2)} has a call component \code{gam.random(data[["random(f, lambda = #' 2)"]], z, w, df = NULL, lambda = 2, intercept = TRUE)}. This is an #' expression that gets evaluated repeatedly in \code{general.wam} (the #' backfitting algorithm). #' #' \code{gam.random} returns an object with components \item{residuals}{The #' residuals from the smooth fit. } \item{nl.df}{the degrees of freedom} #' \item{var}{the pointwise variance for the fit} \item{lambda}{the value of #' \code{lambda} used in the fit} When \code{gam.random} is evaluated with an #' \code{xeval} argument, it returns a vector of predictions. #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992). #' @seealso \code{\link{lo}}, \code{\link{s}}, \code{\link{bs}}, #' \code{\link{ns}}, \code{\link{poly}} #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' #' Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} #' London: Chapman and Hall. #' #' Cantoni, E. and hastie, T. (2002) Degrees-of-freedom tests for smoothing #' splines, \emph{Biometrika} 89(2), 251-263 #' @keywords models regression nonparametric smooth random effects mixed #' effects #' @examples #' #' # fit a model with a linear term in Age and a random effect in the factor Level #' y ~ Age + random(Level, lambda=1) #' #' @export "gam.random" <- function(f, y, w, df = sum(non.zero), lambda = 0,intercept=TRUE, xeval) { df.inv <- function(n, df, lambda = sum(n)/df - mean(n), iterations = 10 ) { if(df > length(n)) return(0) current.df <- sum(n/(n + lambda)) if(abs((df - current.df)/df) < 0.0001 | iterations == 1) lambda else { lambda <- exp(log(lambda) + (current.df - df)/(sum(( n * lambda)/(n + lambda)^2))) Recall(n, df, lambda, iterations - 1) } } f=attr(f,"values") nw <- tapply(w, f, sum) non.zero <- !is.na(nw) if(is.null(df)) df <- sum(non.zero) if(lambda == 0) lambda <- df.inv(nw[non.zero], df) df <- sum(nw[non.zero]/(nw[non.zero] + lambda)) fit <- tapply(w * y, f, sum)/(nw + lambda) if(intercept)fit=fit-mean(fit) var <- as.vector(w/(nw[f] + lambda)) residuals <- as.vector(y - fit[f]) if(missing(xeval)) list(x = seq(along = nw), y = fit, residuals = residuals, var = var, nl.df = df, lambda = lambda) else fit[xeval] } gam/R/gplot.factor.R0000644000176200001440000000361314331341323013744 0ustar liggesusers#' @method gplot factor #' @export #' @export gplot.factor "gplot.factor" <- function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, xlim = NULL, ylim = NULL, fit = TRUE, ...) { if(length(x) != length(y)) stop("x and y do not have the same length; possibly a consequence of an na.action" ) nn <- as.numeric(table(x)) codex <- as.numeric(x) ucodex <- seq(nn)[nn > 0] o <- match(ucodex, codex, 0) uy <- as.numeric(y[o]) ylim <- range(ylim, uy) xlim <- range(c(0, sum(nn), xlim)) rightx <- cumsum(nn) leftx <- c(0, rightx[ - length(nn)]) ux <- ((leftx + rightx)/2) delta <- (rightx - leftx)/8 jx <- runif(length(codex), (ux - delta)[codex], (ux + delta)[codex]) nnajx <- jx[!is.na(jx)] if(rugplot) xlim <- range(c(xlim, nnajx)) if(se && !is.null(se.y)) { se.upper <- uy + 2 * se.y[o] se.lower <- uy - 2 * se.y[o] ylim <- range(c(ylim, se.upper, se.lower)) } if(!is.null(residuals)) { if(length(residuals) == length(y)) { residuals <- y + residuals ylim <- range(c(ylim, residuals)) } else { residuals <- NULL warning(paste("Residuals do not match x in \"", ylab, "\" preplot object", sep = "")) } } ylim <- ylim.scale(ylim, scale) Levels <- levels(x) if(!all(nn>0)) { keep <- nn > 0 ux <- ux[keep] delta <- delta[keep] leftx <- leftx[keep] rightx <- rightx[keep] Levels <- Levels[keep] } plot(ux, uy, ylim = ylim, xlim = xlim, xlab = "", type = "n", ylab = ylab, xaxt = "n", ...) mtext(xlab, 1, 2) axis(side = 3, at = ux - delta, labels = Levels, srt = 45, tick = FALSE, adj = 0) if(fit) segments(leftx + delta, uy, rightx - delta, uy) if(!is.null(residuals)) points(jx, residuals) if(rugplot) rug(nnajx) if(se) { segments(ux + delta, se.upper, ux - delta, se.upper) segments(ux + delta, se.lower, ux - delta, se.lower) segments(ux, se.lower, ux, se.upper, lty = 2) } invisible(diff(ylim)) } gam/R/gam.s.R0000644000176200001440000001151714331341323012351 0ustar liggesusers#' Specify a Smoothing Spline Fit in a GAM Formula #' #' A symbolic wrapper to indicate a smooth term in a formala argument to gam #' #' #' @aliases s gam.s #' @param x the univariate predictor, or expression, that evaluates to a #' numeric vector. #' @param df the target equivalent degrees of freedom, used as a smoothing #' parameter. The real smoothing parameter (\code{spar} below) is found such #' that \code{df=tr(S)-1}, where \code{S} is the implicit smoother matrix. #' Values for \code{df} should be greater than \code{1}, with \code{df=1} #' implying a linear fit. If both \code{df} and \code{spar} are supplied, the #' former takes precedence. Note that \code{df} is not necessarily an integer. #' @param spar can be used as smoothing parameter, with values typically in #' \code{(0,1]}. See \code{\link{smooth.spline}} for more details. #' @param y a response variable passed to \code{gam.s} during backfitting #' @param w weights #' @param xeval If this argument is present, then \code{gam.s} produces a #' prediction at \code{xeval}. #' @return #' #' \code{s} returns the vector \code{x}, endowed with a number of attributes. #' The vector itself is used in the construction of the model matrix, while the #' attributes are needed for the backfitting algorithms \code{general.wam} #' (weighted additive model) or \code{s.wam}. Since smoothing splines #' reproduces linear fits, the linear part will be efficiently computed with #' the other parametric linear parts of the model. #' #' Note that \code{s} itself does no smoothing; it simply sets things up for #' \code{gam}. #' #' One important attribute is named \code{call}. For example, \code{s(x)} has a #' call component \code{gam.s(data[["s(x)"]], z, w, spar = 1, df = 4)}. This is #' an expression that gets evaluated repeatedly in \code{general.wam} (the #' backfitting algorithm). #' #' \code{gam.s} returns an object with components \item{residuals}{The #' residuals from the smooth fit. Note that the smoother removes the parametric #' part of the fit (using a linear fit in \code{x}), so these residual #' represent the nonlinear part of the fit.} \item{nl.df}{the nonlinear degrees #' of freedom} \item{var}{the pointwise variance for the nonlinear fit} #' #' When \code{gam.s} is evaluated with an \code{xeval} argument, it returns a #' vector of predictions. #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992). #' @seealso \code{\link{lo}}, \code{\link{smooth.spline}}, \code{\link{bs}}, #' \code{\link{ns}}, \code{\link{poly}} #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' #' Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} #' London: Chapman and Hall. #' #' Cantoni, E. and hastie, T. (2002) Degrees-of-freedom tests for smoothing #' splines, \emph{Biometrika} 89(2), 251-263 #' @keywords models regression nonparametric smooth #' @examples #' #' # fit Start using a smoothing spline with 4 df. #' y ~ Age + s(Start, 4) #' # fit log(Start) using a smoothing spline with 5 df. #' y ~ Age + s(log(Start), df=5) #' #' @export "gam.s" <- function(x, y, w = rep(1, length(x)), df = 4, spar = 1, xeval) { storage.mode(x) <- storage.mode(y) <- storage.mode(w) <- storage.mode( spar) <- storage.mode(df) <- "double" n <- as.integer(length(x)) x <- signif(x, 6) mat <- gam.match(x) omat <- mat$o nef <- mat$nef ## ## in rgam.r, splsm calls both splsm1 and splsm2. ## splsm2 needs (10+2*4)*(nef+2)+5*nef+n+15 doubles for work. ## splsm1 needs 3*nef+2*n+10. work.len <- max(3 * nef + 2 * n + 10, (10 + 2 * 4) * (nef + 2) + 5 * nef + n + 15) fit <- .Fortran("splsm", x, y, w, n, omat, nef, spar = spar, df = df, s = double(n), s0 = double(1), var = double(nef), FALSE, work = double(work.len), PACKAGE="gam") if(missing(xeval)) list(residuals = y - fit$s, nl.df = fit$df - 1, var = fit$ var[omat]) else { skn <- .Fortran("sknotl", fit$work[seq(nef)], nef, knot = double(nef + 6), k = integer(1), PACKAGE="gam") smallest <- x[omat == 1][1] largest <- x[omat == nef][1] k <- skn$k gam.sp(xeval, skn$knot[seq(k)], k - 4, fit$work[seq(3 * nef + n + 10, length = k - 4)], smallest, largest - smallest) } } gam/R/gam.sp.R0000644000176200001440000000210314331341323012520 0ustar liggesusers#' @export "gam.sp" <- function(x, knots, nknots, coef, smallest, scale) { nas <- is.na(x) xs <- as.double((x[!nas] - smallest)/scale) bad.left <- xs < 0 bad.right <- xs > 1 good <- !(bad.left | bad.right) y <- xs if(any(good)) { junk <- .Fortran("bvalus", as.integer(sum(good)), knots, coef, as.integer(nknots), xs[good], s = double(sum(good)), as.integer(0), PACKAGE="gam") y[good] <- junk$s } if(any(!good)) { end.fit <- .Fortran("bvalus", as.integer(2), knots, coef, as.integer(nknots), as.double(c(0, 1)), s = double(2), as.integer(0), PACKAGE="gam")$s end.slopes <- .Fortran("bvalus", as.integer(2), knots, coef, as.integer(nknots), as.double(c(0, 1)), s = double(2), as.integer(1), PACKAGE="gam")$s if(any(bad.left)) y[bad.left] <- end.fit[1] + end.slopes[1] * (xs[ bad.left]) if(any(bad.right)) y[bad.right] <- end.fit[2] + end.slopes[2] * (xs[ bad.right] - 1) } pred <- x * 0 pred[!nas] <- y pred } gam/R/anova.gam.R0000644000176200001440000000510714331605303013212 0ustar liggesusers#' Analysis of Deviance for a Generalized Additive Model #' #' Produces an ANODEV table for a set of GAM models, or else a summary for a single GAM model #' #' These are methods for the functions \code{anova} or \code{summary} for #' objects inheriting from class `Gam`. See \code{\link{anova}} for the general #' behavior of this function and for the interpretation of `test`. #' #' When called with a single `Gam` object, a special pair of anova tables for #' `Gam` models is returned. This gives a breakdown of the degrees of freedom #' for all the terms in the model, separating the projection part and #' nonparametric part of each, and returned as a list of two anova objects. For #' example, a term specified by `s()` is broken down into a single degree of #' freedom for its linear component, and the remainder for the nonparametric #' component. In addition, a type of score test is performed for each of the #' nonparametric terms. The nonparametric component is set to zero, and the #' linear part is updated, holding the other nonparametric terms fixed. This is #' done efficiently and simulataneously for all terms. #' #' @aliases anova.Gam summary.Gam #' @param object a fitted Gam #' @param ... other fitted Gams for \code{anova} #' @param test a character string specifying the test statistic to be used. #' Can be one of '"F"', '"Chisq"' or '"Cp"', with partial matching allowed, or #' 'NULL' for no test. #' @param dispersion a dispersion parameter to be used in computing standard #' errors #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992). #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' #' Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} #' London: Chapman and Hall. #' #' Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics #' with S.} New York: Springer. #' @keywords models regression nonparametric smooth #' @method anova Gam #' @export #' @export anova.Gam #' @examples #' #' data(gam.data) #' Gam.object <- gam(y~s(x,6)+z,data=gam.data) #' anova(Gam.object) #' Gam.object2 <- update(Gam.object, ~.-z) #' anova(Gam.object, Gam.object2, test="Chisq") "anova.Gam" <- function(object, ..., test = c("Chisq", "F", "Cp")) { test=match.arg(test) margs <- function(...) nargs() if(margs(...)) anova(structure(list(object, ...),class="glmlist"), test = test) else summary.Gam(object)$anova } gam/R/lo.R0000644000176200001440000001561514331341323011761 0ustar liggesusers#' Specify a loess fit in a GAM formula #' #' A symbolic wrapper to indicate a smooth term in a formala argument to gam #' #' A smoother in gam separates out the parametric part of the fit from the #' non-parametric part. For local regression, the parametric part of the fit is #' specified by the particular polynomial being fit locally. The workhorse #' function \code{gam.lo} fits the local polynomial, then strips off this #' parametric part. All the parametric pieces from all the terms in the #' additive model are fit simultaneously in one operation for each loop of the #' backfitting algorithm. #' #' @aliases lo gam.lo #' @param ... the unspecified \code{\dots{}} can be a comma-separated list of #' numeric vectors, numeric matrix, or expressions that evaluate to either of #' these. If it is a list of vectors, they must all have the same length. #' @param span the number of observations in a neighborhood. This is the #' smoothing parameter for a \code{loess} fit. If specified, the full argument #' name \code{span} must be written. #' @param degree the degree of local polynomial to be fit; currently restricted #' to be \code{1} or \code{2}. If specified, the full argument name #' \code{degree} must be written. #' @param x for \code{gam.lo}, the appropriate basis of polynomials generated #' from the arguments to \code{lo}. These are also the variables that receive #' linear coefficients in the GAM fit. #' @param y a response variable passed to \code{gam.lo} during backfitting #' @param w weights #' @param ncols for \code{gam.lo} the number of columns in \code{x} used as the #' smoothing inputs to local regression. For example, if \code{degree=2}, then #' \code{x} has two columns defining a degree-2 polynomial basis. Both are #' needed for the parameteric part of the fit, but \code{ncol=1} telling the #' local regression routine that the first column is the actually smoothing #' variable. #' @param xeval If this argument is present, then \code{gam.lo} produces a #' prediction at \code{xeval}. #' @return \code{lo} returns a numeric matrix. The simplest case is when there #' is a single argument to \code{lo} and \code{degree=1}; a one-column matrix #' is returned, consisting of a normalized version of the vector. If #' \code{degree=2} in this case, a two-column matrix is returned, consisting of #' a degree-2 polynomial basis. Similarly, if there are two arguments, or the #' single argument is a two-column matrix, either a two-column matrix is #' returned if \code{degree=1}, or a five-column matrix consisting of powers #' and products up to degree \code{2}. Any dimensional argument is allowed, #' but typically one or two vectors are used in practice. #' #' The matrix is endowed with a number of attributes; the matrix itself is used #' in the construction of the model matrix, while the attributes are needed for #' the backfitting algorithms \code{general.wam} (weighted additive model) or #' \code{lo.wam} (currently not implemented). Local-linear curve or surface #' fits reproduce linear responses, while local-quadratic fits reproduce #' quadratic curves or surfaces. These parts of the \code{loess} fit are #' computed exactly together with the other parametric linear parts #' #' When two or more smoothing variables are given, the user should make sure #' they are in a commensurable scale; \code{lo()} does no normalization. This #' can make a difference, since \code{lo()} uses a spherical (isotropic) #' neighborhood when establishing the nearest neighbors. #' #' Note that \code{lo} itself does no smoothing; it simply sets things up for #' \code{gam}; \code{gam.lo} does the actual smoothing. of the model. #' #' One important attribute is named \code{call}. For example, \code{lo(x)} has #' a call component \code{gam.lo(data[["lo(x)"]], z, w, span = 0.5, degree = 1, #' ncols = 1)}. This is an expression that gets evaluated repeatedly in #' \code{general.wam} (the backfitting algorithm). #' #' \code{gam.lo} returns an object with components \item{residuals}{The #' residuals from the smooth fit. Note that the smoother removes the parametric #' part of the fit (using a linear fit with the columns in \code{x}), so these #' residual represent the nonlinear part of the fit.} \item{nl.df}{the #' nonlinear degrees of freedom} \item{var}{the pointwise variance for the #' nonlinear fit} #' #' When \code{gam.lo} is evaluated with an \code{xeval} argument, it returns a #' matrix of predictions. #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992). #' @seealso \code{\link{s}}, \code{\link{bs}}, \code{\link{ns}}, #' \code{\link{poly}}, \code{\link{loess}} #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' #' Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} #' London: Chapman and Hall. #' @keywords models regression nonparametric smooth #' @examples #' #' y ~ Age + lo(Start) #' # fit Start using a loess smooth with a (default) span of 0.5. #' y ~ lo(Age) + lo(Start, Number) #' y ~ lo(Age, span=0.3) # the argument name span cannot be abbreviated. #' #' @export lo lo <- function (..., span = 0.5, degree = 1) { vars <- list(...) locall <- sys.call() chcall <- deparse(locall) nvars <- length(vars) if (degree > 2) stop("degrees 1 or 2 are implemented") if (nvars == 1) { xvar <- as.matrix(vars[[1]]) xnames <- deparse(locall[[2]]) if(is.null(dimnames(xvar)[[2]])){ nc=ncol(xvar) dxnames=xnames if(nc>1)dxnames=paste(xnames,1:nc,sep=".") dimnames(xvar)=list(NULL,dxnames) } } else { nobs <- length(vars[[1]]) xvar <- matrix(0, nobs, nvars) xnames <- character(nvars) for (i in seq(nvars)) { tt <- vars[[i]] if (!is.null(dd <- dim(tt)) && dd[2] > 1) stop("either call lo with a matrix argument, or else a comma separated list x1, x2") exptt <- locall[[i + 1]] xnames[i] <- deparse(exptt) xvar[, i] <- as.numeric(tt) } dimnames(xvar) <- list(NULL, xnames) } polyx <- polylo(xvar, degree = degree) pd <- attr(polyx, "degree") opd <- order(pd) if (length(pd) > 1) { polyx <- polyx[, opd] p <- sum(pd == 1) } else p <- 1 nobs <- dim(polyx)[1] nas <- is.na(polyx[, 1:p]) if (any(nas)) { if (p > 1) nas <- nas %*% array(1, c(p, 1)) attr(polyx, "NAs") <- seq(nobs)[nas > 0] } real.call <- substitute(gam.lo(data[[chcall]], z, w, span = span, degree = degree, ncols = p), list(span = span, degree = degree, chcall = chcall, p = p)) atts <- c(attributes(polyx), list(span = span, degree = degree, ncols = p, call = real.call)) attributes(polyx) <- atts class(polyx) <- c("smooth", "matrix") polyx } gam/R/lo.wam.R0000644000176200001440000000721114331341323012535 0ustar liggesusers#' @export "lo.wam" <- function(x, y, w, s, which, smooth.frame, maxit = 30, tol = 1e-7, trace = FALSE, se = TRUE, ...) { if(is.data.frame(smooth.frame)) { first <- TRUE # first call to wam; set up some things #on first entry, smooth.frame is a data frame with elements the terms to be #smoothed in which data <- smooth.frame[, names(which), drop = FALSE] smooth.frame <- gam.match(data) dx <- as.integer(dim(x)) oldClass(data) <- NULL atts <- lapply(data, attributes) span <- sapply(atts, "[[", "span") degree <- sapply(atts, "[[", "degree") nvars <- sapply(atts, "[[", "ncols") ndim <- sapply(atts, "[[", "dim")[2, ] npetc <- as.integer(c(dx, length(which), 0, maxit, 0)) nef <- smooth.frame$nef nvmax <- 200 + 300 * (1 - 1/log(apply(cbind(nef - 200, 3), 1, max))) # nvmax <- pmax(200,nef) nspar <- (nef * span + 1) # liv <- 50 + (2^nvars + 4) * nvmax + 2 * nef # lv <- 50 + (3 * nvars + 3) * nvmax + nef + (ifelse(degree == # 2, ((nvars + 2) * (nvars + 1))/2, nvars + 1) + # 2) * nspar liv <- 100 + (2^nvars + 4) * nvmax + 2 * nef lv <- 100 + (3 * nvars + 3) * nvmax + nef + (ifelse(degree == 2, ((nvars + 2) * (nvars + 1))/2, nvars + 1) + 2) * nspar LL <- nspar * nvmax liv <- liv + LL lv <- lv + (nvars + 1) * LL which <- sapply(which, "[", 1) wddnfl <- cbind(unlist(which), nvars, ndim, degree, nef, liv=ceiling(liv), lv=ceiling(lv), nvmax=ceiling(nvmax)) storage.mode(wddnfl) <- "integer" spatol <- as.double(c(span, tol)) nwork <- 9 * dx[1] + sum(nef * (nvars + ndim + 4) + 5 + 3 * ndim) ###I put in a factor 2 here because I dont know what else to do to solved this seg fault liv <- as.integer(2*ceiling(sum(liv))) lv <- as.integer(2*ceiling(sum(lv))) smooth.frame <- c(smooth.frame, list(npetc = npetc, wddnfl = wddnfl, spatol = spatol,niwork=2*sum(nvars), nwork = nwork, liv = liv, lv = lv)) } else first <- FALSE storage.mode(y) <- "double" storage.mode(w) <- "double" n <- smooth.frame$npetc[1] p <- smooth.frame$npetc[2] q <- smooth.frame$npetc[3] fit <- .Fortran("baklo", x, y = y, w = w, npetc = smooth.frame$npetc, smooth.frame$wddnfl, smooth.frame$spatol, smooth.frame$o, etal = double(n), s = s, eta = double(n), beta = double(p), var = s, df = double(q), qr = x, qraux = double(p), qpivot = as.integer(1:p), effects=double(n), integer(smooth.frame$liv), double(smooth.frame$lv), integer(smooth.frame$niwork), double(smooth.frame$nwork), PACKAGE="gam") nit <- fit$npetc[4] qrank <- fit$npetc[6] if((nit == maxit) & maxit > 1) warning(paste("lo.wam convergence not obtained in ", maxit, " iterations")) names(fit$df) <- dimnames(s)[[2]] names(fit$beta) <- labels(x)[[2]] qrx <- structure(list(qr = fit$qr,qraux = fit$qraux, rank = qrank, pivot = fit$qpivot,tol=1e-7),class="qr") effects<-fit$effects r1 <- seq(len = qrx$rank) dn <- colnames(x) if (is.null(dn)) dn <- paste("x", 1:p, sep = "") names(effects) <- c(dn[qrx$pivot[r1]], rep.int("", n - qrx$rank)) rl <- list(coefficients = fit$beta, residuals = fit$y - fit$eta, fitted.values = fit$eta, effects=effects, weights=w, rank=qrank, assign=attr(x,"assign"), qr=qrx, smooth = fit$s, nl.df = fit$df ) rl$df.residual <- n - qrank - sum(rl$nl.df) - sum(fit$w == 0) rl$iter=NA if(se) rl <- c(rl, list(var = fit$var)) c(list(smooth.frame = smooth.frame), rl) } gam/R/assign.list.R0000644000176200001440000000034314331341323013575 0ustar liggesusers#' @export assign.list<-function(assignx,term.labels){ ass<-as.list(seq(term.labels)) names(ass)<-term.labels indexset<-seq(along=assignx) lapply(ass,function(i,indexset,assignx)indexset[assignx==i],indexset,assignx) } gam/R/step.gam.R0000644000176200001440000003162514331341323013064 0ustar liggesusers#' Stepwise model builder for GAM #' #' Builds a GAM model in a step-wise fashion. For each "term" there is an #' ordered list of alternatives, and the function traverses these in a greedy #' fashion. Note: this is NOT a method for \code{step}, which used to be a #' generic, so must be invoked with the full name. #' #' @param object An object of class \code{Gam} or any of it's inheritants. #' @param scope defines the range of models examined in the step-wise search. #' It is a list of formulas, with each formula corresponding to a term in the #' model. Each of these formulas specifies a "regimen" of candidate forms in #' which the particular term may enter the model. For example, a term formula #' might be \code{~1+ Income + log(Income) + s(Income)}. This means that #' \code{Income} could either appear not at all, linearly, linearly in its #' logarithm, or as a smooth function estimated nonparametrically. A \code{1} #' in the formula allows the additional option of leaving the term out of the #' model entirely. Every term in the model is described by such a term #' formula, and the final model is built up by selecting a component from each #' formula. #' #' As an alternative more convenient for big models, each list can have instead #' of a formula a character vector corresponding to the candidates for that #' term. Thus we could have \code{c("1","x","s(x,df=5")} rather than #' \code{~1+x+s(x,df=5)}. #' #' The supplied model \code{object} is used as the starting model, and hence #' there is the requirement that one term from each of the term formulas be #' present in \code{formula(object)}. This also implies that any terms in #' \code{formula(object)} \emph{not} contained in any of the term formulas will #' be forced to be present in every model considered. The function #' \code{gam.scope} is helpful for generating the scope argument for a large #' model. #' @param scale an optional argument used in the definition of the AIC #' statistic used to evaluate models for selection. By default, the scaled #' Chi-squared statistic for the initial model is used, but if forward #' selection is to be performed, this is not necessarily a sound choice. #' @param direction The mode of step-wise search, can be one of \code{"both"}, #' \code{"backward"}, or \code{"forward"}, with a default of \code{"both"}. If #' \code{scope} is missing, the default for \code{direction} is "both". #' @param trace If \code{TRUE} (the default), information is printed during the #' running of \code{step.Gam()}. This is an encouraging choice in general, #' since \code{step.Gam()} can take some time to compute either for large #' models or when called with an an extensive \code{scope=} argument. A simple #' one line model summary is printed for each model selected. This argument can #' also be given as the binary \code{0} or \code{1}. A value \code{trace=2} #' gives a more verbose trace. #' @param keep A filter function whose input is a fitted \code{Gam} object, and #' anything else passed via \dots{}, and whose output is arbitrary. Typically #' \code{keep()} will select a subset of the components of the object and #' return them. The default is not to keep anything. #' @param steps The maximum number of steps to be considered. The default is #' 1000 (essentially as many as required). It is typically used to stop the #' process early. #' @param parallel If \code{TRUE}, use parallel \code{foreach} to fit each #' trial run. Must register parallel before hand, such as \code{doMC} or #' others. See the example below. #' @param \dots Additional arguments to be passed on to \code{keep} #' @return The step-wise-selected model is returned, with up to two additional #' components. There is an \code{"anova"} component corresponding to the steps #' taken in the search, as well as a \code{"keep"} component if the #' \code{keep=} argument was supplied in the call. #' #' We describe the most general setup, when \code{direction = "both"}. At any #' stage there is a current model comprising a single term from each of the #' term formulas supplied in the \code{scope=} argument. A series of models is #' fitted, each corrresponding to a formula obtained by moving each of the #' terms one step up or down in its regimen, relative to the formula of the #' current model. If the current value for any term is at either of the extreme #' ends of its regimen, only one rather than two steps can be considered. So if #' there are \code{p} term formulas, at most \code{2*p - 1} models are #' considered. A record is kept of all the models ever visited (hence the #' \code{-1} above), to avoid repetition. Once each of these models has been #' fit, the "best" model in terms of the AIC statistic is selected and defines #' the step. The entire process is repeated until either the maximum number of #' steps has been used, or until the AIC criterion can not be decreased by any #' of the eligible steps. #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992). #' @seealso \code{\link{gam.scope}},\code{\link{step}},\code{\link{glm}}, #' \code{\link{gam}}, \code{\link{drop1}}, \code{\link{add1}}, #' \code{\link{anova.Gam}} #' @references Hastie, T. J. (1992) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' #' Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive Models.} #' London: Chapman and Hall. #' @keywords models regression nonparametric smooth #' @examples #' #' data(gam.data) #' Gam.object <- gam(y~x+z, data=gam.data) #' step.object <-step.Gam(Gam.object, scope=list("x"=~1+x+s(x,4)+s(x,6)+s(x,12),"z"=~1+z+s(z,4))) #' \dontrun{ #' # Parallel #' require(doMC) #' registerDoMC(cores=2) #' step.Gam(Gam.object, scope=list("x"=~1+x+s(x,4)+s(x,6)+s(x,12),"z"=~1+z+s(z,4)),parallel=TRUE) #' } #' #' #' @export step.Gam step.Gam <- function (object, scope, scale, direction = c("both", "backward", "forward"), trace = TRUE, keep = NULL, steps = 1000, parallel=FALSE,...) { trace=as.numeric(trace) get.visit <- function(trial, visited){ match(paste(trial,collapse=""),apply(visited,2,paste,collapse=""),FALSE) } deviancelm <- function(object, ...) if(is.null(w <- object$weights)) sum(object$residuals^2) else sum(w * object$ residuals^2) scope.char <- function(formula) { formula = update(formula, ~-1 + .) tt <- terms(formula) tl <- attr(tt, "term.labels") if (attr(tt, "intercept")) c("1", tl) else tl } re.arrange <- function(keep) { namr <- names(k1 <- keep[[1]]) namc <- names(keep) nc <- length(keep) nr <- length(k1) array(unlist(keep, recursive = FALSE), c(nr, nc), list(namr, namc)) } untangle.scope <- function(terms, regimens) { a <- attributes(terms) response <- deparse(a$variables[[2]]) term.labels <- a$term.labels if (!is.null(a$offset)) { off1 <- deparse(a$variables[[a$offset]]) } nt <- length(regimens) select <- integer(nt) for (i in seq(nt)) { j <- match(regimens[[i]], term.labels, 0) if (any(j)) { if (sum(j > 0) > 1) stop(paste("The elements of a regimen", i, "appear more than once in the initial model", sep = " ")) select[i] <- seq(j)[j > 0] term.labels <- term.labels[-sum(j)] } else { if (!(j <- match("1", regimens[[i]], 0))) stop(paste("regimen", i, "does not appear in the initial model", sep = " ")) select[i] <- j } } if (length(term.labels)) term.labels <- paste(term.labels, "+") if (!is.null(a$offset)) term.labels <- paste(off1, term.labels, sep = " + ") return(list(response = paste(response, term.labels, sep = " ~ "), select = select)) } make.step <- function(models, fit, scale, object) { chfrom <- sapply(models, "[[", "from") chfrom[chfrom == "1"] <- "" chto <- sapply(models, "[[", "to") chto[1]="" chto[chto == "1"] <- "" dev <- sapply(models, "[[", "deviance") df <- sapply(models, "[[", "df.resid") ddev <- c(NA, diff(dev)) ddf <- c(NA, diff(df)) AIC <- sapply(models, "[[", "AIC") heading <- c("Stepwise Model Path \nAnalysis of Deviance Table", "\nInitial Model:", deparse(as.vector(formula(object))), "\nFinal Model:", deparse(as.vector(formula(fit))), paste("\nScale: ", format(scale), "\n", sep = "")) # rowns=paste(chfrom,chto,sep=" -> ") # rowns[1]="" # rowns=paste(seq(rowns)-1,rowns,sep=": ") aod <- data.frame(From=chfrom,To=chto, Df = ddf, Deviance = ddev, `Resid. Df` = df, `Resid. Dev` = dev, AIC = AIC, check.names = FALSE) aod <- as.anova(aod, heading) class(aod)=c("stepanova","data.frame") fit$anova=aod fit } direction <- match.arg(direction) if (missing(scope)) stop("you must supply a scope argument to step.Gam(); the gam.scope() function might be useful") if (!is.character(scope[[1]])) scope <- lapply(scope, scope.char) response <- untangle.scope(object$terms, scope) form.y <- response$response backward <- direction == "both" | direction == "backward" forward <- direction == "both" | direction == "forward" items <- response$select family <- family(object) Call <- object$call term.lengths <- sapply(scope, length) n.items <- length(items) visited <- matrix(items) form.vector <- character(n.items) for (i in seq(n.items)) form.vector[i] <- scope[[i]][items[i]] form <- deparse(object$formula) if (trace>0) cat("Start: ", form) fit <- object n <- length(fit$fitted) if (missing(scale)) { famname <- family$family["name"] scale <- switch(famname, Poisson = 1, Binomial = 1, deviancelm(fit)/fit$df.resid) } else if (scale == 0) scale <- deviancelm(fit)/fit$df.resid bAIC <- fit$aic if (trace>0) cat("; AIC=", format(round(bAIC, 4)), "\n") models <- list( list(deviance = deviance(fit), df.resid = fit$df.resid, AIC = bAIC, from = "", to = "") ) if (!is.null(keep)) { keep.list <- list(keep(fit,...)) keep.it=TRUE} else keep.it=FALSE AIC <- bAIC + 1 stepnum=0 while (bAIC < AIC & steps > 0) { steps <- steps - 1 stepnum=stepnum+1 AIC <- bAIC form.list=NULL ###First some prelimenaries to see what formulas to try for (i in seq(n.items)) { if (backward) { trial <- items trial[i] <- trial[i] - 1 if (trial[i] > 0 && !get.visit(trial,visited)) { visited<-cbind(visited,trial) tform.vector <- form.vector tform.vector[i] <- scope[[i]][trial[i]] form.list=c(form.list,list(list(trial=trial, form.vector=tform.vector, which=i))) } } if (forward) { trial <- items trial[i] <- trial[i] + 1 if (trial[i] <= term.lengths[i] && !get.visit(trial,visited)){ visited<-cbind(visited,trial) tform.vector <- form.vector tform.vector[i] <- scope[[i]][trial[i]] form.list=c(form.list,list(list(trial=trial, form.vector=tform.vector, which=i))) } } } if(is.null(form.list))break ### Now we are ready for the expensive loop ### Parallel is set up #if(parallel&&require(foreach)){ if(parallel){ # step.list=foreach(i=1:length(form.list),.inorder=FALSE,.packages="gam",.verbose=trace>1)%dopar% step.list=foreach(i=1:length(form.list),.inorder=FALSE,.verbose=trace>1)%dopar% { tform=paste(form.y, paste(form.list[[i]]$form.vector, collapse = " + ")) update(object, eval(parse(text = tform)),trace = FALSE, ...) } } ### No parallel else { step.list=as.list(sequence(length(form.list))) for(i in 1:length(form.list)){ tform=paste(form.y, paste(form.list[[i]]$form.vector, collapse = " + ")) step.list[[i]]=update(object, eval(parse(text = tform)),trace = FALSE, ...) if(trace>1)cat("Trial: ", tform,"; AIC=", format(round(step.list[[i]]$aic, 4)), "\n") } } ### end expensive loop taic.vec=sapply(step.list,"[[","aic") if(keep.it) keep.list=c(keep.list, lapply(step.list,keep,...)) bAIC=min(taic.vec) if (bAIC >= AIC | steps == 0) { if (keep.it) fit$keep <- re.arrange(keep.list) return(make.step(models, fit, scale, object)) } else { o1=order(taic.vec)[1] fit=step.list[[o1]] form.list=form.list[[o1]] bwhich=form.list$which bfrom=form.vector[bwhich] form.vector=form.list$form.vector #this is the new one bto=form.vector[bwhich] if (trace>0) cat(paste("Step:",stepnum,sep=""), deparse(fit$formula), "; AIC=", format(round(bAIC, 4)), "\n") items <- form.list$trial models <- c(models,list(list(deviance = deviance(fit), df.resid = fit$df.resid, AIC = bAIC, from = bfrom, to = bto))) } } } gam/R/gam.match.R0000644000176200001440000000233214331341323013176 0ustar liggesusers#' @export "gam.match" <- function(x) { if(is.list(x)) { junk <- Recall(x[[1]]) if((nvar <- length(x)) == 1) return(list(o = junk$o, nef = junk$nef)) else { o <- matrix(junk$o, length(junk$o), nvar) nef <- rep(junk$nef, nvar) for(i in 2:nvar) { junk <- Recall(x[[i]]) o[, i] <- junk$o nef[i] <- junk$nef } names(nef) <- nn <- names(x) dimnames(o) <- list(NULL, nn) return(list(o = o, nef = nef)) } } if(is.matrix(x)) { ats <- attributes(x) a <- ats$NAs ncols <- ats$ncols d <- dim(x) if(is.null(ncols)) ncols <- d[2] if(ncols == 1) return(Recall(structure(x[, 1, drop = TRUE], NAs = a))) if(is.null(a)) { o <- seq(d[1]) nef <- d[1] } else { nef <- d[1] - length(a) o <- rep(nef + 1, d[1]) o[ - a] <- seq(nef) } return(list(o = as.integer(o), nef = as.integer(nef))) } else { a <- attributes(x)$NAs if(!is.null(a)) x[a] <- NA xr <- signif(as.vector(x), 6) sx <- unique(sort(xr)) nef <- as.integer(length(sx)) if(nef <= 3) stop("A smoothing variable encountered with 3 or less unique values; at least 4 needed" ) o <- match(xr, sx, nef + 1) o[is.na(o)] <- nef + 1 return(list(o = as.integer(o), nef = as.integer(nef))) } } gam/R/gam.nlchisq.R0000644000176200001440000000025114331341323013541 0ustar liggesusers#' @export "gam.nlchisq" <- function(qr, resid, w, s) { wt <- sqrt(w) s <- s * wt resid <- wt * resid Rsw <- qr.resid(qr, s) apply(Rsw^2 + 2 * s * resid, 2, sum) } gam/R/random.R0000644000176200001440000000077714331341323012632 0ustar liggesusers#' @rdname gam.random #' @export random "random" <- function (f, df = NULL, lambda = 0, intercept = TRUE) { scall <- deparse(sys.call()) if (!inherits(f, "factor")) stop("random() expects a factor or category as its first argument") newf=rep(0,length(f)) attr(newf,"values")=f attr(newf, "call") <- substitute(gam.random(data[[scall]], z, w, df = df, lambda = lambda, intercept = intercept)) oldClass(newf) <- "smooth" newf } gam/R/gplot.numeric.R0000644000176200001440000000305614331341323014131 0ustar liggesusers#' @method gplot numeric #' @export #' @export gplot.numeric "gplot.numeric" <- function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, xlim = NULL, ylim = NULL, fit = TRUE, ...) { if(length(x) != length(y)) stop("x and y do not have the same length; possibly a consequence of an na.action" ) ### Here we check if its a simple linear term; if so, we include a point at the mean of x if(se && !is.null(se.y) && ylab==paste("partial for",xlab)){ x=c(x,mean(x)) y=c(y,0) se.y=c(se.y,0) } ux <- unique(sort(x)) o <- match(ux, x) uy <- y[o] xlim <- range(xlim, ux) ylim <- range(ylim, uy) if(rugplot) { jx <- jitter(x[!is.na(x)]) xlim <- range(c(xlim, jx)) } if(se && !is.null(se.y)) { se.upper <- uy + 2 * se.y[o] se.lower <- uy - 2 * se.y[o] ylim <- range(c(ylim, se.upper, se.lower)) } if(!is.null(residuals)) { if(length(residuals) == length(y)) { residuals <- y + residuals ylim <- range(c(ylim, residuals)) } else { residuals <- NULL warning(paste("Residuals do not match x in \"", ylab, "\" preplot object", sep = "")) } } ylim <- ylim.scale(ylim, scale) if(!is.null(residuals)) { plot(x, residuals, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, ...) if(fit) lines(ux, uy) } else { if(fit) plot(ux, uy, type = "l", xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, ...) } if(rugplot) rug(jx) if(se) { lines(ux, se.upper, lty = 3) lines(ux, se.lower, lty = 3) } invisible(diff(ylim)) } gam/R/gam.scope.R0000644000176200001440000000514414331341323013217 0ustar liggesusers#' Generate a scope for step.Gam #' #' Given a data.frame as an argument, generate a scope list for use in #' step.Gam, each element of which gives the candidates for that term. #' #' This function creates a similar scope formula for each variable in the #' frame. A column named "x" by default will generate a scope term #' \code{~1+x+s(x)}. With \code{arg=c("df=4","df=6")} we get #' \code{~1+x+s(x,df=4)+s(x,df=6)}. With form=FALSE, we would get the character #' vector \code{c("1","x","s(x,df=4)","s(x,df=6")}. #' #' @param frame a data.frame to be used in \code{step.Gam}. Apart from the #' response column, all other columns will be used. #' @param response The column in \code{frame} used as the response. Default is #' 1. #' @param smoother which smoother to use for the nonlinear terms; i.e. "s" or #' "lo", or any other supplied smoother. Default is "s". #' @param arg a character (vector), which is the argument to \code{smoother}. #' For example, \code{arg="df=6"} would result in the expression #' \code{s(x,df=6)} for a column named "x". This can be a vector, for example #' \code{arg=c("df=4","df=6")}, which would result two smooth terms. #' @param form if \code{TRUE}, each term is a formula, else a character vector. #' @return a scope list is returned, with either a formula or a character #' vector for each term, which describes the candidates for that term in the #' Gam. #' @author Written by Trevor Hastie, following closely the design in the #' "Generalized Additive Models" chapter (Hastie, 1992) in Chambers and Hastie #' (1992). This version of \code{gam.scope} is adapted from the S version. #' @seealso \code{\link{step.Gam}} #' @references Hastie, T. J. (1991) \emph{Generalized additive models.} Chapter #' 7 of \emph{Statistical Models in S} eds J. M. Chambers and T. J. Hastie, #' Wadsworth & Brooks/Cole. #' @keywords models regression nonparametric smooth #' @examples #' #' data(gam.data) #' gdata=gam.data[,1:3] #' gam.scope(gdata,2) #' gam.scope(gdata,2,arg="df=5") #' gam.scope(gdata,2,arg="df=5",form=FALSE) #' gam.scope(gdata,2,arg=c("df=4","df=6")) #' #' @export gam.scope "gam.scope" <- function(frame, response = 1, smoother = "s", arg = NULL, form = TRUE) { vnames <- names(frame) vnames <- vnames[ - response] step.list <- as.list(vnames) names(step.list) <- vnames for(vname in vnames) { junk <- c("1", vname) if(is.vector(frame[[vname]])) junk <- c(junk, paste(smoother, "(", vname, if(is.null( arg)) ")" else paste(",", arg, ")", sep = ""), sep = "")) if(form) junk <- eval(parse(text = paste("~", paste(junk, collapse = "+")))) step.list[[vname]] <- junk } step.list } gam/R/gam-package.R0000644000176200001440000000514014331341323013474 0ustar liggesusers#' Generalized Additive Models #' #' This package provides functions for fitting and working with generalized additive models as described in chapter 7 of "Statistical Models in S" (Chambers and Hastie (eds), 1991) and "Generalized Additive Models" (Hastie and Tibshirani, 1990). #' @name gam-package #' @docType package #' @author Trevor Hastie #' @keywords models regression package #' @useDynLib gam #' @import methods stats splines foreach #' @importFrom graphics axis lines mtext persp plot points rug segments #' @importFrom utils head tail packageDescription menu assignInMyNamespace NULL #' Internal gam functions #' #' @description Service functions and as yet undocumented functions for the gam library #' @name gam-internal #' @aliases .First.lib [.smooth general.wam anova.Gamlist as.anova #' as.data.frame.lo.smooth assign.list Gamlist gam.match gam.nlchisq gam.sp #' gplot gplot.default gplot.factor gplot.list gplot.matrix gplot.numeric #' labels.Gam lo.wam newdata.predict.Gam polylo print.Gam print.Gamex #' print.summary.Gam s.wam ylim.scale #' @author Trevor Hastie #' @keywords internal NULL #' Simulated dataset for gam #' #' A simple simulated dataset, used to test out the gam functions #' #' This dataset is artificial, and is used to test out some of the features of #' gam. #' #' @name gam.data #' @aliases gam.data gam.newdata #' @docType data #' @format A data frame with 100 observations on the following 6 variables: #' \describe{ #' \item{x}{a numeric vector - predictor} #' \item{y}{a numeric vector - the response} #' \item{z}{a numeric vector - noise predictor} #' \item{f}{a numeric vector - true function} #' \item{probf}{a numeric vector - probability function} #' \item{ybin}{a numeric vector - binary response} #' } #' @keywords datasets #' @examples #' #' data(gam.data) #' gam(y ~ s(x) + z, data=gam.data) #' NULL #' A classic example dataset for GAMs #' #' Data on the results of a spinal operation "laminectomy" on children, to #' correct for a condition called "kyphosis"; see Hastie and Tibshirani (1990) #' for details #' #' #' @name kyphosis #' @docType data #' @usage data(kyphosis) #' @format A data frame with 81 observations on the following 4 variables. #' \describe{ \item{Kyphosis}{a response factor with levels \code{absent} #' \code{present}.} \item{Age}{of child in months, a numeric vector} #' \item{Number}{of vertebra involved in the operation,a numeric vector} #' \item{Start}{level of the operation, a numeric vector} } #' @source Hastie, T. and Tibshirani, R. (1990) \emph{Generalized Additive #' Models.} London: Chapman and Hall. #' @keywords datasets NULL gam/R/gplot.matrix.R0000644000176200001440000000253714331341323013776 0ustar liggesusers#' @method gplot matrix #' @export #' @export gplot.matrix "gplot.matrix" <- function(x, y, se.y = NULL, xlab, ylab, residuals = NULL, rugplot = FALSE, scale = 0, se = FALSE, fit, ...) { if(ncol(x) != 2) { warning(paste("A perspective plot was requested for \"", ylab, "\" but the \"x\" variable has dimension other than 2", sep = "")) invisible(return(0)) } bivar.dup <- function(x) { if(is.null(dx <- dim(x)) || dx[2] > 2) stop("x must be bivariate") duplicated(x[, 1] + (1i) * x[, 2]) } xname <- dimnames(x)[[2]] dups <- bivar.dup(x) if (requireNamespace("interp", quietly = TRUE)) { xyz <- interp::interp(x[!dups, 1], x[!dups, 2], y[!dups]) } else { stop("You need to install the package 'interp' from the R contributed libraries to use this plotting method for bivariate functions") } zmin <- min(xyz$z[!is.na(xyz$z)]) z <- ifelse(is.na(xyz$z), zmin, xyz$z) scale2 <- diff(range(z)) # Adjust scale scale <- max(scale, scale2) # persp(xyz$x, xyz$y, (z - zmin)/scale, xlab = xname[1], ylab = xname[ # 2], zlab = ylab, ...) persp(xyz$x, xyz$y, z, xlab = xname[1], ylab = xname[2], zlab = ylab, ...) invisible(scale) } gam/R/plot.preplot.gam.R0000644000176200001440000000161014331341323014542 0ustar liggesusers#' @method plot preplot.Gam #' @export #' @export plot.preplot.Gam "plot.preplot.Gam" <- function(x, y = NULL, residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, fit = TRUE, ...) { listof <- inherits(x[[1]], "preplot.Gam") if(listof) { TT <- names(x) scales <- rep(0, length(TT)) names(scales) <- TT for(i in TT) scales[i] <- plot.preplot.Gam(x[[i]], y = NULL, residuals, rugplot, se, scale, fit, ...) # scales[i] <- UseMethod("plot",x[[i]]) invisible(scales) } else { dummy <- function(residuals = NULL, rugplot = TRUE, se = FALSE, scale = 0, fit = TRUE, ...) c(list(residuals = residuals, rugplot = rugplot, se = se, scale = scale, fit = fit), list(...)) d <- dummy(residuals, rugplot, se, scale, fit, ...) uniq.comps <- unique(c(names(x), names(d))) Call <- c(as.name("gplot"), c(d, x)[uniq.comps]) mode(Call) <- "call" invisible(eval(Call)) } } gam/R/gamlist.R0000644000176200001440000000015014331341323012773 0ustar liggesusers#' @export "Gamlist" <- function(...) { gl <- list(...) oldClass(gl) <- c("Gamlist", "glmlist") gl } gam/R/polylo.R0000644000176200001440000000410514331341323012655 0ustar liggesusers#' @export polylo <- function (x, degree = 1, monomial = FALSE) { if (degree >= 4) warning("This is not a smart polynomial routine. You may get numerical problems with a degree of 4 or more") x <- as.matrix(x) dn <- dimnames(x) dd <- dim(x) np <- dd[2] ad <- rep(1, ncol(x)) ### Used to have a x=scale(x) ### That messed up predictions on new data ### So we remove it ### x=scale(x) if (np == 1) monomial <- TRUE if (degree > 1) { if (monomial) { ad <- seq(degree) px <- x cc <- sapply(split(paste(diag(np)), rep(seq(np), rep(np, np))), paste, collapse = "") tx <- x for (i in 2:degree) { px <- px * tx x <- cbind(x, px) cc <- c(cc, sapply(split(paste(diag(np) * i), rep(seq(np), rep(np, np))), paste, collapse = "")) } } else { matarray <- array(x, c(dd, degree)) for (i in 2:degree) matarray[, , i] <- x^i matarray <- aperm(matarray, c(1, 3, 2)) x <- matarray[, , np, drop=TRUE] ad0 <- seq(degree) ad <- ad0 ncol.mat0 <- degree ncol.x <- degree d0 <- paste(ad0) cc <- d0 for (ii in seq(np - 1, 1)) { index0 <- rep(seq(ncol.mat0), ncol.x) index <- rep(seq(ncol.x), rep(ncol.mat0, ncol.x)) newad <- ad0[index0] + ad[index] retain <- newad <= degree mat0 <- matarray[, , ii, drop = TRUE] if (any(retain)) newmat <- mat0[, index0[retain]] * x[, index[retain]] else newmat <- NULL ddn <- paste(d0[index0[retain]], cc[index[retain]], sep = "") zeros <- paste(rep(0, nchar(cc[1])), collapse = "") cc <- paste(0, cc, sep = "") d00 <- paste(d0, zeros, sep = "") x <- cbind(mat0, x, newmat) cc <- c(d00, cc, ddn) ad <- c(ad0, ad, newad[retain]) ncol.x <- length(ad) } } if (!is.null(dn)) dn[[2]] <- cc else dn <- list(NULL, cc) dimnames(x) <- dn } attr(x, "degree") <- ad x } gam/R/gam.exact.R0000644000176200001440000001436314331341323013215 0ustar liggesusers#' A method for gam producing asymptotically exact standard errors for linear #' estimates #' #' This function is a "wrapper" for a Gam object, and produces exact standard #' errors for each linear term in the gam call (except for the intercept). #' #' Only standard errors for the linear terms are produced. There is a print #' method for the Gamex class. #' #' @param Gam.obj a Gam object #' @return A list (of class Gamex) containing a table of coefficients and a #' variance covariance matrix for the linear terms in the formula of the gam #' call. #' @author Aidan McDermott, Department of Biostatistics, Johns Hopkins #' University. Modified by Trevor Hastie for R #' @references Issues in Semiparametric Regression: A Case Study of Time #' Series Models in Air Pollution and Mortality, Dominici F., McDermott A., #' Hastie T.J., \emph{JASA}, December 2004, 99(468), 938-948. See #' \url{https://hastie.su.domains/Papers/dominiciR2.pdf} #' @keywords models regression nonparametric smooth #' @examples #' #' set.seed(31) #' n <- 200 #' x <- rnorm(n) #' y <- rnorm(n) #' a <- rep(1:10,length=n) #' b <- rnorm(n) #' z <- 1.4 + 2.1*a + 1.2*b + 0.2*sin(x/(3*max(x))) + 0.3*cos(y/(5*max(y))) + 0.5 * rnorm(n) #' dat <- data.frame(x,y,a,b,z,testit=b*2) #' ### Model 1: Basic #' Gam.o <- gam(z ~ a + b + s(x,3) + s(y,5), data=dat) #' coefficients(summary.glm(Gam.o)) #' gam.exact(Gam.o) #' ### Model 2: Poisson #' Gam.o <- gam(round(abs(z)) ~ a + b + s(x,3) + s(y,5), data=dat,family=poisson) #' coefficients(summary.glm(Gam.o)) #' gam.exact(Gam.o) #' #' @export gam.exact "gam.exact" <- function(Gam.obj) ### ----------------------------------------------------------------------------------- ### gam.exact is a method for the Gam class. ### ### Computes the asymptotically exact variance-covariance matrix for the linear ### terms in the model (except for the intercept). ### ### Note: Use of lo in the model formula is not allowed. ### ### Author: Aidan McDermott (AMcD) ### Date: Mar 5, 2003 ### ### Mar 28, 2003 ### Fixed single linear term models -- thanks to Tim Ramsay ### April 17, 2006 ### Modified to work in R by Trevor Hastie ### ### See: ### ### [1] Issues in Semiparametric Regression: A Case Study of Time Series ### Models in Air Pollution and Mortality, ### Dominici F., McDermott A., Hastie T.J., ### Technical Report, Department of Biostatistics, Johns Hopkins University, ### Baltimore, MD, USA. ### ### ----------------------------------------------------------------------------------- { if ( is.na(match("Gam",class(Gam.obj))) ) { stop("not a Gam object") } nl.df <- Gam.obj$nl.df terms <- terms(Gam.obj) at.terms <- attributes(terms) coef <- coef(Gam.obj) w <- Gam.obj$weights mu <- Gam.obj$fitted.values eta <- Gam.obj$additive.predictors y <- as.matrix(Gam.obj$y) family <- family(Gam.obj) mu.eta.val <- family$mu.eta(eta) z <- eta + (y - mu)/mu.eta.val ### Don't want lo in Gam formula. ### if ( length((at.terms$specials)$lo) > 0 ) { ### stop("lo found in Gam formula.") ### } X <- model.matrix(Gam.obj) Y <- as.matrix(Gam.obj$y) ### only take terms that survived the original gam call names.coef <- names(coef) has.intercept <- match("(Intercept)",names.coef) if ( !is.na(has.intercept) ) names.coef <- names.coef[-has.intercept] X <- X[,names.coef] tnames <- dimnames(X)[[2]] form <- "y~" special.list <- c() ### Replace the df with the actual df returned by gam. ### Rewrite fromula to match names in X for ( k in 1:length(tnames) ) { if ( substring(tnames[k],1,2) == "s(" ) { s.call <- match.call(s,parse(text=tnames[k])) this.name <- as.name(paste("x",k,sep="")) which <- match(tnames[k],names(nl.df)) if ( is.na(which) ) stop(paste("can't find df for term",tnames[k])) this.df <- nl.df[which]+1 form <- paste(form, "+s(",this.name,",df =",this.df,")") special.list <- c(special.list,k) } else if ( substring(tnames[k],1,3) == "lo(" ) { lname <- length(tnames[k]) if ( substring(tnames[k],lname,lname) == "1" ) tnames[k] <- substring(tnames[k],1,(lname-1)) if ( substring(tnames[k],lname,lname) == ")" ) { lo.call <- match.call(lo,parse(text=tnames[k])) this.name <- as.name(paste("x",k,sep="")) lo.call[[2]] <- this.name lo.call <- deparse(lo.call) form <- paste(form,"+",lo.call) } special.list <- c(special.list,k) } else form <- paste(form,"+x",k,sep="") } mydat <- data.frame(cbind(Y,X)) names(mydat) <- c("y",paste("x",1:ncol(X),sep="")) XX <- X mydat[,"w"] <- w Control <- Gam.obj$call$control if ( is.null(Control) ) { call <- Gam.obj$call call[[1]] <- as.name("gam.control") Control <- eval(call,sys.parent()) } for ( k in 1:length(tnames) ) { if ( substring(tnames[k],1,2) != "s(" & substring(tnames[k],1,3) != "lo(" ) { this.var <- paste("x",k,sep="") upd.form <- update(as.formula(form),paste(this.var,"~. -",this.var)) XX[,k] <- gam(formula=upd.form,data=mydat,family=gaussian,weights=w, control=eval(Control))$fitted } } ### Need to test we get some data if ( length(X) == 0 ) stop("nothing to do") X <- X[,-special.list,drop=FALSE] sx <- XX[,-special.list,drop=FALSE] swx <- w*sx if ( length(X) == 0 ) stop("no linear terms in the model -- nothing to do") A <- t(X) %*% ( w * X ) - t(X) %*% ( w * sx ) B <- t(X*w) - t(swx) H <- solve(A) %*% B beta <- H %*% z varbeta <- (H * (1/w)) %*% t(H) * as.vector(summary(Gam.obj)$dispersion) se <- sqrt(diag(varbeta)) coef <- cbind(summary.glm(Gam.obj)$coef,NA,NA,NA) tab <- cbind(beta,se,beta/se,2*(1-pnorm(beta/se))) coef[dimnames(tab)[[1]],c(5,6,7)] <- tab[,c(2,3,4)] dimnames(coef) <- list(dimnames(coef)[[1]], c(dimnames(coef)[[2]][1:4], "A-exact SE","A-exact Z","A-exact P")) out.object <- list(coefficients=coef,covariance=varbeta) class(out.object) <- c("Gamex") return(out.object) } gam/R/s.R0000644000176200001440000000143014331341323011577 0ustar liggesusers#' @rdname gam.s #' @export s "s" <- function(x, df = 4, spar = 1) { scall <- deparse(sys.call()) if(missing(df)){ if(!missing(spar))df<-0 } if(ncol(as.matrix(x)) > 1) stop(paste( "The default smoother is bivariate; you gave a matrix as an argument in ", scall, "\n")) if(!is.null(levels(x))) { if(inherits(x, "ordered")) x <- as.numeric(x) else stop("unordered factors cannot be used as smoothing variables" ) } attr(x, "spar") <- spar attr(x, "df") <- df real.call <- substitute(gam.s(data[[scall]], z, w, spar = spar, df = df )) attr(x, "call") <- real.call attr(x, "class") <- "smooth" a <- is.na(x) if(any(a)) attr(x, "NAs") <- seq(along = x)[a] x } gam/R/gplot.R0000644000176200001440000000007214331341323012463 0ustar liggesusers#' @export "gplot" <- function(x, ...) UseMethod("gplot") gam/R/print.gamex.R0000644000176200001440000000021714331341323013573 0ustar liggesusers#' @method print Gamex #' @export #' @export print.Gamex "print.Gamex" <- function(x,...) { print(x$coefficients) invisible() } gam/R/anova.gamlist.R0000644000176200001440000000033514331341323014103 0ustar liggesusers#' @method anova Gamlist #' @export #' @export anova.Gamlist "anova.Gamlist" <- function(object, ..., test = c("none", "Chisq", "F", "Cp")){ test=match.arg(test) class(object)="glmlist" anova(object, test = test) } gam/MD50000644000176200001440000001154214531547262011342 0ustar liggesusersf2c1e10f8fccfeb3ad602d28a1f4e443 *ChangeLog ec8c7c33dbaabd13ca77a58588b3862e *DESCRIPTION 925c443b54adb66ef081ee4a122ee306 *NAMESPACE 45a6dd6611459b8d2de7169e2037111e *R/anova.gam.R 7a320a8e7b45eddd80986125849c1a14 *R/anova.gamlist.R 305f56e3f22adff045a0e2ee51b6bc10 *R/as.anova.R 85161fca0cf065f463e2583306f8afe2 *R/as.data.frame.lo.smooth.R 304308d3643d20a38b53084f6e0008af *R/assign.list.R ec281b5b676da6825d38a1a3b2b8f9ae *R/gam-package.R 929d4a67d517fcbcf35ccee9265efc87 *R/gam.R b857105ac05db0cec4adc1f7e3c1a760 *R/gam.control.R 6d62ea564a04fa500ff62dfefd9a6469 *R/gam.exact.R 8031ea00cb235defaa9414af06b2cc74 *R/gam.fit.R 6e8cb5b59255b50c3f00f59ad35e9b08 *R/gam.lo.R c68bd705ee5a841031a45b6911b5885d *R/gam.match.R f185fe374abe4e5bd32b03b28a78ae4f *R/gam.nlchisq.R 1c39e822cc45dfb3ec4b6c9ced2c9e10 *R/gam.random.R b2db77c3d131331fb606d3848cbe9821 *R/gam.s.R 9f4b7b269aed7212ff3b9b97ac8dea1d *R/gam.scope.R bbdcf0f404cae5c35916fcc649ebd1c6 *R/gam.smoothers.R 6a84329e19bfe5dbfd8d59804880127f *R/gam.sp.R bb498eaab43aaf907fb4fab5622b6459 *R/gamlist.R 536df42ab8fa1a1f203be2e39bddfa1e *R/general.wam.R 392fa4529bfa7e924cda330b3843434f *R/gplot.R 8087636a94c3fd3aa36677654787704e *R/gplot.default.R 7888b63a06a206a4143717b0775c6978 *R/gplot.factor.R 9b10965073a9854cdc9e3a71c691108c *R/gplot.list.R d47bfd243e9d7ff67638dffa823823cc *R/gplot.matrix.R 458f99426517fae46bda1cf6c4ce9c29 *R/gplot.numeric.R 97efd4e1ea6fcea890a5a41dccf69356 *R/labels.gam.R c04bea19d2a7a99a676b658ab9e6c585 *R/lo.R 0300abfe654d7a0c658ee13a13e880f4 *R/lo.wam.R 2e33008274c19dfd9c955114fec84785 *R/na.gam.replace.R 0adee00be27de48768858d03b7e09e82 *R/newdata.predict.gam.R 39cfb671132d4928c0a77a79edb1967d *R/onAttach.R b56811cc898935544f3e3f483c629ee6 *R/plot.gam.R b4c2974cb3759b300dd261caf4c4c3b6 *R/plot.preplot.gam.R d16fb40d09974a208b004bbbd3670169 *R/polylo.R 9f9c96deba336fb3b8f4940c80289a95 *R/predict.gam.R b1bc2f4a9b796515d9f5d36136d8c708 *R/preplot.gam.R 07738753bd098545a6abb1b31f63d1cd *R/print.gam.R 30e8060b1547d99e6947a5d5c2376341 *R/print.gamex.R 93f7a5ab6a984631d937808b46f497d2 *R/print.stepanova.R 6f6aa23675cd5ee7a6d00b290afc2bc8 *R/print.summary.gam.R f393835ccc0c054898ddfc200e40f24f *R/random.R 46648f59fe1cf566376221b03e9c78c6 *R/s.R 8d955e71d6a2e63dc50b06fd5a20cf5c *R/s.wam.R 55bfbdd6ef7e9f6ad54028310a73fcce *R/step.gam.R 5b71da053c66854b038aae4406c266e2 *R/subset.smooth.R b9f2968a22d99c8f319ba256fbd3c203 *R/summary.gam.R 1619805fd6e9f40a4a63afb624ec3679 *R/ylim.scale.R 4342548df46914e45085f921b8251caf *README.md ba66638e3de17b868b4d98dffe95009d *data/gam.data.RData 83529cbff37939aff8d96d32d6458f12 *data/gam.newdata.RData 4df6bee1aa3bee402b8f1083dda04b04 *data/kyphosis.RData a42dba5f95d8760e06a78389d780b170 *inst/ratfor/backfit.r a009bd4d2232ec7cc19b9d7d10280ffb *inst/ratfor/backlo.r 1ca924fd62063613d16c1cf607abb6b2 *inst/ratfor/linear.r 4e0b184dc647e3abac7fb7f023ed4a69 *inst/ratfor/lo.r 58295734adaaee3561f298e7c0b93eee *inst/ratfor/splsm.r 7c00cedc4eb75e97553ec4690c1427df *man/anova.gam.Rd d53f38426ecd20f44ee133304bfca868 *man/gam-internal.Rd a0d654b56d29a4e5b46b5220955307e9 *man/gam-package.Rd aa0a7ac1483f424fd17b3e161da223a4 *man/gam.Rd 09135690dd727c87a8c8ea4941d3055e *man/gam.control.Rd 51c5227e396714c3d16587f3d59cffbe *man/gam.data.Rd 03f7e3d1a0af307525c750949068c316 *man/gam.exact.Rd 089df59b0c8e3a3d01ece7a0fa1fa2d6 *man/gam.random.Rd 4db1d913aaf92c0aa4f2b19e80169e48 *man/gam.s.Rd ea4ebeeabc4925580a0184572439b02b *man/gam.scope.Rd 720529580a8c6da4b66e41ea082e673d *man/gam.smoothers.Rd 1b102f9f238f01fee86c2374506c6b0a *man/kyphosis.Rd 9fe802f1961a2e5dc6cf5b5653570dcc *man/lo.Rd 3e562dd1ccb7d1615d96ccc0bd06b0cb *man/na.gam.replace.Rd 25db5cb95489f1bb6247b0d18562633d *man/plot.gam.Rd 54d97424827aef2ccce15acc0914b152 *man/predict.gam.Rd b91f939de8d7c795907316c374ce51c2 *man/step.gam.Rd 2bf8ef7e1425c36f4be16667cdcdd3b3 *src/Makevars 2fa4c7011c2bc0f7449ae151d5cc44ae *src/Makevars.win 64d00814d4672cfd6d88f56b319343e7 *src/backfit.f 571110c81e325f8f456378a64bcda99b *src/backlo.f 30c0bb30ef2574b3d555a62338bc3eef *src/bsplvd.f a584f30cc63c75d163222d2264c4dbf7 *src/bvalue.f 40c1f6b57d6c3a03a1d972f009c5e5df *src/bvalus.f bf5f2d130e9f4ea39fe81367d8ceb35a *src/gam_init.c 9d3f7aa5149ccdb2a6ece27026774c74 *src/linear.f 9749fbbaf1adaacc55e629824e33ee44 *src/lo.f b4ac1722e54fabc8b65b4476f9258613 *src/loessc.c 3fd0e9e83115f6cc0ed2d86ddcaa4a1b *src/loessf.f a677b63352a629403575888656ac13ef *src/modreg.h d2baa8a158ee73576984f57a4a5df005 *src/qsbart.f 876032799d52ef84fb846af58939a318 *src/sbart.c 82da999d24034505301e31c78d1e58cc *src/sgram.f d277bb97eef775673f5fa2da911d81de *src/sinerp.f bb20f950f41f3c0d5173c374ce731782 *src/splsm.f 86f67fc697130d2622aab95955e7e558 *src/sslvrg.f 4f6275039d4731d4f2920fc3de5f61e7 *src/stxwx.f f22ec598690ab6be3e1744dd8a6e5666 *tests/testthat.R 5837755a3f8a782816e5f6a28a343897 *tests/testthat/test_example.R ecac26c90344ffd54e66357d037bf9b3 *tests/testthat/test_results/gam-1.20-results.RDS gam/inst/0000755000176200001440000000000014216146461012000 5ustar liggesusersgam/inst/ratfor/0000755000176200001440000000000014216146461013275 5ustar liggesusersgam/inst/ratfor/backfit.r0000644000176200001440000001554114216146461015071 0ustar liggesuserssubroutine bakfit(x,npetc,y,w,which,spar,dof,match,nef, etal,s,eta,beta,var,tol, qr,qraux,qpivot,effect,work) #integer npetc(7) #1:n #2:p #3:q #4:ifvar #5:nit #6:maxit #7:qrank #subroutine bakfit(x,n,p,y,w,q,which,spar,dof,match,nef, # etal,s,eta,beta,var,ifvar,tol,nit,maxit, # qr,qraux,qrank,qpivot,work) #This subroutine fits an additive spline fit to y #All arguments are either double precision or integer # bakfit uses the modified backfitting algorithm described in Buja, Hastie # and Tibshirani, Annals of Statistics, 1989. It calls splsm, and some # linpack based routines # This was written by Trevor Hastie in 1990 # It has been modified from the S3 version by Trevor Hastie # in March 2005, to accommodate the modified sbart routine in R # Note that spar has changed, and we change it here to conform with # the smooth.spline routine in R #INPUT # #x double dim n by p ; x variables, includes constant #n integer number of rows in x #p integer number of columns of x #y double length n ; y variable for smoothing #w double length n ; prior weights for smoothing, > 0 #q integer number of nonlinear terms #which integer length q indices of columns of x for nonlinear fits #spar double length q spars for smoothing; see below #dof double length q dof for/from smoothing; see below #match integer n by q matrix of match'es; see below #nef integer q vector of nef's; see below #s double n by q nonlinear part of the smooth functions # used as starting values. the linear part is # irrelevant #ifvar logical should the variance information be computed #tol double tolerance for backfitting convergence; 0.0005 is good #maxit integer maximum number of iterations; 15 is good #qr double n by p weighted qr decomposition of x #qraux double p belongs with qr #qrank integer rank of x ; if qrank=0, then bakfit computes qr and qraux #qpivot integer p the columns of qr are rearranged according to pivot #effec double n effect vector #work double # Let nk=max(nef)+2, then # work should be (10+2*4)*nk+5*nef+5*n+15 +q double #BELOW #the following comments come from documentation for splsm # they apply to each element of spar,dof match etc #spar double smoothing parameter -1.5 =1, dof is used # note: dof does not use the constant term #match integer length n -- in S language x[i] == sort(unique(x)[match[i]] # match is produced by subroutine namat #nef number of unique elements in x; so match has values between 1 and nef+1 # missing data are given the match number nef+1 #work double workspace of length (10+2*4)*(nef+2)+5*nef+n+15 # #OUTPUT # #x,y,w,n,p,which,q,maxit,match,nef are untouched #spar for each element of spar: # if spar was 0 and dof was 0, then spar is that spar # that minimized gcv # if spar was 0 and dof > 0, then spar is that which achieves dof #dof the dof of the fitted smooth. Note: even if dof was given # as 4, it will be returned as say 3.995 which is what # spar produces #etal double length n linear component of the fit #s double n by q nonlinear part of the smooth functions #eta double length n fitted values #beta double length p linear coefficients # So, the centered fitted functions are: # b(j)*(x(i,j)-mean(x(.,j)) +s(i,j) # where j is an element of which #var double n by q # if ifvar was .true. # the unscaled variance elements for the NONLINEAR # and UNIQUE part of s, in the order of sort(unique(x)) # var is lev(i)/w(i) -h(i)/w where h(i) is the hat element from # the simple weighted least squares fit. This is used in gamcov # #nit number of iterations used #qr etc the qr is returned implicit double precision(a-h,o-z) logical ifvar integer npetc(7),iter integer n,p,q,which(*),match(*),nef(*),nit,maxit,qrank,qpivot(*) double precision x(*),y(*),w(*),spar(*),dof(*), etal(*),s(*),eta(*),beta(*),var(*),tol, qr(*),qraux(*),effect(*),work(*) n=npetc(1) p=npetc(2) q=npetc(3) ifvar=.false. if(npetc(4)==1)ifvar=.true. maxit=npetc(6) qrank=npetc(7) do i=1,q{work(i)=dof(i)} call backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta,beta,var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,work(q+1),work(q+n+1), work(q+2*n+1),work(q+3*n+1),work(q+4*n+1)) npetc(7)=qrank return end subroutine backf1(x,n,p,y,w,q,which,spar,dof,match,nef, etal,s,eta,beta,var,ifvar,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,z,old,sqwt,sqwti,work) implicit double precision(a-h,o-z) logical ifvar integer n,p,q,which(q),match(n,q),nef(q),nit,maxit,qrank,qpivot(p) double precision x(n,p),y(n),w(n),spar(q),dof(q), etal(n),s(n,q),eta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),effect(n),work(*) double precision z(*),old(*),dwrss,ratio double precision sqwt(n),sqwti(n) logical anyzwt double precision deltaf, normf,onedm7 integer job,info onedm7=1d-7 job=1101;info=1 if(q==0)maxit=1 ratio=1d0 # fix up sqy's for weighted problems. anyzwt=.false. do i=1,n{ if(w(i)>0d0){ sqwt(i)=dsqrt(w(i)) sqwti(i)=1d0/sqwt(i) } else{ sqwt(i)=0d0 sqwti(i)=0d0 anyzwt=.true. } } # if qrank > 0 then qr etc contain the qr decomposition # else bakfit computes it. if(qrank==0){ do i=1,n{ do j=1,p{ qr(i,j)=x(i,j)*sqwt(i) } } do j=1,p{qpivot(j)=j} call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7) } do i=1,n{ eta(i)=0d0 for(j=1;j<=q;j=j+1){ eta(i)=eta(i)+s(i,j) } } nit=0 while ((ratio > tol )&(nit < maxit)){ # first the linear fit deltaf=0d0 nit=nit+1 do i=1,n{ z(i)=(y(i)-eta(i))*sqwt(i) old(i)=etal(i) } # call dqrsl1(qr,dq,qraux,qrank,sqz,one,work(1),etal,two,three) #job=1101 -- computes fits, effects and beta call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),etal,job,info) # now unsqrt the fits #Note: we dont have to fix up the zero weights till the end, since their fits #are always immaterial to the computation do i=1,n{ etal(i)=etal(i)*sqwti(i) } # now a single non-linear backfitting loop for(k=1;k<=q;k=k+1){ j=which(k) do i=1,n{ old(i)=s(i,k) z(i)=y(i)-etal(i)-eta(i)+old(i) } # this uses spar to set smoothing after iteration 1 if(nit>1){dof(k)=0d0} call splsm(x(1,j),z,w,n,match(1,k),nef(k),spar(k), dof(k),s(1,k),s0,var(1,k),ifvar,work) do i=1,n{ eta(i)=eta(i)+s(i,k)-old(i) etal(i)=etal(i)+s0 } deltaf=deltaf+dwrss(n,old,s(1,k),w) } normf=0d0 do i=1,n{ normf=normf+w(i)*eta(i)*eta(i) } if(normf>0d0){ ratio=dsqrt(deltaf/normf) } else {ratio = 0d0} # call DBLEPR("ratio",-1,ratio,1) } #now package up the results do j=1,p {work(j)=beta(j)} do j=1,p {beta(qpivot(j))=work(j)} if(anyzwt){ do i=1,n { if(w(i) <= 0d0){ etal(i)=0d0 do j=1,p{ etal(i)=etal(i)+beta(j)*x(i,j) } } } } do i=1,n eta(i)=eta(i)+etal(i) do j=1,q { call unpck(n,nef(j),match(1,j),var(1,j),old) do i=1,n {var(i,j)=old(i)} } return end gam/inst/ratfor/splsm.r0000644000176200001440000001564714216146461014633 0ustar liggesuserssubroutine sknotl(x,n,knot,k) implicit double precision(a-h,o-z) double precision x(n),knot(n+6),a1,a2,a3,a4 integer n,k,ndk,j # Allocate knots acording to the cutoffs given below # Cutoff constants a1 = log(50d0)/log(2d0) ; a2 = log(100d0)/log(2d0) a3 = log(140d0)/log(2d0) ; a4 = log(200d0)/log(2d0) # Cutoff Criteria if(n<50) { ndk = n } else if (n>=50 & n<200) { ndk = 2.**(a1+(a2-a1)*(n-50.)/150.) } else if (n>=200 & n<800) { ndk = 2.**(a2+(a3-a2)*(n-200.)/600.) } else if (n>=800 & n<3200) { ndk = 2.**(a3+(a4-a3)*(n-800.)/2400.) } else if (n>=3200) { ndk = 200. + float(n-3200)**.2 } k = ndk + 6 # Allocate Knots ( note no account is taken of any weighting vector ) do j=1,3 { knot(j) = x(1) } do j=1,ndk { knot(j+3) = x( 1 + (j-1)*(n-1)/(ndk-1) ) } do j=1,3 { knot(ndk+3+j) = x(n) } return end subroutine splsm(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov,work) #This subroutine performs a smoothing spline fit # This was written by Trevor Hastie in 1990 # It has been modified from the S3 version by Trevor Hastie # in July 2004, to accommodate the modified sbart routine in R # and also to accommodate only the gam bakfit routine. # Note that spar has changed, and we change it here to conform with # the smooth.spline routine in R #All arguments are either double precision or integer #INPUT # #x double length n ; x variable for smoothing #y double length n ; y variable for smoothing #w double length n ; weights for smoothing, > 0 #n integer length above #match integer length n -- in S language x[i] == sort(unique(x)[match[i]] # match is produced by subroutine namat #nef number of unique elements in x; so match has values between 1 and nef+1 # missing data are given the match number nef+1 #spar double smoothing parameter -1.5 =1, dof is used # note: dof does not use the constant term #ifcov integer if 1, the unscaled variance information is computed #work double workspace of length (10+2*4)*(nef+2)+5*nef+n+15 # #OUTPUT # #x,y,w,n,match,nef are untouched #spar if dof > 1, then spar is that which achieves dof #dof the dof of the fitted smooth. Note: even if dof was given # as 4, it will be returned as say 3.995 which is what # spar produces #smo double length n the fitted values, with weighted average 0 #s0 double weighted mean of y #cov double length nef the unscaled variance elements for the NONLINEAR # and UNIQUE part of smo, in the order of sort(unique(x)) # cov is lev(i)/w(i) -h(i)/w where h(i) is the hat element from # the simple weighted least squares fit. This is passed on # to bakfit and used in gamcov # # splsm calls (eventually after some memory management dummy calls) # sbart, the spline routine of Finbarr O'Sullivan, slightly modified # by Trevor Hastie, 8/2/89 implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,cov(*),work(*) integer n,match(*),nef integer ifcov # work should be (10+2*ld4)*nk+5*nef+n+15 double # ld4 =4 nk<= nef+2 call splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,cov,ifcov, # xin(nef+1),yin(nef+1), win(nef+1), knot(n+6), work(1), work(nef+2),work(2*nef+3),work(3*nef+4), work(3*nef+n+10)) return end subroutine splsm1(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,win,knot, work) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*),work(*) integer n,match(*),nef integer ifcov double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nef+6) integer nk,ldnk,ld4,k double precision xmin,xrange call suff(n,nef,match,x,y,w,xin,yin,win,work(1)) xmin=xin(1) xrange=xin(nef)-xin(1) do i=1,nef {xin(i)=(xin(i)-xmin)/xrange} call sknotl(xin,nef,knot,k) nk=k-4 ld4=4 ldnk=1 # p21p nd ldnk is not used call splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,win,knot, # coef(nk),sout(nef+1), levout(nef+1), xwy(nk), # hs0(nk), hs1(nk), hs2(nk), # hs3(nk), # sg0(nk), sg1(nk), sg2(nk), # sg3(nk), # abd(ld4,nk), p1ip(ld4,nk), # p2ip(ldnk,nk) work(1), work(nk+1), work(nk+nef+2),work(nk+2*nef+3), work(2*nk+2*nef+3),work(3*nk+2*nef+3),work(4*nk+2*nef+3), work(5*nk+2*nef+3), work(6*nk+2*nef+3),work(7*nk+2*nef+3),work(8*nk+2*nef+3), work(9*nk+2*nef+3), work(10*nk+2*nef+3),work((10+ld4)*nk+2*nef+3), work((10+2*ld4)*nk+2*nef+3), ld4,ldnk,nk) return end subroutine splsm2(x,y,w,n,match,nef,spar,dof,smo,s0,lev,ifcov, xin,yin,win,knot, coef,sout,levout,xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,nk) implicit double precision(a-h,o-z) double precision x(*),y(*),w(*),spar,dof,smo(*),s0,lev(*) integer n,match(*),nef integer nk,ldnk,ld4 integer ifcov double precision xin(nef+1),yin(nef+1),win(nef+1),knot(nk+4) double precision coef(nk),sout(nef+1),levout(nef+1),xwy(nk), hs0(nk),hs1(nk),hs2(nk),hs3(nk), sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(ld4,nk),p1ip(ld4,nk),p2ip(ldnk,*) # local variables integer ispar,icrit,isetup,ier double precision lspar,uspar,tol,penalt, sumwin,dofoff,crit,xbar,dsum,xsbar double precision yssw, eps integer maxit # yssw is an additional parameter introduced in R version of sbart double precision wmean crit=0d0 # Note we only allow limited options here if(dof <= 0d0){ # use spar ispar=1 icrit=3 dofoff=0d0 } else{ if( dof < 1d0 )dof=1d0 ispar=0 icrit=3 dofoff=dof+1d0 } #Here we set some default parameters similar to the smooth.spline in R isetup=0 ier=1 penalt=1d0 lspar= -1.5 uspar= 2.0 tol=1d-4 eps=2d-8 maxit=200 do i=1,nef sout(i)=yin(i)*yin(i) sumwin=0d0 do i=1,nef sumwin=sumwin+win(i) yssw=wmean(nef,sout,win) s0=wmean(n,y,w) # which should be equal to wmean(nef,yin,win) yssw=yssw*(sumwin-s0*s0) call sbart(penalt,dofoff,xin,yin,win,yssw,nef,knot,nk, coef,sout,levout,crit, icrit,spar,ispar,maxit, lspar,uspar,tol,eps, isetup, xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,ier) #return #now clean up do i=1,nef { win(i)=win(i)*win(i) #we sqrted them in sbart } sbar=wmean(nef,sout,win) xbar=wmean(nef,xin,win) #now remove the linear leverage from the leverage for the smooths # will be altered at this stage do i=1,nef {lev(i)=(xin(i)-xbar)*sout(i) } xsbar=wmean(nef,lev,win) do i=1,nef {lev(i)=(xin(i)-xbar)**2 } dsum=wmean(nef,lev,win) do i=1,nef { if(win(i)>0d0) { lev(i)=levout(i)/win(i)-1d0/sumwin -lev(i)/(sumwin*dsum) } else {lev(i)=0d0} } dof=0d0 do i=1,nef {dof=dof+lev(i)*win(i)} dof=dof+1d0 do i=1,nef sout(i)=sout(i)-sbar -(xin(i)-xbar)*xsbar/dsum call unpck(n,nef,match,sout,smo) return end double precision function wmean(n,y,w) integer n double precision y(n),w(n),wtot,wsum wtot=0d0 wsum=0d0 do i=1,n{ wsum=wsum+y(i)*w(i) wtot=wtot+w(i) } if(wtot > 0d0) {wmean=wsum/wtot} else {wmean=0d0} return end gam/inst/ratfor/backlo.r0000644000176200001440000001062614216146461014720 0ustar liggesuserssubroutine baklo(x,y,w,npetc,wddnfl,spatol,match, etal,s,eta,beta,var,dof, qr,qraux,qpivot,effect,iv,v,iwork,work) implicit double precision(a-h,o-z) integer n,p,q,nit,maxit,qrank integer npetc(7),wddnfl(*),match(*),qpivot(*),iv(*),iwork(*) ##integer which(q),dwhich(q),degree(q),nef(q),liv(q),lv(q),nvmax(q) double precision x(*),y(*),w(*),spatol(*), etal(*),s(*),eta(*),beta(*),var(*),dof(*), qr(*),qraux(*),v(*),effect(*),work(*) #work size: 4*n + sum( nef(k)*(pj+dj+4)+5+3*pj ) +5*n # = 9*n + sum( nef(k)*(pj+dj+4)+5+3*pj ) n=npetc(1) p=npetc(2) q=npetc(3) maxit=npetc(5) qrank=npetc(6) call baklo0(x,n,p,y,w,q,wddnfl(1),wddnfl(q+1),wddnfl(2*q+1), spatol(1),wddnfl(3*q+1),dof,match,wddnfl(4*q+1), etal,s,eta,beta,var,spatol(q+1), nit,maxit,qr,qraux,qrank,qpivot,effect, work(1),work(n+1),work(2*n+1),work(3*n+1), iv,wddnfl(5*q+1),wddnfl(6*q+1),v,wddnfl(7*q+1), iwork(1),work(4*n+1)) npetc(4)=nit npetc(6)=qrank return end subroutine baklo0(x,n,p,y,w,q,which,dwhich,pwhich,span,degree,dof,match,nef, etal,s,eta,beta,var,tol,nit,maxit, qr,qraux,qrank,qpivot,effect,z,old,sqwt,sqwti, iv,liv,lv,v,nvmax,iwork,work) implicit double precision(a-h,o-z) integer n,p,q,which(q),dwhich(q),pwhich(q),degree(q),match(n,q),nef(q),nit, maxit,qrank,qpivot(p),iv(*),liv(q),lv(q),nvmax(q),iwork(q) double precision x(n,p),y(n),w(n),span(q),dof(q), etal(n),s(n,q),eta(n),beta(p),var(n,q),tol, qr(n,p),qraux(p),v(*),effect(n),work(*) #work should be sum( nef(k)*(pj+dj+4)+5+3*pj ) +5*n double precision z(*),old(*),dwrss,ratio double precision sqwt(n),sqwti(n) logical anyzwt double precision deltaf, normf,onedm7 integer job,info,slv,sliv,iw,j,dj,pj onedm7=1d-7 job=1101;info=1 if(q==0)maxit=1 ratio=1d0 # fix up sqy's for weighted problems. anyzwt=.false. do i=1,n{ if(w(i)>0d0){ sqwt(i)=dsqrt(w(i)) sqwti(i)=1d0/sqwt(i) } else{ sqwt(i)=0d0 sqwti(i)=0d0 anyzwt=.true. } } # if qrank > 0 then qr etc contain the qr decomposition # else baklo computes it. if(qrank==0){ do i=1,n{ do j=1,p{ qr(i,j)=x(i,j)*sqwt(i) } } do j=1,p{qpivot(j)=j} call dqrdca(qr,n,n,p,qraux,qpivot,work,qrank,onedm7) } do i=1,n{ eta(i)=0d0 for(j=1;j<=q;j=j+1){ eta(i)=eta(i)+s(i,j) } } nit=0 while ((ratio > tol )&(nit < maxit)){ # first the linear fit deltaf=0d0 nit=nit+1 do i=1,n{ z(i)=(y(i)-eta(i))*sqwt(i) old(i)=etal(i) } # call dqrsl1(qr,dq,qraux,qrank,sqz,one,work(1),etal,two,three) #job=1101 -- computes fits, effects and beta call dqrsl(qr,n,n,qrank,qraux,z,work(1),effect(1),beta, work(1),etal,job,info) # now unsqrt the fits #Note: we dont have to fix up the zero weights till the end, since their fits #are always immaterial to the computation do i=1,n{ etal(i)=etal(i)*sqwti(i) } # now a single non-linear backfitting loop sliv=1 slv=1 iw=5*n+1 for(k=1;k<=q;k=k+1){ j=which(k) dj=dwhich(k) pj=pwhich(k) do i=1,n{ old(i)=s(i,k) z(i)=y(i)-etal(i)-eta(i)+old(i) } call lo1(x(1,j),z,w,n,dj,pj,nvmax(k),span(k),degree(k),match(1,k), nef(k),nit,dof(k),s(1,k),var(1,k),work(iw), # xin,win work(iw+pj+1),work(iw+nef(k)*dj+pj+1), # sqwin,sqwini, work(iw+nef(k)*(dj+1)+pj+2),work(iw + nef(k)*(dj+2)+pj+2), # xqr,qrank, work(iw+nef(k)*(dj+3)+pj+2),work(iw+nef(k)*(pj+dj+4)+pj+2), # qpivot,qraux, # work(iw+nef(k)*(pj+dj+4)+pj+3),work(iw+nef(k)*(pj+dj+4)+4+2*pj), iwork(1),work(iw+nef(k)*(pj+dj+4)+4+2*pj), iv(sliv),liv(k),lv(k),v(slv), work(1) ) #work should be sum( nef(k)*(pj+dj+4)+5+3*pj ) +5*n # In the call above I give lo1 pieces of work to use for storing # the qr decomposition, and it gets the same undisturbed portion # each time. The fact that it is given a double work word for qrank # is irrelevant but convenient; it still stores the integer qrank there. # I do this because there is a partition like this for each lo() term # in the model, and the number of them is variable sliv=sliv+liv(k) slv=slv+lv(k) iw=iw+nef(k)*(pj+dj+4)+5+3*pj do i=1,n{ eta(i)=eta(i)+s(i,k)-old(i) } deltaf=deltaf+dwrss(n,old,s(1,k),w) } normf=0d0 do i=1,n{ normf=normf+w(i)*eta(i)*eta(i) } if(normf>0d0){ ratio=dsqrt(deltaf/normf) } else {ratio = 0d0} } #now package up the results do j=1,p {work(j)=beta(j)} do j=1,p {beta(qpivot(j))=work(j)} if(anyzwt){ do i=1,n { if(w(i) <= 0d0){ etal(i)=0d0 do j=1,p{ etal(i)=etal(i)+beta(j)*x(i,j) } } } } do i=1,n eta(i)=eta(i)+etal(i) return end gam/inst/ratfor/linear.r0000644000176200001440000013671714216146461014751 0ustar liggesuserssubroutine dqrls(x,dx,pivot,qraux,y,dy,beta,res,qt,tol,scrtch,rank) integer pivot(*),dx(2),dy(2),rank double precision x(*), qraux(*), y(*), beta(*),res(*),qt(*),tol(*), scrtch(*) integer n,p,q,kn,kp,k,info n=dx(1); p=dx(2); q=dy(2) call dqrdca(x,n,n,p,qraux,pivot,scrtch,rank,tol(1)) kn=1; kp=1 if(rank>0)for(k=1;k<=q;k=k+1){ call dqrsl(x,n,n,rank,qraux,y(kn),scrtch,qt(kn),beta(kp), res(kn),scrtch,00110,info) kn = kn+n; kp=kp+p } return end #apply the qr decomposition to do various jobs subroutine dqrsl1(qr,dq,qra,rank,y,k,qy,qb,job,info) double precision qr(*),qra(*),y(*),qy(*),qb(*); integer dq(2),job,k,rank integer n,kn,kb,j double precision ourqty(1), ourqy(1), ourb(1), ourrsd(1), ourxb(1) ourqty(1) = 0d0 ourqy(1) = 0d0 ourb(1) = 0d0 ourrsd(1) = 0d0 ourxb(1) = 0d0 n = dq(1) kn = 1; kb = 1 switch(job) { case 10000: #qy for(j=0; j 0.)t = nrmxl/t if(t < eps){ call dshift(x,ldx,n,l,curpvt) jp = jpvt(l); t=qraux(l); tt=work(l); ww = work(l+p) for(j=l+1; j<=curpvt; j=j+1){ jj=j-1 jpvt(jj)=jpvt(j); qraux(jj)=qraux(j) work(jj)=work(j); work(jj+p) = work(j+p) } jpvt(curpvt)=jp; qraux(curpvt)=t; work(curpvt)=tt; work(curpvt+p) = ww curpvt=curpvt-1; if(lup>curpvt)lup=curpvt } else { if(l==n)break if (x(l,l)!=0.0d0) nrmxl = dsign(nrmxl,x(l,l)) call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1) x(l,l) = 1.0d0+x(l,l) for(j=l+1; j<=curpvt; j=j+1) { t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) if (qraux(j)!=0.0d0) { tt = 1.0d0-(dabs(x(l,j))/qraux(j))**2 tt = dmax1(tt,0.0d0) t = tt tt = 1.0d0+0.05d0*tt*(qraux(j)/work(j))**2 if (tt!=1.0d0) qraux(j) = qraux(j)*dsqrt(t) else { qraux(j) = dnrm2(n-l,x(l+1,j),1) work(j) = qraux(j) } } } qraux(l) = x(l,l) x(l,l) = -nrmxl l=l+1 } } rank = lup return end subroutine dchdc(a,lda,p,work,jpvt,job,info) integer lda,p,jpvt(p),job,info double precision a(lda,p),work(p) integer pu,pl,plp1,j,jp,jt,k,kb,km1,kp1,l,maxl double precision temp double precision maxdia logical swapk,negk pl = 1 pu = 0 info = p if (job!=0) { do k = 1,p { swapk = jpvt(k)>0 negk = jpvt(k)<0 jpvt(k) = k if (negk) jpvt(k) = -jpvt(k) if (swapk) { if (k!=pl) { call dswap(pl-1,a(1,k),1,a(1,pl),1) temp = a(k,k) a(k,k) = a(pl,pl) a(pl,pl) = temp plp1 = pl+1 if (p>=plp1) do j = plp1,p if (j=pl) do kb = pl,p { k = p-kb+pl if (jpvt(k)<0) { jpvt(k) = -jpvt(k) if (pu!=k) { call dswap(k-1,a(1,k),1,a(1,pu),1) temp = a(k,k) a(k,k) = a(pu,pu) a(pu,pu) = temp kp1 = k+1 if (p>=kp1) do j = kp1,p if (j=pl&&kmaxdia) { maxdia = a(l,l) maxl = l } # quit if the pivot element is not positive. if (maxdia<=0.0d0) go to 10 if (k!=maxl) { # start the pivoting and update jpvt. km1 = k-1 call dswap(km1,a(1,k),1,a(1,maxl),1) a(maxl,maxl) = a(k,k) a(k,k) = maxdia jp = jpvt(maxl) jpvt(maxl) = jpvt(k) jpvt(k) = jp } # reduction step. pivoting is contained across the rows. work(k) = dsqrt(a(k,k)) a(k,k) = work(k) if (p>=kp1) do j = kp1,p { if (k!=maxl) if (jnm) ierr = 10*n else { call balanc(nm,n,a,is1,is2,fv1) call elmhes(nm,n,is1,is2,a,iv1) if (matz==0) # .......... find eigenvalues only .......... call hqr(nm,n,is1,is2,a,wr,wi,ierr) else { # .......... find both eigenvalues and eigenvectors .......... call eltran(nm,n,is1,is2,a,iv1,z) call hqr2(nm,n,is1,is2,a,wr,wi,z,ierr) if (ierr==0) call balbak(nm,n,is1,is2,fv1,n,z) } } return end subroutine chol(a,p,work,jpvt,job,info) integer p,jpvt(*),job,info(*) double precision a(p,*),work(*) integer i,j for(j =2; j<=p; j = j+1) for(i=1; i0; j=j-1 ){ do i = 1,l if (i!=j) if (a(j,i)!=0.0d0) next 2 go to 10 } go to 20 10 m = l iexc = 1 repeat { # .......... in-line procedure for row and # column exchange .......... scale(m) = j if (j!=m) { do i = 1,l { f = a(i,j) a(i,j) = a(i,m) a(i,m) = f } do i = k,n { f = a(j,i) a(j,i) = a(m,i) a(m,i) = f } } switch(iexc) { case 1: # .......... search for rows isolating an eigenvalue # and push them down .......... if (l==1) go to 40 l = l-1 break 1 case 2: # .......... search for columns isolating an eigenvalue # and push them left .......... k = k+1 20 do j = k,l { do i = k,l if (i!=j) if (a(i,j)!=0.0d0) next 2 go to 30 } break 2 30 m = k iexc = 2 } } } # .......... now balance the submatrix in rows k to l .......... do i = k,l scale(i) = 1.0d0 repeat { # .......... iterative loop for norm reduction .......... noconv = .false. do i = k,l { c = 0.0d0 r = 0.0d0 do j = k,l if (j!=i) { c = c+dabs(a(j,i)) r = r+dabs(a(i,j)) } # .......... guard against zero c or r due to underflow .......... if (c!=0.0d0&&r!=0.0d0) { g = r/radix f = 1.0d0 s = c+r while (c=g) { f = f/radix c = c/b2 } # .......... now balance .......... if ((c+r)/f<0.95d0*s) { g = 1.0d0/f scale(i) = scale(i)*f noconv = .true. do j = k,n a(i,j) = a(i,j)*g do j = 1,l a(j,i) = a(j,i)*f } } } } until(!noconv) 40 low = k igh = l return end subroutine balbak(nm,n,low,igh,scale,m,z) integer i,j,k,m,n,ii,nm,igh,low double precision scale(n),z(nm,m) double precision s if (m!=0) { if (igh!=low) do i = low,igh { s = scale(i) # .......... left hand eigenvectors are back transformed # if the foregoing statement is replaced by # s=1.0d0/scale(i). .......... do j = 1,m z(i,j) = z(i,j)*s } # ......... for i=low-1 step -1 until 1, # igh+1 step 1 until n do -- .......... do ii = 1,n { i = ii if (iigh) { if (i=kp1) do m = kp1,la { mm1 = m-1 x = 0.0d0 i = m do j = m,igh if (dabs(a(j,mm1))>dabs(x)) { x = a(j,mm1) i = j } int(m) = i if (i!=m) { # .......... interchange rows and columns of a .......... do j = mm1,n { y = a(i,j) a(i,j) = a(m,j) a(m,j) = y } do j = 1,igh { y = a(j,i) a(j,i) = a(j,m) a(j,m) = y } } # .......... end interchange .......... if (x!=0.0d0) { mp1 = m+1 do i = mp1,igh { y = a(i,mm1) if (y!=0.0d0) { y = y/x a(i,mm1) = y do j = m,n a(i,j) = a(i,j)-y*a(m,j) do j = 1,igh a(j,m) = a(j,m)+y*a(j,i) } } } } return end subroutine eltran(nm,n,low,igh,a,int,z) integer i,j,n,kl,mp,nm,igh,low,mp1 double precision a(nm,igh),z(nm,n) integer int(igh) # .......... initialize z to identity matrix .......... do j = 1,n { do i = 1,n z(i,j) = 0.0d0 z(j,j) = 1.0d0 } kl = igh-low-1 if (kl>=1) for(mp = igh-1; mp > low; mp = mp -1) { mp1 = mp+1 do i = mp1,igh z(i,mp) = a(i,mp-1) i = int(mp) if (i!=mp) { do j = mp,igh { z(mp,j) = z(i,j) z(i,j) = 0.0d0 } z(i,mp) = 1.0d0 } } return end subroutine hqr(nm,n,low,igh,h,wr,wi,ierr) integer i,j,k,l,m,n,en,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr double precision h(nm,n),wr(n),wi(n) double precision p,q,r,s,t,w,x,y,zz,norm,tst1,tst2 logical notlas ierr = 0 norm = 0.0d0 k = 1 # .......... store roots isolated by balanc # and compute matrix norm .......... do i = 1,n { do j = k,n norm = norm+dabs(h(i,j)) k = i if (iigh) { wr(i) = h(i,i) wi(i) = 0.0d0 } } en = igh t = 0.0d0 itn = 30*n repeat { # .......... search for next eigenvalues .......... if (en low; l = l-1){ s = dabs(h(l-1,l-1))+dabs(h(l,l)) if (s==0.0d0) s = norm tst1 = s tst2 = tst1+dabs(h(l,l-1)) if (tst2==tst1) break 1 } # .......... form shift .......... x = h(en,en) if (l==en) go to 50 y = h(na,na) w = h(en,na)*h(na,en) if (l==na) break 1 if (itn==0) break 2 if (its==10||its==20) { # .......... form exceptional shift .......... t = t+x do i = low,en h(i,i) = h(i,i)-x s = dabs(h(en,na))+dabs(h(na,enm2)) x = 0.75d0*s y = x w = -0.4375d0*s*s } its = its+1 itn = itn-1 # .......... look for two consecutive small # sub-diagonal elements. # for m=en-2 step -1 until l do -- .......... do mm = l,enm2 { m = enm2+l-mm zz = h(m,m) r = x-zz s = y-zz p = (r*s-w)/h(m+1,m)+h(m,m+1) q = h(m+1,m+1)-zz-r-s r = h(m+2,m+1) s = dabs(p)+dabs(q)+dabs(r) p = p/s q = q/s r = r/s if (m==l) break 1 tst1 = dabs(p)*(dabs(h(m-1,m-1))+dabs(zz)+dabs(h(m+1,m+1))) tst2 = tst1+dabs(h(m,m-1))*(dabs(q)+dabs(r)) if (tst2==tst1) break 1 } mp2 = m+2 do i = mp2,en { h(i,i-2) = 0.0d0 if (i!=mp2) h(i,i-3) = 0.0d0 } # .......... double qr step involving rows l to en and # columns m to en .......... do k = m,na { notlas = k!=na if (k!=m) { p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if (notlas) r = h(k+2,k-1) x = dabs(p)+dabs(q)+dabs(r) if (x==0.0d0) next 1 p = p/x q = q/x r = r/x } s = dsign(dsqrt(p*p+q*q+r*r),p) if (k!=m) h(k,k-1) = -s*x else if (l!=m) h(k,k-1) = -h(k,k-1) p = p+s x = p/s y = q/s zz = r/s q = q/p r = r/p if (!notlas) { # .......... row modification .......... do j = k,n { p = h(k,j)+q*h(k+1,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y } j = min0(en,k+3) # .......... column modification .......... do i = 1,j { p = x*h(i,k)+y*h(i,k+1) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q } } else { # .......... row modification .......... do j = k,n { p = h(k,j)+q*h(k+1,j)+r*h(k+2,j) h(k,j) = h(k,j)-p*x h(k+1,j) = h(k+1,j)-p*y h(k+2,j) = h(k+2,j)-p*zz } j = min0(en,k+3) # .......... column modification .......... do i = 1,j { p = x*h(i,k)+y*h(i,k+1)+zz*h(i,k+2) h(i,k) = h(i,k)-p h(i,k+1) = h(i,k+1)-p*q h(i,k+2) = h(i,k+2)-p*r } } } } # .......... two roots found .......... p = (y-x)/2.0d0 q = p*p+w zz = dsqrt(dabs(q)) x = x+t if (q<0.0d0) { # .......... complex pair .......... wr(na) = x+p wr(en) = x+p wi(na) = zz wi(en) = -zz } else { # .......... real pair .......... zz = p+dsign(zz,p) wr(na) = x+zz wr(en) = wr(na) if (zz!=0.0d0) wr(en) = x-w/zz wi(na) = 0.0d0 wi(en) = 0.0d0 } en = enm2 next 1 # .......... one root found .......... 50 wr(en) = x+t wi(en) = 0.0d0 en = na } # .......... set error -- all eigenvalues have not # converged after 30*n iterations .......... ierr = en return end subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr) integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn,igh,itn,its,low,mp2,enm2,ierr double precision h(nm,n),wr(n),wi(n),z(nm,n) double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2 logical notlas ierr = 0 norm = 0.0d0 k = 1 # .......... store roots isolated by balanc # and compute matrix norm .......... do i = 1,n { do j = k,n norm = norm+dabs(h(i,j)) k = i if (iigh) { wr(i) = h(i,i) wi(i) = 0.0d0 } } en = igh t = 0.0d0 itn = 30*n repeat { # .......... search for next eigenvalues .......... if (enigh) do j = i,n z(i,j) = h(i,j) # .......... multiply by transformation matrix to give # vectors of original full matrix. # for j=n step -1 until low do -- .......... do jj = low,n { j = n+low-jj m = min0(j,igh) do i = low,igh { zz = 0.0d0 do k = low,m zz = zz+z(i,k)*h(k,j) z(i,j) = zz } } } return end subroutine cdiv(ar,ai,br,bi,cr,ci) double precision ar,ai,br,bi,cr,ci # complex division, (cr,ci) = (ar,ai)/(br,bi) double precision s,ars,ais,brs,bis s = dabs(br)+dabs(bi) ars = ar/s ais = ai/s brs = br/s bis = bi/s s = brs**2+bis**2 cr = (ars*brs+ais*bis)/s ci = (ais*brs-ars*bis)/s return end subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr) integer n,nm,ierr,matz double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n) if (n>nm) ierr = 10*n else if (matz!=0) { # .......... find both eigenvalues and eigenvectors .......... call tred2(nm,n,a,w,fv1,z) call tql2(nm,n,w,fv1,z,ierr) } else { # .......... find eigenvalues only .......... call tred1(nm,n,a,w,fv1,fv2) call tqlrat(n,w,fv2,ierr) } return end subroutine tql2(nm,n,d,e,z,ierr) integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr double precision d(n),e(n),z(nm,n) double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag ierr = 0 if (n!=1) { do i = 2,n e(i-1) = e(i) f = 0.0d0 tst1 = 0.0d0 e(n) = 0.0d0 do l = 1,n { j = 0 h = dabs(d(l))+dabs(e(l)) if (tst1=d(i-1)) go to 10 d(i) = d(i-1) } i = 1 10 d(i) = p } return # .......... set error -- no convergence to an # eigenvalue after 30 iterations .......... 20 ierr = l } return end subroutine tred1(nm,n,a,d,e,e2) integer i,j,k,l,n,ii,nm,jp1 double precision a(nm,n),d(n),e(n),e2(n) double precision f,g,h,scale do i = 1,n { d(i) = a(n,i) a(n,i) = a(i,i) } # .......... for i=n step -1 until 1 do -- .......... do ii = 1,n { i = n+1-ii l = i-1 h = 0.0d0 scale = 0.0d0 if (l>=1) { # .......... scale row (algol tol then not needed) .......... do k = 1,l scale = scale+dabs(d(k)) if (scale==0.0d0) do j = 1,l { d(j) = a(l,j) a(l,j) = a(i,j) a(i,j) = 0.0d0 } else { do k = 1,l { d(k) = d(k)/scale h = h+d(k)*d(k) } e2(i) = scale*scale*h f = d(l) g = -dsign(dsqrt(h),f) e(i) = scale*g h = h-f*g d(l) = f-g if (l!=1) { # .......... form a*u .......... do j = 1,l e(j) = 0.0d0 do j = 1,l { f = d(j) g = e(j)+a(j,j)*f jp1 = j+1 if (l>=jp1) do k = jp1,l { g = g+a(k,j)*d(k) e(k) = e(k)+a(k,j)*f } e(j) = g } # .......... form p .......... f = 0.0d0 do j = 1,l { e(j) = e(j)/h f = f+e(j)*d(j) } h = f/(h+h) # .......... form q .......... do j = 1,l e(j) = e(j)-h*d(j) # .......... form reduced a .......... do j = 1,l { f = d(j) g = e(j) do k = j,l a(k,j) = a(k,j)-f*e(k)-g*d(k) } } do j = 1,l { f = d(j) d(j) = a(l,j) a(l,j) = a(i,j) a(i,j) = f*scale } next 1 } } e(i) = 0.0d0 e2(i) = 0.0d0 } return end subroutine tred2(nm,n,a,d,e,z) integer i,j,k,l,n,ii,nm,jp1 double precision a(nm,n),d(n),e(n),z(nm,n) double precision f,g,h,hh,scale do i = 1,n { do j = i,n z(j,i) = a(j,i) d(i) = a(n,i) } if (n!=1) { # .......... for i=n step -1 until 2 do -- .......... do ii = 2,n { i = n+2-ii l = i-1 h = 0.0d0 scale = 0.0d0 if (l>=2) { # .......... scale row (algol tol then not needed) .......... do k = 1,l scale = scale+dabs(d(k)) if (scale!=0.0d0) { do k = 1,l { d(k) = d(k)/scale h = h+d(k)*d(k) } f = d(l) g = -dsign(dsqrt(h),f) e(i) = scale*g h = h-f*g d(l) = f-g # .......... form a*u .......... do j = 1,l e(j) = 0.0d0 do j = 1,l { f = d(j) z(j,i) = f g = e(j)+z(j,j)*f jp1 = j+1 if (l>=jp1) do k = jp1,l { g = g+z(k,j)*d(k) e(k) = e(k)+z(k,j)*f } e(j) = g } # .......... form p .......... f = 0.0d0 do j = 1,l { e(j) = e(j)/h f = f+e(j)*d(j) } hh = f/(h+h) # .......... form q .......... do j = 1,l e(j) = e(j)-hh*d(j) # .......... form reduced a .......... do j = 1,l { f = d(j) g = e(j) do k = j,l z(k,j) = z(k,j)-f*e(k)-g*d(k) d(j) = z(l,j) z(i,j) = 0.0d0 } go to 10 } } e(i) = d(l) do j = 1,l { d(j) = z(l,j) z(i,j) = 0.0d0 z(j,i) = 0.0d0 } 10 d(i) = h } # .......... accumulation of transformation matrices .......... do i = 2,n { l = i-1 z(n,l) = z(l,l) z(l,l) = 1.0d0 h = d(i) if (h!=0.0d0) { do k = 1,l d(k) = z(k,i)/h do j = 1,l { g = 0.0d0 do k = 1,l g = g+z(k,i)*z(k,j) do k = 1,l z(k,j) = z(k,j)-g*d(k) } } do k = 1,l z(k,i) = 0.0d0 } } do i = 1,n { d(i) = z(n,i) z(n,i) = 0.0d0 } z(n,n) = 1.0d0 e(1) = 0.0d0 return end subroutine dmatp(x,dx,y,dy,z) integer dx(2),dy(2) double precision x(*), y(*),z(*),ddot integer n,p,q,i,j n=dx(1); p=dx(2); q=dy(2) do i = 1,n { jj = 1; ij = i do j = 1, q { z(ij) = ddot(p,x(i),n,y(jj),1) # x[i,1] & y[1,j] if(j0) if (da!=0.0d0) if (incx!=1||incy!=1) { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dy(iy) = dy(iy)+da*dx(ix) ix = ix+incx iy = iy+incy } } else { m = mod(n,4) if (m!=0) { do i = 1,m dy(i) = dy(i)+da*dx(i) if (n<4) return } mp1 = m+1 do i = mp1,n,4 { dy(i) = dy(i)+da*dx(i) dy(i+1) = dy(i+1)+da*dx(i+1) dy(i+2) = dy(i+2)+da*dx(i+2) dy(i+3) = dy(i+3)+da*dx(i+3) } } return end subroutine dcopy(n,dx,incx,dy,incy) double precision dx(*),dy(*) integer i,incx,incy,ix,iy,m,mp1,n if (n>0) if (incx!=1||incy!=1) { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dy(iy) = dx(ix) ix = ix+incx iy = iy+incy } } else { m = mod(n,7) if (m!=0) { do i = 1,m dy(i) = dx(i) if (n<7) return } mp1 = m+1 do i = mp1,n,7 { dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) } } return end double precision function ddot(n,dx,incx,dy,incy) double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n ddot = 0.0d0 dtemp = 0.0d0 if (n>0) if (incx==1&&incy==1) { m = mod(n,5) if (m!=0) { do i = 1,m dtemp = dtemp+dx(i)*dy(i) if (n<5) go to 10 } mp1 = m+1 do i = mp1,n,5 dtemp = dtemp+dx(i)*dy(i)+dx(i+1)*dy(i+1)+dx(i+2)*dy(i+2)+dx(i+3)*dy(i+3)+dx(i+4)*dy(i+4) 10 ddot = dtemp } else { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dtemp = dtemp+dx(ix)*dy(iy) ix = ix+incx iy = iy+incy } ddot = dtemp } return end double precision function dnrm2(n,dx,incx) integer nst double precision dx(*),cutlo,cuthi,hitest,sum,xmax,zero,one data zero,one/0.0d0,1.0d0/ data cutlo,cuthi/8.232d-11,1.304d19/ if (n<=0) dnrm2 = zero else { nst = 20 sum = zero nn = n*incx i = 1 repeat { if (nst == 20) { goto 20 } else if (nst == 30) { goto 30 } else if (nst == 40) { goto 40 } else if (nst == 80) { goto 80 } 20 if (dabs(dx(i))>cutlo) go to 50 nst = 30 xmax = zero 30 if (dx(i)==zero) go to 100 if (dabs(dx(i))>cutlo) go to 50 nst = 40 go to 70 40 if (dabs(dx(i))<=cutlo) go to 80 sum = (sum*xmax)*xmax 50 hitest = cuthi/float(n) do j = i,nn,incx { if (dabs(dx(j))>=hitest) go to 60 sum = sum+dx(j)**2 } break 1 60 i = j nst = 80 sum = (sum/dx(i))/dx(i) 70 xmax = dabs(dx(i)) go to 90 80 if (dabs(dx(i))>xmax) { sum = one+sum*(xmax/dx(i))**2 xmax = dabs(dx(i)) go to 100 } 90 sum = sum+(dx(i)/xmax)**2 100 i = i+incx if (i>nn) go to 110 } dnrm2 = dsqrt(sum) return 110 dnrm2 = xmax*dsqrt(sum) } return end subroutine dscal(n,da,dx,incx) double precision da,dx(*) integer i,incx,m,mp1,n,nincx if (n>0) if (incx!=1) { nincx = n*incx do i = 1,nincx,incx dx(i) = da*dx(i) } else { m = mod(n,5) if (m!=0) { do i = 1,m dx(i) = da*dx(i) if (n<5) return } mp1 = m+1 do i = mp1,n,5 { dx(i) = da*dx(i) dx(i+1) = da*dx(i+1) dx(i+2) = da*dx(i+2) dx(i+3) = da*dx(i+3) dx(i+4) = da*dx(i+4) } } return end subroutine dswap(n,dx,incx,dy,incy) double precision dx(*),dy(*),dtemp integer i,incx,incy,ix,iy,m,mp1,n if (n>0) if (incx!=1||incy!=1) { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dtemp = dx(ix) dx(ix) = dy(iy) dy(iy) = dtemp ix = ix+incx iy = iy+incy } } else { m = mod(n,3) if (m!=0) { do i = 1,m { dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp } if (n<3) return } mp1 = m+1 do i = mp1,n,3 { dtemp = dx(i) dx(i) = dy(i) dy(i) = dtemp dtemp = dx(i+1) dx(i+1) = dy(i+1) dy(i+1) = dtemp dtemp = dx(i+2) dx(i+2) = dy(i+2) dy(i+2) = dtemp } } return end subroutine dshift(x,ldx,n,j,k) integer ldx,n,j,k double precision x(ldx,k),tt integer i,jj if (k>j) do i = 1,n { tt = x(i,j) do jj = j+1,k x(i,jj-1) = x(i,jj) x(i,k) = tt } return end subroutine rtod(dx,dy,n) real dx(*) double precision dy(*) integer i,m,mp1,n if (n>0) { m = mod(n,7) if (m!=0) { do i = 1,m dy(i) = dx(i) if (n<7) return } mp1 = m+1 do i = mp1,n,7 { dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) } } return end subroutine dtor(dx,dy,n) double precision dx(*) real dy(*) integer i,m,mp1,n if (n>0) { m = mod(n,7) if (m!=0) { do i = 1,m dy(i) = dx(i) if (n<7) return } mp1 = m+1 do i = mp1,n,7 { dy(i) = dx(i) dy(i+1) = dx(i+1) dy(i+2) = dx(i+2) dy(i+3) = dx(i+3) dy(i+4) = dx(i+4) dy(i+5) = dx(i+5) dy(i+6) = dx(i+6) } } return end subroutine drot(n,dx,incx,dy,incy,c,s) double precision dx(*),dy(*),dtemp,c,s integer i,incx,incy,ix,iy,n if (n>0) if (incx==1&&incy==1) do i = 1,n { dtemp = c*dx(i)+s*dy(i) dy(i) = c*dy(i)-s*dx(i) dx(i) = dtemp } else { ix = 1 iy = 1 if (incx<0) ix = (-n+1)*incx+1 if (incy<0) iy = (-n+1)*incy+1 do i = 1,n { dtemp = c*dx(ix)+s*dy(iy) dy(iy) = c*dy(iy)-s*dx(ix) dx(ix) = dtemp ix = ix+incx iy = iy+incy } } return end subroutine drotg(da,db,c,s) double precision da,db,c,s,roe,scale,r,z roe = db if (dabs(da)>dabs(db)) roe = da scale = dabs(da)+dabs(db) if (scale==0.0d0) { c = 1.0d0 s = 0.0d0 r = 0.0d0 } else { r = scale*dsqrt((da/scale)**2+(db/scale)**2) r = dsign(1.0d0,roe)*r c = da/r s = db/r } z = 1.0d0 if (dabs(da)>dabs(db)) z = s if (dabs(db)>=dabs(da)&&c!=0.0d0) z = 1.0d0/c da = r db = z return end subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) integer ldx,n,k,job,info double precision x(ldx,*),qraux(*),y(*),qy(*),qty(*),b(*),rsd(*),xb(*) integer i,j,jj,ju,kp1 double precision ddot,t,temp logical cb,cqy,cqty,cr,cxb info = 0 cqy = job/10000!=0 cqty = mod(job,10000)!=0 cb = mod(job,1000)/100!=0 cr = mod(job,100)/10!=0 cxb = mod(job,10)!=0 ju = min0(k,n-1) if (ju==0) { if (cqy) qy(1) = y(1) if (cqty) qty(1) = y(1) if (cxb) xb(1) = y(1) if (cb) if (x(1,1)!=0.0d0) b(1) = y(1)/x(1,1) else info = 1 if (cr) rsd(1) = 0.0d0 } else { if (cqy) call dcopy(n,y,1,qy,1) if (cqty) call dcopy(n,y,1,qty,1) if (cqy) do jj = 1,ju { j = ju-jj+1 if (qraux(j)!=0.0d0) { temp = x(j,j) x(j,j) = qraux(j) t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,qy(j),1) x(j,j) = temp } } if (cqty) do j = 1,ju if (qraux(j)!=0.0d0) { temp = x(j,j) x(j,j) = qraux(j) t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j) call daxpy(n-j+1,t,x(j,j),1,qty(j),1) x(j,j) = temp } if (cb) call dcopy(k,qty,1,b,1) kp1 = k+1 if (cxb) call dcopy(k,qty,1,xb,1) if (cr&&k1) ncu = min0(n,p) if (jobu!=0) wantu = .true. if (mod(job,10)!=0) wantv = .true. info = 0 nct = min0(n-1,p) nrt = max0(0,min0(p-2,n)) lu = max0(nct,nrt) if (lu>=1) do l = 1,lu { lp1 = l+1 if (l<=nct) { s(l) = dnrm2(n-l+1,x(l,l),1) if (s(l)!=0.0d0) { if (x(l,l)!=0.0d0) s(l) = dsign(s(l),x(l,l)) call dscal(n-l+1,1.0d0/s(l),x(l,l),1) x(l,l) = 1.0d0+x(l,l) } s(l) = -s(l) } if (p>=lp1) do j = lp1,p { if (l<=nct) if (s(l)!=0.0d0) { t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) } e(j) = x(l,j) } if (wantu&&l<=nct) do i = l,n u(i,l) = x(i,l) if (l<=nrt) { e(l) = dnrm2(p-l,e(lp1),1) if (e(l)!=0.0d0) { if (e(lp1)!=0.0d0) e(l) = dsign(e(l),e(lp1)) call dscal(p-l,1.0d0/e(l),e(lp1),1) e(lp1) = 1.0d0+e(lp1) } e(l) = -e(l) if (lp1<=n&&e(l)!=0.0d0) { do i = lp1,n work(i) = 0.0d0 do j = lp1,p call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1) do j = lp1,p call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1) } if (wantv) do i = lp1,p v(i,l) = e(i) } } m = min0(p,n+1) nctp1 = nct+1 nrtp1 = nrt+1 if (nct=nctp1) do j = nctp1,ncu { do i = 1,n u(i,j) = 0.0d0 u(j,j) = 1.0d0 } if (nct>=1) do ll = 1,nct { l = nct-ll+1 if (s(l)==0.0d0) { do i = 1,n u(i,l) = 0.0d0 u(l,l) = 1.0d0 } else { lp1 = l+1 if (ncu>=lp1) do j = lp1,ncu { t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l) call daxpy(n-l+1,t,u(l,l),1,u(l,j),1) } call dscal(n-l+1,-1.0d0,u(l,l),1) u(l,l) = 1.0d0+u(l,l) lm1 = l-1 if (lm1>=1) do i = 1,lm1 u(i,l) = 0.0d0 } } } if (wantv) do ll = 1,p { l = p-ll+1 lp1 = l+1 if (l<=nrt) if (e(l)!=0.0d0) do j = lp1,p { t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l) call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1) } do i = 1,p v(i,l) = 0.0d0 v(l,l) = 1.0d0 } mm = m iter = 0 repeat { if (m==0) return if (iter>=maxit) break 1 do ll = 1,m { l = m-ll if (l==0) break 1 test = dabs(s(l))+dabs(s(l+1)) ztest = test+dabs(e(l)) if (ztest==test) go to 150 } go to 160 150 e(l) = 0.0d0 160 if (l==m-1) kase = 4 else { lp1 = l+1 mp1 = m+1 do lls = lp1,mp1 { ls = m-lls+lp1 if (ls==l) break 1 test = 0.0d0 if (ls!=m) test = test+dabs(e(ls)) if (ls!=l+1) test = test+dabs(e(ls-1)) ztest = test+dabs(s(ls)) if (ztest==test) go to 170 } go to 180 170 s(ls) = 0.0d0 180 if (ls==l) kase = 3 else if (ls==m) kase = 1 else { kase = 2 l = ls } } l = l+1 switch(kase) { case 1: mm1 = m-1 f = e(m-1) e(m-1) = 0.0d0 do kk = l,mm1 { k = mm1-kk+l t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 if (k!=l) { f = -sn*e(k-1) e(k-1) = cs*e(k-1) } if (wantv) call drot(p,v(1,k),1,v(1,m),1,cs,sn) } case 2: f = e(l-1) e(l-1) = 0.0d0 do k = l,m { t1 = s(k) call drotg(t1,f,cs,sn) s(k) = t1 f = -sn*e(k) e(k) = cs*e(k) if (wantu) call drot(n,u(1,k),1,u(1,l-1),1,cs,sn) } case 3: scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)),dabs(s(l)),dabs(e(l))) sm = s(m)/scale smm1 = s(m-1)/scale emm1 = e(m-1)/scale sl = s(l)/scale el = e(l)/scale b = ((smm1+sm)*(smm1-sm)+emm1**2)/2.0d0 c = (sm*emm1)**2 shift = 0.0d0 if (b!=0.0d0||c!=0.0d0) { shift = dsqrt(b**2+c) if (b<0.0d0) shift = -shift shift = c/(b+shift) } f = (sl+sm)*(sl-sm)+shift g = sl*el mm1 = m-1 do k = l,mm1 { call drotg(f,g,cs,sn) if (k!=l) e(k-1) = f f = cs*s(k)+sn*e(k) e(k) = cs*e(k)-sn*s(k) g = sn*s(k+1) s(k+1) = cs*s(k+1) if (wantv) call drot(p,v(1,k),1,v(1,k+1),1,cs,sn) call drotg(f,g,cs,sn) s(k) = f f = cs*e(k)+sn*s(k+1) s(k+1) = -sn*e(k)+cs*s(k+1) g = sn*e(k+1) e(k+1) = cs*e(k+1) if (wantu&&k=s(l+1)) break 1 t = s(l) s(l) = s(l+1) s(l+1) = t if (wantv&&l0; j = j-1) { if (x(j,j)==0.0d0) {info = j; break} for(l=1; l<=q; l = l+1) { b(j,l) = b(j,l)/x(j,j) if (j!=1) { t = -b(j,l) call daxpy(j-1,t,x(1,j),1,b(1,l),1) } } } return end subroutine dtrsl(t,ldt,n,b,job,info) integer ldt,n,job,info double precision t(ldt,*),b(*) double precision ddot,temp integer which,j,jj # check for zero diagonal elements. do info = 1,n if (t(info,info)==0.0d0) return info = 0 # determine the task and go to it. which = 1 if (mod(job,10)!=0) which = 2 if (mod(job,100)/10!=0) which = which+2 switch(which) { case 1: b(1) = b(1)/t(1,1) if (n>=2) do j = 2,n { temp = -b(j-1) call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1) b(j) = b(j)/t(j,j) } case 2: b(n) = b(n)/t(n,n) if (n>=2) do jj = 2,n { j = n-jj+1 temp = -b(j+1) call daxpy(j,temp,t(1,j+1),1,b(1),1) b(j) = b(j)/t(j,j) } case 3: b(n) = b(n)/t(n,n) if (n>=2) do jj = 2,n { j = n-jj+1 b(j) = b(j)-ddot(jj-1,t(j+1,j),1,b(j+1),1) b(j) = b(j)/t(j,j) } case 4: b(1) = b(1)/t(1,1) if (n>=2) do j = 2,n { b(j) = b(j)-ddot(j-1,t(1,j),1,b(1),1) b(j) = b(j)/t(j,j) } } return end gam/inst/ratfor/lo.r0000644000176200001440000001053214216146461014073 0ustar liggesuserssubroutine lo0(x,y,w,n,d,p,nvmax,span,degree,match,nef,dof,s,var, beta,iv,liv,lv,v,iwork,work) integer n,d,p,nvmax,degree,match(*),nef,liv,lv,iv(liv),iwork(*) double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),v(lv),work(*) double precision beta(p+1) #work should be nef*(p+d+8) + 2*p + n +8 integer qrank call lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,0,dof,s,var,beta, # xin,win,sqwin,sqwini, work(1),work(nef*d+1),work(nef*(d+1)+2),work(nef*(d+2)+2), # xqr,qrank,qpivot,qraux, work(nef*(d+3)+2),qrank,iwork(1),work(nef*(p+d+4)+3+p), iv,liv,lv,v, work(nef*(p+d+4)+4+2*p) ) return end subroutine lo1(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, work) integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1) integer iv(liv),liv,lv double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1), xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p+1),v(lv), work(*) #work should have size n +4*(nef+1) call lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, work(1),work(nef+2),work(2*nef+3),work(3*nef+4)) return end subroutine lo2(x,y,w,n,d,p,nvmax,span,degree,match,nef,nit,dof,s,var,beta, xin,win,sqwin,sqwini,xqr,qrank,qpivot,qraux, iv,liv,lv,v, levout,sout,yin,work) integer n,d,p,nvmax,degree,match(*),nef,nit,qrank,qpivot(p+1) integer iv(liv),liv,lv double precision x(n,d),y(n),w(n),span,dof,s(n),var(n),beta(p+1), xin(nef,d),win(nef+1),sqwin(nef),sqwini(nef),xqr(nef,p+1), qraux(p+1),v(lv), levout(nef+1), sout(nef+1),yin(nef+1),work(*) #work should be length n double precision junk, onedm7 integer job, info logical setLf, ifvar job=110;info=1 ifvar=.true. onedm7=1d-7 if(nit<=1){ call pck(n,nef,match,w,win) do i=1,nef{ if(win(i)>0d0){ sqwin(i)=dsqrt(win(i)) sqwini(i)=1d0/sqwin(i) } else{ sqwin(i)=1d-5 sqwini(i)=1d5 } } do i=1,n{ k=match(i) if(k<=nef){ do j=1,d xin(k,j)=x(i,j) for(j=d+1;j<=p;j=j+1) xqr(k,j+1)=x(i,j) } } do i=1,nef{ xqr(i,1)=sqwin(i) do j=1,d xqr(i,j+1)=xin(i,j)*sqwin(i) for(j=d+2;j<=p+1;j=j+1) xqr(i,j)=xqr(i,j)*sqwin(i) } for(j=1;j<=p+1;j=j+1) qpivot(j)=j call dqrdca(xqr,nef,nef,p+1,qraux,qpivot,work,qrank,onedm7) setLf = (nit==1) call lowesd(106,iv,liv,lv,v,d,nef,span,degree,nvmax,setLf) v(2)=span/5d0 } do i=1,n work(i)=y(i)*w(i) call pck(n,nef,match,work,yin) do i=1,nef yin(i)=yin(i)*sqwini(i)*sqwini(i) if(nit<=1)call lowesb(xin,yin,win,levout,ifvar,iv,liv,lv,v) else call lowesr(yin,iv,liv,lv,v) call lowese(iv,liv,lv,v,nef,xin,sout) #now remove the parametric piece do i=1,nef sout(i)=sout(i)*sqwin(i) call dqrsl(xqr,nef,nef,qrank,qraux,sout,work(1),work(1),beta, sout,work(1),job,info) #####dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) do i=1,nef sout(i)=sout(i)*sqwini(i) #now clean up if(nit<=1){ #get rid of the parametric component of the leverage job=10000 for(j=1;j<=p+1;j=j+1){ do i=1,nef work(i)=0d0 work(j)=1d0 call dqrsl(xqr,nef,nef,qrank,qraux,work,var,junk,junk, junk,junk,job,info) do i=1,nef levout(i)=levout(i) - var(i)**2 } dof=0d0 do i=1,nef { if(win(i)>0d0) { levout(i)=levout(i)/win(i) } else {levout(i)=0d0} } do i=1,nef {dof=dof+levout(i)*win(i)} call unpck(n,nef,match,levout,var) for(j=1;j<=p+1;j=j+1){work(j)=beta(j)} for(j=1;j<=p+1;j=j+1){beta(qpivot(j))=work(j)} } call unpck(n,nef,match,sout,s) return end subroutine pck(n,p,match,x,xbar) integer match(n),p,n double precision x(n),xbar(n) do i=1,p xbar(i)=0d0 do i=1,n xbar(match(i))=xbar(match(i))+x(i) return end subroutine suff(n,p,match,x,y,w,xbar,ybar,wbar,work) integer match(n),p,n double precision x(n),xbar(n),y(n),ybar(n),w(n),wbar(n),work(n) call pck(n,p,match,w,wbar) do i=1,n xbar(match(i))=x(i) do i=1,n work(i)=y(i)*w(i) call pck(n,p,match,work,ybar) do i=1,p{ if(wbar(i)>0d0) ybar(i)=ybar(i)/wbar(i) else ybar(i)=0d0 } return end subroutine unpck(n,p,match,xbar,x) integer match(n),p,n double precision x(n),xbar(p+1) if(p 0d0) {dwrss=wsum/wtot} else {dwrss=0d0} return end