polspline/0000755000176200001440000000000014516541355012270 5ustar liggesuserspolspline/NAMESPACE0000644000176200001440000000313214516535020013476 0ustar liggesusers useDynLib(polspline,.registration = TRUE) export(unstrip, hare, plot.hare, print.hare, summary.hare, dhare, hhare, phare, qhare, rhare, xhare, heft, plot.heft, print.heft, summary.heft, dheft, hheft, pheft, qheft, rheft, oldlogspline.to.logspline, poldlogspline, qoldlogspline, roldlogspline, doldlogspline, plot.oldlogspline, print.oldlogspline, summary.oldlogspline, oldlogspline, lspec, clspec, dlspec, plspec, rlspec, plot.lspec, print.lspec, summary.lspec, polymars, predict.polymars, testhare, print.polymars, summary.polymars, plot.polymars, persp.polymars, design.polymars, logspline, plogspline, qlogspline, rlogspline, dlogspline, plot.logspline, print.logspline, summary.logspline, polyclass, cpolyclass, ppolyclass, plot.polyclass, rpolyclass, print.polyclass, summary.polyclass, beta.polyclass) S3method(persp, polymars) S3method(plot, hare) S3method(plot, heft) S3method(plot, logspline) S3method(plot, lspec) S3method(plot, oldlogspline) S3method(plot, polyclass) S3method(plot, polymars) S3method(predict, polymars) S3method(print, hare) S3method(print, heft) S3method(print, logspline) S3method(print, lspec) S3method(print, oldlogspline) S3method(print, polyclass) S3method(print, polymars) S3method(summary, hare) S3method(summary, heft) S3method(summary, logspline) S3method(summary, lspec) S3method(summary, oldlogspline) S3method(summary, polyclass) S3method(summary, polymars) importFrom("graphics", "abline", "contour", "image", "lines", "par", "persp", "plot", "points", "text") importFrom("stats", "fft", "lm", "median", "quantile", "rnorm", "runif", "var") polspline/man/0000755000176200001440000000000014516535020013033 5ustar liggesuserspolspline/man/polymars.Rd0000644000176200001440000002651314516535020015177 0ustar liggesusers\name{polymars} \alias{polymars} \title{Polymars: multivariate adaptive polynomial spline regression} \description{ An adaptive regression procedure using piecewise linear splines to model the response. } \usage{polymars(responses, predictors, maxsize, gcv = 4, additive = FALSE, startmodel, weights, no.interact, knots, knot.space = 3, ts.resp, ts.pred, ts.weights, classify, factors, tolerance, verbose = FALSE) } \arguments{ \item{responses}{vector of responses, or a matrix for multiple response regression. In the case of a matrix each column corresponds to a response and each row corresponds to an observation. Missing values are not allowed. } \item{predictors}{matrix of predictor variables for the regression. Each column corresponds to a predictor and each row corresponds to an observation in the same order as they appear in the response argument. Missing values are not allowed. } \item{maxsize}{the maximum number of basis functions that the model is allowed to grow to in the stepwise addition procedure. Default is \eqn{\min(6*(n^{1/3}),n/4,100)}, where \code{n} is the number of observations. } \item{gcv}{parameter used to find the overall best model from a sequence of fitted models. The residual sum of squares of a model is penalized by dividing by the square of \code{1-(gcv x model size)/cases}. A larger gcv value would tend to produce a smaller model. Models for which \code{1-(gcv x model size)/cases} is smaller or equal than 0 are never selected. } \item{additive}{Should the fitted model be additive in the predictors? } \item{startmodel}{the first model that is to be fit by \code{polymars}. It is either an object of the class \code{polymars} or a model dreamed up by the user. In that case, it takes the form of a \code{4 x n} matrix, where \code{n} is the number of basis functions in the starting model excluding the intercept. Each row corresponds to one basis function (with two possible components). Column 1 is the index of the first predictor involved. Column 2 is a possible knot in this predictor. If column 2 is \code{NA}, the first component is linear. Column 3 is the possible second predictor involved (if column 3 is \code{NA} the basis function only depends on one predictor). Column 4 contains the possible knot for the predictor in column 3, and it is \code{NA} when this component is linear. Example: if a row reads \code{3 NA 2 4.7}, the corresponding basis function is \eqn{[X_3 * (X_2-4.7)_+]}; if a row reads \code{2 4.3 NA NA} the corresponding basis function is \eqn{[(X_2-4.3)_+]}. A fifth column can be added with 1s and 0s, The 1s specify which basis functions of the startmodel must be in each model. Thus, these functions stay in the model during the whole stepwise fitting procedure. If \code{startmodel} is not specified \code{polymars} starts with a model that only contains the intercept. } \item{weights}{optional vector of observation weights; if supplied, the algorithm fits to minimize the sum of the weights multiplied by the squared residuals. The length of weights must be the same as the number of observations. The weights must be nonnegative. } \item{no.interact}{an optional matrix used if certain predictor interactions are not allowed in the model. It is given as a matrix of size \code{2 x m}, with predictor indices as entries. The two predictors of any row cannot have interaction terms with each other. } \item{knots}{defines how the function is to find potential knots for the spline basis functions. This can be set to the maximum number of knots you would like to be considered for each predictor. Usually, to avoid the design matrix becoming singular the actual number of knots produced is constrained to at most every third order statistic in any predictor. This constraint can be adjusted using the \code{knot.space} argument. It can also be a vector with the number of potential knots for each predictor. Again the actual number of knots produced is constrained to be at most every third order statistic any predictor. A third possibility is to provide a matrix where each columns corresponds to the ordered knots you would like to have considered for that predictor. This matrix should be filled out to a rectangular data structure with NAs. The default is \code{min(20, round(n/4))} knots per predictor. When specifying knots as a vector an entry of \code{-1} indicates that the predictor is a categorical variable and each unique entry in it's column is treated as a level. When specifying knots as a single number or a matrix and there are categorical variables these are specified separately as such using the factor argument. } \item{knot.space}{ is an integer describing the minimum number of order statistics apart that two knots can be. Knots should not be too close to insure numerical stability. } \item{ts.resp}{ testset responses for model selection. Should have the same number of columns as the training set response. A testset can be used for the model selection. Depending on the value of classify, either the model with the smallest testset residual sum of squares or the smallest testset classification error is provided. Overrides \code{gcv}. } \item{ts.pred}{ testset predictors. Should have the same number of columns as the training set predictors. } \item{ts.weights}{ testset observation weights. A vector of length equal to the number of cases of the testset. All weights must be non-negative. } \item{classify}{ when the response is discrete (categorical), polymars can be used for classification. In particular, when \code{classify = TRUE}, a discrete response with \code{K} levels is replaced by \code{K} indicator variables as response. Model selection is still being carried out using gcv, except when a testset is provided, in which case testset misclassification is used to select the best model. } \item{factors}{ used to indicate that certain variables in the predictor set are categorical variables. Specified as a vector containing the appropriate predictor indices (column numbers of categorical variables in predictors matrix). Factors can also be set when the \code{knots} argument is given as a vector, with \code{-1} as the appropriate entries for factors. } \item{tolerance}{ for each possible candidate to be added/deleted the resulting residual sums of squares of the model, with/without this candidate, must be calculated. The inversion of of the "X-transpose by X" matrix, X being the design matrix, is done by an updating procedure c.f. C.R. Rao - Linear Statistical Inference and Its Applications, 2nd. edition, page 33. In the inversion the size of the bottom right-hand entry of this matrix is critical. If it\code{s value is near zero or the value of it}s inverse is almost zero then the inversion procedure becomes somewhat inaccurate. The lower the tolerance value the more careful the procedure is in selecting candidates for addition to the model but it may exclude too conservatively. And the other hand if the tolerance is set too high a spurious result with a singular or otherwise sub-optimal model may occur. By default tolerance is set to 1.0e-5. } \item{verbose}{ when set to \code{TRUE}, the function will print out a line for each addition or deletion stage. For example, " + 8 : 5 3.25 2 NA" means adding interaction basis function of predictor 5 with knot at 3.25 and predictor 2 (linear), to make a model of size 8, including intercept. } } \value{ An object of the class \link{polymars}. The returned object contains information about the fitting steps and the model selected. The first data frame contains a row for each step of the fitting procedure. In the columns are: a 1 for an addition step or a 0 for a deletion step, the size of the model at each step, residual sums of squares (RSS) and the generalized cross validation value (GCV), testset residual sums of squares or testset misclassification, whatever was used for the model selection. The second data frame, model, contains a row for each basis function of the model. Each row corresponds to one basis function (with two possible components). The pred1 column contains the indices of the first predictor of the basis function. Column knot1 is a possible knot in this predictor. If this column is NA, the first component is linear. If any of the basis functions of the model is categorical then there will be a level1 column. Column pred2 is the possible second predictor involved (if it is NA the basis function only depends on one predictor). Column knot2 contains the possible knot for the predictor pred2, and it is NA when this component is linear. This is a similar format to the startmodel argument together with an additional first row corresponding to the intercept but the startmodel doesn't use a separate column to specify levels of a categorical variable . If any predictor in pred2 is categorical then there will be a level2 column. The column "coefs" (more than one column in the case of multiple response regression) contains the coefficients. The returned object also contains the fitted values and residuals of the data used in fitting the model. } \note{The algorithm employed by \code{polymars} is different from the MARS(tm) algorithm of Friedman (1991), though it has many similarities. (The name \code{polymars} has been used for this algorithm well before MARS was trademarked.) Some of the main differences are: \code{polymars} requires linear terms of a predictor to be in the model before nonlinear terms using the same predictor can be added; \code{polymars} requires a univariate basis function to be in the model before a tensor-product basis function involving the univariate basis function can be in the model; during stepwise deletion the same hierarchy is maintained; \code{polymars} can be fit to multiple outcomes simultaneously, with categorical outcomes it can be used for multiple classification; and \code{\link{polyclass}} uses the same modeling strategy as \code{polymars}, but uses a logistic (polychotomous) likelihood. MARS is a registered trademark of Jeril, Inc and is used here with permission. Commercial licenses and versions of PolyMARS may be obtained from Salford Systems at http://www.salford-systems.com} \references{Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Friedman, J. H. (1991). Multivariate adaptive regression splines (with discussion). \emph{The Annals of Statistics}, \bold{19}, 1--141. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Martin O'Connor.} \seealso{ \code{\link{polyclass}}, \code{\link{design.polymars}}, \code{\link{persp.polymars}}, \code{\link{plot.polymars}}, \code{\link{predict.polymars}}, \code{\link{summary.polymars}}.} \examples{ data(state) state.pm <- polymars(state.region, state.x77, knots = 15, classify = TRUE) state.pm2 <- polymars(state.x77[, 2], state.x77[,-2], gcv = 2) plot(fitted(state.pm2), residuals(state.pm2)) } \keyword{smooth} \keyword{nonlinear} polspline/man/plot.hare.Rd0000644000176200001440000000546014516535020015223 0ustar liggesusers\name{plot.hare} \alias{plot.hare} \title{Hare: hazard regression} \description{Plots a density, distribution function, hazard function or survival function for a \code{hare} object.} \usage{\method{plot}{hare}(x, cov, n = 100, which = 0, what = "d", time, add = FALSE, xlim, xlab, ylab, type, ...) } \arguments{ \item{x}{\code{hare} object, typically the result of \code{\link{hare}}. } \item{cov}{a vector of length \code{fit\$ncov}, indicating for which combination of covariates the plot should be made. Can be omitted only if \code{fit\$ncov} is 0. } \item{n}{the number of equally spaced points at which to plot the function. } \item{which}{for which coordinate should the plot be made. 0: time; positive value i: covariate i. Note that if which is the positive value i, then the element corresponding to this covariate must be given in \code{cov} even though its actual value is irrelevant. } \item{what}{ what should be plotted: \code{"d"} (density), \code{"p"} (distribution function), \code{"s"} (survival function) or \code{"h"} (hazard function). } \item{time}{if which is not equal to 0, the value of time for which the plot should be made. } \item{add}{should the plot be added to an existing plot? } \item{xlim}{plotting limits; default is from the maximum of 0 and 10\% before the 1st percentile to the minimmum of 10\% further than the 99th percentile and the largest observation.} \item{xlab,ylab}{labels for the axes. Per default no labels are printed.} \item{type}{plotting type. The default is lines.} \item{...}{all other plotting options are passed on. } } \details{This function produces a plot of a \code{\link{hare}} fit at \code{n} equally spaced points roughly covering the support of the density. (Use \code{xlim=c(from,to)} to change the range of these points.) } \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{\code{\link{hare}}, \code{\link{summary.hare}}, \code{\link{dhare}}, \code{\link{hhare}}, \code{\link{phare}}, \code{\link{qhare}}, \code{\link{rhare}}.} \examples{ fit <- hare(testhare[,1], testhare[,2], testhare[,3:8]) # hazard curve for covariates like case 1 plot(fit, testhare[1,3:8], what = "h") # survival function as a function of covariate 2, for covariates as case 1 at t=3 plot(fit, testhare[1,3:8], which = 2, what = "s", time = 3) } \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/hare.Rd0000644000176200001440000001220214516535020014236 0ustar liggesusers\name{hare} \alias{hare} \title{Hare: hazard regression} \description{Fit a hazard regression model: linear splines are used to model the baseline hazard, covariates, and interactions. Fitted models can be, but do not need to be, proportional hazards models. } \usage{hare(data, delta, cov, penalty, maxdim, exclude, include, prophaz = FALSE, additive = FALSE, linear, fit, silent = TRUE) } \arguments{ \item{data}{ vector of observations. Observations may or may not be right censored. All observations should be nonnegative. } \item{delta}{ binary vector with the same length as \code{data}. Elements of \code{data} for which the corresponding element of \code{delta} is 0 are assumed to be right censored, elements of \code{data} for which the corresponding element of \code{delta} is 1 are assumed to be uncensored. If \code{delta} is missing, all observations are assumed to be uncensored. } \item{cov}{ covariates: matrix with as many rows as the length of \code{data}. May be omitted if there are no covariates. (If there are no covariates, however, \code{\link{heft}} will provide a more flexible model using cubic splines.) } \item{penalty}{ the parameter to be used in the AIC criterion. The method chooses the number of knots that minimizes \code{-2 * loglikelihood + penalty * (dimension)}. The default is to use \code{penalty = log(samplesize)} as in BIC. The effect of this parameter is summarized in \code{\link{summary.hare}}. } \item{maxdim}{ maximum dimension (default is \eqn{6*\mbox{length(data)}^0.2)}{\code{6 * length(data)^0.2}}. } \item{exclude}{ combinations to be excluded - this should be a matrix with 2 columns - if for example \code{exclude[1, 1] = 2} and \code{exclude[1, 2] = 3} no interaction between covariate 2 and 3 is included. 0 represents time. } \item{include}{ those combinations that can be included. Should have the same format as \code{exclude}. Only one of \code{exclude} and \code{include} can be specified . } \item{prophaz}{ should the model selection be restricted to proportional hazards models? } \item{additive}{ should the model selection be restricted to additive models? } \item{linear}{ vector indicating for which of the variables no knots should be entered. For example, if \code{linear = c(2, 3)} no knots for either covariate 2 or 3 are entered. 0 represents time. The default is none. } \item{fit}{ \code{\link{hare}} object. If \code{fit} is specified, \code{\link{hare}} adds basis functions starting with those in \code{fit}. } \item{silent}{ suppresses the printing of diagnostic output about basis functions added or deleted, Rao-statistics, Wald-statistics and log-likelihoods. } } \value{An object of class \code{hare}, which is organized to serve as input for \code{\link{plot.hare}}, \code{\link{summary.hare}}, \code{\link{dhare}} (conditional density), \code{\link{hhare}} (conditional hazard rate), \code{\link{phare}} (conditional probabilities), \code{\link{qhare}} (conditional quantiles), and \code{\link{rhare}} (random numbers). The object is a list with the following members: \item{ncov}{ number of covariates. } \item{ndim}{ number of dimensions of the fitted model. } \item{fcts}{ matrix of size \code{ndim x 6}. each row is a basis function. First element: first covariate involved (0 means time); second element: which knot (0 means: constant (time) or linear (covariate)); third element: second covariate involved (\code{NA} means: this is a function of one variable); fourth element: knot involved (if the third element is \code{NA}, of no relevance); fifth element: beta; sixth element: standard error of beta.} \item{knots}{ a matrix with \code{ncov} rows. Covariate \code{i} has row \code{i+1}, time has row 1. First column: number of knots in this dimension; other columns: the knots, appended with \code{NA}s to make it a matrix. } \item{penalty}{ the parameter used in the AIC criterion.} \item{max}{ maximum element of survival data.} \item{ranges}{ column \code{i} gives the range of the \code{i}-th covariate.} \item{logl}{ matrix with two columns. The \code{i}-th element of the first column is the loglikelihood of the model of dimension \code{i}. The second column indicates whether this model was fitted during the addition stage (1) or during the deletion stage (0). } \item{sample}{ sample size.} } \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{\code{\link{heft}}, \code{\link{plot.hare}}, \code{\link{summary.hare}}, \code{\link{dhare}}, \code{\link{hhare}}, \code{\link{phare}}, \code{\link{qhare}}, \code{\link{rhare}}.} \examples{ fit <- hare(testhare[,1], testhare[,2], testhare[,3:8]) } \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/persp.polymars.Rd0000644000176200001440000000257614516535020016332 0ustar liggesusers\name{persp.polymars} \alias{persp.polymars} \title{Polymars: multivariate adaptive polynomial spline regression} \description{This function is not intended for direct use. It is called by \code{\link{plot.polymars}}.} \usage{\method{persp}{polymars}(x, predictor1, predictor2, response, n = 33, xlim, ylim, xx, contour.polymars, main, intercept, ...) } \arguments{ \item{x, predictor1, predictor2}{this function is not intended to be called directly.} \item{response, n, xlim, ylim}{this function is not intended to be called directly.} \item{xx, contour.polymars}{this function is not intended to be called directly.} \item{main, intercept, ...}{this function is not intended to be called directly.} } \details{ This function produces a 3-d contour or perspective plot. It is intended to be called by \code{\link{plot.polymars}}.} \references{Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Martin O'Connor.} \seealso{\code{\link{polymars}}, \code{\link{plot.polymars}}.} \keyword{smooth} \keyword{nonlinear} polspline/man/summary.oldlogspline.Rd0000644000176200001440000000462314516535020017516 0ustar liggesusers\name{summary.oldlogspline} \alias{summary.oldlogspline} \alias{print.oldlogspline} \title{ Logspline Density Estimation - 1992 version } \description{ This function summarizes both the stepwise selection process of the model fitting by \code{\link{oldlogspline}}, as well as the final model that was selected using AIC/BIC. A \code{logspline} object was fit using the 1992 knot deletion algorithm (\code{\link{oldlogspline}}). The 1997 algorithm using knot deletion and addition is available using the \code{\link{logspline}} function. } \usage{\method{summary}{oldlogspline}(object, ...) \method{print}{oldlogspline}(x, ...)} \arguments{ \item{object,x}{ \code{oldlogspline} object, typically the result of \code{\link{oldlogspline}} } \item{...}{ other arguments are ignored.} } \details{ These function produces the same printed output. The main body is a table with five columns: the first column is a possible number of knots for the fitted model; the second column is the log-likelihood for the fit; the third column is \code{-2 * loglikelihood + penalty * (number of knots - 1)}, which is the AIC criterion; \code{\link{logspline}} selected the model with the smallest value of AIC; the fourth and fifth columns give the endpoints of the interval of values of penalty that would yield the model with the indicated number of knots. (\code{NA}s imply that the model is not optimal for any choice of \code{penalty}.) At the bottom of the table the number of knots corresponding to the selected model is reported, as is the value of penalty that was used. } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{plot.oldlogspline}}, \code{\link{doldlogspline}}, \code{\link{poldlogspline}},\cr \code{\link{qoldlogspline}}, \code{\link{roldlogspline}}.} \examples{ y <- rnorm(100) fit <- oldlogspline(y) summary(fit) } \keyword{distribution} \keyword{smooth} polspline/man/oldlogspline.Rd0000644000176200001440000001305014516535020016014 0ustar liggesusers\name{oldlogspline} \alias{oldlogspline} \title{ Logspline Density Estimation - 1992 version } \description{Fits a \code{logspline} density using splines to approximate the log-density using the 1992 knot deletion algorithm (\code{\link{oldlogspline}}). The 1997 algorithm using knot deletion and addition is available using the \code{\link{logspline}} function. } \usage{oldlogspline(uncensored, right, left, interval, lbound, ubound, nknots, knots, penalty, delete = TRUE) } \arguments{ \item{uncensored}{ vector of uncensored observations from the distribution whose density is to be estimated. If there are no uncensored observations, this argument can be omitted. However, either \code{uncensored} or \code{interval} must be specified. } \item{right}{ vector of right censored observations from the distribution whose density is to be estimated. If there are no right censored observations, this argument can be omitted. } \item{left}{ vector of left censored observations from the distribution whose density is to be estimated. If there are no left censored observations, this argument can be omitted. } \item{interval}{ two column matrix of lower and upper bounds of observations that are interval censored from the distribution whose density is to be estimated. If there are no interval censored observations, this argument can be omitted. } \item{lbound,ubound}{ lower/upper bound for the support of the density. For example, if there is a priori knowledge that the density equals zero to the left of 0, and has a discontinuity at 0, the user could specify \code{lbound = 0}. However, if the density is essentially zero near 0, one does not need to specify \code{lbound}. The default for \code{lbound} is \code{-inf} and the default for \code{ubound} is \code{inf}. } \item{nknots}{ forces the method to start with nknots knots (\code{delete = TRUE}) or to fit a density with nknots knots (\code{delete = FALSE}). The method has an automatic rule for selecting nknots if this parameter is not specified. } \item{knots}{ ordered vector of values (that should cover the complete range of the observations), which forces the method to start with these knots (\code{delete = TRUE}) or to fit a density with these knots \code{delete = FALSE}). Overrules \code{nknots}. If \code{knots} is not specified, a default knot-placement rule is employed. } \item{penalty}{ the parameter to be used in the AIC criterion. The method chooses the number of knots that minimizes \code{-2 * loglikelihood + penalty * (number of knots - 1)}. The default is to use a penalty parameter of \code{penalty = log(samplesize)} as in BIC. The effect of this parameter is summarized in \code{\link{summary.oldlogspline}}. } \item{delete}{ should stepwise knot deletion be employed? } } \value{Object of the class \code{oldlogspline}, that is intended as input for \code{\link{plot.oldlogspline}}, \code{\link{summary.oldlogspline}}, \code{\link{doldlogspline}} (densities), \code{\link{poldlogspline}} (probabilities),\cr \code{\link{qoldlogspline}} (quantiles), \code{\link{roldlogspline}} (random numbers from the fitted distribution). The function \code{\link{oldlogspline.to.logspline}} can translate an object of the class \code{oldlogspline} to an object of the class \code{logspline}. The object has the following members: \item{call}{ the command that was executed. } \item{knots }{ vector of the locations of the knots in the \code{oldlogspline} model. old } \item{coef}{ coefficients of the spline. The first coefficient is the constant term, the second is the linear term and the k-th \eqn{(k>2)} is the coefficient of \eqn{(x-t(k-2))^3_+} (where \eqn{x^3_+} means the positive part of the third power of \eqn{x}, and \eqn{t(k-2)} means knot \eqn{k-2}). If a coefficient is zero the corresponding knot was deleted from the model. } \item{bound}{ first element: 0 - \code{lbound} was \eqn{-\inf}{-infinity,} 1 it was something else; second element: \code{lbound}, if specified; third element: 0 - \code{ubound} was \eqn{\inf}{infinity}, 1 it was something else; fourth element: \code{ubound}, if specified. } \item{logl}{ the \code{k}-th element is the log-likelihood of the fit with \code{k+2} knots. } \item{penalty}{ the penalty that was used. } \item{sample}{ the sample size that was used. } \item{delete}{ was stepwise knot deletion employed? } } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{plot.oldlogspline}}, \code{\link{summary.oldlogspline}},\cr \code{\link{doldlogspline}}, \code{\link{poldlogspline}}, \code{\link{qoldlogspline}}, \code{\link{roldlogspline}}, \code{\link{oldlogspline.to.logspline}}.} \examples{ # A simple example y <- rnorm(100) fit <- oldlogspline(y) plot(fit) # An example involving censoring and a lower bound y <- rlnorm(1000) censoring <- rexp(1000) * 4 delta <- 1 * (y <= censoring) y[delta == 0] <- censoring[delta == 0] fit <- oldlogspline(y[delta == 1], y[delta == 0], lbound = 0) } \keyword{distribution} \keyword{smooth} polspline/man/plot.oldlogspline.Rd0000644000176200001440000000434014516535020016773 0ustar liggesusers\name{plot.oldlogspline} \alias{plot.oldlogspline} \title{Logspline Density Estimation - 1992 version } \description{Plots an \code{oldlogspline} density, distribution function, hazard function or survival function from a logspline density that was fitted using the 1992 knot deletion algorithm. The 1997 algorithm using knot deletion and addition is available using the \code{\link{logspline}} function. } \usage{\method{plot}{oldlogspline}(x, n = 100, what = "d", xlim, xlab = "", ylab = "", type = "l", add = FALSE, ...) } \arguments{ \item{x}{\code{logspline} object, typically the result of \code{\link{logspline}}.} \item{n}{the number of equally spaced points at which to plot the density. } \item{what}{what should be plotted: \code{"d"} (density), \code{"p"} (distribution function), \code{"s"} (survival function) or \code{"h"} (hazard function). } \item{xlim}{ range of data on which to plot. Default is from the 1th to the 99th percentile of the density, extended by 10\% on each end.} \item{xlab,ylab}{labels plotted on the axes. } \item{type}{type of plot.} \item{add}{should the plot be added to an existing plot.} \item{...}{other plotting options, as desired} } \details{This function produces a plot of a \code{\link{oldlogspline}} fit at \code{n} equally spaced points roughly covering the support of the density. (Use \code{xlim=c(from,to)} to change the range of these points.) } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{summary.oldlogspline}}, \code{\link{doldlogspline}}, \code{\link{poldlogspline}},\cr \code{\link{qoldlogspline}}, \code{\link{roldlogspline}}.} \examples{ y <- rnorm(100) fit <- oldlogspline(y) plot(fit) } \keyword{distribution} \keyword{smooth} polspline/man/beta.polyclass.Rd0000644000176200001440000000403314516535020016245 0ustar liggesusers\name{beta.polyclass} \alias{beta.polyclass} \title{Polyclass: polychotomous regression and multiple classification} \description{Produces a beta-plot for a \code{polyclass} object. } \usage{beta.polyclass(fit, which, xsp = 0.4, cex) } \arguments{ \item{fit}{\code{polyclass} object, typically the result of \code{\link{polyclass}}. } \item{which}{which classes should be compared? Default is to compare all classes. } \item{xsp}{location of the vertical line to the left of the axis. Useful for making high quality, device dependent, graphics. } \item{cex}{character size. Default is whatever the present character size is. Useful for making high quality, device dependent, graphics. } } \value{ A beta plot. One line for each basis function. The left part of the plot indicates the basis function, the right half the relative location of the betas (coefficients) of that basis function, normalized with respect to parent basis functions, for all classes. The scaling is supposed to suggest a relative importance of the basis functions. This may suggest which basis functions are important for separating particular classes. } \references{ Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{polyclass}}, \code{\link{plot.polyclass}}, \code{\link{summary.polyclass}}, \code{\link{cpolyclass}}, \code{\link{ppolyclass}}, \code{\link{rpolyclass}}.} \note{This is not a generic function, and the complete name, beta.polyclass, has to be specified.} \examples{ data(iris) fit.iris <- polyclass(iris[,5], iris[,1:4]) beta.polyclass(fit.iris) } \keyword{smooth} \keyword{nonlinear} polspline/man/summary.polyclass.Rd0000644000176200001440000000303714516535017017040 0ustar liggesusers\name{summary.polyclass} \alias{summary.polyclass} \alias{print.polyclass} \title{Polyclass: polychotomous regression and multiple classification} \description{This function summarizes both the stepwise selection process of the model fitting by \code{\link{polyclass}}, as well as the final model that was selected} \usage{\method{summary}{polyclass}(object, ...) \method{print}{polyclass}(x, ...) } \arguments{ \item{object,x}{ \code{polyclass} object, typically the result of \code{\link{polyclass}}. } \item{...}{other arguments are ignored.} } \value{These function summarize a \code{polyclass} fit identically. They also give information about fits that could have been obtained with other model selection options in \code{\link{polyclass}}. } \references{ Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{polyclass}}, \code{\link{plot.polyclass}}, \code{\link{beta.polyclass}}, \code{\link{cpolyclass}}, \code{\link{ppolyclass}}, \code{\link{rpolyclass}}.} \examples{ data(iris) fit.iris <- polyclass(iris[,5], iris[,1:4]) summary(fit.iris) } \keyword{smooth} \keyword{nonlinear} polspline/man/heft.Rd0000644000176200001440000001242314516535017014260 0ustar liggesusers\name{heft} \alias{heft} \title{Heft: hazard estimation with flexible tails} \description{Hazard estimation using cubic splines to approximate the log-hazard function and special functions to allow non-polynomial shapes in both tails. } \usage{heft(data, delta, penalty, knots, leftlin, shift, leftlog, rightlog, maxknots, mindist, silent = TRUE) } \arguments{ \item{data}{ vector of observations. Observations may or may not be right censored. All observations should be nonnegative. } \item{delta}{ binary vector with the same length as \code{data}. Elements of \code{data} for which the corresponding element of \code{delta} is 0 are assumed to be right censored, elements of \code{data} for which the corresponding element of \code{delta} is 1 are assumed to be uncensored. If \code{delta} is missing, all observations are assumed to be uncensored. } \item{penalty}{ the parameter to be used in the AIC criterion. The method chooses the number of knots that minimizes \code{-2 * loglikelihood + penalty * (dimension)}. The default is to use \code{penalty = log(samplesize)} as in BIC. The effect of this parameter is summarized in \code{\link{summary.heft}}. } \item{knots}{ ordered vector of values, which forces the method to start with these knots. If \code{knots} is not specified, a default knot-placement rule is employed. } \item{leftlin}{ if \code{leftlin} is \code{TRUE} an extra basis-function, which is linear to the left of the first knot, is included in the basis. If any of \code{data} is exactly 0, the default of \code{leftlin} is \code{TRUE}, otherwise it is \code{FALSE}. } \item{shift}{ parameter for the log terms. Default is \code{quantile(data[delta == 1], .75)}. } \item{leftlog}{ coefficient of \eqn{\log \frac x{x + \mbox{shift}}}{\code{log(x/(x+shift))}}, which must be greater than \code{-1}. (In particular, if \code{leftlog} equals zero no \eqn{\log \frac x{x + \mbox{shift}}}{\code{log(x/(x+shift))}} term is included.) If \code{leftlog} is missing its maximum likelihood estimate is used. If any of \code{data} is exactly zero, \code{leftlog} is set to zero. } \item{rightlog}{ coefficient of \eqn{\log (x + \mbox{shift})}{\code{log(x+shift)}}, which must be greater than \code{-1}. (In particular, if \code{leftlog} equals zero no \eqn{\log (x + \mbox{shift})}{\code{log(x+shift)}} term is included.) If \code{rightlog} is missing its maximum likelihood estimate is used. } \item{maxknots}{ maximum number of knots allowed in the model (default is \eqn{4*n^{0.2})}{\code{4 * n^0.2}}, where \eqn{n} is the length of \code{data}. } \item{mindist}{ minimum distance in order statistics between knots. The default is 5. } \item{silent}{ suppresses the printing of diagnostic output about knots added or deleted, Rao-statistics, Wald-statistics and log-likelihoods. } } \value{An object of class \code{heft}, which is organized to serve as input for \code{\link{plot.heft}}, \code{\link{summary.heft}}, \code{\link{dheft}} (density), \code{\link{hheft}} (hazard rate), \code{\link{pheft}} (probabilities), \code{\link{qheft}} (quantiles), and \code{\link{rheft}} (random numbers). The object is a list with the following members: \item{knots }{ vector of the locations of the knots in the \code{heft} model. } \item{logl}{ the \code{k}-th element is the log-likelihood of the fit with \code{k} knots. } \item{thetak}{ coefficients of the knot part of the spline. The k-th coefficient is the coefficient of \eqn{(x-t(k))^3_+}. If a coefficient is zero the corresponding knot was considered and then deleted from the model. } \item{thetap}{ coefficients of the polynomial part of the spline. The first element is the constant term and the second element is the linear term. } \item{thetal}{ coefficients of the logarithmic terms. The first element equals \code{leftlog} and the second element equals \code{rightlog}. } \item{penalty}{ the penalty that was used. } \item{shift}{ parameter used in the definition of the log terms. } \item{sample}{ the sample size. } \item{logse}{ the standard errors of \code{thetal}. } \item{max}{ the largest element of data. } \item{ad}{ vector indicating whether a model of this dimension was not fit (2), fit during the addition stage (0) or during the deletion stage (1). } } \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{hare}}, \code{\link{plot.heft}}, \code{\link{summary.heft}}, \code{\link{dheft}}, \code{\link{hheft}}, \code{\link{pheft}}, \code{\link{qheft}}, \code{\link{rheft}}.} \examples{ fit1 <- heft(testhare[,1], testhare[,2]) # modify tail behavior fit2 <- heft(testhare[,1], testhare[,2], leftlog = FALSE, rightlog = FALSE, leftlin = TRUE) fit3 <- heft(testhare[,1], testhare[,2], penalty = 0) # select largest model } \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/design.polymars.Rd0000644000176200001440000000362114516535020016442 0ustar liggesusers\name{design.polymars} \alias{design.polymars} \title{Polymars: multivariate adaptive polynomial spline regression} \description{Produces a design matrux for a model of class \code{polymars}.} \usage{design.polymars(object, x) } \arguments{ \item{object}{ object of the class \code{polymars}, typically the result of \code{\link{polymars}}.} \item{x}{ the predictor values at which the design matrix will be computed. The predictor values can be in a number of formats. It can take the form of a vector of length equal to the number of predictors in the original data set or it can be shortened to the length of only those predictors that occur in the model, in the same order as they appear in the original data set. Similarly, \code{x} can take the form of a matrix with the number of columns equal to the number of predictors in the original data set, or shortened to the number of predictors in the model. } } \value{The design matrix corresponding to the fitted \code{\link{polymars}} model.} \references{ Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg} \seealso{ \code{\link{polymars}}, \code{\link{plot.polymars}}, \code{\link{predict.polymars}}, \code{\link{summary.polymars}}.} \examples{ data(state) state.pm <- polymars(state.region, state.x77, knots = 15, classify = TRUE, gcv = 1) desmat <- design.polymars(state.pm, state.x77) # compute traditional summary of the fit for the first class summary(lm(((state.region=="Northeast")*1) ~ desmat -1)) } \keyword{smooth} \keyword{nonlinear} polspline/man/summary.heft.Rd0000644000176200001440000000476214516535017015763 0ustar liggesusers\name{summary.heft} \alias{summary.heft} \alias{print.heft} \title{Heft: hazard estimation with flexible tails} \description{This function summarizes both the stepwise selection process of the model fitting by \code{\link{heft}}, as well as the final model that was selected using AIC/BIC.} \usage{\method{summary}{heft}(object, ...) \method{print}{heft}(x, ...) } \arguments{ \item{object,x}{ \code{heft} object, typically the result of \code{\link{heft}}. } \item{...}{other arguments are ignored.} } \details{These function produce identical printed output. The main body is a table with six columns: the first column is a possible number of knots for the fitted model; the second column is 0 if the model was fitted during the addition stage and 1 if the model was fitted during the deletion stage; the third column is the log-likelihood for the fit; the fourth column is \code{-2 * loglikelihood + penalty * (dimension)}, which is the AIC criterion - \code{heft} selected the model with the minimum value of AIC; the fifth and sixth columns give the endpoints of the interval of values of penalty that would yield the model with the indicated number of knots. (\code{NA}s imply that the model is not optimal for any choice of penalty.) At the bottom of the table the number of knots corresponding to the selected model is reported, as are the value of penalty that was used and the coefficients of the log-based terms in the fitted model and their standard errors. } \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{heft}}, \code{\link{plot.heft}}, \code{\link{dheft}}, \code{\link{hheft}}, \code{\link{pheft}}, \code{\link{qheft}}, \code{\link{rheft}}.} \examples{ fit1 <- heft(testhare[,1], testhare[,2]) summary(fit1) # modify tail behavior fit2 <- heft(testhare[,1], testhare[,2], leftlog = FALSE, rightlog = FALSE, leftlin = TRUE) summary(fit2) fit3 <- heft(testhare[,1], testhare[,2], penalty = 0) # select largest model summary(fit3) } \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/summary.logspline.Rd0000644000176200001440000000445314516535020017020 0ustar liggesusers\name{summary.logspline} \alias{summary.logspline} \alias{print.logspline} \title{Logspline Density Estimation } \description{ This function summarizes both the stepwise selection process of the model fitting by \code{\link{logspline}}, as well as the final model that was selected using AIC/BIC. A \code{logspline} object was fit using the 1997 knot addition and deletion algorithm. The 1992 algorithm is available using the \code{\link{oldlogspline}} function. } \usage{\method{summary}{logspline}(object, ...) \method{print}{logspline}(x, ...) } \arguments{ \item{object,x}{\code{logspline} object, typically the result of \code{\link{logspline}}} \item{...}{ other arguments are ignored.} } \details{These function produce identical printed output. The main body is a table with five columns: the first column is a possible number of knots for the fitted model; the second column is the log-likelihood for the fit; the third column is \code{-2 * loglikelihood + penalty * (number of knots - 1)}, which is the AIC criterion; \code{\link{logspline}} selected the model with the smallest value of AIC; the fourth and fifth columns give the endpoints of the interval of values of penalty that would yield the model with the indicated number of knots. (\code{NA}s imply that the model is not optimal for any choice of \code{penalty}.) At the bottom of the table the number of knots corresponding to the selected model is reported, as is the value of penalty that was used. } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{plot.logspline}}, \code{\link{dlogspline}}, \code{\link{plogspline}}, \code{\link{qlogspline}}, \code{\link{rlogspline}},\cr \code{\link{oldlogspline}}.} \examples{ y <- rnorm(100) fit <- logspline(y) summary(fit) } \keyword{distribution} \keyword{smooth} polspline/man/summary.hare.Rd0000644000176200001440000000523514516535020015742 0ustar liggesusers\name{summary.hare} \alias{summary.hare} \alias{print.hare} \title{Hare: hazard regression} \description{This function summarizes both the stepwise selection process of the model fitting by \code{\link{hare}}, as well as the final model that was selected using AIC/BIC.} \usage{\method{summary}{hare}(object, ...) \method{print}{hare}(x, ...) } \arguments{ \item{object,x}{ \code{hare} object, typically the result of \code{\link{hare}}. } \item{...}{other arguments are ignored.} } \details{These function produce identical printed output. The main body consists of two tables. The first table has six columns: the first column is a possible number of dimensions for the fitted model; the second column indicates whether this model was fitted during the addition or deletion stage; the third column is the log-likelihood for the fit; the fourth column is \code{-2 * loglikelihood + penalty * (dimension)}, which is the AIC criterion - \code{hare} selected the model with the minimum value of AIC; the last two columns give the endpoints of the interval of values of penalty that would yield the model with the indicated number of dimensions (\code{NA}s imply that the model is not optimal for any choice of penalty). At the bottom of the first table the dimension of the selected model is reported, as is the value of penalty that was used. Each row of the second table summarizes the information about a basis function in the final model. It shows the variables involved, the knot locations, the estimated coefficient and its standard error and Wald statistic (estimate/SE). } \note{ Since the basis functions are selected in an adaptive fashion, typically most Wald statistics are larger than (the magical) 2. These statistics should be taken with a grain of salt though, as they are inflated because of the adaptivity of the model selection.} \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \seealso{\code{\link{hare}}, \code{\link{plot.hare}}, \code{\link{dhare}}, \code{\link{hhare}}, \code{\link{phare}}, \code{\link{qhare}}, \code{\link{rhare}}.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \examples{ fit <- hare(testhare[,1], testhare[,2], testhare[,3:8]) summary(fit) } \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/predict.polymars.Rd0000644000176200001440000000504214516535020016622 0ustar liggesusers\name{predict.polymars} \alias{predict.polymars} \title{Polymars: multivariate adaptive polynomial spline regression} \description{Produces fitted values for a model of class \code{polymars}.} \usage{\method{predict}{polymars}(object, x, classify = FALSE, intercept, ...) } \arguments{ \item{object}{ object of the class \code{polymars}, typically the result of \code{\link{polymars}}.} \item{x}{ the predictor values at which the fitted values will be computed. The predictor values can be in a number of formats. It can take the form of a vector of length equal to the number of predictors in the original data set or it can be shortened to the length of only those predictors that occur in the model, in the same order as they appear in the original data set. Similarly, \code{x} can take the form of a matrix with the number of columns equal to the number of predictors in the original data set, or shortened to the number of predictors in the model. } \item{classify}{ if the original call to polymars was for a classification problem and you would like the classifications (class predictions), set this option equal to \code{TRUE}. Otherwise the function returns a response column for each class (the highest values in each row is its class for the case when \code{classify = TRUE}). } \item{intercept}{ Setting intercept equal to \code{FALSE} evaluates the object without intercept. The intercept may also be given any numerical value which overrides the fitted coefficient from the object. The defualt is \code{TRUE}. } \item{...}{other arguments are ignored.} } \value{A matrix of fitted values. The number of columns in the returned matrix equals the number of responses in the original call to \code{\link{polymars}}.} \references{ Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Martin O'Connor.} \seealso{ \code{\link{polymars}}, \code{\link{design.polymars}}, \code{\link{plot.polymars}}, \code{\link{summary.polymars}}.} \examples{ data(state) state.pm <- polymars(state.region, state.x77, knots = 15, classify = TRUE, gcv = 1) table(predict(state.pm, x = state.x77, classify = TRUE), state.region) } \keyword{smooth} \keyword{nonlinear} polspline/man/lspec.Rd0000644000176200001440000001345714516535020014442 0ustar liggesusers\name{lspec} \alias{lspec} \title{Lspec: logspline estimation of a spectral distribution} \description{ Fit an \code{lspec} model to a time-series or a periodogram.} \usage{lspec(data, period, penalty, minmass, knots, maxknots, atoms, maxatoms, maxdim , odd = FALSE, updown = 3, silent = TRUE) } \arguments{ \item{data}{ time series (exactly one of \code{data} and \code{period} should be specified). If \code{data} is specified, \code{lspec} first computes the modulus of the fast Fourier transform of the series using the function \code{\link{fft}}, resulting in a periodogram of length \code{floor(length(data)/2)}. } \item{period}{ value of the periodogram for a time series at frequencies \eqn{\frac{2\pi j}T}{2pi*j/T}, for \eqn{1\leq j \leq T/2}{1<=j<=T/2}. If period is specified, odd should indicate whether the length of the series T is odd \code{(odd = TRUE)} or even \code{(odd = FALSE)}. Exactly one of \code{data} and \code{period} should be specified. } \item{penalty}{ the parameter to be used in the AIC criterion. The method chooses the number of basis functions that minimizes \code{-2 * loglikelihood + penalty * (number of basis functions)}. Default is to use a penalty parameter of \code{penalty = log(length(period))} as in BIC. } \item{minmass}{ threshold value for atoms. No atoms having smaller mass than \code{minmass} are included in the model. If \code{minmass} takes its default value, in 95\% of the samples, when data is Gaussian white noise, the model will not contain atoms. } \item{knots}{ ordered vector of values, which forces the method to start with these knots. If \code{knots} is not specified, the program starts with one knot at zero and then employs stepwise addition of knots and atoms. } \item{maxknots}{ maximum number of knots allowed in the model. Does not need to be specified, since the program has a default for \code{maxdim} and the number of dimensions equals the number of knots plus the number of atoms. If \code{maxknots = 1} the fitted spectral density function is constant. } \item{atoms}{ ordered vector of values, which forces the method to start with discrete components at these frequencies. The values of atoms are rounded to the nearest multiple of \eqn{\frac{2\pi}T}{2*pi/T}. If atoms is not specified, the program starts with no atoms and then performs stepwise addition of knots and atoms. } \item{maxatoms}{ maximum number of discrete components allowed in the model. Does not need to be specified, since the program has a default for \code{maxdim} and the number of dimensions equals the number of knots plus the number of atoms. If \code{maxatoms = 0} a continuous spectral distribution is fit. } \item{maxdim}{ maximum number of basis functions allowed in the model (default is \eqn{\max(15,4\times\mbox{length(period)}^{0.2})}{max(15,4*length(period)^0.2)}). } \item{odd}{ see \code{period}. If \code{period} is not specified, \code{odd} is not relevant. } \item{updown}{ the maximal number of times that \code{lspec} should go through a cycle of stepwise addition and stepwise deletion until a stable solution is reached. } \item{silent}{ should printing of information be suppressed?} } \value{Object of class \code{lspec}. The output is organized to serve as input for \code{\link{plot.lspec}} (summary plots), \code{\link{summary.lspec}} (summarizes fitting), \code{\link{clspec}} (for autocorrelations and autocovariances), \code{\link{dlspec}} (for spectral density and line-spectrum,) \code{\link{plspec}} (for the spectral distribution), and \code{\link{rlspec}} (for random time series with the same spectrum). \item{call}{ the command that was executed. } \item{thetap}{ coefficients of the polynomial part of the spline. } \item{nknots}{ the number of knots that were retained. } \item{knots}{ vector of the locations of the knots in the logspline model. Only the knots that were retained are in this vector. } \item{thetak}{ coefficients of the knot part of the spline. The k-th coefficient is the coefficient of \eqn{(x-t(k))^3_+}. } \item{natoms}{ the number of atoms that were retained. } \item{atoms}{ vector of the locations of the atoms in the model. Only the atoms that were retained are in this vector. } \item{mass}{ The k-th coefficient is the mass at \code{atom[k]}. } \item{logl}{ the log-likelihood of the model. } \item{penalty}{ the penalty that was used. } \item{minmass}{ the minimum mass for an atom that was allowed. } \item{sample}{ the sample size that was used, either computed as \code{length(data)} or as \code{(2 * length(period))} when \code{odd = FALSE} or as \code{(2 * length(period) + 1)} when \code{odd = TRUE}. } \item{updown}{ the actual number of times that \code{lspec} went through a cycle of stepwise addition and stepwise deletion until a stable solution was reached, or minus the number of times that lspec went through a cycle of stepwise addition and stepwise deletion until it decided to quit. } } \references{ Charles Kooperberg, Charles J. Stone, and Young K. Truong (1995). Logspline Estimation of a Possibly Mixed Spectral Distribution. \emph{Journal of Time Series Analysis}, \bold{16}, 359-388. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{\code{\link{plot.lspec}}, \code{\link{summary.lspec}}, \code{\link{clspec}}, \code{\link{dlspec}}, \code{\link{plspec}}, \code{\link{rlspec}}.} \examples{ data(co2) co2.detrend <- unstrip(lm(co2~c(1:length(co2)))$residuals) fit <- lspec(co2.detrend) } \keyword{ts} \keyword{smooth} polspline/man/testhare.Rd0000644000176200001440000000227714516535020015151 0ustar liggesusers\name{testhare} \alias{testhare} \title{Fake survival data for Hare and Heft} \description{Fake survival analysis data set for testing \code{\link{hare}} and \code{\link{heft}}} \usage{testhare} \format{ A matrix with 2000 lines (observations) and 8 columns. Column 1 is intended to be the survival time, column 2 the censoring indicator, and columns 3 through 8 are predictors (covariates).} \source{I started out with a real data set; then I sampled, transformed and added noise. Virtually no number is unchanged.} \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{hare}}, \code{\link{heft}}.} \examples{ harefit <- hare(testhare[,1], testhare[,2], testhare[,3:8]) heftfit <- heft(testhare[,1], testhare[,2]) } \keyword{survival} \keyword{datasets} polspline/man/doldlogspline.Rd0000644000176200001440000000516014516535020016163 0ustar liggesusers\name{doldlogspline} \alias{doldlogspline} \alias{poldlogspline} \alias{qoldlogspline} \alias{roldlogspline} \title{Logspline Density Estimation - 1992 version } \description{Probability density function (\code{doldlogspline}), distribution function (\code{poldlogspline}), quantiles (\code{qoldlogspline}), and random samples (\code{roldlogspline}) from a logspline density that was fitted using the 1992 knot deletion algorithm (\code{\link{oldlogspline}}). The 1997 algorithm using knot deletion and addition is available using the \code{\link{logspline}} function. } \usage{doldlogspline(q, fit) poldlogspline(q, fit) qoldlogspline(p, fit) roldlogspline(n, fit) } \arguments{ \item{q}{ vector of quantiles. Missing values (NAs) are allowed. } \item{p}{ vector of probabilities. Missing values (NAs) are allowed. } \item{n}{ sample size. If \code{length(n)} is larger than 1, then \code{length(n)} random values are returned. } \item{fit}{ \code{oldlogspline} object, typically the result of \code{\link{oldlogspline}}. } } \value{ Densities (\code{doldlogspline}), probabilities (\code{poldlogspline}), quantiles (\code{qoldlogspline}), or a random sample (\code{roldlogspline}) from an \code{oldlogspline} density that was fitted using knot deletion. } \details{ Elements of \code{q} or \code{p} that are missing will cause the corresponding elements of the result to be missing. } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{plot.oldlogspline}}, \code{\link{summary.oldlogspline}}} \examples{ x <- rnorm(100) fit <- oldlogspline(x) qq <- qoldlogspline((1:99)/100, fit) plot(qnorm((1:99)/100), qq) # qq plot of the fitted density pp <- poldlogspline((-250:250)/100, fit) plot((-250:250)/100, pp, type = "l") lines((-250:250)/100, pnorm((-250:250)/100)) # asses the fit of the distribution dd <- doldlogspline((-250:250)/100, fit) plot((-250:250)/100, dd, type = "l") lines((-250:250)/100, dnorm((-250:250)/100)) # asses the fit of the density rr <- roldlogspline(100, fit) # random sample from fit } \keyword{distribution} \keyword{smooth} polspline/man/plot.polymars.Rd0000644000176200001440000000735714516535020016161 0ustar liggesusers\name{plot.polymars} \alias{plot.polymars} \title{Polymars: multivariate adaptive polynomial spline regression} \description{Produces two and three dimensional plots of the fitted values from a \code{polymars} object. } \usage{\method{plot}{polymars}(x, predictor1, response, predictor2, xx, add = FALSE, n, xyz = FALSE, contour.polymars = FALSE, xlim, ylim, intercept, ...) } \arguments{ \item{x}{\code{polymars} object, typically the result of \code{\link{polymars}}. } \item{predictor1}{the index of a predictor that was used when the \code{polymars} model was fit. For the two dimensional plots, this variable is plotted along the X-axis. } \item{response}{ if the model was fitted to multiple response data the response index should be specified. } \item{predictor2}{ the index of a predictor that was used when the \code{polymars} model was fit. For the three dimensional plots, this variable is plotted along the Y-axis. See \code{xyz}. } \item{xx}{ should be a vector of length equal to the number of predictors in the original data set. The values should be in the same order as in the original dataset. By default the function uses the median values of the data that was used to fit the model. Although the values for predictor and predictor2 are not used, they should still be provided as part of \code{xx}. } \item{add}{ should the plot be added to a previously created plot? Works only for two dimensional plots. } \item{n}{ number of plotting points (2 dimensional plot) or plotting points along each axis (3 dimensional plot). The default is \code{n = 100} for 2 dimensional plots and \code{n = 33} for 3 dimensional plots. } \item{xyz}{ is the plot being made a 3 dimensional plot? If there is only one response it need not be set, if two numerical values accompany the model in the call they will be understood as two predictors for a 3-d plot. By default a 3-d plot uses the \code{\link{persp}} function. Categorical predictors cannot be used for 3 dimensional plots. } \item{contour.polymars}{ if the plot being made a 3 dimensional plot should it be made as a contour plot (\code{TRUE}) or a perspective plot (\code{FALSE}). function \link{contour} is being made. } \item{intercept}{ Setting intercept equal to \code{FALSE} evaluates the object without intercept. The intercept may also be given any numerical value which overrides the fitted coefficient from the object. The default is \code{TRUE}. } \item{xlim,ylim}{Plotting limits. The function tries to choose intelligent limits itself} \item{...}{ other options are passed on. } } \details{ This function produces a 2-d plot of 1 predictor and response of a \code{polymars} object at n equally spaced points or a 3-d plot of two predictors and response of a \code{polymars} object. The range of the plot is by default equal to the range of the particular predictor(s) in the original data, but this can be changed by \code{xlim = c(from, to)} and \code{ylim = c(from, to)}. } \references{Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Martin O'Connor.} \seealso{ \code{\link{design.polymars}}, \code{\link{polymars}}, \code{\link{predict.polymars}}, \code{\link{summary.polymars}}.} \examples{ data(state) state.pm <- polymars(state.region, state.x77, knots = 15, classify = TRUE, gcv = 1) plot(state.pm, 3, 4) } \keyword{smooth} \keyword{nonlinear} polspline/man/polyclass.Rd0000644000176200001440000002277014516535020015343 0ustar liggesusers\name{polyclass} \alias{polyclass} \title{Polyclass: polychotomous regression and multiple classification} \description{Fit a polychotomous regression and multiple classification using linear splines and selected tensor products. } \usage{polyclass(data, cov, weight, penalty, maxdim, exclude, include, additive = FALSE, linear, delete = 2, fit, silent = TRUE, normweight = TRUE, tdata, tcov, tweight, cv, select, loss, seed) } \arguments{ \item{data}{vector of classes: \code{data} should ranges over consecutive integers with 0 or 1 as the minimum value. } \item{cov}{covariates: matrix with as many rows as the length of \code{data}. } \item{weight}{optional vector of case-weights. Should have the same length as \code{data}.} \item{penalty}{ the parameter to be used in the AIC criterion if the model selection is carried out by AIC. The program chooses the number of knots that minimizes \code{-2 * loglikelihood + penalty * (dimension)}. The default is to use \code{penalty = log(length(data))} as in BIC. If the model selection is carried out by cross-validation or using a test set, the program uses the number of knots that minimizes \code{loss + penalty * dimension * (loss for smallest model)}. In this case the default of \code{penalty} is 0. } \item{maxdim}{ maximum dimension (default is \eqn{\min(n, 4 * n^{1/3}*(cl-1)}{\code{min(n, 4 * n^(1/3) * (cl - 1)}}, where \eqn{n} is \code{length(data)} and \eqn{cl} the number of classes. } \item{exclude}{ combinations to be excluded - this should be a matrix with 2 columns - if for example \code{exclude[1, 1] = 2} and \code{exclude[1, 2] = 3} no interaction between covariate 2 and 3 is included. 0 represents time. } \item{include}{ those combinations that can be included. Should have the same format as \code{exclude}. Only one of \code{exclude} and \code{include} can be specified . } \item{additive}{should the model selection be restricted to additive models? } \item{linear}{ vector indicating for which of the variables no knots should be entered. For example, if \code{linear = c(2, 3)} no knots for either covariate 2 or 3 are entered. 0 represents time. } \item{delete}{ should complete basis functions be deleted at once (2), should only individual dimensions be deleted (1) or should only the addition stage of the model selection be carried out (0)? } \item{fit}{ \code{polyclass} object. If \code{fit} is specified, \code{\link{polyclass}} adds basis functions starting with those in \code{fit}. } \item{silent}{ suppresses the printing of diagnostic output about basis functions added or deleted, Rao-statistics, Wald-statistics and log-likelihoods. } \item{normweight}{ should the weights be normalized so that they average to one? This option has only an effect if the model is selected using AIC. } \item{tdata,tcov,tweight}{ test set. Should satisfy the same requirements as \code{data}, \code{cov} and \code{weight}. If all test set weights are one, \code{tweight} can be omitted. If \code{tdata} and \code{tcov} are specified, the model selection is carried out using this test set, irrespective of the input for \code{penalty} or \code{cv}. } \item{cv}{ in how many subsets should the data be divided for cross-validation? If \code{cv} is specified and tdata is omitted, the model selection is carried out by cross-validation. } \item{select}{ if a test set is provided, or if the model is selected using cross validation, should the model be select that minimizes (misclassification) loss (0), that maximizes test set log-likelihood (1) or that minimizes test set squared error loss (2)? } \item{loss}{ a rectangular matrix specifying the loss function, whose size is the number of classes times number of actions. Used for cross-validation and test set model selection. \code{loss[i, j]} contains the loss for assigning action \code{j} to an object whose true class is \code{i}. The default is 1 minus the identity matrix. \code{loss} does not need to be square. } \item{seed}{ optional seed for the random number generator that determines the sequence of the cases for cross-validation. If the seed has length 12 or more, the first twelve elements are assumed to be \code{.Random.seed}, otherwise the function \code{\link{set.seed}} is used. If \code{seed} is 0 or \code{rep(0, 12)}, it is assumed that the user has already provided a (random) ordering. If \code{seed} is not provided, while a fit with an element \code{fit\$seed} is provided, \code{.Random.seed} is set using \code{set.seed(fit\$seed)}. Otherwise the present value of \code{.Random.seed} is used. } } \value{ The output is an object of class \code{polyclass}, organized to serve as input for \code{\link{plot.polyclass}}, \code{\link{beta.polyclass}}, \code{\link{summary.polyclass}}, \code{\link{ppolyclass}} (fitted probabilities), \code{\link{cpolyclass}} (fitted classes) and \code{\link{rpolyclass}} (random classes). The function returns a list with the following members: \item{call}{the command that was executed. } \item{ncov}{number of covariates. } \item{ndim}{number of dimensions of the fitted model. } \item{nclass}{number of classes. } \item{nbas}{number of basis functions. } \item{naction}{number of possible actions that are considered. } \item{fcts}{matrix of size \code{nbas x (nclass + 4)}. each row is a basis function. First element: first covariate involved (\code{NA} = constant); second element: which knot (\code{NA} means: constant or linear); third element: second covariate involved (\code{NA} means: this is a function of one variable); fourth element: knot involved (if the third element is \code{NA}, of no relevance); fifth, sixth,... element: beta (coefficient) for class one, two, ... } \item{knots}{ a matrix with \code{ncov} rows. Covariate \code{i} has row \code{i+1}, time has row 1. First column: number of knots in this dimension; other columns: the knots, appended with \code{NA}s to make it a matrix. } \item{cv}{ in how many sets was the data divided for cross-validation. Only provided if \code{method = 2}. } \item{loss}{ the loss matrix used in cross-validation and test set. Only provided if \code{method = 1} or \code{method = 2}. } \item{penalty}{ the parameter used in the AIC criterion. Only provided if \code{method = 0}. } \item{method}{ 0 = AIC, 1 = test set, 2 = cross-validation. } \item{ranges}{ column \code{i} gives the range of the \code{i}-th covariate. } \item{logl}{ matrix with eight or eleven columns. Summarizes fits. Column one indicates the dimension, column column two the AIC or loss value, whichever was used during the model selection appropriate, column three four and five give the training set log-likelihood, (misclassification) loss and squared error loss, columns six to eight give the same information for the test set, column nine (or column six if \code{method = 0} or \code{method = 2}) indicates whether the model was fitted during the addition stage (1) or during the deletion stage (0), column ten and eleven (or seven and eight) the minimum and maximum penalty parameter for which AIC would have selected this model. } \item{sample}{sample size. } \item{tsample}{the sample size of the test set. Only prvided if \code{method = 1}. } \item{wgtsum}{sum of the case weights. } \item{covnames}{names of the covariates. } \item{classnames}{(numerical) names of the classes. } \item{cv.aic}{the penalty value that was determined optimal by by cross validation. Only provided if \code{method = 2}. } \item{cv.tab}{table with three columns. Column one and two indicate the penalty parameter range for which the cv-loss in column three would be realized. Only provided if \code{method = 2}.} \item{seed}{the random seed that was used to determine the order of the cases for cross-validation. Only provided if \code{method = 2}.} \item{delete}{ were complete basis functions deleted at once (2), were only individual dimensions deleted (1) or was only the addition stage of the model selection carried out (0)? } \item{beta}{ moments of basisfunctions. Needed for \code{\link{beta.polyclass}}. } \item{select}{ if a test set is provided, or if the model is selected using cross validation, was the model selected that minimized (misclassification) loss (0), that maximized test set log-likelihood (1) or that minimized test set squared error loss (2)? } \item{anova}{ matrix with three columns. The first two elements in a line indicate the subspace to which the line refers. The third element indicates the percentage of variance explained by that subspace. } \item{twgtsum}{ sum of the test set case weights (only if \code{method = 1}). } } \references{Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{polymars}}, \code{\link{plot.polyclass}}, \code{\link{summary.polyclass}}, \code{\link{beta.polyclass}}, \code{\link{cpolyclass}},\cr \code{\link{ppolyclass}}, \code{\link{rpolyclass}}.} \examples{ data(iris) fit.iris <- polyclass(iris[,5], iris[,1:4]) } \keyword{smooth} \keyword{nonlinear} polspline/man/dheft.Rd0000644000176200001440000000354214516535020014420 0ustar liggesusers\name{dheft} \alias{dheft} \alias{hheft} \alias{pheft} \alias{qheft} \alias{rheft} \title{Heft: hazard estimation with flexible tails} \description{Density (\code{dheft}), cumulative probability (\code{pheft}), hazard rate (\code{hheft}), quantiles (\code{qheft}), and random samples (\code{rheft}) from a \code{\link{heft}} object} \usage{dheft(q, fit) hheft(q, fit) pheft(q, fit) qheft(p, fit) rheft(n, fit) } \arguments{ \item{q}{ vector of quantiles. Missing values (\code{NA}s) are allowed. } \item{p}{ vector of probabilities. Missing values (\code{NA}s) are allowed. } \item{n}{ sample size. If \code{length(n)} is larger than 1, then \code{length(n)} random values are returned. } \item{fit}{ \code{heft} object, typically obtained from \code{\link{heft}}. } } \value{Densities (\code{dheft}), hazard rates (\code{hheft}), probabilities (\code{pheft}), quantiles (\code{qheft}), or a random sample (\code{rheft}) from a \code{\link{heft}} object.} \details{ Elements of \code{q} or \code{p} that are missing will cause the corresponding elements of the result to be missing. } \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{heft}}, \code{\link{plot.heft}}, \code{\link{summary.heft}}. } \examples{ fit <- heft(testhare[,1],testhare[,2]) dheft(0:10,fit) hheft(0:10,fit) pheft(0:10,fit) qheft((1:19)/20,fit) rheft(10,fit) } \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/summary.lspec.Rd0000644000176200001440000000236114516535017016134 0ustar liggesusers\name{summary.lspec} \alias{summary.lspec} \alias{print.lspec} \title{Lspec: logspline estimation of a spectral distribution} \description{Summary of a model fitted with \code{\link{lspec}} } \usage{\method{summary}{lspec}(object, ...) \method{print}{lspec}(x, ...) } \arguments{ \item{object,x}{ \code{lspec} object, typically the result of \code{\link{lspec}}.} \item{...}{other options are ignored.}} \details{These function produce an identical printed summary of an \code{lspec} object.} \references{ Charles Kooperberg, Charles J. Stone, and Young K. Truong (1995). Logspline Estimation of a Possibly Mixed Spectral Distribution. \emph{Journal of Time Series Analysis}, \bold{16}, 359-388. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{\link{lspec}, \link{plot.lspec}, \link{clspec}, \link{dlspec}, \link{plspec}, \link{rlspec}.} \examples{ data(co2) co2.detrend <- lm(co2~c(1:length(co2)))$residuals fit <- lspec(co2.detrend) summary(fit) } \keyword{ts} \keyword{smooth} polspline/man/xhare.Rd0000644000176200001440000000215314516535020014432 0ustar liggesusers\name{xhare} \alias{xhare} \title{Hare: hazard regression} \description{Driver function for \code{\link{dhare}}, \code{\link{hhare}}, \code{\link{phare}}, \code{\link{qhare}}, and \code{\link{rhare}}. This function is not intended for use by itself.} \usage{xhare(arg1, arg2, arg3, arg4) } \arguments{ \item{arg1,arg2,arg3,arg4}{ arguments. } } \details{ This function is used internally. } \note{This function is not intended for direct use.} \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{hare}}, \code{\link{dhare}}, \code{\link{hhare}}, \code{\link{phare}}, \code{\link{qhare}}, \code{\link{rhare}}.} \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/unstrip.Rd0000644000176200001440000000202714516535020015027 0ustar liggesusers\name{unstrip} \alias{unstrip} \title{Reformat data as vector or matrix} \description{This function tries to convert a date.frame or a matrix to a no-frills matrix without labels, and a vector or time-series to a no-frills vector without labels.} \usage{unstrip(x) } \arguments{ \item{x}{ one- or two-dimensional object.} } \value{If \code{x} is two-dimensional a matrix without names, if \code{x} is one-dimensional a numerical vector} \details{Many of the functions for \code{\link{logspline}}, \code{\link{oldlogspline}}, \code{\link{lspec}}, \code{\link{polyclass}}, \code{\link{hare}}, \code{\link{heft}}, and \code{\link{polymars}} were written in the ``before data.frame'' era; \code{unstrip} attempts to keep all these functions useful with more advanced input objects. In particular, many of these functions call \code{unstrip} before doing anything else.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \examples{ data(co2) unstrip(co2) data(iris) unstrip(iris) } \keyword{utilities} \keyword{classes} polspline/man/plot.lspec.Rd0000644000176200001440000000425114516535017015415 0ustar liggesusers\name{plot.lspec} \alias{plot.lspec} \title{Lspec: logspline estimation of a spectral distribution} \description{Plots a spectral density function, line spectrum, or spectral distribution from a model fitted with \code{\link{lspec}} } \usage{\method{plot}{lspec}(x, what = "b", n, add = FALSE, xlim, ylim, xlab = "", ylab = "", type, ...) } \arguments{ \item{x}{\code{lspec} object, typically the result of \code{\link{lspec}}.} \item{what}{what should be plotted: b (spectral density and line spectrum superimposed), d (spectral density function), l (line spectrum) or p (spectral distribution function). } \item{n}{the number of equally spaced points at which to plot the fit; default is \code{max(100,fit\$sample)}. } \item{add}{indicate that the plot should be added to an existing plot. } \item{xlim}{X-axis plotting limits: default is \eqn{c(0,\pi)}{c(0,pi)}, except when what = "p", when the default is \eqn{c(-\pi,\pi)}{c(-pi,pi)}.} \item{ylim}{Y-axis plotting limits.} \item{xlab,ylab}{axis labels.} \item{type}{plotting type; default is \code{"l"} when \code{what = "d"} and \code{what = "p"}, \code{"h"} when \code{what = "l"}, and a combination of \code{"h"} and \code{"l"} when \code{what ="b"}} \item{...}{all regular plotting options are passed on. } } \note{If \code{what = "p"} the plotting range cannot extend beyond the interval \eqn{[-\pi,\pi]}{[-pi,pi]}. } \references{ Charles Kooperberg, Charles J. Stone, and Young K. Truong (1995). Logspline Estimation of a Possibly Mixed Spectral Distribution. \emph{Journal of Time Series Analysis}, \bold{16}, 359-388. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{\code{\link{lspec}}, \code{\link{summary.lspec}}, \code{\link{clspec}}, \code{\link{dlspec}}, \code{\link{plspec}}, \code{\link{rlspec}}.} \examples{ data(co2) co2.detrend <- lm(co2~c(1:length(co2)))$residuals fit <- lspec(co2.detrend) plot(fit) } \keyword{ts} \keyword{smooth} polspline/man/plot.polyclass.Rd0000644000176200001440000000632514516535020016316 0ustar liggesusers\name{plot.polyclass} \alias{plot.polyclass} \title{Polyclass: polychotomous regression and multiple classification} \description{Probability or classification plots for a \code{\link{polyclass}} model. } \usage{\method{plot}{polyclass}(x, cov, which, lims, what, data, n, xlab="", ylab="", zlab="", ...) } \arguments{ \item{x}{\code{polyclass} object, typically the result of \code{\link{polyclass}}. } \item{cov}{ a vector of length \code{fit\$ncov}, indicating for which combination of covariates the plot should be made. Can never be omitted. Should always have length \code{fit\$ncov}, even if some values are irrelevant. } \item{which}{ for which covariates should the plot be made. Number or a character string defining the name, if the same names were used with the call to \code{\link{polyclass}}. Which should have length one if \code{what} is 6 or larger and length two if \code{what} is 5 or smaller. } \item{lims}{plotting limits. If omitted, the plot is made over the same range of the covariate as in the original data. Otherwise a vector of length two of the form \code{c(min, max)} if what is 6 or larger and a vector of length four of the form \code{c(xmin, xmax, ymin ,ymax)} if \code{what} is 5 or smaller. } \item{what}{ an integer between 1 and 8, defining the type of plot to be made. \enumerate{ \item Plots the probability of one class as a contour plot of two variables. \item Plots the probability of one class as a perspective plot of two variables. \item Plots the probability of one class as an image plot of two variables. \item Classifies the area as a contour plot of two variables. \item Classifies the area as an image plot of two variables. \item Classifies the line as a plot of one variable. \item Plots the probabilities of all classes as a function of one variable. \item Plots the probability of one class as a function of one variable. } } \item{data}{Class for which the plot is made. Should be provided if \code{what} is 1, 2, 3 or 8. } \item{n}{ the number of equally spaced points at which to plot the fit. The default is 250 if \code{what} is 6 or larger or 50 (which results in 2500 plotting points) if \code{what} is 5 or smaller. } \item{xlab,ylab,zlab}{axis plotting labels.} \item{...}{ all other options are passed on. } } \references{Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{polyclass}}, \code{\link{summary.polyclass}}, \code{\link{beta.polyclass}}, \code{\link{cpolyclass}}, \code{\link{ppolyclass}}, \code{\link{rpolyclass}}.} \examples{ data(iris) fit.iris <- polyclass(iris[,5], iris[,1:4]) plot(fit.iris, iris[64,1:4], which=c(3,4), data=2, what=1) plot(fit.iris,iris[64,1:4], which=c(3,4), what=5) plot(fit.iris,iris[64,1:4], which=4, what=7) } \keyword{smooth} \keyword{nonlinear} polspline/man/cpolyclass.Rd0000644000176200001440000000452014516535017015505 0ustar liggesusers\name{cpolyclass} \alias{cpolyclass} \alias{ppolyclass} \alias{rpolyclass} \title{Polyclass: polychotomous regression and multiple classification} \description{ Classify new cases (\code{cpolyclass}), compute class probabilities for new cases (\code{ppolyclass}), and generate random multinomials for new cases (\code{rpolyclass}) for a \code{\link{polyclass}} model.} \usage{cpolyclass(cov, fit) ppolyclass(data, cov, fit) rpolyclass(n, cov, fit) } \arguments{ \item{cov}{ covariates. Should be a matrix with \code{fit\$ncov} columns. For \code{rpolyclass} \code{cov} should either have one row, in which case all random numbers are based on the same covariates, or \code{n} rows in which case each random number has its own covariates. } \item{fit}{ \code{polyclass} object, typically the result of \code{\link{polyclass}}. } \item{data}{ there are several possibilities. If data is a vector with as many elements as cov has rows, each element of data corresponds to a row of cov; if only one value is given, the probability of being in that class is computed for all sets of covariates. If data is omitted, all class probabilities are provided. } \item{n}{ number of pseudo random numbers to be generated. } } \value{ Most likely classes (\code{cpolyclass}), probabilities (\code{cpolyclass}), or random classes according to the estimated probabilities (\code{rpolyclass}). } \references{ Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{polyclass}}, \code{\link{plot.polyclass}}, \code{\link{summary.polyclass}}, \code{\link{beta.polyclass}}.} \examples{ data(iris) fit.iris <- polyclass(iris[,5], iris[,1:4]) class.iris <- cpolyclass(iris[,1:4], fit.iris) table(class.iris, iris[,5]) prob.setosa <- ppolyclass(1, iris[,1:4], fit.iris) prob.correct <- ppolyclass(iris[,5], iris[,1:4], fit.iris) rpolyclass(100, iris[64,1:4], fit.iris) } \keyword{smooth} \keyword{nonlinear} polspline/man/clspec.Rd0000644000176200001440000000552014516535020014575 0ustar liggesusers\name{clspec} \alias{clspec} \alias{dlspec} \alias{plspec} \alias{rlspec} \title{Lspec: logspline estimation of a spectral distribution} \description{Autocorrelations, autocovariances (\code{clspec}), spectral densities and line spectrum (\code{dlspec}), spectral distributions (\code{plspec}) or a random time series(\code{rlspec}) from a model fitted with \code{\link{lspec}}.} \usage{clspec(lag, fit, cov = TRUE, mm) dlspec(freq, fit) plspec(freq, fit, mm) rlspec(n, fit, mean = 0, cosmodel = FALSE, mm)} \arguments{ \item{lag}{ vector of integer-valued lags for which the autocorrelations or autocorrelations are to be computed. } \item{fit}{ \code{lspec} object, typically the result of \code{\link{lspec}}.} \item{cov}{ compute autocovariances (\code{TRUE}) or autocorrelations (\code{FALSE}). } \item{mm}{ number of points used in integration and the fft. Default is the smallest power of two larger than \code{max(fit\$sample, max(lag),1024)} for \code{clspec} and \code{plspec} or the smallest power of two larger than \code{max(fit\$sample, n, max(lag), 1024)} for (\code{rlspec}). } \item{freq}{ vector of frequencies. For \code{plspec} frequencies should be between \eqn{-\pi}{-pi} and \eqn{\pi}{pi}. } \item{n}{ length of the random time series to be generated. } \item{mean}{ mean level of the time series to be generated. } \item{cosmodel}{ indicate that the data should be generated from a model with constant harmonic terms rather than a true Gaussian time series. } } \value{Autocovariances or autocorrelations (\code{clspec}); values of the spectral distribution at the requested frequencies. (\code{plspec}); random time series of length \code{n} (\code{rlspec}); or a list with three components (\code{dlspec}): \item{d}{the spectral density evaluated at the vector of frequencies,} \item{modfreq}{modified frequencies of the form \eqn{\frac{2\pi j}{T}}{(2pi*j/T)} that are close to the frequencies that were requested,} \item{m}{mass of the line spectrum at the modified frequencies.} } \references{ Charles Kooperberg, Charles J. Stone, and Young K. Truong (1995). Logspline Estimation of a Possibly Mixed Spectral Distribution. \emph{Journal of Time Series Analysis}, \bold{16}, 359-388. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{\code{\link{lspec}}, \code{\link{plot.lspec}}, \code{\link{summary.lspec}}.} \examples{ data(co2) co2.detrend <- lm(co2~c(1:length(co2)))$residuals fit <- lspec(co2.detrend) clspec(0:12,fit) plspec((0:314)/100, fit) dlspec((0:314)/100, fit) rlspec(length(co2),fit) } \keyword{ts} \keyword{smooth} polspline/man/plot.logspline.Rd0000644000176200001440000000430514516535020016275 0ustar liggesusers\name{plot.logspline} \alias{plot.logspline} \title{Logspline Density Estimation } \description{Plots a \code{logspline} density, distribution function, hazard function or survival function from a logspline density that was fitted using the 1997 knot addition and deletion algorithm (\code{\link{logspline}}). The 1992 algorithm is available using the \code{\link{oldlogspline}} function. } \usage{\method{plot}{logspline}(x, n = 100, what = "d", add = FALSE, xlim, xlab = "", ylab = "", type = "l", ...) } \arguments{ \item{x}{\code{logspline} object, typically the result of \code{\link{logspline}}.} \item{n}{the number of equally spaced points at which to plot the density. } \item{what}{what should be plotted: \code{"d"} (density), \code{"p"} (distribution function), \code{"s"} (survival function) or \code{"h"} (hazard function). } \item{add}{should the plot be added to an existing plot.} \item{xlim}{ range of data on which to plot. Default is from the 1th to the 99th percentile of the density, extended by 10\% on each end.} \item{xlab,ylab}{labels plotted on the axes. } \item{type}{type of plot.} \item{...}{other plotting options, as desired} } \details{This function produces a plot of a \code{\link{logspline}} fit at \code{n} equally spaced points roughly covering the support of the density. (Use \code{xlim = c(from, to)} to change the range of these points.) } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{summary.logspline}}, \code{\link{dlogspline}}, \code{\link{plogspline}}, \code{\link{qlogspline}}, \code{\link{rlogspline}}, \code{\link{oldlogspline}}.} \examples{ y <- rnorm(100) fit <- logspline(y) plot(fit) } \keyword{distribution} \keyword{smooth} polspline/man/dhare.Rd0000644000176200001440000000531214516535017014414 0ustar liggesusers\name{dhare} \alias{dhare} \alias{hhare} \alias{phare} \alias{qhare} \alias{rhare} \title{Hare: hazard regression} \description{Density (\code{dhare}), cumulative probability (\code{phare}), hazard rate (\code{hhare}), quantiles (\code{qhare}), and random samples (\code{rhare}) from a \code{\link{hare}} object.} \usage{dhare(q, cov, fit) hhare(q, cov, fit) phare(q, cov, fit) qhare(p, cov, fit) rhare(n, cov, fit) } \arguments{ \item{q}{ vector of quantiles. Missing values (\code{NA}s) are allowed. } \item{p}{ vector of probabilities. Missing values (\code{NA}s) are allowed. } \item{n}{ sample size. If \code{length(n)} is larger than 1, then \code{length(n)} random values are returned. } \item{cov}{ covariates. There are several possibilities. If a vector of length \code{fit\$ncov} is provided, these covariates are used for all elements of \code{p} or \code{q} or for all random numbers. If a matrix of dimension \code{length(p)}, \code{length(q)}, or \code{n} by \code{fit\$ncov} is provided, the rows of \code{cov} are matched with the elements of \code{p} or \code{q} or every row of \code{cov} has its own random number. If a matrix of dimension \code{m} times \code{fit\$ncov} is provided, while \code{length(p) = 1} or \code{length(q) = 1} or \code{n = 1}, the single element of \code{p} or \code{q} is used \code{m} times, or \code{m} random numbers with different sets of covariates are generated. } \item{fit}{ \code{hare} object, typically obtained from \code{\link{hare}}. } } \value{Densities (\code{dhare}), hazard rates (\code{hhare}), probabilities (\code{phare}), quantiles (\code{qhare}), or a random sample (\code{rhare}) from a \code{\link{hare}} object.} \details{ Elements of \code{q} or \code{p} that are missing will cause the corresponding elements of the result to be missing. } \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{\code{\link{hare}}, \code{\link{plot.hare}}, \code{\link{summary.hare}}.} \examples{ fit <- hare(testhare[,1], testhare[,2], testhare[,3:8]) dhare(0:10, testhare[117,3:8], fit) hhare(0:10, testhare[1:11,3:8], fit) phare(10, testhare[1:25,3:8], fit) qhare((1:19)/20, testhare[117,3:8], fit) rhare(10, testhare[117,3:8], fit) } \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/summary.polymars.Rd0000644000176200001440000000544314516535020016672 0ustar liggesusers\name{summary.polymars} \alias{summary.polymars} \alias{print.polymars} \title{Polymars: multivariate adaptive polynomial spline regression} \description{ Gives details of a \code{polymars} object.} \usage{\method{summary}{polymars}(object, ...) \method{print}{polymars}(x, ...) } \arguments{ \item{object,x}{ object of the class \code{polymars}, typically the result of \code{\link{polymars}}.} \item{...}{other arguments are ignored.} } \details{ These two functions provide identical printed information. about the fitting steps and the model selected. The first data frame contains a row for each step of the fitting procedure. In the columns are: a 1 for an addition step or a 0 for a deletion step, the size of the model at each step, residual sums of squares (RSS) and the generalized cross validation value (GCV), testset residual sums of squares or testset misclassification, whatever was used for the model selection. The second data frame, model, contains a row for each basis function of the model. Each row corresponds to one basis function (with two possible components). The pred1 column contains the indices of the first predictor of the basis function. Column knot1 is a possible knot in this predictor. If this column is NA, the first component is linear. If any of the basis functions of the model is categorical then there will be a level1 column. Column pred2 is the possible second predictor involved (if it is NA the basis function only depends on one predictor). Column knot2 contains the possible knot for the predictor pred2, and it is NA when this component is linear. This is a similar format to the startmodel argument together with an additional first row corresponding to the intercept but the startmodel doesn't use a separate column to specify levels of a categorical variable . If any predictor in pred2 is categorical then there will be a level2 column. The column "coefs" (more than one column in the case of multiple response regression) contains the coefficients. } \references{ Charles Kooperberg, Smarajit Bose, and Charles J. Stone (1997). Polychotomous regression. \emph{Journal of the American Statistical Association}, \bold{92}, 117--127. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Martin O'Connor.} \seealso{ \code{\link{polymars}}, \code{\link{design.polymars}}, \code{\link{persp.polymars}}, \code{\link{plot.polymars}}, \code{\link{predict.polymars}}.} \examples{ data(state) state.pm <- polymars(state.region, state.x77, knots = 15, classify = TRUE) summary(state.pm) } \keyword{smooth} \keyword{nonlinear} polspline/man/plot.heft.Rd0000644000176200001440000000450014516535020015224 0ustar liggesusers\name{plot.heft} \alias{plot.heft} \title{Heft: hazard estimation with flexible tails} \description{Plots a density, distribution function, hazard function or survival function for a \code{heft} object.} \usage{\method{plot}{heft}(x, n = 100, what = "d", add = FALSE, xlim, xlab, ylab, type, ...) } \arguments{ \item{x}{\code{heft} object, typically the result of \code{\link{heft}}. } \item{n}{the number of equally spaced points at which to plot the function. } \item{what}{ what should be plotted: \code{"d"} (density), \code{"p"} (distribution function), \code{"s"} (survival function) or \code{"h"} (hazard function). } \item{add}{should the plot be added to an existing plot? } \item{xlim}{plotting limits; default is from the maximum of 0 and 10\% before the 1st percentile to the minimmum of 10\% further than the 99th percentile and the largest observation.} \item{xlab,ylab}{labels for the axes. The default is no labels.} \item{type}{plotting type. The default is lines.} \item{...}{all other plotting options are passed on. } } \details{This function produces a plot of a \code{\link{heft}} fit at \code{n} equally spaced points roughly covering the support of the density. (Use \code{xlim=c(from,to)} to change the range of these points.) } \references{Charles Kooperberg, Charles J. Stone and Young K. Truong (1995). Hazard regression. \emph{Journal of the American Statistical Association}, \bold{90}, 78-94. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{heft}}, \code{\link{summary.heft}}, \code{\link{dheft}}, \code{\link{hheft}}, \code{\link{pheft}}, \code{\link{qheft}}, \code{\link{rheft}}.} \examples{ fit1 <- heft(testhare[,1], testhare[,2]) plot(fit1, what = "h") # modify tail behavior fit2 <- heft(testhare[,1], testhare[,2], leftlog = FALSE, rightlog = FALSE, leftlin = TRUE) plot(fit2, what = "h", add = TRUE,lty = 2) fit3 <- heft(testhare[,1], testhare[,2], penalty = 0) # select largest model plot(fit3, what = "h", add = TRUE,lty = 3) } \keyword{distribution} \keyword{smooth} \keyword{survival} polspline/man/logspline.Rd0000644000176200001440000001457114516535020015326 0ustar liggesusers\name{logspline} \alias{logspline} \title{ Logspline Density Estimation } \description{Fits a \code{logspline} density using splines to approximate the log-density using the 1997 knot addition and deletion algorithm (\code{\link{logspline}}). The 1992 algorithm is available using the \code{\link{oldlogspline}} function. } \usage{logspline(x, lbound, ubound, maxknots = 0, knots, nknots = 0, penalty, silent = TRUE, mind = -1, error.action = 2) } \arguments{ \item{x}{ data vector. The data needs to be uncensored. \code{\link{oldlogspline}} can deal with right- left- and interval-censored data. } \item{lbound,ubound}{ lower/upper bound for the support of the density. For example, if there is a priori knowledge that the density equals zero to the left of 0, and has a discontinuity at 0, the user could specify \code{lbound = 0}. However, if the density is essentially zero near 0, one does not need to specify \code{lbound}. } \item{maxknots}{ the maximum number of knots. The routine stops adding knots when this number of knots is reached. The method has an automatic rule for selecting maxknots if this parameter is not specified. } \item{knots}{ ordered vector of values (that should cover the complete range of the observations), which forces the method to start with these knots. Overrules knots. If \code{knots} is not specified, a default knot-placement rule is employed. } \item{nknots}{ forces the method to start with \code{nknots} knots. The method has an automatic rule for selecting \code{nknots} if this parameter is not specified. } \item{penalty}{ the parameter to be used in the AIC criterion. The method chooses the number of knots that minimizes \code{-2 * loglikelihood + penalty * (number of knots - 1)}. The default is to use a penalty parameter of \code{penalty = log(samplesize)} as in BIC. The effect of this parameter is summarized in \code{\link{summary.logspline}}. } \item{silent}{ should diagnostic output be printed? } \item{mind}{ minimum distance, in order statistics, between knots. } \item{error.action}{how should \code{logspline} deal with non-convergence problems? Very-very rarely in some extreme situations \code{logspline} has convergence problems. The only two situations that I am aware of are when there is effectively a sharp bound, but this bound was not specified, or when the data is severly rounded. \code{logspline} can deal with this in three ways. If \code{error.action} is 2, the same data is rerun with the slightly more stable, but less flexible \code{oldlogspline}. The object is translated in a \code{logspline} object using \code{oldlogspline.to.logspline}, so this is almost invisible to the user. It is particularly useful when you run simulation studies, as he code can seemlessly continue. Only the \code{lbound} and \code{ubound} options are passed on to \code{oldlogspline}, other options revert to the default. If \code{error.action} is 1, a warning is printed, and \code{logspline} returns nothing (but does not crash). This is useful if you run a simulation, but do not like to revert to \code{oldlogspline}. If \code{error.action} is 0, the code crashes using the \code{stop} function.} } \value{Object of the class \code{logspline}, that is intended as input for \code{\link{plot.logspline}} (summary plots), \code{\link{summary.logspline}} (fitting summary), \code{\link{dlogspline}} (densities), \code{\link{plogspline}} (probabilities), \code{\link{qlogspline}} (quantiles), \code{\link{rlogspline}} (random numbers from the fitted distribution). The object has the following members: \item{call}{the command that was executed.} \item{nknots}{the number of knots in the model that was selected.} \item{coef.pol}{coefficients of the polynomial part of the spline. The first coefficient is the constant term and the second is the linear term.} \item{coef.kts}{coefficients of the knots part of the spline. The \code{k}-th element is the coefficient of \eqn{(x-t(k))^3_+} (where \eqn{x^3_+} means the positive part of the third power of \eqn{x}, and \eqn{t(k)} means knot \code{k}).} \item{knots}{vector of the locations of the knots in the \code{logspline} model.} \item{maxknots}{the largest number of knots minus one considered during fitting (i.e. with \code{maxknots = 6} the maximum number of knots is 5).} \item{penalty}{the penalty that was used. } \item{bound}{ first element: 0 - \code{lbound} was \eqn{-\inf}{-infinity,} 1 it was something else; second element: \code{lbound}, if specified; third element: 0 - \code{ubound} was \eqn{\inf}{infinity}, 1 it was something else; fourth element: \code{ubound}, if specified. } \item{samples}{the sample size.} \item{logl}{matrix with 3 columns. Column one: number of knots; column two: model fitted during addition (1) or deletion (2); column 3: log-likelihood.} \item{range}{range of the input data.} \item{mind}{minimum distance in order statistics between knots required during fitting (the actual minimum distance may be much larger).} } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{plot.logspline}}, \code{\link{summary.logspline}}, \code{\link{dlogspline}}, \code{\link{plogspline}}, \code{\link{qlogspline}}, \cr \code{\link{rlogspline}}, \code{\link{oldlogspline},} \code{\link{oldlogspline.to.logspline}}.} \examples{ y <- rnorm(100) fit <- logspline(y) plot(fit) # # as (4 == length(-2, -1, 0, 1, 2) -1), this forces these initial knots, # and does no knot selection fit <- logspline(y, knots = c(-2, -1, 0, 1, 2), maxknots = 4, penalty = 0) # # the following example give one of the rare examples where logspline # crashes, and this shows the use of error.action = 2. # set.seed(118) zz <- rnorm(300) zz[151:300] <- zz[151:300]+5 zz <- round(zz) fit <- logspline(zz) # # you could rerun this with # fit <- logspline(zz, error.action=0) # or # fit <- logspline(zz, error.action=1) } \keyword{distribution} \keyword{smooth} polspline/man/oldlogspline.to.logspline.Rd0000644000176200001440000000356614516535020020443 0ustar liggesusers\name{oldlogspline.to.logspline} \alias{oldlogspline.to.logspline} \title{Logspline Density Estimation - 1992 to 1997 version } \description{Translates an \code{oldlogspline} object in an \code{logspline} object. This routine is mostly used in \code{logspline}, as it allows the routine to use \code{oldlogspline} for some situations where \code{logspline} crashes. The other use is when you have censored data, and thus have to use \code{oldlogspline} to fit, but wish to use the auxiliary routines from \code{logspline}.} \usage{oldlogspline.to.logspline(obj, data) } \arguments{ \item{obj}{ object of class \code{logspline} } \item{data}{ the original data. Used to compute the \code{range} component of the new object. if \code{data} is not available, the 1/(n+1) and n/(n+1) quantiles of the fitted distribution are used for \code{range}. } } \value{ object of the class \code{logspline}. The \code{call} component of the new object is not useful. The \code{delete} component of the old object is ignored.} \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{oldlogspline}}.} \examples{ x <- rnorm(100) fit.old <- oldlogspline(x) fit.translate <- oldlogspline.to.logspline(fit.old,x) fit.new <- logspline(x) plot(fit.new) plot(fit.old,add=TRUE,col=2) # # should look almost the same, the differences are the # different fitting routines # } \keyword{distribution} \keyword{smooth} polspline/man/dlogspline.Rd0000644000176200001440000000502414516535017015471 0ustar liggesusers\name{dlogspline} \alias{dlogspline} \alias{plogspline} \alias{qlogspline} \alias{rlogspline} \title{Logspline Density Estimation} \description{Density (\code{dlogspline}), cumulative probability (\code{plogspline}), quantiles (\code{qlogspline}), and random samples (\code{rlogspline}) from a logspline density that was fitted using the 1997 knot addition and deletion algorithm (\code{\link{logspline}}). The 1992 algorithm is available using the \code{\link{oldlogspline}} function. } \usage{dlogspline(q, fit, log = FALSE) plogspline(q, fit) qlogspline(p, fit) rlogspline(n, fit) } \arguments{ \item{q}{ vector of quantiles. Missing values (NAs) are allowed. } \item{p}{ vector of probabilities. Missing values (NAs) are allowed. } \item{n}{ sample size. If \code{length(n)} is larger than 1, then \code{length(n)} random values are returned. } \item{fit}{ \code{logspline} object, typically the result of \code{\link{logspline}}. } \item{log}{ should dlogspline return densities (TRUE) or log-densities (FALSE) } } \value{Densities (\code{dlogspline}), probabilities (\code{plogspline}), quantiles (\code{qlogspline}), or a random sample (\code{rlogspline}) from a \code{logspline} density that was fitted using knot addition and deletion. } \details{ Elements of \code{q} or \code{p} that are missing will cause the corresponding elements of the result to be missing. } \references{Charles Kooperberg and Charles J. Stone. Logspline density estimation for censored data (1992). \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 301--328. Charles J. Stone, Mark Hansen, Charles Kooperberg, and Young K. Truong. The use of polynomial splines and their tensor products in extended linear modeling (with discussion) (1997). \emph{Annals of Statistics}, \bold{25}, 1371--1470.} \author{ Charles Kooperberg \email{clk@fredhutch.org}.} \seealso{ \code{\link{logspline}}, \code{\link{plot.logspline}}, \code{\link{summary.logspline}}, \code{\link{oldlogspline}}.} \examples{ x <- rnorm(100) fit <- logspline(x) qq <- qlogspline((1:99)/100, fit) plot(qnorm((1:99)/100), qq) # qq plot of the fitted density pp <- plogspline((-250:250)/100, fit) plot((-250:250)/100, pp, type = "l") lines((-250:250)/100,pnorm((-250:250)/100)) # asses the fit of the distribution dd <- dlogspline((-250:250)/100, fit) plot((-250:250)/100, dd, type = "l") lines((-250:250)/100, dnorm((-250:250)/100)) # asses the fit of the density rr <- rlogspline(100, fit) # random sample from fit } \keyword{distribution} \keyword{smooth} polspline/DESCRIPTION0000644000176200001440000000166214516541355014003 0ustar liggesusersPackage: polspline Version: 1.1.24 Date: 2023-10-26 Maintainer: Charles Kooperberg Title: Polynomial Spline Routines Authors@R: c(person("Charles", "Kooperberg", role = c("aut", "cre"), email = "clk@fredhutch.org"), person("Cleve", "Moler", role = "ctb", comment = "LINPACK routines in src"), person("Jack", "Dongarra", role = "ctb", comment = "LINPACK routines in src")) Description: Routines for the polynomial spline fitting routines hazard regression, hazard estimation with flexible tails, logspline, lspec, polyclass, and polymars, by C. Kooperberg and co-authors. Imports: stats, graphics License: GPL (>= 2) NeedsCompilation: yes Author: Charles Kooperberg [aut, cre], Cleve Moler [ctb] (LINPACK routines in src), Jack Dongarra [ctb] (LINPACK routines in src) Repository: CRAN Packaged: 2023-10-26 19:12:32 UTC; clk Date/Publication: 2023-10-26 19:50:05 UTC polspline/src/0000755000176200001440000000000014516535040013051 5ustar liggesuserspolspline/src/heftall.c0000644000176200001440000024157114516535017014652 0ustar liggesusers/* * Copyright (C) 1993--2018 Charles Kooperberg * * 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. * * The text of the GNU General Public License, version 2, is available * as http://www.gnu.org/copyleft or by writing to the Free Software * Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include #include #include "R.h" #define Salloc(n, t) (t *)R_alloc((long)(n), (int)sizeof(t)) #define MAXKNOTS 35 #define HLENGTH MAXKNOTS+5 void F77_NAME(xdsifa)(double[][HLENGTH], int *, int *, int *, int *); void F77_NAME(xdsisl)(double[][HLENGTH], int *, int *, int *, double *); void F77_NAME(xdsidi)(double[][HLENGTH], int *, int *, int *, double *, int *, double *, int *); void F77_NAME(xdgefa)(double[][HLENGTH], int *, int *, int *, int *); void F77_NAME(xdgesl)(double[][HLENGTH], int *, int *, int *, double *, int *); static double hmylog(double x); /* MAXKNOTS is the maximum number of knots in a model HLENGTH is the generic vector length */ static double *wkddd,*wkvec1,*wkvec2,**wkmat1,*wkphi,**wkmat,*wkphi2,*wkxx,*wkcand; static double *wkmasterpt,*wkphi3,*wkse3,*wkphi4,**wkhh,**wkpowdat,**wkpowvec; static double **wkinfo2,*wkscore2,*wkscore3,*wknewbas,*wknewdata,*wkphi7,**wkmat33; static double *wksorted; void sheftx(int *nx); void sheft(int *nx, double *data, int *delta, int *nkstart, double *knots, double *alpha, double *tails, int *iauto, double *logl, double *theta, int *iknots, int *zerror, double *cc, int *nkmax, int *ad, int *mindist); static struct model *makemodel(void); static struct datas *makedata(int i); static double ***dstriparray(int r, int c, int s); static int *ihvector(int l); static double *dhvector(int l); static int **ihmatrix(int r, int c); static double **dhmatrix(int r, int c); static void heft(struct datas *dat, int nkstart, double alpha, struct model *mod1, int iauto, int *zerror, int nkmax, int mind); static void hknotplace(int *nkstart, struct model *mod1); static void getcoef(struct model *m1); static void getcoefx(double **coef2, double ***coef3, double *knots, int **icoef, int nk); static void start(struct model *mod1, struct datas *dat); static void hstart2(double *theta, int nk, double **basdata1, double **basdata2, int nx, double *tails); static void nstart(struct model *mod1, struct datas *dat, int nkstart); static void thetaswap(struct model *mod1); static void intprep(int *nint, int nintx, struct model *mod1, struct datas *dat, int what); static void midblob(int *where, int j, int i, int nint, double *basvec, double *mult, int nx, double *data); static void lgrange(double a, double b, double c, double d, double n, double u, double v, double *mult, int j); static int hopplus(double *xx, double *data, int i, int j); static void basis(double *x, int nx, double *knots, int nk, double **basmat, double cc, int **icoef, double ***coef3); static void hiter(struct model *mod1, struct datas *dat, int *zerror, int nint, int what); static double summer(struct model *mod1, int what, int nint, struct datas *dat); static double summer2(double *score, double **hessian, int what, int nk, int ndata, int nint, double *theta, double **basdata, double **basint, int *delta, double *mult); static double lambda(int nk, double **basis, double *theta, int which); static int step(struct datas *dat, struct model *mod1, int *itails, double *ldif, int nint, int *zerror, int what); static int step2(int nx, int *delta, int nint, double **basmat, double *mult, double *theta, int nk, double **basdata, double **hessian, int *zerror, double *score, int *itails, double *ldif, int what); static void tossit(struct model *mod1, struct model *modmin, double alpha, int *zerror); static void hremoveknot(struct model *mod1, int *zerror); static void hetse(struct model *mod1, struct model *modmin, double alpha); static void getse2(struct model *mod1); static int add(struct model *mod1, struct datas *dat, int nint, int *zerror, struct model *modmin, int mind); static double hrao(struct model *mod1, struct datas *dat, double cand, int nint, double **powvec, double **powdat, int ipowvec[3], int ipowdat[3]); static void newnew(double *knots, int nk, double cand, double *newbas, double *newdata, int nint, struct datas *dat, double *basvec, double **powdat, double **powvec, int ipowdat[3], int ipowvec[3]); static void thetaform(struct model *mod1, int besti); static int hindyl(int u, int l, double *x); static int hindyr(int u, int l, double *x); static int hindl(int *ll, int *uu, int mind, double *x, int nx, double knt); static int hindr(int *ll, int *uu, int mind, double *x, int nx, double knt); static int hindx(int *ll, int *uu, int nx); static int hindm(int *ll, int *uu, int mind, double *x, int nx, double k0, double k1); static int hlocation(int what, double *x, int nx, double k); static void dubmodel(struct model *m2, struct model *m1); static void hlusolve(double **a, int n, double *b, int *k); static void hlusolve2(double **a, int n, double *b, int *k); static void hluinverse(double **a, int n); void heftpq(double *knots, double *cc, double *thetak, double *thetal, double *thetap, int *what, double *pp, double *qq, int *nk, int *np); static double xlambda(double *knots, double cc, double *thetak, double *thetal, double *thetap, int nk, double x); static double ilambda(double *knots, double cc, double *thetak, double *thetal, double *thetap, int nk, double z1, double z2, int i); static void allocer(int nd, int i00); static double hmylog(double x); struct model { int nk,*iknots,**icoef,nk1,*ad; double *knots,*theta,**coef2,***coef3,aic,*score,**hessian,*logl,tailse[2]; double *basvec,**basmat,*mult,*tails,*yknots,ll; }; /* nk - number of knots in a model iknots - which of the potential knots in yknots are a member of knots (1=yes, 0=no) icoef - does basisfunction i exist in interval j (related to coef2/coef3) nk1 - largest number of knots fitted ad - vector of 0/1/2 which indicate whether the best model of the corresponding dimension was not fit (2), fit during addition (0) or deletion (1) knots - the knots theta - theta-hat coef2 - representation of the basis into truncated polynomial representation coef3 - alternative representation of the basis into truncated polynomials aic - aikaike criterion of this model score - score function hessian- hessian logl - vector: for those elements of ad that are 0 or 1 the loglikelihood of the corrsponding model tailse - standard errors of the log terms basvec - used for the numerical integration basmat - used for the numerical integration mult - used for the numerical integration tails - vector indicating the status of the tail basisfunctions yknots - all knots ever used during the analysis, knots is a subset of yknots ll */ struct datas { int nd,*delta; double *data,cc,**basdata1,**basdata2; }; /* nd - length of the data delta - vector with delta values data - sorted vector of observations cc - c=number basdata1 - used for numerical integrations basdata2 - used for numerical integrations */ /******************************************************************************/ /* this routine looks ugly - and is ugly. It only relates the S-variables to the C-variables - almost all should be self explanatory */ void sheftx(int *nx) { *nx=HLENGTH; } void sheft(int *nx, double *data, int *delta, int *nkstart, double *knots, double *alpha, double *tails, int *iauto, double *logl, double *theta, int *iknots, int *zerror, double *cc, int *nkmax, int *ad, int *mindist) { int i; struct model *mod1; struct datas *dat; /* if nx<1 we are only interested in the setting of HLENGTH */ if(*nx<1){ *nx=HLENGTH; return; } /* in */ dat=makedata(*nx); (*dat).data=data; (*dat).delta=delta; (*dat).cc=*cc; mod1=makemodel(); for(i=0;i=0;i--)(*d1).delta[i]=1; return d1; } /******************************************************************************/ static double ***dstriparray(int r,int c,int s) { int i,j,k; double ***m; m=(double ***) Salloc(r+1,double**); for(i=0;i<=r;i++) { m[i]=(double **)Salloc(c+1,double*); for(j=0;j<=c;j++){ m[i][j]=(double *)Salloc(s+1,double); for(k=0;k<=s;k++)m[i][j][k]=0.; } } return m; } /******************************************************************************/ static int *ihvector(int l) /* allocate an int vector with subscript range v[0...l] */ { int i,*v; v=(int *)Salloc(l+1,int); for(i=0;i<=l;i++)v[i]=0; return v; } /******************************************************************************/ static double *dhvector(int l) /* allocate a double vector with subscript range v[0...l] */ { double *v; int i; v=(double *)Salloc(l+1,double); for(i=0;i<=l;i++)v[i]=0.; return v; } /******************************************************************************/ static int **ihmatrix(int r,int c) /* allocate an int matrix with subscript range m[0..r][0..c] */ { int i,j,**m; m=(int **) Salloc(r+1,int*); for(i=0;i<=r;i++){ m[i]=(int *) Salloc(c+1,int); for(j=0;j<=c;j++)m[i][j]=0; } return m; } /******************************************************************************/ static double **dhmatrix(int r,int c) /* allocate a double matrix with subscript range m[0..r][0..c] */ { int i,j; double **m; m=(double **) Salloc(r+1,double*); for(i=0;i<=r;i++){ m[i]=(double *) Salloc(c+1,double); for(j=0;j<=c;j++)m[i][j]=0.; } return m; } /******************************************************************************/ /* this is the main loop */ static void heft(struct datas *dat, int nkstart, double alpha, struct model *mod1, int iauto, int *zerror, int nkmax, int mind) /* dat - the data nkstart- starting number of knots alpha - penalty parameter (bic) mod1 - the working model iauto - 0 - fully automatic knots 2 - user chooses knots zerror - error conditions nkmax - maximum number of knots mind - minimum distance between knots */ { int i00; struct model *modmin,*modold,*makemodel(void); int nint1=20,nint2=50,nint,nintx1=2,nintx2=6,nintx=0,i,j,addi=0,nkmax2,ndd; double r,newk,lold[HLENGTH],*ddd; /* modmin - model with minimum aic modold - old model nkmax2 - copy of nkmax on entrance nint - number of integration points active nint1 - number of integration points low precision nint2 - number of integration points low precision nintx - number of times more points before first knot and in last interval nintx1,nintx2 - to nintx as nint2 and nint1 are to nint i,j - counter addi - are we adding (0=no, 1=yes, 2=just gave up) r - utility newk - knot to be added lold - old loglikelihoods - in case we don't want to add anymore */ /* initialize */ for(i=0;i 0){ /* place the knots */ hknotplace(&nkstart,mod1); if(nkstart< -900)return; if(nkmax==nkstart)addi=0; /* positioned */ else addi=1; } /* addition and deletion compute the maximum number of knots */ if(nkmax==0){ r = 5.*pow((double)((*dat).nd),0.2); if(r>29.9)r=29.9; if((*dat).nd<=60)r=(*dat).nd/5.; if(r<1.5)r=1.5; nkmax=ceil(r); } /* place knots */ if(iauto==0){ r=(.25)*ndd-0.25; i=floor(r); r=r-i; (*mod1).knots[0]=(1-r)*ddd[i]+r*ddd[i+1]; /* if we are constant in the left tail, we start with 2 knots */ if((*mod1).tails[4]<0.5){ (*mod1).nk = 2; nkstart=2; r=(.75)*ndd-0.75; i=floor(r); r=r-i; (*mod1).knots[1]=(1-r)*ddd[i]+r*ddd[i+1]; if((*mod1).knots[1]==(*mod1).knots[0]){ i=hlocation(1,ddd,ndd,(*mod1).knots[0]); if(i==ndd-1){ (void)Rprintf("too few distinct data: 1st quart=max\n"); nkstart=-998; return; } (*mod1).knots[1]=ddd[i+1]; } } else{ /* if we are linear in the left tail, we start with 3 knots */ r=(.5)*ndd-0.5; i=floor(r); r=r-i; (*mod1).knots[1]=(1-r)*ddd[i]+r*ddd[i+1]; r=(.75)*ndd-0.75; i=floor(r); r=r-i; (*mod1).knots[2]=(1-r)*ddd[i]+r*ddd[i+1]; (*mod1).nk = 3; nkstart=3; if((*mod1).knots[1]==(*mod1).knots[0]){ i=hlocation(0,ddd,ndd,(*mod1).knots[0]); if(i==0){ (void)Rprintf("too few distinct data: median=min data\n"); nkstart=-998; return; } (*mod1).knots[0]=ddd[i-1]; } if((*mod1).knots[1]==(*mod1).knots[2]){ i=hlocation(1,ddd,ndd,(*mod1).knots[1]); if(i==ndd-1){ (void)Rprintf("too few distinct data: median=max data\n"); nkstart=-998; return; } (*mod1).knots[2]=ddd[i+1]; } } addi=1; } if(zerror[6]==37){ (void)Rprintf("starting knots at "); for(i=0;i0 there were problems */ if(zerror[1]>0 && (*mod1).nk<6){ (void)Rprintf("sorry - can't recover with so few knots (%d)\n",(*mod1).nk); /* if(zerror[0]==0) exit(1); else return; */ return; } /* if zerror[1]=2 we might be helped by starting to remove */ if(zerror[1]==2){ nkstart=(*mod1).nk-1; dubmodel(mod1,modold); (void)Rprintf("trying to start removing knots.....\n"); addi=2; } /* record the old fit, justin case */ dubmodel(modold,mod1); /* no reason to keep on adding */ lold[(*mod1).nk]=(*mod1).ll; if(nkmax!=nkstart && nkmax2==0){ for(i=2;i<(*mod1).nk-2;i++){ if((*mod1).ll-lold[i]<((*mod1).nk-i-2.)/2.+0.5){ nkmax=(*mod1).nk; addi=2; } } } /* have we added enough? */ if(addi==1 && nkmax==(*mod1).nk) addi=2; hetse(mod1,modmin,alpha); /* post-processing addition */ if(addi==1){ newk=add(mod1,dat,nint,zerror,modmin,mind); /* oops, cannot add anymore */ if(newk<0) { addi=2; nkmax=(*mod1).nk; } } }while(addi==1); } /* record where we start from */ for(i=0;i0){ zerror[1]=0; nstart(mod1,dat,(*mod1).nk); hiter(mod1,dat,zerror,nint,1); if(zerror[1]>0){ (void)Rprintf("sorry - cannot recover during removal fase..\n"); /* if(zerror[0]==0) exit(1); else return; */ } } /* post-processing - removal */ tossit(mod1,modmin,alpha,zerror); }while(((*mod1).nk>1 && (*mod1).tails[4]<0.5 )|| (*mod1).nk>2); /* send the correct model back */ dubmodel(mod1,modmin); for(i=0;i0)for(i=1;i<*nkstart;i++){ if((*mod1).knots[i]>(*mod1).knots[i1]){ i1++; (*mod1).knots[i1]=(*mod1).knots[i]; } else{ if((*mod1).knots[i]<(*mod1).knots[i1]){ (void)Rprintf("** knots not in sequence **\n"); jj = -999; } if((*mod1).knots[i]==(*mod1).knots[i1]){ (void)Rprintf("*** warning, knot %d is double: removed ***\n",i); } } } /* how many knots are left */ if(jj>0){ *nkstart = i1+1; /* copy the knots in yknots */ for(i=0;i<*nkstart;i++)(*mod1).yknots[i]=(*mod1).knots[i]; r=1.; for(i=1;i<*nkstart;i++){ if((*mod1).knots[i]/(*mod1).knots[i-1]>r){ r=(*mod1).knots[i]/(*mod1).knots[i-1]; } } if(r>4000.){ (void)Rprintf( "*** warning: max knot-ratio is %e - answers inaccurate ***\n",r); } (*mod1).nk=*nkstart; } else{ *nkstart= -999; } } /******************************************************************************/ /* This function computes the coefficients of the basis functions from the knots the basis funcftions are G2-G(p-1), where (p=K+1). G2=B1. Basis functions B(2)-B(nk-3) are multiples of B-splines. Further the coefficients are choosen such that the quadratic and cubic terms in both tails are 0; this leads to differnt basis functions for B(1), B(nk-2) and B(nk-1). B(1) is linear left of the first knot. B(nk-2) is constant to the right of the last knot and B(nk-1) is constant 1 everywhere */ static void getcoef(struct model *m1) { getcoefx((*m1).coef2,(*m1).coef3,(*m1).knots,(*m1).icoef,(*m1).nk); } static void getcoefx(double **coef2, double ***coef3, double *knots, int **icoef, int nk) /* coef2 - first index: basis function number-1, second index: 0:1, 1:x, 2:(x-t1)+^3, 3:(x-t2)+^3, 4:(x-t3)+^3,..... coef3 - between knot(i) and knot(i+1) the coef of x^power of basisfct(j) first index: basis function number-1 (j-1) second index: power of x third index: interval (i) icoef - does basisfunction i exist in interval j? knots - knots nk - number of knots */ { int i,j,k; double z0,z1; /* i j k - counter z0,z1 - value of constants of two succesive basisfunctions */ /* Initializations */ for(i=0; i 2){ coef2[0][2] = 1.; coef2[0][3] = (knots[0]-knots[2]) / (knots[2]-knots[1]); coef2[0][4] = (knots[1]-knots[0]) / (knots[2]-knots[1]); coef2[0][1] = -3. * (pow(knots[0],2.) + coef2[0][3] * pow(knots[1],2.) + coef2[0][4] * pow(knots[2],2.)); coef2[0][0] = - knots[nk-1] * coef2[0][1] - coef2[0][2] * pow((knots[nk-1]-knots[0]),3.) - coef2[0][3] * pow((knots[nk-1]-knots[1]),3.) - coef2[0][4] * pow((knots[nk-1]-knots[2]),3.); coef2[0][5] = 0.; } coef2[nk-2][0] = 1.; /* we first create basis functions that are 0 before knot[i] and constant after knot [i+3] */ if(nk > 3){ for(i=1;i 4){ for(i=1;i2){ for(k=0; k<3; k++){ coef3[0][1][k]=coef2[0][1]; coef3[0][0][k]=coef2[0][0]; icoef[0][k]=1; } /* The rest is a bit tricking with the correct indices */ for(i=0;i0 && j0) theta[0]=tails[1]; if(tails[2]>0) theta[nk]=tails[3]; /* first allocate some storage space */ mat1=wkmat1; vec1=wkvec1; vec2=wkvec2; /* compute the fitted values = Y */ for(i=0;i0.5){ for(i=1;i0) (*mod1).theta[0]=(*mod1).tails[1]; if((*mod1).tails[2]>0) (*mod1).theta[nk]=(*mod1).tails[3]; r=0; j=0; for(i=0;i<(*dat).nd;i++){ r+=(*dat).data[i]; j+=(*dat).delta[i]; } r = r/(double)j; (*mod1).theta[nk-1]= -hmylog(r); return; } /* things are on a power basis and should get to the real basis */ phi=wkphi; mat=wkmat; for(j=0; j=(*dat).data[nx-3]){ nkplus--; } else k=2; } else k=2; i++; } else{ masterpt[nkplus]=(*mod1).knots[j]; nkplus++; if(k==2 && masterpt[nkplus-1]-masterpt[nkplus-2]0 || i>0 || (*mod1).knots[0]<(*dat).data[2] || i<1){ nkplus--; masterpt[nkplus-1]=masterpt[nkplus]; } } j++; k=1; } }while(i2){ for(j=1;j=zmax || *where >= nx){ lgrange(x1,x2,x3,x4,(double)(nx-*where),zmin,zmax,mult,i4); lgrange(x1,x2,x4,x3,(double)(nx-*where),zmin,zmax,mult,i3); lgrange(x1,x3,x4,x2,(double)(nx-*where),zmin,zmax,mult,i2); lgrange(x2,x3,x4,x1,(double)(nx-*where),zmin,zmax,mult,i1); zmin=zmax+1.; if(data[*where]==zmax) (*where)++; } else{ lgrange(x1,x2,x3,x4,(double)(nx-*where),zmin,data[*where],mult,i4); lgrange(x1,x2,x4,x3,(double)(nx-*where),zmin,data[*where],mult,i3); lgrange(x1,x3,x4,x2,(double)(nx-*where),zmin,data[*where],mult,i2); lgrange(x2,x3,x4,x1,(double)(nx-*where),zmin,data[*where],mult,i1); zmin=data[*where]; (*where)++; } }while(zminxx[i-1])return i+1; return i; } /******************************************************************************/ static void basis(double *x, int nx, double *knots, int nk, double **basmat, double cc, int **icoef, double ***coef3) /* x - sorted vector of data points, in which the basisfunctions are to be computed nx - length of x knots - vector of knots nk - length of knots basmat - to be the basisfunctions in each point cc - the cc number for the log-terms. icoef - does basis function [i] exist in interval t(j-1)-t(j), it is in icoef[i][j]; coef3 - coefficient of x^j for basis function [i] in interval t(k-1)-t(k).*/ { int i,j,where=0; /* where indicates in between which two knots a point is */ /* inialize */ for(i=0;i0) basmat[i][0]=hmylog(x[i]/(x[i]+cc)); basmat[i][nk]=hmylog(x[i]+cc); /* find where the knot is */ if(x[i]>knots[where] && whereknots[where] && where0;j--){ if(basmat[i][nk+2]<0.5 && icoef[j-1][where]!=0){ basmat[i][nk+2]=j; j=0; } } /* update the other basis functions */ for(j=1;j0.5) itails[0]=1; else itails[0]=0; /* itails[1]: 0 - linear left term included 1 - linear left term not included */ if((*mod1).tails[4]>0.5) itails[1]=1; else itails[1]=0; /* itails[2]: 0 - right term included and operational 1 - right term not included (or user fixed) 2 - right term protection against -1 */ if((*mod1).tails[2]>0.5) itails[2]=1; else{ itails[2]=0; if((*mod1).theta[(*mod1).nk]< -0.999) itails[2]=2; } /* iterations start */ for(ctr=1;ctr<500;ctr++){ /* one step */ status=step(dat,mod1,itails,&ldif,nint,zerror,what); /* problems in the right tail */ if((*mod1).theta[(*mod1).nk]<-1){ if(zerror[0]==0){ warning("*** warning: right tail adjustment ***\n"); } (*mod1).theta[(*mod1).nk]=-1; itails[2]=2; status=4; } /* serious problems */ if(status==1 || status==3 || (status==2 && itails[0]==-1)){ zerror[1]=1; return; } /* problems in the left tail */ if(status==2 && itails[0]==0){ (*mod1).theta[0]=-0.8; itails[0]=2; } /* is there convergence (or pseudo convergence) */ if(status==0 && ldif<0.0000001){ /* we are done */ if(itails[0]<2 && itails[2]<2) ctr+=10000; /* we might be done, we have converged in a subspace */ if(itails[2]==2){ ldif=summer(mod1,2,nint,dat); if((*mod1).score[(*mod1).nk]>0.) itails[2]=0; else ctr+=10000; } /* we have converged in a subspace and take it from there */ if(itails[0]==2) itails[0]=-1; } } /* if ctr<1000 there was no convergence */ if(ctr<1000){ zerror[1]=2; (void)Rprintf("*** zerror: no convergence ***\n"); return; } /* final bookkeeping */ if((*mod1).tails[2]<2.5) ldif=summer(mod1,2,nint,dat); /* adjust for fixed tail thetas */ for(i=0;i<3;i++){ if(itails[i]!=0){ if(i==2) i=(*mod1).nk; for(j=0;j<=(*mod1).nk;j++){ (*mod1).hessian[j][i]=0; (*mod1).hessian[i][j]=0; } (*mod1).score[i]=0.; (*mod1).hessian[i][i]=-1.; } } if(zerror[6]==37 || zerror[0]==0){ (void)Rprintf("logl= %.2f ",ldif); (void)Rprintf("(nk = %d)\n",(*mod1).nk); } (*mod1).ll=ldif; } /******************************************************************************/ /* computes l(), S() and H() */ static double summer(struct model *mod1, int what, int nint, struct datas *dat) { return summer2((*mod1).score,(*mod1).hessian,what,(*mod1).nk,(*dat).nd,nint, (*mod1).theta,(*dat).basdata1,(*mod1).basmat,(*dat).delta,(*mod1).mult); } static double summer2(double *score, double **hessian, int what, int nk, int ndata, int nint, double *theta, double **basdata, double **basint, int *delta, double *mult) /* score - score function hessian - hessian what - 0: just logl, 1: also score, 2: also hessian; nk - number of knots ndata - number of datapoints nint - number of integration points theta - theta (see above) basdata - basisfunctions in datapoints basint - basisfunctions in integration points delta - delta for data points mult - multipliers for p=0/1/2 in integration points */ { double logl=0.,lam,lm0,lm1; /* logl - loglikelihood lam - lambda or exp(lambda) i,j,k- counters */ /* initializations */ int i,j,k; if(what>0){ for(i=0;i<=nk;i++){ score[i]=0.; if(what>1) for(j=0;j<=nk;j++) hessian[i][j]=0.; } } /* the integral part, anything related to basisfunction 1 goes different */ for(i=0;i0){ score[0] += lm0*basint[i][0]; score[nk-1] += lm0*basint[i][nk-1]; score[nk] += lm0*basint[i][nk]; for(j=(int)basint[i][nk+1];j<=(int)basint[i][nk+2] && j>0;j++){ score[j] += lm0*basint[i][j]; } if(what >1){ lm1=lm0*basint[i][nk]; for(k=0;k<=nk;k++) hessian[k][nk] += lm1*basint[i][k]; lm1=lm0*basint[i][nk-1]; for(k=0;k<=nk-1;k++) hessian[k][nk-1] += lm1*basint[i][k]; lm1=lm0*basint[i][0]; hessian[0][0] += lm1*basint[i][0]; for(j=(int)basint[i][nk+1];j<=(int)basint[i][nk+2] && j>0;j++){ lm1=lm0*basint[i][j]; for(k=0;k<=j;k++) hessian[k][j] += lm1*basint[i][k]; } } } } /* symmatrize the hessian */ for(j=0;j0) for(j=0;j<=nk;j++) score[j] += basdata[i][j]; } } return logl; } /******************************************************************************/ /* this routine computes lambda(theta) */ static double lambda(int nk,double **basis,double *theta,int which) /* nk - number of knots theta[k] - theta of B(k), (for k=1....k-1) theta[0] - theta of G(1) theta[nk] - theta of G(p) which - see next line basis - matrix with in position [which][i] basisfunction i in which */ { int k; double r=0; r=theta[0]*basis[which][0]+theta[nk]*basis[which][nk] +theta[nk-1]*basis[which][nk-1]; for(k=(int)basis[which][nk+1];k<=(int)basis[which][nk+2] && k>0;k++){ r += theta[k]*basis[which][k]; } return r; } /******************************************************************************/ /* this routine does one Newton Raphson step */ static int step(struct datas *dat, struct model *mod1, int *itails, double *ldif, int nint, int *zerror, int what) { return step2((*dat).nd,(*dat).delta,nint,(*mod1).basmat,(*mod1).mult, (*mod1).theta,(*mod1).nk,(*dat).basdata1,(*mod1).hessian,zerror, (*mod1).score,itails,ldif,what); } static int step2(int nx, int *delta, int nint, double **basmat, double *mult, double *theta, int nk, double **basdata, double **hessian, int *zerror, double *score, int *itails, double *ldif, int what) /* nx - sample size delta - censoring (0=yes, 1=no) itails - status of the three tail thetas ldif - returns the difference between the likelihoods nint - number of integration points during first part of iteration basmat - basis functions in integration points mult - integration multipliers in integration points theta - theta score - score function nk - present number of knots basdata- basis functions in datapoints hessian- hessian of present solution zerror - zerror conditions */ { double *cand,lnew=0.,r,lold; int i,j; /* i,k - counter lold - old log-likelihood lnew - new log-likelihood cand - candidate for theta r - utility */ /* allocate memmory */ cand=wkcand; /* compute likelihood, score and hessian */ lold=summer2(score,hessian,2,nk,nx,nint,theta,basdata,basmat,delta,mult); /* fix some things if thetas are fixed */ for(i=0;i<3;i++){ if(itails[i]>0){ if(i==2) i=nk; for(j=0;j<=nk;j++){ hessian[j][i]=0; hessian[i][j]=0; } score[i]=0.; hessian[i][i]=1.; } } /* solve the system */ i=1; hlusolve(hessian,nk+1,score,&i); if(i==-1){ if(what==1)(void)Rprintf("*** oops, an unstable system ***\n"); return 1; } /* if the left theta is free, it shouldn't become smaller than -1 */ if(itails[0]<=0){ r= -theta[0]-1.; if(r>-score[0]){ r=1./pow(1.5,ceil(hmylog(-score[0]/r)/hmylog(1.5))); if(zerror[0]==0){ warning("*** warning: step (-1) halving(%e) ***\n",r); } if(r<0.0001 && itails[0]>=0){ if(zerror[0]==0){ if(what==1)(void)Rprintf("*** warning: too much step halving ***\n"); } return 2.; } for(i=0;i<=nk;i++)score[i]=score[i]*r; } } /* step halving to increase loglikelihood */ r=2.; i= -1; do{ r=r/2.; i++; for(j=0;j<=nk;j++) cand[j]=theta[j]-r*score[j]; if(zerror[0]==0 && i>0){ warning("*** warning: step (ll) halving(%e,%e)***\n",lold,lnew); } if(r<0.000000001){ if(what==1)(void)Rprintf("*** warning: too much step halving ***\n"); return 3; } lnew=summer2(score,hessian,0,nk,nx,nint,cand,basdata,basmat,delta,mult); *ldif=lnew-lold; }while(*ldif<-0.00000001 && r>0); /* record the solution */ if(r>0){ if(cand[nk]<-1.02){ r=(-1.02-theta[nk])/(cand[nk]-theta[nk]); for(j=0;j<=nk;j++) theta[j]=r*cand[j]+(1.-r)*theta[j]; } else{ for(j=0;j<=nk;j++) theta[j]=cand[j]; } } return 0; } /******************************************************************************/ /* this routine does the post-processing in the case of knot removal */ static void tossit(struct model *mod1,struct model *modmin,double alpha,int *zerror) /* mod1 - present model modmin - minimum aic model alpha - alpha (AIC) zerror - zerror status */ { /* record things like loglikelihood, check whether we improved */ (*mod1).aic= -2.*(*mod1).ll + alpha * ((*mod1).nk+1); if((*mod1).tails[4]>0.5) (*mod1).aic-=alpha; if((*mod1).ll>(*mod1).logl[(*mod1).nk] || (*modmin).ad[(*mod1).nk]==2){ (*mod1).logl[(*mod1).nk]=(*mod1).ll; (*modmin).logl[(*mod1).nk]=(*mod1).ll; (*modmin).ad[(*mod1).nk]=1; } /* did we improve */ if((*mod1).aic <= (*modmin).aic) dubmodel(modmin,mod1); else if( -2.*(*mod1).ll + alpha > (*modmin).aic) (*mod1).nk=0; /* figure out which knot to remove (and update knots and iknots) */ hremoveknot(mod1,zerror); if((*modmin).nk == (*mod1).nk+1 &&(*modmin).ad[(*mod1).nk]==1){ (*modmin).tailse[0]=(*mod1).tailse[0]; (*modmin).tailse[1]=(*mod1).tailse[1]; } } /******************************************************************************/ /* selects which knot to remove */ static void hremoveknot(struct model *mod1,int *zerror) /* mod1 - model zerror- zerror status */ { double ratmax=0.,*se,*phi; int i,j,k,irmax=1,nk; /* i j k - counters phi - linear combination of thetas se - standard zerrors of phi ratmax - maximum ratio se/phi irmax - index of maximum ratio nk - (*mod1).nk */ /* allocate storage */ se=wkse3; phi=wkphi3; ((*mod1).nk) += -1; nk=(*mod1).nk; /* Take linear combinations of theta such that phi is theta(phi) for the truncated power basis. (Which is not a basis.) */ for(i=0;i<=nk;i++){ phi[i] = 0.; for(j=0;j0.5){ (*mod1).hessian[0][0]=-1.; for(j=1;j0.5 || (*mod1).theta[nk+1]<= -0.999999){ for(j=0;j0.5){ for(j=0;j0.5) (*mod1).tailse[0]=0.; else (*mod1).tailse[0]=sqrt(-(*mod1).hessian[0][0]); if((*mod1).tails[2]>0.5 || (*mod1).theta[nk+1]<= -1.) (*mod1).tailse[1]=0.; else (*mod1).tailse[1]=sqrt(-(*mod1).hessian[nk+1][nk+1]); /* we are done */ if(nk==1 || (nk==2 && (*mod1).tails[4]>0.5)) return; /* in case there is no left-linear term */ if((*mod1).tails[4]>0.5){ for(j=0;j3 || (nk==2 && (*mod1).tails[4]<0.5)){ for(i=0;i phi[i] * ratmax){ ratmax = se[i] / phi[i]; irmax = i; } } } else irmax=1; /* update iknots */ j=0; for(i=0;i0.5) (*mod1).aic-=alpha; (*mod1).logl[(*mod1).nk]=(*mod1).ll; (*modmin).ad[(*mod1).nk]=0; (*modmin).logl[(*mod1).nk]=(*mod1).ll; /* did we improve */ if((*mod1).aic <= (*modmin).aic){ dubmodel(modmin,mod1); /* get the se */ getse2(mod1); (*modmin).tailse[0]=(*mod1).tailse[0]; (*modmin).tailse[1]=(*mod1).tailse[1]; } } /******************************************************************************/ /* finds the SEs */ static void getse2(struct model *mod1) /* mod1 - model zerror- zerror status */ { double *phi,**hh; int i,j,nk; /* i j k - counters phi - linear combination of thetas se - standard zerrors of phi ratmax - maximum ratio se/phi irmax - index of maximum ratio nk - (*mod1).nk */ /* allocate storage */ phi=wkphi4; hh=wkhh; nk=(*mod1).nk-1; for(j=0;j0.5){ hh[0][0]=-1.; for(j=1;j0.5 || (*mod1).theta[nk+1]<= -0.999999){ for(j=0;j0.5){ for(j=0;j0.5) (*mod1).tailse[0]=0.; else (*mod1).tailse[0]=sqrt(-hh[0][0]); if((*mod1).tails[2]>0.5 || (*mod1).theta[nk+1]<= -1.) (*mod1).tailse[1]=0.; else (*mod1).tailse[1]=sqrt(-hh[nk+1][nk+1]); } /******************************************************************************/ /* this routine figures out where to add a knot using the Rao criterion */ static int add(struct model *mod1, struct datas *dat, int nint, int *zerror, struct model *modmin, int mind) /* mod1 - present model dat - data nint - number of integration points mind - minimum distance between knots zerror - zerror status modmin - best model up to now mind - minimum distance between knots */ { int i,j,ipowdat[3],ipowvec[3],besti=-1,ll=0,uu=0,nowloc2,bestloc=-1,nx; int loloc=0,uploc=0,nowloc1=0; double bestrao=-1.,nowrao1,nowrao2,**powdat,**powvec,*sorted; /* bestrao - bestrao statistic up to now nowrao1 - new rao statistic besti - in between which two knots is the new one nowrao2 - another new rao statistic bestloc - location of best rao statistic newloc1 - location of new rao statistic newloc2 - another location of new rao statistic i - counter loloc - smallest possible location uploc - largest possible location ll - potential loloc uu - potential uploc find.. - find various locations j - stopper powvec - piecewise polynomial products, used by hrao powdat - piecewise polynomial products, used by hrao rao - computes a rao-statistic */ /* powvec and powdat are the piecewise polynomial products */ sorted=wksorted; nx=0; for(i=0;i<(*dat).nd;i++){ if((*dat).delta[i]==1){ sorted[nx]=(*dat).data[i]; nx++; } } powvec=wkpowvec; powdat=wkpowdat; if((*mod1).nk!=2){ for(j=0;j<3;j++){ ipowvec[j]=-1; for(i=0;i(*mod1).knots[(*mod1).nk-3+j]){ powvec[i][j]=pow((*mod1).basvec[i]-(*mod1).knots[(*mod1).nk-3+j], (double)3.); } else{ powvec[i][j]=0.; ipowvec[j]=i; } } } for(j=0;j<3;j++){ ipowdat[j]=-1; for(i=0;i<(*dat).nd;i++){ if((*dat).data[i]>(*mod1).knots[(*mod1).nk-3+j]){ powdat[i][j]=pow((*dat).data[i]-(*mod1).knots[(*mod1).nk-3+j], (double)3.); } else{ powdat[i][j]=0.; ipowdat[j]=i; } } } } /* find the interval */ for(i=0;i<=(*mod1).nk;i++){ /* before first knot */ if(i==0 && (*mod1).nk>0) nowloc1=hindl(&ll,&uu,mind,sorted,nx,(*mod1).knots[0]); /* after last knot */ if(i==(*mod1).nk && (*mod1).nk>0) nowloc1=hindr(&ll,&uu,mind, sorted,nx,(*mod1).knots[(*mod1).nk-1]); /* first knot */ if(i==0 && (*mod1).nk==0) nowloc1=hindx(&ll,&uu,nx); /* in between knots */ if(i>0 && i<(*mod1).nk) nowloc1=hindm(&ll,&uu,mind, sorted,nx,(*mod1).knots[i-1],(*mod1).knots[i]); /* possible location */ if(nowloc1>=0){ nowrao1=hrao(mod1,dat,sorted[nowloc1],nint,powvec,powdat,ipowvec, ipowdat); if(nowrao1>bestrao){ loloc=ll; uploc=uu; bestloc=nowloc1; bestrao=nowrao1; besti=i; } } } if(bestloc<0)return -1; /* as long as the locations are different, do interval halving */ do{ if(sorted[uploc]>sorted[loloc]){ nowloc2=hindyr(uploc,bestloc,sorted); /* two search points, the upper one */ if(nowloc2>=0){ nowrao2=hrao(mod1,dat,sorted[nowloc2],nint,powvec,powdat,ipowvec, ipowdat); } else nowrao2=bestrao; /* two search points, the lower one */ nowloc1=hindyl(bestloc,loloc,sorted); if(nowloc1>=0){ nowrao1=hrao(mod1,dat,sorted[nowloc1],nint,powvec,powdat,ipowvec, ipowdat); } else nowrao1=bestrao; /* the middle one is the best, we call it quits */ if(bestrao>=nowrao2 && bestrao>=nowrao1){ loloc=uploc; } else{ /* the lower search point is the best */ if(nowrao1>bestrao){ uploc=bestloc; bestloc=nowloc1; bestrao=nowrao1; } /* the upper search point is the best */ else{ loloc=bestloc; bestloc=nowloc2; bestrao=nowrao2; } } } }while(sorted[uploc]>sorted[loloc]); /* failure */ if(bestloc<0)return bestloc; /* done record the new knot in its correct position */ if(besti==(*mod1).nk) (*mod1).knots[(*mod1).nk]=sorted[bestloc]; else{ for(i=(*mod1).nk;i>besti;i=i-1){ (*mod1).knots[i]=(*mod1).knots[i-1]; (*modmin).iknots[i]=(*modmin).iknots[i-1]; } (*mod1).knots[besti]=sorted[bestloc]; (*modmin).iknots[besti]=0; } ((*mod1).nk)++; thetaform(mod1,besti); if(zerror[6]==37){ (void)Rprintf("knot added at %.2f ",sorted[bestloc]); (void)Rprintf("(rao = %.2f) || ",bestrao); } return bestloc; } /******************************************************************************/ /* these routines compute the rao-score statistic in cand */ static double hrao(struct model *mod1, struct datas *dat, double cand, int nint, double **powvec, double **powdat, int ipowvec[3], int ipowdat[3]) { double **info2,*score2,*score3,*newbas,*newdata,lm0,lam,r; int i,j,nk=(*mod1).nk; /* info2 - larger copy of hessian score2 - larger copy of score score3 - another larger copy of score newbas - new basis function in integration poins newdata - new basis function in data points lam - lambda or exp(lambda) lm0 - multiplier times lam r - value of rao i,j - counter nk - (*mod1).nk newnew - computes newdata and newbas */ /* allocate memmory */ info2=wkinfo2; score2=wkscore2; score3=wkscore3; newbas=wknewbas; newdata=wknewdata; /* copy score and info in score2 and info2 */ score2[nk+1]=0.; info2[nk+1][nk+1]=0.; for(i=0;i<=nk;i++){ score2[i]=(*mod1).score[i]; info2[i][nk+1]=0.; info2[nk+1][i]=0.; for(j=0;j<=nk;j++){ info2[i][j]=(*mod1).hessian[i][j]; } } /* compute newdata and newbas */ newnew((*mod1).knots,nk,cand,newbas,newdata,nint,dat, (*mod1).basvec,powdat,powvec,ipowdat,ipowvec); /* compute the extra row of info and extra element of score - compare mint */ for(i=0;i0;j++){ info2[j][nk+1]+=lm0*(*mod1).basmat[i][j]; } } /* add the delta part to the score function */ for(i=0;i<(*dat).nd;i++){ if((*dat).delta[i]==1) score2[nk+1]+=newdata[i]; } /* left tail peculiarities */ if((*mod1).tails[0]>0.5 || (*mod1).theta[0]<-0.999){ score2[0]=0.; info2[0][0]=-1.; for(i=1;i<=nk+1;i++){ info2[0][i]=0.; info2[i][0]=0.; } } /* more left tail peculiarities */ if((*mod1).tails[4]>0.5){ score2[1]=0.; for(i=0;i<=nk+1;i++){ info2[1][i]=0.; info2[i][1]=0.; } info2[1][1]=-1.; } /* right tail peculiarities */ if((*mod1).tails[2]>0.5 || (*mod1).theta[nk]<-0.999){ score2[nk]=0.; for(i=0;i<=nk+1;i++){ info2[nk][i]=0.; info2[i][nk]=0.; } info2[nk][nk]=-1.; } /* symmaterize and copy in score3 */ for(j=0;j<=nk+1;j++){ info2[nk+1][j]=info2[j][nk+1]; score3[j]=score2[j]; } /* compute rao in 2-steps, solving a system and an inner product */ i=0; hlusolve(info2,nk+2,score2,&i); r=0.; for(i=0;i2){ /* compute the coefficients */ vec[0]=-1.; vec[1]=-cand; vec[2]=-cand*cand; mat[0][0]=1.; mat[0][1]=1.; mat[0][2]=1.; mat[1][0]=knots[nk-3]; mat[1][1]=knots[nk-2]; mat[1][2]=knots[nk-1]; mat[2][0]=knots[nk-3]*knots[nk-3]; mat[2][1]=knots[nk-2]*knots[nk-2]; mat[2][2]=knots[nk-1]*knots[nk-1]; i=0; hlusolve2(mat,(int)3,vec,&i); /* compute in integration points */ for(i=0;icand) newbas[i]=pow((basvec[i]-cand),(double)3.); } for(j=0;j<3;j++){ if(ipowvec[j]cand){ newdata[i]=pow(((*dat).data[i]-cand),(double)3.); } } } for(j=0;j<3;j++){ if(ipowdat[j]<(*dat).nd-1){ for(i=ipowdat[j]+1;i<(*dat).nd;i++){ if((*dat).delta[i]==1) newdata[i]+=vec[j]*powdat[i][j]; } } } } /* if there were only two knots */ if(nk==2){ /* compute coefficients */ vec[0]=(knots[1]-cand)/(knots[0]-knots[1]); vec[1]=(cand-knots[0])/(knots[0]-knots[1]); /* compute in data points */ for(i=0;i<(*dat).nd;i++){ newdata[i]=0.; if((*dat).delta[i]==1){ if((*dat).data[i]besti) (*mod1).theta[i+2]=phi[i+1]; } } /******************************************************************************/ /* finds a new location in an interval (l,b) - that is the lower end might not have been tested yet */ static int hindyl(int u,int l,double *x) { int i; if(x[l]==x[u])return -1; i=(u+l-1)/2; if(x[i]!=x[u])return i; i=(i+l)/2; if(x[i]!=x[u])return i; return l; } /******************************************************************************/ /* finds a new location in an interval (b,u) - that is the upper end might not have been tested yet */ static int hindyr(int u,int l,double *x) { int i; if(x[l]==x[u])return -1; i=(u+l+1)/2; if(x[i]!=x[l])return i; i=(i+u)/2; if(x[i]!=x[l])return i; return u; } /******************************************************************************/ /* Finds a possible location for a knot on the interval (0,knot1) ll - lowest number we can search on in the future uu - highest number we can search on in the future mind minimum distance between knots x - data nx - length of data knt- knot */ static int hindl(int *ll, int *uu, int mind, double *x, int nx, double knt) { /* i - utility hlocation - finds uu */ int i; (*uu)=hlocation(0,x,nx,knt); if((*uu)k)return 0; if(x[nx-1]<=k)return nx-1; for(i=0;ik && x[i]<=k) return i; } } if(x[nx-1]=k)return 0; for(i=1;i=k && x[i-1]knots[i] && i< *nk){ do{ z+=ilambda(knots,*cc,thetak,thetal,thetap,*nk,x,knots[i],i); x=knots[i]; i++; } while(qq[j]>knots[i] && i< *nk); } /* then integrate to qq[j] */ z+=ilambda(knots,*cc,thetak,thetal,thetap,*nk,x,qq[j],i); pp[j]=1-exp(-z); x=qq[j]; } } } /* get quantiles from probabilities */ else{ /* first compute -log(1-p) in first knot */ zk=ilambda(knots,*cc,thetak,thetal,thetap,*nk,(double)0.,knots[0],0); for(j=0;j<*np;j++){ if(pp[j]>0 && pp[j]<1){ pp[j]= -hmylog(1-pp[j]); /* first integrate until the closest knot before pp[j] */ if(pp[j]>zk && i < *nk){ do{ z=zk; x=knots[i]; i++; zk+=ilambda(knots,*cc,thetak,thetal,thetap,*nk,x,knots[i],i); xl=x; zl=0; l=0; } while(pp[j]>zk && i<*nk); } /* then takes steps of one tenth of the interval */ if(pp[j]>z+zl){ do{ l++; if(i<*nk && i>0){ x=xl; z+=zl; xl=(double)l/dpp*knots[i]+(dpp-l)/dpp*knots[i-1]; } if(i==0){ x=xl; z+=zl; xl=(double)l/dpp*knots[i]; } /* outside the most extreme knot, we double the distance */ if(i==*nk){ z+=zl; x=xl; xl=2.*(x-knots[*nk-2])+knots[*nk-2]; } zl=ilambda(knots,*cc,thetak,thetal,thetap,*nk,x,xl,i); } while(pp[j]>z+zl); } /* linear interpolate further */ qq[j]=x+(pp[j]-z)/zl*(xl-x); } } } } /******************************************************************************/ static double xlambda(double *knots, double cc, double *thetak, double *thetal, double *thetap, int nk, double x) /* computes exp(lambda(x)), all quantities, see above */ { double y; int i; if(x>0){ y=thetap[0]+x*thetap[1]+hmylog(x+cc)*thetal[1]+hmylog(x/(x+cc))*thetal[0]; for(i=0;iknots[i];i++) y+=(x-knots[i])*(x-knots[i])*(x-knots[i])*thetak[i]; return exp(y); } /* if x is 0 forget about log(x/(x+c)) */ else{ y=thetap[0]+x*thetap[1]+hmylog(x+cc)*thetal[1]; for(i=0;iknots[i];i++) y+=(x-knots[i])*(x-knots[i])*(x-knots[i])*thetak[i]; return exp(y); } } /******************************************************************************/ static double ilambda(double *knots, double cc, double *thetak, double *thetal, double *thetap, int nk, double z1, double z2, int i) /* integrates exp(lambda(x)) from z1 to z2, which is between knot[i-1] and knot[i] (knot[-1]=0, knot[nk]=infty) */ { double r1,r2,y[60],w[60],f; int k; r1 = (z2-z1)/2.; r2 = (z2+z1)/2.; /* Gaussian quadrature - see Abromowitz and Stegun */ y[0] = 0.125233408511469 * r1; w[0] = 0.249147045813403 * r1; y[1] = 0.367831498998180 * r1; w[1] = 0.233492536538355 * r1; y[2] = 0.587317954286617 * r1; w[2] = 0.203167426723066 * r1; y[3] = 0.769902674194305 * r1; w[3] = 0.160078328543346 * r1; y[4] = 0.904117256370475 * r1; w[4] = 0.106939325995318 * r1; y[5] = 0.981560634246719 * r1; w[5] = 0.047175336386512 * r1; k=6; /* w[ 0]= 0.00178328072169643 * r1; y[0 ]= 0.99930504173577217 * r1; w[ 1]= 0.00414703326056247 * r1; y[1 ]= 0.99634011677195533 * r1; w[ 2]= 0.00650445796897836 * r1; y[2 ]= 0.99101337147674429 * r1; w[ 3]= 0.00884675982636395 * r1; y[3 ]= 0.98333625388462598 * r1; w[ 4]= 0.01116813946013113 * r1; y[4 ]= 0.97332682778991098 * r1; w[ 5]= 0.01346304789671864 * r1; y[5 ]= 0.96100879965205377 * r1; w[ 6]= 0.01572603047602472 * r1; y[6 ]= 0.94641137485840277 * r1; w[ 7]= 0.01795171577569734 * r1; y[7 ]= 0.92956917213193957 * r1; w[ 8]= 0.02013482315353021 * r1; y[8 ]= 0.91052213707850282 * r1; w[ 9]= 0.02227017380838325 * r1; y[9 ]= 0.88931544599511414 * r1; w[10]= 0.02435270256871087 * r1; y[10]= 0.86599939815409277 * r1; w[11]= 0.02637746971505466 * r1; y[11]= 0.84062929625258032 * r1; w[12]= 0.02833967261425948 * r1; y[12]= 0.81326531512279754 * r1; w[13]= 0.03023465707240248 * r1; y[13]= 0.78397235894334139 * r1; w[14]= 0.03205792835485155 * r1; y[14]= 0.75281990726053194 * r1; w[15]= 0.03380516183714161 * r1; y[15]= 0.71988185017161088 * r1; w[16]= 0.03547221325688239 * r1; y[16]= 0.68523631305423327 * r1; w[17]= 0.03705512854024005 * r1; y[17]= 0.64896547125465731 * r1; w[18]= 0.03855015317861563 * r1; y[18]= 0.61115535517239328 * r1; w[19]= 0.03995374113272034 * r1; y[19]= 0.57189564620263400 * r1; w[20]= 0.04126256324262353 * r1; y[20]= 0.53127946401989457 * r1; w[21]= 0.04247351512365359 * r1; y[21]= 0.48940314570705296 * r1; w[22]= 0.04358372452932345 * r1; y[22]= 0.44636601725346409 * r1; w[23]= 0.04459055816375657 * r1; y[23]= 0.40227015796399163 * r1; w[24]= 0.04549162792741814 * r1; y[24]= 0.35722015833766813 * r1; w[25]= 0.04628479658131442 * r1; y[25]= 0.31132287199021097 * r1; w[26]= 0.04696818281621002 * r1; y[26]= 0.26468716220876742 * r1; w[27]= 0.04754016571483031 * r1; y[27]= 0.21742364374000708 * r1; w[28]= 0.04799938859645831 * r1; y[28]= 0.16964442042399283 * r1; w[29]= 0.04834476223480295 * r1; y[29]= 0.12146281929612056 * r1; w[30]= 0.04857546744150343 * r1; y[30]= 0.07299312178779904 * r1; w[31]= 0.04869095700913972 * r1; y[31]= 0.02435029266342443 * r1; k=32; */ f=0.; for(i=0;i #include #include "R.h" #define Salloc(n, t) (t *)R_alloc((long)(n), (int)sizeof(t)) #define NBMAX 70 #define PIL 3.141592653589793116 #define TINY 1.0e-20 #define DIM5 NBMAX+5 void F77_NAME(xdsifa)(double[][DIM5], int *, int *, int *, int *); void F77_NAME(xdsisl)(double[][DIM5], int *, int *, int *, double *); void F77_NAME(xdsidi)(double[][DIM5], int *, int *, int *, double *, int *, double *, int *); static double **uumm,*uuaa,*uuww,*uuvv1,*uuvv2; static double *uubetan,**xxcumul; static int *uuika; static int silent; void tspspsx(int *dims); void tspsps(int *dims, double *data, double *knots, int *atoms, double *alpha, double *logs, double *theta, int *ad, double *mass); static void tspsps2(int *dims, double *data, double *knots, double alpha, double *logs, double *theta, int *ad, double *xx, double *zz, int *atoms, int *nothere, double mass); static int tsadd(double **basis, double **info, int nd, int n, double *kts, int mind, double *xx, double *bb, double **cumul, int *spk, int *nk, int *ns, int cank, int cans, int *nothere); static double tsraod(int loc, double **mm, int nk, int nd, double *xx, double *bb, double **basis, int n); static double tsraoc(int loc, double **mm, int n, int nk, double *xx, double *kts, double **cumul, int ika, double *ww, double *aa, double *bb, double **basis, int nd, int *spk); static int tsrem(double **info, int *nk, double *beta, double *kts, double **coef, int *ns, int *spk, int nd); static double tsnew(double *data, int n, double *beta, int *er, double *score, double **info, int nk, double *zz, double *ff, double ***coef2, double *xx, double *kk, double **cumul, int nd, int *spk, double **basis, int ns, int *nothere, double mass, int *fl); static double tslogall(double *bb, double *beta, double *score, double **info, int n, int nk, double *data, int what, double *xx, double **cumul, double **basis, int nd, int *spk, int ns, int *fl); static void tsbasis(double **basis, double *kk, int n, int nb, double **coef, double *xx, double ***coef2, int *fl); static void tsb5(double **coef, double *kk, int col, int row, int i); static void tsb1(double **coef, int col, int row); static void tsb2(double **coef, double *kk, int col, int row, int i); static void tsb3(double **coef, double *kk, int col, int row, int i); static void tsb4(double **coef, double *kk, int col, int row, int i); static int *tssivec(int nh); static double *tssdvec(int nh); static double ***tssdtri(int r, int c, int s); static double **tssdmat(int nrh, int nch); static void tsintsum(double rr[], int k0, int k1, double f); static void tslusolve(double **a, int n, double *b); static void tsluinverse(double **a, int n); static void tsallocer(void); /******************************************************************************/ /* This function controls the updown movements */ /******************************************************************************/ void tspspsx(int *dims) { dims[0]=NBMAX; } void tspsps(int *dims, double *data, double *knots, int *atoms, double *alpha, double *logs, double *theta, int *ad, double *mass) /* for most variables see tspsps2 below */ { /* dims: 0 - nx (SAMPLE SIZE) 1 - maxdim 2 - dimatt (should we attain maxdim?) 3 - maxknots 4 - ktsatt 5 - nknots 6 - maxatoms 7 - spkatt 8 - natoms 9 - odd 10 - repeat 11 - error 12 - mind yy - winning log-likelihood, last time i,j - counter xspk - original atoms er2 - number of problems cdims - copy of dims xkts - original kts xx - x-coordinates zz - log(data) mass - minimum mass in a atom zzz - utility */ int i,j,er2=0,*xspk,*nothere; int cdims[13]; double yy=0.,*xx,*zz,*xkts,zzz=0.; /* we only want the length of NBMAX */ if(dims[0]<0){ dims[0]=NBMAX; return; } tsallocer(); /* allocation */ xx=tssdvec(dims[0]+1); zz=tssdvec(dims[0]); nothere=tssivec(dims[0]); xkts=tssdvec(dims[0]); xspk=tssivec(dims[0]); silent=1-dims[11]; dims[11]=0; /* at least one repeat */ if(dims[10]<1)dims[10]=1; /* initialize the x-values - this makes a difference whether the original series was odd or even */ if(dims[9]==0){ for(i=0;i1 && dims[7]==0){ dims[6]=0; dims[7]=1; } else j=1; } tspsps2(dims,data,knots,*alpha,logs,theta,ad,xx,zz,atoms,nothere, *mass); /* if we did not converge, initialize again */ if(dims[11]!=0){ er2++; if(er2==1){ for(i=0;i0 && dims[5]+dims[8]>cdims[1]-5 && dims[2]==0){ cdims[1]=dims[5]+dims[8]+5; if(cdims[1]>NBMAX-5)cdims[1]=NBMAX-5; } if(j==0 && dims[5]+dims[8]>cdims[1]-1 && dims[2]==0){ cdims[1]=dims[5]+dims[8]+1; if(cdims[1]>NBMAX-5)cdims[1]=NBMAX-1; } /* we really didn't converge */ }while(dims[11]!=0 && dims[12]<6); if(j==0){ dims[7]= 0; dims[6]= -1; } /* return on error or on only repeat */ if(dims[10]==1)dims[10]=0; if(dims[10]==0 || dims[11]!=0) return; for(i=3;i<13;i++)cdims[i]=dims[i]; /* there was no improvement, or the winner was fitted during addition */ if(j>0){ if(fabs((double)(yy-logs[dims[5]+dims[8]]))1){ /* maximum number is present number */ dims[1]=dims[5]+dims[8]; /* attain nothing */ dims[2]=0; dims[4]=0; dims[7]=0; tspsps2(dims,data,knots,*alpha,logs,theta,ad,xx,zz,atoms,nothere,*mass); } dims[10]= -dims[10]; } /******************************************************************************/ /* does the work */ /******************************************************************************/ static void tspsps2(int *dims, double *data, double *knots, double alpha, double *logs, double *theta, int *ad, double *xx, double *zz, int *atoms, int *nothere, double mass) { /* dims - various integer parameters data - periodogram knots - starting knots/best knots alpha - penalty parameter (bic) logs - log-likelihood of fitted models theta - coefficients (in powerbasis format) ad - was a model fit during the addition (0), or deletion (1) stage zz - log(xx) xx - frequencies of the periodogram atoms - starting atoms/best atoms nothere - at which indices is no atom allowed mass - minimum mass at an index mind - minimum distance between knots */ int nx=dims[0],maxd=dims[1],atd=dims[2],maxk=dims[3],atk=dims[4],nk=dims[5]; int maxs=dims[6],ats=dims[7],ns=dims[8],er=dims[11],mind=dims[12],*fl; int nd=dims[5]+dims[8],add=0,i,j,*spk,cank,cans,id=dims[5]; double **info,*score,**basis,*beta,logl,*kts,aic,aicmn,**coef,*bb; double ***coef2,**cumul; /* nx - sample-size maxd - maximum number of dimensions atd - should maxd be attained (1=yes, 0=no) maxk - maximum number of knots atk - should maxk be attained (1=yes, 0=no) nk - number of (starting) knots maxs - maximum number of atoms ats - should maxs be attained (1=yes, 0=no) ns - number of (starting) atoms er - error criterion mind - minimum distance between knots nd - number of dimensions add - addition stage (0), deletion stage (1) or finished (>1) i,j - counter cank - can we add a knot? cans - can we add a atom? tsrem() - removes a knot tsadd() - adds a knot spk - present atoms info - hessian score - score vector basis - matrix of basis functions (smooth part) (nx x nk) beta - coefficients of basis functions logl - loglikelihood present model kts - present knots aic - present aic aicmn - minimum aic tsnew() - newton raphson coef - translates powerbasis and B-spline basis coef2 - translates powerbasis and B-spline basis bb - misfit - residual ratios cumul - cumulative sums: xx to power * (1,misfit) * (1,basis) tsbasis() - computes the basis */ /* allocate storage */ score=tssdvec(NBMAX); beta=tssdvec(NBMAX); info=tssdmat(NBMAX,NBMAX); coef=tssdmat(NBMAX,NBMAX+4); coef2=tssdtri(4,NBMAX,NBMAX+1); basis=tssdmat(nx,NBMAX); fl=tssivec(2*NBMAX); kts=tssdvec(NBMAX); spk=tssivec(NBMAX); bb=tssdvec(nx); cumul=xxcumul; /* define some cumul elements */ for(i=0;i<11+NBMAX*4;i++){ for(j=0;j<=nx;j++){ cumul[i][j]=0.; } } for(i=nx-1;i>0;i--){ cumul[7][i-1]=cumul[7][i]+1.; cumul[8][i-1]=cumul[8][i]+xx[i]; cumul[9][i-1]=cumul[9][i]+xx[i]*xx[i]; cumul[10][i-1]=cumul[10][i]+xx[i]*xx[i]*xx[i]; } /* initialize ad and logs and aicmn */ for(i=0;i0)add=7; for(i=0;i=10) cans=0; /* what can we add? */ i=tsadd(basis,info,nd,nx,kts,mind,xx,bb,cumul,spk,&nk,&ns,cank,cans, nothere); /* can we keep on adding?*/ if(i> -10)nd=i; else add=1; } /* this is the first time, and we specified knots */ if(add==7)add=0; /* compute the continuous basis functions */ tsbasis(basis,kts,nx,nk,coef,xx,coef2,fl); /* fit using newton raphson */ do{ logl=tsnew(data,nx,beta,&er,score,info,nk,zz,bb,coef2,xx,kts,cumul, nd,spk,basis,ns,nothere,mass,fl); if(silent==1)(void)Rprintf("==> %.2f (%d)\n",logl,nd); if(er<0){ ns--; nd--; } }while(er<0); /* if er==0 there was no error */ if(er==0){ /* store the loglikelihood, if this is the best model of this dimension */ if(ad[nd-1]==2||logl>logs[nd-1]){ ad[nd-1]=add; if(nd==1)ad[nd-1]=0; logs[nd-1]=logl; } /* compute aic */ aic=nd*alpha-2*logl; /* is this the best model up to now: store beta as theta, knots, aic and dims */ if(aic=alpha*(nd-1) || nd==1))add=3; /* if we are adding, and we have the maximum number of knots, start deleting */ if(add==0){ if(nd==maxd)add=1; if(nk==maxk && ns==maxs && atk==1 && ats==1)add=1; } /* if we are adding, and we have make no improvement, start deleting */ if(add==0 && (atd==0 || atk*ats==0)){ for(i=2;i0){ for(i=n-1;i>0;i--){ for(j=0;j<(*nk);j++){ k=11+4*j; r1=basis[i][j]*bb[i]; cumul[k][i-1]=cumul[k][i]+r1; r1=r1*xx[i]; cumul[k+1][i-1]=cumul[k+1][i]+r1; r1=r1*xx[i]; cumul[k+2][i-1]=cumul[k+2][i]+r1; r1=r1*xx[i]; cumul[k+3][i-1]=cumul[k+3][i]+r1; } } /* find the indices of the present knots */ j=0; for(i=0;(i<(n-1)&&j<(*nk));i++){ if(kts[j]<(xx[i]+xx[i+1])/2.){ ika[j]=i; j++; } } if(j<(*nk))ika[j]=n-1; ika[*nk]=n+mind; if(ika[0]==1)ika[0]=2; /* some stuff useful for tsraoc() */ ww[NBMAX]=cumul[10][ika[0]]-cumul[3][ika[0]]; ww[NBMAX]+=aa[2]*(cumul[2][ika[0]]-cumul[9][ika[0]]); ww[NBMAX]-=aa[4]*(cumul[1][ika[0]]-cumul[8][ika[0]]); ww[NBMAX]+=aa[6]*(cumul[0][ika[0]]-cumul[7][ika[0]]); for(j=0;j<(*nk);j++){ i=13+j*4; ww[j]=cumul[1+i][ika[0]]-aa[2]*cumul[i][ika[0]] +aa[4]*cumul[i-1][ika[0]]-aa[6]*cumul[i-2][ika[0]]; } /* search in between pairs of knots */ bestraoc= -1.; j=0; i=1; if(ika[0]<=mind){ i=ika[0]+mind+1; if(ika[0]==0)i++; j=1; } ix=i; for(i=ix;ibestraoc){ bestraoc=nowrao; bestloc=i; } } else{ i=ika[j]+mind; j++; } } } /* discrete search */ if(cans>0){ j=0; spk[(*ns)]=n+1; for(i=1;i1. && nothere[i]==0){ nowrao=tsraod(i,mm,(*nk),nd,xx,bb,basis,n); if(nowrao>bestraod){ bestraod=nowrao; bestlod=i; } } } } } /* is there anything? */ if(bestloc<0 && bestlod<0)return -100; /* record the knot, sort the knots */ if(bestraoc>bestraod){ if(bestloc0;i--)if(kts[i]0;i--)if(spk[i]=3.1415926){ bbn=0.5*bbn; vv[nd]=0.5*vv[nd]; vv[0]=0.5*vv[0]; if(nk>1){ vv[1]=0.5*vv[1]; if(nk>3){ vv[3]=0.5*vv[3]; } } } /* compute */ r1=0.; for(i=0;ikts[0]){ vv[nd]=(cumul[4][ika]-cumul[4][0])*aa[1]*aa[1]; /* sequence important */ aax[3]=aa[1]+aa[2]-aa[3]; aax[5]=aa[5]-aa[4]; aax[7]=aa[6]-aa[7]; aax[2]=aa[1]+aa[2]; for(i=0;i<7;i++){ if(i>3){ if(i==6){ b1=1.; } else{ if(i==5){ b1= -2.*aax[2]; } else{ b1=2.*aa[4]+aax[2]*aax[2]; b2=aax[3]*aax[3]; } } } else{ if(i>1){ if(i==3){ b1= -2.*aa[6]-2.*aax[2]*aa[4]; b2=2.*aax[3]*aax[5]; } else{ b1=aa[4]*aa[4]+2.*aa[6]*aax[2]; b2=aax[5]*aax[5]+2.*aax[7]*aax[3]; } } else{ if(i==1){ b1= -2.*aa[4]*aa[6]; b2=2.*aax[5]*aax[7]; } else{ b1=aa[6]*aa[6]; b2=aax[7]*aax[7]; } } } vv[nd]+=b1*(cumul[i][loc]-cumul[i][ika]); if(i<5)vv[nd]-=b2*cumul[i][loc]; } } else{ vv[nd]=(cumul[4][loc]-cumul[4][0])*aa[1]*aa[1]; /* sequence important */ aax[2]=aa[1]+aa[2]-aa[3]; aax[4]=aa[5]-aa[4]; aax[6]=aa[6]-aa[7]; aax[3]=aa[1]-aa[3]; for(i=0;i<7;i++){ if(i>3){ if(i==6){ b1=1.; } else{ if(i==5){ b1=2.*aax[3]; } else{ b1=2.*aa[5]+aax[3]*aax[3]; b2=aax[2]*aax[2]; } } } else{ if(i>1){ if(i==3){ b1= -2.*aa[7]+2.*aax[3]*aa[5]; b2=2.*aax[2]*aax[4]; } else{ b1=aa[5]*aa[5]-2.*aa[7]*aax[3]; b2=aax[4]*aax[4]+2.*aax[6]*aax[2]; } } else{ if(i==1){ b1= -2.*aa[5]*aa[7]; b2=2.*aax[4]*aax[6]; } else{ b1=aa[7]*aa[7]; b2=aax[6]*aax[6]; } } } vv[nd]+=b1*(cumul[i][ika]-cumul[i][loc]); if(i<5)vv[nd]-=b2*cumul[i][ika]; } } /* subtract half times the last element */ if(xx[n-1]>3.1415926){ bsx=PIL-kts[0]; bsx=(aa[1]*PIL*PIL+(PIL-xlc)*(PIL-xlc)*(PIL-xlc)-bsx*bsx*bsx)/2.; bbn+=bsx*(1.-bbpi); bbpi=bsx*bbpi; vv[nd]+=bsx*bbpi*2.; vv[0]+=bbpi; if(nk>1){ vv[1]+=bbpi*b1pi; if(nk>3)vv[3]+=bbpi*b3pi; } } for(i=nk;ixlc)y+=(x-xlc)*(x-xlc)*(x-xlc); if(x>kts[0])y-=(x-kts[0])*(x-kts[0])*(x-kts[0]); vv[i]= -bb[spk[i-nk]]*y; if(x>3.1415926)vv[i]=0.5*vv[i]; } if(xlc>xx[n-1])loc=n; /* compute*/ r1=0.; for(i=0;i1){ for(i=0;i<(*nk);i++){ phi = 0.; se = 0.; /* compute phi and se^2 */ for(j=0;j<(*nk);j++){ phi+=beta[j]*coef[j][i+4]; for(k=0;k<(*nk);k++) se-=coef[j][i+4]*coef[k][i+4]*info[j][k]; } /* what is the ratio? */ phi=fabs(phi); if(se>0) se=sqrt(se); else se=0.; if(se>phi*ratmax){ ratmax=se/phi; irmax=i; } } } /* for each atom */ for(i=(*nk);i0) se=sqrt(se); else se=0.; if(se>phi*ratmax){ ratmax=se/phi; irmax=i; } } /* remove the loser - if it is a knot */ if(irmax<(*nk)){ if(silent==1)(void)Rprintf("del knot at %.3f (",kts[irmax]); for(j=irmax;j<((*nk)-1);j++)kts[j]=kts[j+1]; (*nk)-=1; } /* remove the loser - if it is a atom */ else{ irmax-=(*nk); if(silent==1)(void)Rprintf("del atom at %.3d (",spk[irmax]); for(j=irmax;j<((*ns)-1);j++)spk[j]=spk[j+1]; (*ns)-=1; } if(silent==1)Rprintf("%.3f) ",1./ratmax); return nd-1; } /******************************************************************************/ /* does the newton raphson iterations */ /******************************************************************************/ static double tsnew(double *data, int n, double *beta, int *er, double *score, double **info, int nk, double *zz, double *ff, double ***coef2, double *xx, double *kk, double **cumul, int nd, int *spk, double **basis, int ns, int *nothere, double mass, int *fl) { int i,j,k,i1,jx; double logold,lognew,*betan,r,zerror; double uu[7],vv[7],xz; int k1,k2,k3,l,l2; /* i,j,k - counter tslogall() computes score, hessian and loglikelihood logold - old loglikelihood lognew - new loglikelihood betan - new beta r - utility zerror - convergence criterion */ /* allocate, initialize */ betan=uubetan; *er=0; for(i=0;i=kk[k1] && k10){ for(i=0;i0){ for(i=0;i=3.1415926) logl+=0.5*(bb[n-1]-log(bb[n-1]/data[n-1])); /* update score and hessian - the continuous elements */ if(what==2){ for(k=n-1;k>0;k--){ r1=bb[k]; cumul[0][k-1]=cumul[0][k]+bb[k]; for(j=1;j<7;j++){ r1=r1*xx[k]; cumul[j][k-1]=cumul[j][k]+r1; } } } if(what>0){ for(i=0;ik)k=fl[2*j]; uu=fl[2*i+1]; if(fl[2*j+1]>uu)uu=fl[2*j+1]; kx=k; for(k=kx;k=3.1415926){ bb[n-1]=0.5*bb[n-1]; score[0]+=(0.5-bb[n-1]); info[0][0]+=bb[n-1]; if(nk>1){ score[1]+=b1*(0.5-bb[n-1]); info[1][0]+=b1*bb[n-1]; info[1][1]+=b1*b1*bb[n-1]; if(nk>3){ score[3]+=b3*(0.5-bb[n-1]); info[3][0]+=b3*bb[n-1]; info[3][1]+=b3*b1*bb[n-1]; info[3][3]+=b3*b3*bb[n-1]; } } bb[n-1]=2.*bb[n-1]; } for(i=0;i0){ if(spk[ns-1]==n-1 && xx[n-1]>=3.1415926){ score[nd-1]=0.5*score[nd-1]; info[nd-1][nd-1]=0.5*info[nd-1][nd-1]; info[0][nd-1]=0.5*info[0][nd-1]; info[nd-1][0]=info[0][nd-1]; if(nk>1){ info[1][nd-1]=0.5*info[1][nd-1]; info[nd-1][1]=info[1][nd-1]; if(nk>3){ info[3][nd-1]=0.5*info[3][nd-1]; info[nd-1][3]=info[3][nd-1]; } } } } } return logl; } /******************************************************************************/ /* compute the basis functions */ /******************************************************************************/ static void tsbasis(double **basis, double *kk, int n, int nb, double **coef, double *xx, double ***coef2, int *fl) { int i,j,k; double r1; /* i,j,k - counters tsb1() -get coef for basis function 1 tsb2() -get coef for basis function 2 tsb3() -get coef for basis function 3 tsb4() -get coef for basis function 4 tsb5() -get coef for basis function 5 and later */ /* initialize */ for(i=0;i1)tsb2(coef,kk,nb+2,1,nb-2); if(nb>2)tsb3(coef,kk,4,2,0); if(nb>3)tsb4(coef,kk,nb,3,nb-4); for(i=5;i<=nb;i++)tsb5(coef,kk,i-1,i-1,i-5); /* compute the values */ for(i=0;i=0;i--){ if(xx[i]>kk[k-4]){ r1=(xx[i]-kk[k-4])*(xx[i]-kk[k-4])*(xx[i]-kk[k-4]); for(j=1;j=4) { fl[2*i]=(int)(kk[i-4]*(double)n/PIL)-1; if(fl[2*i]<1) fl[2*i]=1; fl[2*i+1]=(int)(kk[i]*(double)n/PIL)+1; fl[2*i+1]=n; } } for(i=0;i= 0 ? (x) : -(x)) #define dabs(x) (doublereal)abs(x) #define min(a,b) ((a) <= (b) ? (a) : (b)) #define max(a,b) ((a) >= (b) ? (a) : (b)) #define dmin(a,b) (doublereal)min(a,b) #define dmax(a,b) (doublereal)max(a,b) /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 #ifdef __cplusplus typedef int /* Unknown procedure type */ (*U_fp)(...); typedef shortint (*J_fp)(...); typedef integer (*I_fp)(...); typedef real (*R_fp)(...); typedef doublereal (*D_fp)(...), (*E_fp)(...); typedef /* Complex */ VOID (*C_fp)(...); typedef /* Double Complex */ VOID (*Z_fp)(...); typedef logical (*L_fp)(...); typedef shortlogical (*K_fp)(...); typedef /* Character */ VOID (*H_fp)(...); typedef /* Subroutine */ int (*S_fp)(...); #else typedef int /* Unknown procedure type */ (*U_fp)(void); typedef shortint (*J_fp)(void); typedef integer (*I_fp)(void); typedef real (*R_fp)(void); typedef doublereal (*D_fp)(void), (*E_fp)(void); typedef /* Complex */ VOID (*C_fp)(void); typedef /* Double Complex */ VOID (*Z_fp)(void); typedef logical (*L_fp)(void); typedef shortlogical (*K_fp)(void); typedef /* Character */ VOID (*H_fp)(void); typedef /* Subroutine */ int (*S_fp)(void); #endif /* E_fp is for real functions when -R is not specified */ typedef doublereal E_f; /* real function with -R not specified */ /* undef any lower-case symbols that your C compiler predefines, e.g.: */ #ifndef Skip_f2c_Undefs #undef cray #undef gcos #undef mc68010 #undef mc68020 #undef mips #undef pdp11 #undef sgi #undef sparc #undef sun #undef sun2 #undef sun3 #undef sun4 #undef u370 #undef u3b #undef u3b2 #undef u3b5 #undef unix #undef vax #endif #endif polspline/src/Makevars0000644000176200001440000000003714516535017014551 0ustar liggesusersPKG_LIBS=$(BLAS_LIBS) $(FLIBS) polspline/src/lsdall.c0000644000176200001440000033521214516535017014502 0ustar liggesusers/* * * Copyright [1993-2018] [Charles Kooperberg] * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. * Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * */ #include #include #define NC 50 #include "R.h" void F77_NAME(xdsifa)(double[][NC], int *, int *, int *, int *); void F77_NAME(xdsisl)(double[][NC], int *, int *, int *, double *); void F77_NAME(xdsidi)(double[][NC], int *, int *, int *, double *, int *, double *, int *); void F77_NAME(xssort)(double *, double *, int *, int *); static double knots[NC],coef[NC][4][NC],zheta[NC],czheta,xg[NC],dfunpar[6]; static int nknots,ng3[NC],ng4[NC]; void logcensor(int *idelete, int *iknotauto, double sample[], int nsample[], double bound[], int SorC[], int *ynknots, double yknots[], double ycoef[], double *alpha, double wk[], double wk2[], double logl[]); static int removeknot(double info[][NC], double coef2[][NC]); static void fits(double xcoef2[][NC], double xzheta[], double xczheta, double ycoef[], int xiknots[], int xnknots); static double liter(double info[][NC], double sufficient[][2], double bound[], int SorC[], int nsample[], double sample[], int accuracy, int *itrouble); static void setbounds(double bound[], double cbound[], int nsample[]); static double erroradjust(double shift[]); static double error2(double shift[], double rvr[]); static double likeli(double candidate[], int nsample[], double sample[], double bound[], int accuracy); static double linsearch(double shift[], double oldll, double bound[], int nsample[], double sample[], int accuracy); static double onesearch(double rt, double shift[], int accuracy, double bound[], int *err, int nsample[], double sample[]); static int numbertester(double aa); static double expin(int version, double t1, double t2, double a[]); static double expin2(int version, double t1, double t2, double aa[], double b1, double b0); static double dens3(double x); static double dens33(double x); static double numint(double k1, double k2, int accuracy); static double numint2(double k1, double k2, int accuracy); static double numints(double vv[], double k1, double k2, int accuracy, int ip); static double fun2(double x); static double fun48(double w, double x, double vv[], int ip); static void coeff(double coef2[][NC]); static void start1(double crossprods[][NC], double derivatives[], double sample[], int nsample[]); static void start2(double crossprods[][NC], double derivatives[], double coef2[][NC], int nkstart, int iremove); static void suffstat1(double suffcombine[][2], double sample[], int nsample[]); static void suffstat2(double suffcombine[][2], double coef2[][NC], double sufficient[][2]); static void knotplace(int iknots[], double rknots[], int iknotauto, double bound[], double sample[], int nsample[], int SorC[], double smp2[], double smp3[], double qt[]); static int knotnumber(int idelete, int nsample[], int nknots, int SorC[]); static int piecedens(double sample[], double smp2[], double smp3[], int nsample[]); static double middle(double info[][NC], double shift[], double sufficient[][2], double bound[], int accuracy, int nsample[], double sample[], double zheta[], int what); static void intnum2(double x1, double x2, double qolint[][NC +1], double shift[], double info[][NC], int n1, int n2, int what); static void intnum3(double x, double qolint[][NC +1], double d1, double e1, int vs, double bd, double shift[], double info[][NC], int n1, int n2, int what); static void intnum4(double x, double qolint[][NC +1], double d1, double e1, int vs, double bd, double shift[], double info[][NC], int n1, int n2, int what); static double tails(double info[][NC], double shift[], double coef[][4][NC], double bound[], double knots[], double zheta[], int nknots, int what); /******************************************************************************/ /* this is the main program */ /* remove follows at the end */ void logcensor(int *idelete, int *iknotauto, double sample[], int nsample[], double bound[], int SorC[], int *ynknots, double yknots[], double ycoef[], double *alpha, double wk[], double wk2[], double logl[]) /* these quantities are defined in the file where they originated and lhead.h */ { int itrouble,accuracy=0,xnknots=0.; double qt[2]; /* functions - see the functions themselves */ double info[NC][NC],loglikelihood,sufficient[NC][2],coef2[NC][NC],xczheta=0.; /* stuf used in iter info - the information matrix loglikelihood sufficient - sufficient statistics coef,coef2 - 2 matrices defining the splines as a function of the knots, see lcoef.c for the exact definitions. */ double derivatives[NC],crossprods[NC][NC],suffcombine[NC][2],xzheta[NC]; /* derivative crossprods used to compute the starting values - see lstart.c suffcombine used to compute the sufficient statistics - see lsuff.c */ double aic,aicmin,r1,rknots[NC],xcoef2[NC][NC]; /* local double stuff: r1 - utility aic - akaike information criterion aicmin - minimum aic encountered alpha - alpha value in aic rknots - copy of knots */ int i,j,nkstart,iremove=0,iknots[NC],xiknots[NC]; /* local integers i,j,k - counter, utility nkstart - number of knots at the beginning of the algorithm iremove - number of the knot that is removed */ /******************************************************************************/ /* compute the number of knots (to start) */ for(i=0;i0){ if(*idelete == 0){ xczheta = czheta; xnknots = nknots; for(i=0; i= aicmin) nknots = 0; } /* If there were more than 4 knots, we should remove one. */ if(nknots >= 4){ /* Select the one to remove. */ iremove = removeknot(info,coef2); /* Remove its remainders from all sort of arrays. That is, shift the ends of the array 1 closer to 0, crossprods gets shifted in 2 directions */ for(i=iremove; i=iremove);i++) crossprods[i+1][j+1] = crossprods[i+2][j+2]; for(i=iremove;(i=iremove);i++) crossprods[i+1][j+1] = crossprods[i+1][j+2]; } } /* this takes care that we stop */ else if(nknots == 3)nknots=2; }} } while(nknots>=3 && *idelete >0); /* Now write the solution down. This prints the density */ nknots = nkstart; fits(xcoef2,xzheta,xczheta,ycoef,xiknots,xnknots); *ynknots = nkstart; bound[2]=(bound[2]-qt[0])/qt[1]; bound[4]=(bound[4]-qt[0])/qt[1]; for(i=0;i0){ se[i] = sqrt(se[i]); /* Select for which knot se/phi takes it maximal value */ if(se[i] > phi[i] * ratmax){ ratmax = se[i] / phi[i]; irmax = i; }} } nknots = nknots-1; return irmax; } /*****************************************************************************/ static void fits(double xcoef2[][50], double xzheta[], double xczheta, double ycoef[], int xiknots[], int xnknots) { int i,j; for(i=0;i< NC;i++)ycoef[i]=0.; ycoef[0]=-log(xczheta); for(i=0;i< xnknots;i++){ ycoef[xiknots[i]+2] = 0.; for(j=0;j< xnknots-1;j++) ycoef[xiknots[i]+2] = ycoef[xiknots[i]+2] + xzheta[j] * xcoef2[j][i+2]; } for(j=0;j< xnknots-1;j++){ ycoef[0]=ycoef[0] + xzheta[j] * xcoef2[j][0]; ycoef[1]=ycoef[1] + xzheta[j] * xcoef2[j][1]; } } /******************************************************************************/ /* this is the main iteration loop */ /* setbounds follows at the end */ static double liter(double info[][50], double sufficient[][2], double bound[], int SorC[], int nsample[], double sample[], int accuracy, int *itrouble) { int counter=0,infol,i1,i2,i3,kpvt[NC],jaja1,i4,iii[4],ithere,i7,nrc=0,nrc2=0; double zerror=0.,oldlikelihood,cbound[7],shift[NC],dd[2]; double candidate[NC],newlikelihood=0.,work[NC][NC]; double one,rvr[100],zerrorx; /* local i1 i2 i3 - counters oldlikelihood - loglikelihood previous iteration newlikelihood - loglikelihood present iteration infol,kpvt - for linpack work - for linpack shift - used for the shift and score zerror - stop criterion cbound - see below candidate - candidate for new zheta counter - number of iterations since last reset of boundaries */ one=0.99999; /* sets integration bounds */ setbounds(bound,cbound,nsample); /* accuracy = 0 means that we approximate censoring */ if(accuracy == 0 && nsample[0]==nsample[1])accuracy=1; /* start of the iteration */ if(SorC[0] == 0) (void)Rprintf("%d \n",nknots); for(i1=1; i1<500; i1++){ /* if we go extremely far out in the tails, and zheta[first] or zheta[last] still doesn't have the right sign, we fix the bounds at the max value */ ithere = 0.; if(bound[3]<0.5||bound[3]>1.5)ithere=5; else{ if(bound[4]>=25*knots[nknots-1]-24*knots[0]){ if(SorC[0]==0&&SorC[24]==0)(void)Rprintf("a very long right tail"); SorC[24]=nknots; *itrouble=17; for(i2=1;i2<5;i2++)bound[i2]=cbound[i2]; return 0.; } } if(bound[1]<0.5||bound[1]>1.5)ithere=ithere+5; else{ if(bound[2]<=-24*knots[nknots-1]+25*knots[0]){ if(SorC[0]==0&&SorC[23]==0)(void)Rprintf("a very long left tail"); SorC[23]=nknots; *itrouble=17; for(i2=1;i2<5;i2++)bound[i2]=cbound[i2]; return 0.; } } /* after 250 iterations we do the censoring exact */ if(accuracy == 0 && i1==250){ accuracy=1; counter = 0; } jaja1=0; counter++; /* if something changed in the bounds since last time counter = 0, and we have to recompute czheta and the loglikelihood */ i7=0; do{ if(counter==1){ do{ czheta = middle(info,shift,sufficient,bound,accuracy, nsample,sample,zheta,0); /* check against overflow and NAs */ i2=-1; if(czheta>0.0)i2=i2+1; if(czheta<2.0)i2=i2+1; if(numbertester(czheta)==1)i2=i2-4; if(i2<0){ for(i2=0;i27 && *itrouble == 0){ *itrouble = 2; for(i2=1;i2<5;i2++)bound[i2]=cbound[i2]; return 0.; } i2=-6; i7++; if(i7==200){ *itrouble=5; return 1.; } } }while(i2<0); newlikelihood=likeli(zheta,nsample,sample,bound,accuracy); } i2=1000*nknots+i1; /* compute score (stored in shift), info and czheta */ czheta = middle(info,shift,sufficient,bound,accuracy, nsample,sample,zheta,2); /* store the loglikelihood of the previous iteration */ oldlikelihood = newlikelihood; /* copy info */ for(i2=0;i27 && *itrouble == 0){ *itrouble = 2; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 0.; } i7++; if(i7==200){ *itrouble = 5; return 1.; } } }while(infol!=0); iii[1]=0; iii[2]=0; if(nsample[2]+nsample[3]+nsample[4] >0) F77_CALL(xdsidi)(work,&i2,&i3,kpvt,dd,iii,rvr,&i4); for(i4=0;i40&&nrc+nrc2>=5&&nrc>=2){ nrc2++; if(nrc2==15 && *itrouble == 0){ *itrouble = 2; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 0.; } if(nrc2==48 && *itrouble != 0){ *itrouble = 5; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 1.; } iii[2]=0; iii[1]=0; nrc=0; } if(iii[2]+iii[1]==0){ F77_CALL(xdsisl)(work,&i2,&i3,kpvt,shift); /* compute the stop criterion and adjust stepsize, if too large */ i7=0; do{ zerrorx=error2(shift,rvr); zerrorx=zerrorx*100.; zerror = erroradjust(shift); if(iii[3]==0)zerror=zerrorx; i2=-1; if(zerror>0.0)i2=i2+2; if(zerror<2.0)i2=i2+2; if(numbertester(zerror)==1)i2=i2-4; if(i2<0){ for(i2=0;i27 && *itrouble == 0){ *itrouble = 2; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 0.; } i7++; if(i7==200){ *itrouble = 5; return 1.; } i2=-7; } }while(i2<0); /* counter is the number of iterations since the last adjustment of integration boundaries. Thus if we find an zerror, we put it to 0 and start all over. Temporarily we deduct 10000 from it if we have to half the step size first */ i7=0; do{ if(counter<-1000)counter=counter+10000; /* We should check whether zheta's that should be negative (the ones for tail basis functions if we are integrating to plus/minus infinity) stay negative. If counter become 0 we essentially leave the loop here..................... We then go from case A to case B...........................................*/ if(zheta[0] + shift[0] >= 0. && bound[1] < 0.5){ cbound[5] = -cbound[5]; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; bound[1] = 1; counter = 0; } if(zheta[nknots-2] + shift[nknots-2] >= 0. && bound[3] < 0.5){ cbound[6] = -cbound[6]; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; bound[3] = 1.; counter = 0; } /* Compute the C(zheta) for the candidate zheta-hat. We can then compute the new log-likelihood. */ if(counter >0){ for(i2=0;i20.0)i2=i2+1; if(czheta<2.0)i2=i2+1; if(numbertester(czheta)==1)i2=i2-4; if(i2>0){ newlikelihood=likeli(candidate,nsample,sample,bound,accuracy); /* If the loglikelihood really decreases, we step size and go back a bit */ if(newlikelihood < oldlikelihood && ((newlikelihood/oldlikelihood < one) || (oldlikelihood/newlikelihood < one)) && zerror > 0.00001){ jaja1++; if(jaja1<12 || i1<3){ for(i2=0;i2 7 && *itrouble == 0){ *itrouble = 2; for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; return 0.; } i7++; if(i7==200){ *itrouble = 5; return 1.; } for(i2=0;i20){ nrc++; for(i2=0;i2-6.||zheta[0]+shift[0]>0)){ cbound[5] = -cbound[5]; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; bound[1] = 1; counter = 0; } if(cbound[6]<0. && bound[3] < 0.5 && (cbound[6]>-6.||zheta[nknots-2]+shift[nknots-2]>0)){ cbound[6] = -cbound[6]; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; bound[3] = 1.; counter = 0; } if(counter ==0){ czheta = middle( info,shift,sufficient,bound,accuracy,nsample,sample,zheta,0); (void) middle(info,shift,sufficient,bound,accuracy,nsample,sample,zheta,1); oldlikelihood=likeli(zheta,nsample,sample,bound,accuracy); for(i2=0;i2 0){ for(i2=0;i29){ if(accuracy == 5){ for(i3=1;i3<5;i3++)bound[i3]=cbound[i3]; rvr[99] = middle( info,shift,sufficient,bound,5,nsample,sample,zheta,0); if(iii[1]+iii[2]!=0) rvr[99] = middle( info,shift,sufficient,bound,5,nsample,sample,zheta,0); i2=0; if(rvr[99]>0.0)i2=i2+1; if(rvr[99]<2.0)i2=i2+1; if(numbertester(rvr[99])==1)i2=i2-4; if(i2>0){ czheta=rvr[99]; newlikelihood=likeli(zheta,nsample,sample,bound,5); } return newlikelihood; } else { accuracy = 5; counter = 0; } } else { /* If we were not integrating to +/- infinity, we either double the integration tails (if a tail zheta was possitive) or we go for it: +/- infinity (That means cbound[5] and cbound[6] become negative.) */ counter=0; /* Left tail */ if(cbound[5] < 0) /* case A */ cbound[5] = 2. * cbound[5]; else{ if(cbound[1] < 0.5 && zheta[0] >=0.){ /* case B */ cbound[5] = 2. * cbound[5]; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; } if(cbound[1] < 0.5 && zheta[0] <0. ){ /* case B to A*/ cbound[5] = -2. * cbound[5]; bound[1] = 0; } if(cbound[1] > 0.5 && bound[1] > 0.5 && bound[1] < 1.5){ /*E*/ cbound[5] = 2. * cbound[5]; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; if(bound[2] < cbound[2]){ /* goto C/D */ bound[2] = cbound[2]; bound[1] = 2.; } } } /* Right tail */ if(cbound[6] < 0) /* case A */ cbound[6] = 2. * cbound[6]; else{ if(cbound[3] < 0.5 && zheta[nknots-2] >=0.){ /* case B */ cbound[6] = 2. * cbound[6]; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; } if(cbound[3] < 0.5 && zheta[nknots-2] <0. ){ /* case B to A*/ cbound[6] = -2. * cbound[6]; bound[3] = 0.; } if(cbound[3] > 0.5 && bound[3] > 0.5 && bound[3] < 1.5){ /* case E*/ cbound[6] = 2. * cbound[6]; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; if(bound[4] > cbound[4]){ /* goto C/D */ bound[4] = cbound[4]; bound[3] = 2; } } } } } } } /* If we ended up here, there was no convergence in 300 iterations. */ if(SorC[0] == 0){ (void)Rprintf("no convergence was achieved with %d knots\n",nknots); SorC[0] = -647; } else SorC[0] = -SorC[0]; return newlikelihood; } static void setbounds(double bound[], double cbound[], int nsample[]) { /* set the integration boundaries. O.k., this is quite complicated. There are 2 arrays that determine how far we are integrating in each tail. For the lower tail: bound[1] - is there a lower bound to which we should integrate (on entry) are we right now integrating to a lower bound (during) is there a lower bound to which we should integrate (on exit) (0 = -infinity; 1 = lower bound); cbound[1]- copies the begin value of bound[1] for during the iterations. bound[2] - if bound[1] == 1/2 the lower bound of integration (on entry) if bound[1] == 1/2 the lower bound of integration (during) if bound[1] == 1/2 the lower bound of integration (on exit) cbound[2]- copies the begin value of bound[2] for during the integration. cbound[5] - technical limit on the integration. If cbound[5] < 0 we can integrate to -infinity (if we want to), if cbound[5] > 0 the furthest we want to integrate is to cbound[5]*(knots[1]-knots[2])+knots[1]; if cbound[5] is smaller than 0 it is twice its last possitive value. For the upper tail: bound[3], bound[4], cbound[3], cbound[4], cbound[6] */ /* the lower tail */ cbound[2] = bound[2]; cbound[1] = bound[1]; cbound[5] = 1.; if(nsample[3]*3>nsample[1])cbound[5]=0.5; bound[2] = cbound[5] * (knots[0] - knots[1]) + knots[0]; /* there are 5 possible situations: A cbound[1]=0, zheta[0]<0 need: cbound[5]=-1, bound[1]=0 B zheta[0]>=0 need: cbound[5]=1, bound[1]=1 C cbound[1]=1, zheta[0]<0 need: cbound[5]=1, bound[1]=2, bound[2]=cbound[2] D zheta[0]>=0, bound[2]=cbound[2]: cbound[5]=1, bound[1]=1 */ if(zheta[0]<0. && cbound[1] < 0.5 && nsample[0] == nsample[1]) cbound[5] = -1.; if(cbound[1] < 0.5 && (zheta[0] >= 0. || nsample[0]!=nsample[1])) bound[1] = 1; if(cbound[1] > 0.5) bound[1] = 2; if(cbound[1] > 0.5 && zheta[1] >= 0. && bound[2] >= cbound[2]) bound[1] = 1; if(cbound[1] > 0.5 && (zheta[0]<0. || (zheta[0] >= 0. && bound[2] < cbound[2]))) bound[2] = cbound[2]; /* the upper tail almost similar */ cbound[4] = bound[4]; cbound[3] = bound[3]; cbound[6] = 1; if(nsample[4]*3>nsample[1])cbound[6]=0.5; bound[4] = cbound[6] * (knots[nknots-1] - knots[nknots-2]) + knots[nknots-1]; if(zheta[nknots-2]<0. && cbound[3] < 0.5 && nsample[0] == nsample[1]) cbound[6] = -cbound[6]; if(cbound[3] < 0.5 && (zheta[nknots-2] >=0. || nsample[0]!=nsample[1])) bound[3] = 1; if(cbound[3] > 0.5) bound[3] = 2; if(cbound[3] > 0.5 && zheta[nknots-2] >= 0. && cbound[4] >= bound[4]) bound[3] = 1; if(cbound[3] > 0.5 && (zheta[nknots-2]<0. || (zheta[nknots-2] >= 0. && bound[4] > cbound[4]))) bound[4] = cbound[4]; } /******************************************************************************/ /* this file contains a few miscelaneous routines erroradjust - computes the error criterion likeli - computes the loglikelihood linsearch - computes the winning stepsize for steepest decent onesearch - computes czheta and the loglikelihood for one zheta+shift */ /******************************************************************************/ /* this function computes the stopcriterion (zerror) and adjust the stepsize (shift) if this is too large. */ static double erroradjust(double shift[]) { double r1,r2; int i; /* all utility numbers */ /* the zerror is the sum of (shift/zheta)^2, except where zheta is very small */ r1 = 0.; for(i=0; i 1000.;i++) shift[i]=shift[i] * 3. / r2; return r1; } static double error2(double shift[], double rvr[]) { int i,j; double r=0.; for(i=0;i=0.0)j++; if(numbertester(r)==1)j=j-2; if(j<0)r=1000; return r; } /******************************************************************************/ /* this routine computes the loglikelihood */ static double likeli(double candidate[], int nsample[], double sample[], double bound[], int accuracy) { double r0,r1,likl,r3[NC+1],aa[6],bb[6]; int i1,i2,i3,i4,iv,iw; r0=exp((double)(-740)); /* the function uses numint and dens33 - which always use zheta, but the routine doesn't always compute the likelihood in zheta, sometimes at another place - so we have to swap zheta and candidate */ for(i1=0;i1<(nknots-1);i1++){ r1=zheta[i1]; zheta[i1]=candidate[i1]; candidate[i1]=r1; } /* the stuff for the exact data is easy */ likl=0.; for(i1=0;i10.5)iv=4; else iv=3; if(bound[1]>0.5)iw=2; else iw=1; aa[1]=0.; aa[2]=0.; aa[3]=1.; aa[4]=zheta[nknots-2]*coef[nknots-2][1][nknots]; aa[5]=zheta[nknots-2]*coef[nknots-2][0][nknots] +zheta[nknots-3]*coef[nknots-3][0][nknots]-log(czheta); if(nknots<4) aa[5]=zheta[nknots-2]*coef[nknots-2][0][nknots]-log(czheta); r3[nknots]=expin(iv,knots[nknots-1],bound[4],aa); bb[1]=0.; bb[2]=0.; bb[3]=1.; bb[4]=zheta[0] * coef[0][1][0]; bb[5]=zheta[0] * coef[0][0][0]-log(czheta); r3[0]=expin(iw,knots[0],bound[2],bb); for(i1=1;i1r0) likl=likl+log(r1); else likl=likl-1000; } /* in the tail */ else likl=likl+log(expin(iv,sample[i2],bound[4],aa)); } /* the left censored data */ for(i1=0;i10){ r1=numint(knots[i3-1],sample[i2],0); for(i4=0;i4r0) likl=likl+log(r1); else likl=likl-1000; } /* in the tail */ else likl=likl+log(expin(iw,sample[i2],bound[2],bb)); } } else{ /* approximate, first right censored - essentially as above there are ng3 points at xg */ if(nsample[3]>0){ i1=0; for(i2=0;i20){ i1=i1+ng3[i2]; for(i3=0;knots[i3]r0) likl=likl+ng3[i2]*log(r1); else likl=likl-1000.*ng3[i2]; } else likl=likl+ng3[i2]*log(expin(iv,xg[i2],bound[4],aa)); if(i1==nsample[3])i2=NC+3; } } } /* approximate, now left censored - essentially as above there are ng4 points at xg */ if(nsample[4]>0){ i1=0; for(i2=0;i20){ i1=i1+ng4[i2]; for(i3=0;knots[i3]0){ r1=numint(knots[i3-1],xg[i2],0); for(i4=0;i4r0) likl=likl+ng4[i2]*log(r1); else likl=likl-1000.*ng4[i2]; } else likl=likl+ng4[i2]*log(expin(iw,xg[i2],bound[2],bb)); if(i1==nsample[4])i2=NC+3; } } } /* the interval censored stuff is easy */ if(nsample[2]>0){ for(i1=0;i10.5)rt=-2.; else rt=(double)floor(log(rr)/log((double)2))-2.; /* onesearch computes the loglikelihood for one rt (stepsize) */ ll=onesearch(rt,shift,accuracy,bound,&err,nsample,sample); /* if for the basis stepsize the likelihood goes up we try more */ if(err==0 && ll>maxll){ do{ maxrt=rt; maxll=ll; rt=rt+2.; ll=onesearch(rt,shift,accuracy,bound,&err,nsample,sample); }while(rt<8.5 && ll>maxll && err==0); } /* if for the basis stepsize the likelihood goes down we try less */ else { do{ rt=rt-2.; ll=onesearch(rt,shift,accuracy,bound,&err,nsample,sample); }while(rt>-14.1 && (ll < maxll || err==1)); } /* write down the winning combination */ if(err==0 && ll>maxll){ maxrt=rt; maxll=ll; } if(maxrt > -50.){ rt = maxrt + 1; ll=onesearch(rt,shift,accuracy,bound,&err,nsample,sample); if(err==0 && ll>maxll){ maxrt=rt; maxll=ll; } maxrt=pow(2.,maxrt); for(i=0;i200){ *err=1; return 0.; } j=0; if(czheta > -5)j++; if(czheta < 5)j++; if(j==0){ *err=1; return 0.; } /* compute likeli */ ll=likeli(rv,nsample,sample,bound,accuracy); return ll; } static int numbertester(double aa) /* if aa = -Inf: 0 aa = +Inf: 1 aa = NaN: 2 otherwise: 3 */ { int i1=0,i2=0,i3=0,i4=0; if(aa< 2.){ i1=1; } if(aa> 0.){ i2=1; } if(aa< pow(10.,200.)){ i3=1; } if(aa> -pow(10.,200.)){ i4=1; } if(i1+i2+i3+i4>=3){ return 3; } if(i2==1 && i4==1){ return 1; } if(i1==1 && i3==1){ return 0; } return 2; } /******************************************************************************/ /* this file contains the following functions: expin - computes an exponential integral expin2 - computes another exponential integral dens3 - computes a logspline-density in one point dens33 - computes the log of a logspline-density in one point numint - computes a numerical integral numints- computes a vector of numerical integrals */ /******************************************************************************/ /* this function computes (analytical) the integral: t1 t1 inf t2 / / / / 2. a4*x+a5 | | | |(a1*x +a2*x+a3)*e dx / / / / -inf t2 t1 t1 1 2. 3 4 <==== version */ static double expin(int version, double t1, double t2, double a[]) /* input: a,b,c,d,e,t1,t2,version: see figure above local: a1,b1,c1: as a,b and c, but for the primitive. f1,f2 half-products */ /* this version does not contain much information - the best way to figure out what is happening is to compute the integrals above, and then check below */ { double a1,b1,c1,f1,f2; int i1,i2; /* if d=0 and version is 1 or 3 well........... */ if(a[4]!=0 || version == 1 || version ==3){ a1 = a[1]/a[4]; b1 = (a[2]-2*a1)/a[4]; c1 = (a[3]-b1)/a[4]; f1 = a1*t1*t1+b1*t1+c1; i1 = 1; if(f1<0) i1 = -1; f1 = log(fabs(f1)) + a[4]*t1+a[5]; if(f1>2000.) f1=2000.; if(version==2 || version == 4){ f2 = a1*t2*t2+b1*t2+c1; i2 = 1; if(f2<0) i2= -1; f2 = log(fabs(f2)) + a[4]*t2+a[5]; if(f2 > 2000.) f2=2000.; if(version == 2)return i1*exp(f1)-i2*exp(f2); return i2*exp(f2)-i1*exp(f1); } if(version==1) return i1*exp(f1); return -i1*exp(f1); } a1 = (((a[1]/3)*(t2-t1)+a[2]/2)*(t2-t1)+a[3])*(t2-t1)*exp(a[5]); if(version==4)return a1; return -a1; } /******************************************************************************/ /* This function computes a similar integral, but with a higher order leading polinomial */ static double expin2(int version, double t1, double t2, double aa[], double b1, double b0) /* input: aa,b1,b0,t1,t2,version: see figure above local: u6,u5,u4,u3,u2,u1,u0: as a4,a3,a2,a1,a0, but for the primitive. f1,f2 half-products */ /* this version does not contain much information - the best way to figure out what is happening is to compute the integrals above, and then check below */ { double u6,u5,u4,u3,u2,u1,u0,f1,f2; int i1,i2; /* if b1=0 and version is 1 or 3 well........... */ if(b1!=0 || version ==1 || version == 3){ u6 = aa[6]/b1; u5 = (aa[5]-6*u6)/b1; u4 = (aa[4]-5*u5)/b1; u3 = (aa[3]-4*u4)/b1; u2 = (aa[2]-3*u3)/b1; u1 = (aa[1]-2*u2)/b1; u0 = (aa[0]-u1)/b1; f1 = (((((u6*t1+u5)*t1+u4)*t1+u3)*t1+u2)*t1+u1)*t1+u0; i1 = 1; if(f1<0) i1 = -1; f1 = log(fabs(f1)) + b1*t1+b0; if(f1>2000.) f1=2000.; if(version==2 || version == 4){ f2 = (((((u6*t2+u5)*t2+u4)*t2+u3)*t2+u2)*t2+u1)*t2+u0; i2 = 1; if(f2<0) i2= -1; f2 = log(fabs(f2)) + b1*t2+b0; if(f2 > 2000.) f2=2000.; if(version == 2)return i1*exp(f1)-i2*exp(f2); return i2*exp(f2)-i1*exp(f1); } if(version==1) return i1*exp(f1); return -i1*exp(f1); } u6 = (((aa[6]/7*(t2-t1)+aa[5]/6)*(t2-t1)+aa[4]/5)*(t2-t1)+aa[3]/4)*(t2-t1); u6 = (((u6 + aa[2]/3)*(t2-t1)+aa[1]/2)*(t2-t1)+aa[0])*(t2-t1)*exp(b0); if(version==4)return u6; return -u6; } /******************************************************************************/ /* this function return a value from a logspline density */ static double dens3(double x) /* point of interest */ { return exp(dens33(x)); } /******************************************************************************/ /* this function return the log of a value from a logspline density */ static double dens33(double x) /* point of interest */ { int j,k; double f; /* circle through the knots */ for(j=0; (j knots[j]); j++); f = -log(czheta); /* find in between which knots the point is, and compute the spline */ for(k=j-3; k=0 && k<=nknots){ f = f + zheta[k] * (coef[k][0][j] + x * (coef[k][1][j] + x * (coef[k][2][j] + x * coef[k][3][j]))); } } return f; } /******************************************************************************/ /* Numerical integration using gaussian quadrature. See Abromowitz and Stegun. k1 and k2: lower and upper integration bounds fun : function to be integrated */ static double numint(double k1, double k2, int accuracy) /* Intgerals using Gauss-Legendre quadrature with 12 points y1,y2,... - abisces w1,w2,... - weight accuracy - accuracy r1 and r2 - from (k1,k2) to (-1,1) */ { double r1,r2,w[33],y[33]; int i; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); if(accuracy == 0 || accuracy == 1){ w[1] = 0.467913934572691 * r1; y[1] = 0.238619186083197 * r1; w[2] = 0.360761573048139 * r1; y[2] = 0.661209386466265 * r1; w[3] = 0.171324429379170 * r1; y[3] = 0.932469514203152 * r1; r1 = 0.; for(i=1;i<4;i++)r1 = r1 + w[i]*(dens3(r2-y[i])+dens3(r2+y[i])); return r1; } w[ 1]= 0.00178328072169643 * r1; y[1 ]= 0.99930504173577217 * r1; w[ 2]= 0.00414703326056247 * r1; y[2 ]= 0.99634011677195533 * r1; w[ 3]= 0.00650445796897836 * r1; y[3 ]= 0.99101337147674429 * r1; w[ 4]= 0.00884675982636395 * r1; y[4 ]= 0.98333625388462598 * r1; w[ 5]= 0.01116813946013113 * r1; y[5 ]= 0.97332682778991098 * r1; w[ 6]= 0.01346304789671864 * r1; y[6 ]= 0.96100879965205377 * r1; w[ 7]= 0.01572603047602472 * r1; y[7 ]= 0.94641137485840277 * r1; w[ 8]= 0.01795171577569734 * r1; y[8 ]= 0.92956917213193957 * r1; w[ 9]= 0.02013482315353021 * r1; y[9 ]= 0.91052213707850282 * r1; w[10]= 0.02227017380838325 * r1; y[10]= 0.88931544599511414 * r1; w[11]= 0.02435270256871087 * r1; y[11]= 0.86599939815409277 * r1; w[12]= 0.02637746971505466 * r1; y[12]= 0.84062929625258032 * r1; w[13]= 0.02833967261425948 * r1; y[13]= 0.81326531512279754 * r1; w[14]= 0.03023465707240248 * r1; y[14]= 0.78397235894334139 * r1; w[15]= 0.03205792835485155 * r1; y[15]= 0.75281990726053194 * r1; w[16]= 0.03380516183714161 * r1; y[16]= 0.71988185017161088 * r1; w[17]= 0.03547221325688239 * r1; y[17]= 0.68523631305423327 * r1; w[18]= 0.03705512854024005 * r1; y[18]= 0.64896547125465731 * r1; w[19]= 0.03855015317861563 * r1; y[19]= 0.61115535517239328 * r1; w[20]= 0.03995374113272034 * r1; y[20]= 0.57189564620263400 * r1; w[21]= 0.04126256324262353 * r1; y[21]= 0.53127946401989457 * r1; w[22]= 0.04247351512365359 * r1; y[22]= 0.48940314570705296 * r1; w[23]= 0.04358372452932345 * r1; y[23]= 0.44636601725346409 * r1; w[24]= 0.04459055816375657 * r1; y[24]= 0.40227015796399163 * r1; w[25]= 0.04549162792741814 * r1; y[25]= 0.35722015833766813 * r1; w[26]= 0.04628479658131442 * r1; y[26]= 0.31132287199021097 * r1; w[27]= 0.04696818281621002 * r1; y[27]= 0.26468716220876742 * r1; w[28]= 0.04754016571483031 * r1; y[28]= 0.21742364374000708 * r1; w[29]= 0.04799938859645831 * r1; y[29]= 0.16964442042399283 * r1; w[30]= 0.04834476223480295 * r1; y[30]= 0.12146281929612056 * r1; w[31]= 0.04857546744150343 * r1; y[31]= 0.07299312178779904 * r1; w[32]= 0.04869095700913972 * r1; y[32]= 0.02435029266342443 * r1; r1 = 0.; for(i=1;i<33;i++)r1 = r1 + w[i]*(dens3(r2-y[i])+dens3(r2+y[i])); return r1; } /******************************************************************************/ /* Numerical integration using gaussian quadrature. See Abromowitz and Stegun. k1 and k2: lower and upper integration bounds fun : function to be integrated */ static double numint2(double k1,double k2,int accuracy) /* Intgerals using Gauss-Legendre quadrature with 12 points y1,y2,... - abisces w1,w2,... - weight accuracy - accuracy r1 and r2 - from (k1,k2) to (-1,1) */ { double r1,r2,w[33],y[33]; int i; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); if(accuracy == 0 || accuracy == 1){ w[1] = 0.467913934572691 * r1; y[1] = 0.238619186083197 * r1; w[2] = 0.360761573048139 * r1; y[2] = 0.661209386466265 * r1; w[3] = 0.171324429379170 * r1; y[3] = 0.932469514203152 * r1; r1 = 0.; for(i=1;i<4;i++)r1 = r1 + w[i]*(fun2(r2-y[i])+fun2(r2+y[i])); return r1; } w[ 1]= 0.00178328072169643 * r1; y[1 ]= 0.99930504173577217 * r1; w[ 2]= 0.00414703326056247 * r1; y[2 ]= 0.99634011677195533 * r1; w[ 3]= 0.00650445796897836 * r1; y[3 ]= 0.99101337147674429 * r1; w[ 4]= 0.00884675982636395 * r1; y[4 ]= 0.98333625388462598 * r1; w[ 5]= 0.01116813946013113 * r1; y[5 ]= 0.97332682778991098 * r1; w[ 6]= 0.01346304789671864 * r1; y[6 ]= 0.96100879965205377 * r1; w[ 7]= 0.01572603047602472 * r1; y[7 ]= 0.94641137485840277 * r1; w[ 8]= 0.01795171577569734 * r1; y[8 ]= 0.92956917213193957 * r1; w[ 9]= 0.02013482315353021 * r1; y[9 ]= 0.91052213707850282 * r1; w[10]= 0.02227017380838325 * r1; y[10]= 0.88931544599511414 * r1; w[11]= 0.02435270256871087 * r1; y[11]= 0.86599939815409277 * r1; w[12]= 0.02637746971505466 * r1; y[12]= 0.84062929625258032 * r1; w[13]= 0.02833967261425948 * r1; y[13]= 0.81326531512279754 * r1; w[14]= 0.03023465707240248 * r1; y[14]= 0.78397235894334139 * r1; w[15]= 0.03205792835485155 * r1; y[15]= 0.75281990726053194 * r1; w[16]= 0.03380516183714161 * r1; y[16]= 0.71988185017161088 * r1; w[17]= 0.03547221325688239 * r1; y[17]= 0.68523631305423327 * r1; w[18]= 0.03705512854024005 * r1; y[18]= 0.64896547125465731 * r1; w[19]= 0.03855015317861563 * r1; y[19]= 0.61115535517239328 * r1; w[20]= 0.03995374113272034 * r1; y[20]= 0.57189564620263400 * r1; w[21]= 0.04126256324262353 * r1; y[21]= 0.53127946401989457 * r1; w[22]= 0.04247351512365359 * r1; y[22]= 0.48940314570705296 * r1; w[23]= 0.04358372452932345 * r1; y[23]= 0.44636601725346409 * r1; w[24]= 0.04459055816375657 * r1; y[24]= 0.40227015796399163 * r1; w[25]= 0.04549162792741814 * r1; y[25]= 0.35722015833766813 * r1; w[26]= 0.04628479658131442 * r1; y[26]= 0.31132287199021097 * r1; w[27]= 0.04696818281621002 * r1; y[27]= 0.26468716220876742 * r1; w[28]= 0.04754016571483031 * r1; y[28]= 0.21742364374000708 * r1; w[29]= 0.04799938859645831 * r1; y[29]= 0.16964442042399283 * r1; w[30]= 0.04834476223480295 * r1; y[30]= 0.12146281929612056 * r1; w[31]= 0.04857546744150343 * r1; y[31]= 0.07299312178779904 * r1; w[32]= 0.04869095700913972 * r1; y[32]= 0.02435029266342443 * r1; r1 = 0.; for(i=1;i<33;i++)r1 = r1 + w[i]*(fun2(r2-y[i])+fun2(r2+y[i])); return r1; } /***************************************/ static double numints(double vv[],double k1,double k2,int accuracy,int ip) /* Intgerals using Gauss-Legendre quadrature with 12 points y1,y2,... - abisces w1,w2,... - weight accuracy - accuracy r1 and r2 - from (k1,k2) to (-1,1) */ { double y[33],w[33],r1,r2; int i1; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); if(accuracy == 0 || accuracy == 1){ w[1 ]= 0.467913934572691 * r1; y[1 ]= 0.238619186083197 * r1; w[2 ]= 0.360761573048139 * r1; y[2 ]= 0.661209386466265 * r1; w[3 ]= 0.171324429379170 * r1; y[3 ]= 0.932469514203152 * r1; for(i1=0;i1= 4){ for(i=1; i= 5){ for(i=1; i 0 && j < nknots+1 && (i != 0 || j != 3)){ if(k != 1){ coef[i][0][j] = coef[i][0][j] - coef2[i][k] * pow(knots[k-2], 3.); coef[i][1][j] = coef[i][1][j] + 3. * coef2[i][k] * pow(knots[k-2], 2.); coef[i][2][j] = coef[i][2][j] - 3. * coef2[i][k] * knots[k-2]; coef[i][3][j] = coef[i][3][j] + coef2[i][k]; } } } } } } /******************************************************************************/ /* These are two functions to compute the starting values. The first one gathers statistics from all the datapoints and knots. The second one computes the starting values from these statistics */ static void start1(double crossprods[][NC],double derivatives[],double sample[],int nsample[]) /* the objective of this routine is the computation of derivatives and crossproducts */ /* sample,nsample,nknots, accuracy and knots see lhead.h and originating file derivatives[0] = sum((sample))'' which is 0.... derivatives[i] = sum(([(sample-knot[i-1])+]^3)'') crossprods[0][0] = sum((sample)'*(sample)')=nsample[0] crossprods[i][0] = sum(([(sample-knot[i-1])+]^3)'*(sample)') crossprods[0][i] = sum(([(sample-knot[i-1])+]^3)'*(sample)') crossprods[i][j] = sum(([(sample-knot[i-1])+]^3)'*([(sample-knot[j-1])+]^3)') they are used in start2 to compute starting values */ { int i,j,k,i2,i3; double xs,uuu,rr,rs; /* counters, utility */ /* Initializations */ for(i=0; irr) rr=sample[i]; for(i=0;i0)for(j=0; jknots[j]){ derivatives[j+1] = derivatives[j+1] + 6 * (sample[i] - knots[j]); crossprods[j+1][0]=crossprods[j+1][0]+3*pow(sample[i]-knots[j],2.); for(k=0; k<=j; k++) crossprods[j+1][k+1] = crossprods[j+1][k+1] + 9 * pow(((sample[i] - knots[j]) * (sample[i] - knots[k])),2.); } } } /* The interval censored part - we take the midpoints of the intervals */ if(nsample[2]>0)for(j=0; jknots[j]){ derivatives[j+1] = derivatives[j+1] + 6 * (xs - knots[j]); crossprods[j+1][0]=crossprods[j+1][0]+3*pow(xs-knots[j],2.); for(k=0; k<=j; k++) crossprods[j+1][k+1] = crossprods[j+1][k+1] + 9 * pow(((xs - knots[j]) * (xs - knots[k])),2.); } } } /* The right censored part */ if(nsample[3]>0)for(j=0; jknots[j]){ derivatives[j+1] = derivatives[j+1] + 1.5 * (uuu - knots[j]); crossprods[j+1][0]=crossprods[j+1][0]+0.75*pow(uuu-knots[j],2.); for(k=0; k<=j; k++) crossprods[j+1][k+1] = crossprods[j+1][k+1] + 2.25 * pow(((uuu - knots[j]) * (uuu - knots[k])),2.); } } } /* The left censored part */ if(nsample[4]>0)for(j=0; jknots[j]){ derivatives[j+1] = derivatives[j+1] + 1.5 * (uuu - knots[j]); crossprods[j+1][0]=crossprods[j+1][0]+0.75*pow(uuu-knots[j],2.); for(k=0; k<=j; k++) crossprods[j+1][k+1] = crossprods[j+1][k+1] + 2.25 * pow(((uuu - knots[j]) * (uuu - knots[k])),2.); } } } /* symmetarize crossprods */ for(j=0; j4){ for(i=0; i2){ zheta[0]=r1; zheta[1]=r2; } if(iremove<3){ zheta[0]=r1/25.; zheta[1]=r2/25.; } if(iremovenknots-3){ zheta[nknots-3]=r3/25.; if(nknots==4&&iremove==3)zheta[1]=(r2+r3)/50.; zheta[nknots-2]=r4/25.; } } /* If the zhetas are too large, we are better of if we make them smaller */ else{ r1=0.; for(i=0;i10000) for(i=0;i knots[i-2]) suffcombine[i][0] = suffcombine[i][0] + pow(sample[j] - knots[i-2], 3.)/(double)nsample[0] ; } /* for the interval censored observations */ for(j=0; j knots[i-2]) suffcombine[i][1] = suffcombine[i][1] + pow(rr - knots[i-2], 3.)/(double)nsample[0] ; } } /******************************************************************************/ static void suffstat2(double suffcombine[][2],double coef2[][NC],double sufficient[][2]) /* all defined in lhead.h and the file where they originate. suffcombine defined in suffstat1 */ { int i,j; /* counters */ /* over the basisfunctions */ for(i=0;i12){ qt[0]=knots[4]; qt[1]=knots[nknots-5]; } if(iknotauto == 0&&nknots>9 && nknots <13){ qt[0]=knots[3]; qt[1]=knots[nknots-4]; } if(iknotauto == 0&&nknots>6 && nknots <10){ qt[0]=knots[2]; qt[1]=knots[nknots-3]; } if(iknotauto == 0&&nknots==3){ qt[0]=(knots[0]+knots[1])/2.; qt[1]=(knots[2]+knots[1])/2.; } if(iknotauto == 0&&nknots>3 &&nknots<7){ qt[0]=knots[1]; qt[1]=knots[nknots-2]; } if(iknotauto == 1){ /* compute the piecewise density */ il = piecedens(sample,smp2,smp3,nsample); kk = floor((double)il/2+2.1); if(nknots>kk && nsample[5]==0){ nknots=kk; if(SorC[0] == 0) (void) Rprintf("running with maximum number of degrees of freedom"); else SorC[20] = 1; } if(nknots==nsample[5]+1)SorC[20]=1; /* Check whether there are not too many knots */ kk=0; ll=0; do{ ll=kk+ll; kk=0; if(bound[1] < 0.5 && bound[3] < 0.5){ /* all knots are a minimum of "five" apart */ if((nknots-1) * five >= nsample[0] - 1){ i = floor(1. + (nsample[0] - 1.) / five); if(SorC[0] == 0){ (void)Rprintf("too many knots, at most %d knots possible\n",i); SorC[0] = -647; } else { SorC[0] = -2; SorC[1] = i; } return; } /* place the 2 extreme knots */ rknots[0] = 1.; rknots[nknots-1] = nsample[0]; /* j and j2 are this way to deal both with odd and even situations */ j = ceil((nknots-1)/2.); j2 = floor((nknots-1)/2.); /* eps1 and eps2 are lower and upper bound on eps, eps is our first guess. */ eps1 = five - pow(((nsample[0] - 1) / five),(1. / (j - 1))); if(eps1 > 0.) eps1 = 0.; eps2 = five - 1.; /* s should become exactly (nsample[0]-1)/2: in that case the knots are symmetric and cover exactly the whole range. We here compute what s would be for the present value of eps s is the span of all the knots: i.e. the location of the middle knot if the first knot is at 1, nknots as specified and eps as guessed. */ do{ eps = (eps1 + eps2) / 2.; s = 1.; w = five; for(i=1; i<=j2; i++){ v = i; /* s is the location after adding another knot */ s = s + w; /* we store the rknots - in case they are good */ rknots[i] = s; rknots[nknots-i-1] = nsample[0] + 1 - s; v = five - v * eps; /* w is what is going to be the next gap */ if(v < 1.) v = 1.; w = w * v; } /* Are there an odd or even number of gaps? */ if(j * 2 == nknots) /* even - no more knots to place. */ s = s + w/2.; else /* odd - the last knot */ rknots[j] = (nsample[0] + 1.) / 2.; /* Is eps too large or too small? */ if(2. * s >= nsample[0]+1) eps1 = eps; else eps2 = eps; /* Are eps1 and eps2 close together */ } while(eps2 - eps1 > .001); } else{ /* if both sides there are finite limits we put them equidistant */ if(bound[1] > 0.5 && bound[3] > 0.5){ for(i=0;i 0.5) rknots[i] = s; else rknots[nknots-i-1]=nsample[0]+1.-s; v = five - v *eps; /* w is what is going to be the next gap */ if(v < 1.) v = 1.; w = w * v; } /* Is eps too large or too small? */ if(s + w >(double)nsample[0]) eps1 = eps; else eps2 = eps; /* Are eps1 and eps2 close together */ } while(eps2 - eps1 > .001); } } if(nknots==3)rknots[1]=nsample[0]/2.; /* Translate rknots in knots */ if(ll==0){ /* the first two knots are easy */ knots[0] = smp2[0]; knots[nknots-1] = smp2[il]; /* cycle through the endpoints, average */ k = 0; for(i=1;i=rknots[i]){ knots[i]=((rknots[i]-smp3[k-1])*smp2[k]+ (smp3[k]-rknots[i])*smp2[k-1])/(smp3[k]-smp3[k-1]); ia=k; k=k+4*il; } } k=ia; } } /* find the first and the third quartile */ for(i=1;i0.25*nsample[0]){ u3=smp2[i]; i=i+2*il; qt[0]=u3; } } for(i=1;i0.75*nsample[0]){ u4=smp2[i]; i=i+2*il; qt[1]=u4; } } /* knots that are close together at the end, are an indicator of a discontinuity we replace the knots if this happens. kk is an indicator that somthing like this is the case - we fix this by, temporarily, cheating and saying that there is a discontinuity (changing bound), ll reminds us to change back, by the way, u2 is the IQR of the data */ if(bound[1]<0.5){ u1=knots[2]-knots[0]; u2=u4-u3; if(u10); if(ll==1||ll==3)bound[1]=0.; if(ll==2||ll==3)bound[3]=0.; /* if after previous changes these knots are still to close together, the density might be real high at the end - we toss out knots in this case */ u1=knots[nknots-1]-knots[nknots-3]; u2=u4-u3; if(u1 knots[j]){ j++; knots[j]=knots[i]; } else { k++; if(SorC[0] == 8){ (void)Rprintf("===> warning: knot %d removed - double knot\n",i+1); if(k == 2){ (void) Rprintf("* several double knots suggests that your data is *\n"); (void) Rprintf("* strongly rounded: attention might be required. *\n"); } } else { SorC[0] = 2 + k; if(SorC[0] == 23)return; SorC[k] = i+1; } } } nknots = j+1; nsample[0]=w1; nsample[1]=w2; nsample[2]=w3; nsample[3]=w4; nsample[4]=w5; nsample[5]=w6; u3=2./(qt[1]-qt[0]); u4=1.-2.*qt[1]/(qt[1]-qt[0]); qt[0]=u4; qt[1]=u3; for(i=0;i=NC || (nknots > nsample[5]+1 && nsample[5]>1)){ if(SorC[0]==0) (void)Rprintf("can not run with that many knots\n"); else SorC[20]=1; nknots=NC-1; if(nknots > nsample[5]+1)nknots=nsample[5]+1; } if(nknots > 0) return nknots; r = 2.5*pow((double)nn,0.2); if(idelete > 0)r=1.6*r; if(idelete > 0 && nn < 51)r=(double)nn/6.; if(r>NC-1.1)r=NC-1.1; if(r<2.5)r=2.5; if(nsample[5]!=0 && r>nsample[5]+1)r=nsample[5]+0.1; return ceil(r); } /******************************************************************************/ static int piecedens(double sample[],double smp2[],double smp3[],int nsample[]) { int i,j,il,k,m,n; if(nsample[1]>0){ i=1; j=nsample[1]; F77_CALL(xssort)(sample,smp3,&j,&i); } if(nsample[2]>0){ for(i=0;i0){ for(i=0;i0){ for(i=0;i0){ for(i=0;i=0;i=i-1){ if(smp3[i]>0){ smp3[i+1]=smp3[i+1]+0.5*smp3[i]; smp3[i]=0.5*smp3[i]; } } if(nsample[2]>0){ k=0; for(i=0;i=0 && i3 < nknots-1) dfunpar[i2]=dfunpar[i2]+coef[i3][i2-1][i1]*zheta[i3]; } } cth = cth + numint2(knots[i1-1],knots[i1],accuracy); } return cth; } /* The integrals are computed numerically per interval between knots */ for(i1=1;i1=0 && i2 < nknots-1 && (i2!=0 || i1!=3)){ shift[i2] = shift[i2] + qolint[0][i1] * coef[i2][0][i1] + qolint[1][i1] * coef[i2][1][i1] + qolint[2][i1] * coef[i2][2][i1] + qolint[3][i1] * coef[i2][3][i1]; /* For the information matrix we need integrals of a basisfunction times a basisfunction times the density, this is a combination of qolints. Many combinations do not exist. */ if(what==2){ for(i3=i1-3;i3<=i2;i3++) if(i3>=0 && i3 < nknots-1 && (i3!=0 || i1!=3)) for(i5=0;i5<4;i5++) for(i4=0;i4<4;i4++) info[i2][i3] = info[i2][i3] + qolint[i5+i4][i1] * coef[i2][i5][i1] * coef[i3][i4][i1]; } } } } /* The following lines make the informationmatrix and score function from what is stored into score and info up to now. */ if(what==2){ for(i1=0;i1 0.5) version=4; version2=1; if(bound[1] > 0.5) version2=2; d1 = zheta[nknots-2] * coef[nknots-2][1][nknots]; d2 = zheta[0] * coef[0][1][0]; e2 = zheta[0] * coef[0][0][0] -log(czheta); if(nknots>3) e1 = zheta[nknots-2] * coef[nknots-2][0][nknots] + zheta[nknots-3] * coef[nknots-3][0][nknots]-log(czheta); else e1 = zheta[nknots-2] * coef[nknots-2][0][nknots]-log(czheta); for(i2=0;i2<7;i2++)aa[i2]=0.; for(i2=0;i2<7;i2++){ aa[i2]=1.; if(i2!=0)aa[i2-1]=0.; qolint[i2][nknots]=expin2(version,knots[nknots-1],bound[4],aa,d1,e1); } for(i2=0;i2<7;i2++)aa[i2]=0.; for(i2=0;i2<7;i2++){ aa[i2]=1.; if(i2!=0)aa[i2-1]=0.; qolint[i2][0]=expin2(version2,knots[0],bound[2],aa,d2,e2); } if(accuracy!=0){ if(nsample[3]>0){ k0=1; for(i2=0;i20){ k0=1; for(i2=0;i20){ k0=1; for(i2=0;i20){ i1=0; for(i2=0;i20){ i1=i1+ng3[i2]; intnum3(xg[i2],qolint,d1,e1,version,bound[4],shift,info, ng3[i2],nsample[0],what); if(i1==nsample[3])i2=NC+3; } } } if(nsample[4]>0){ i1=0; for(i2=0;i20){ i1=i1+ng4[i2]; intnum4(xg[i2],qolint,d2,e2,version2,bound[2],shift,info, ng4[i2],nsample[0],what); if(i1==nsample[4])i2=NC+3; } } } } } for(i1=0;i10) for(i1=0;i1jl && i1=0){ if(i1>jl && i1=0 && i1>jl && i1=0){ for(i2=0; i2<4; i2++) z1[i3] = z1[i3] + coef[i3][i2][jl] * y1[i2]; if(what == 2){ for(i4=jl-3; i4<=jl && i4=0) for(i2=0;i2<4;i2++) for(i5=0;i5<4;i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][jl] * y1[i2+i5] * coef[i4][i5][jl]; } } /* we now compute them for the interval in which the right endpoint is - since y2 = 0 if this interval is the same as the left one, we do not count double*/ for(i3=jr-3; i3<=jr && i3=0){ for(i2=0; i2<4; i2++) z1[i3] = z1[i3] + coef[i3][i2][jr] * y2[i2]; if(what == 2){ for(i4=jr-3; i4<=jr && i4=0) for(i2=0;i2<4;i2++) for(i5=0;i5<4;i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][jr] * y2[i2+i5] * coef[i4][i5][jr]; } } /* now we update shift and info */ if(z0>0.){ for(i3=0; i3jin) z0=z0+qolint[0][i1]; for(i3=i1-3; i3<=i1 && i3=0){ if(i1>jin) for(i2=0; i2<4; i2++) z1[i3]=z1[i3]+coef[i3][i2][i1]*qolint[i2][i1]; if(what==2){ for(i4=i1-3; i4<=i1 && i4=0 && i1>jin) for(i2=0; i2<4; i2++) for(i5=0; i5<4; i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][i1] * qolint[i2+i5][i1] * coef[i4][i5][i1]; } } } /* add the one in the interval in which the point is */ z0=z0+yy[0]; for(i3=jin-3; i3<=jin && i3=0){ for(i2=0; i2<4; i2++) z1[i3] = z1[i3] + coef[i3][i2][jin] * yy[i2]; if(what == 2){ for(i4=jin-3; i4<=jin && i4=0) for(i2=0; i2<4; i2++) for(i5=0; i5<4; i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][jin] * yy[i2+i5] * coef[i4][i5][jin]; } } /* update shift and info */ if(z0>0.){ for(i3=0; i30) (void)numints(yy,knots[jin-1],x,0,im); else{ for(i1=0; i1<7; i1++){ aa[i1]=1.; if(i1!=0) aa[i1-1]=0.; yy[i1]=expin2(vs,x,bd,aa,d1,e1); } } /* initialize */ z0=0.; for(i1=0; i1=0){ if(i1=0 && i1=0){ for(i2=0; i2<4; i2++) z1[i3] = z1[i3] + coef[i3][i2][jin] * yy[i2]; if(what == 2){ for(i4=jin-3; i4<=jin && i4=0) for(i2=0; i2<4; i2++) for(i5=0; i5<4; i5++) z2[i3][i4] = z2[i3][i4] + coef[i3][i2][jin] * yy[i2+i5] * coef[i4][i5][jin]; } } /* update shift and info */ if(z0>0.){ for(i3=0; i3=1){ for(i=0;i 0.5) version=2; /* The numbers a1,b1,c1,d1,e1 are constants in the integrals */ a[1] = 0.; a[4] = zheta[0] * coef[0][1][0]; a[5] = zheta[0] * coef[0][0][0]; if(what==0){ a[2] = 0.; a[3] = 1.; cth = expin(version,knots[0],bound[2],a); } else{ a[2] = coef[0][1][0]; a[3] = coef[0][0][0]; shift[0] = expin(version,knots[0],bound[2],a) /czheta; if(what==2){ a[1]=coef[0][1][0]*coef[0][1][0]; a[2]=coef[0][1][0]*coef[0][0][0]*2.; a[3]=coef[0][0][0]*coef[0][0][0]; info[0][0] =expin(version,knots[0],bound[2],a)/czheta; } } /* Now the right tail. Only the last 2 basisfunctions are not equal to 0 here. The last one has a linear and a constant term, the one but last one only a constant term. */ version=3; if(bound[3] > 0.5) version=4; a[1] = 0.; a[4] = zheta[nknots-2] * coef[nknots-2][1][nknots]; if(nknots>3) a[5] = zheta[nknots-2] * coef[nknots-2][0][nknots] + zheta[nknots-3] * coef[nknots-3][0][nknots]; else a[5] = zheta[nknots-2] * coef[nknots-2][0][nknots]; if(what == 0){ a[2] = 0.; a[3] = 1.; cth = cth + expin(version,knots[nknots-1],bound[4],a); } else { if(nknots>3){ a[2] = 0.; a[3] = coef[nknots-3][0][nknots]; shift[nknots-3] = expin(version,knots[nknots-1],bound[4],a)/czheta; } a[2] = coef[nknots-2][1][nknots]; a[3] = coef[nknots-2][0][nknots]; shift[nknots-2] = expin(version,knots[nknots-1],bound[4],a)/czheta; } if(what == 2 && nknots>3){ a[2] = 0.; a[3] = coef[nknots-3][0][nknots] * coef[nknots-3][0][nknots]; info[nknots-3][nknots-3]=expin(version,knots[nknots-1],bound[4],a)/czheta; a[2] = coef[nknots-3][0][nknots] * coef[nknots-2][1][nknots]; a[3] = coef[nknots-3][0][nknots] * coef[nknots-2][0][nknots]; info[nknots-2][nknots-3]=expin(version,knots[nknots-1],bound[4],a)/czheta; info[nknots-3][nknots-2] = info[nknots-2][nknots-3]; } if(what == 2){ a[1] = coef[nknots-2][1][nknots] * coef[nknots-2][1][nknots]; a[2] = coef[nknots-2][0][nknots] * coef[nknots-2][1][nknots] *2.; a[3] = coef[nknots-2][0][nknots] * coef[nknots-2][0][nknots]; info[nknots-2][nknots-2]=expin(version,knots[nknots-1],bound[4],a)/czheta; } return cth; } /******************************************************************************/ /* static int where(x,knots,lk) double x,knots[]; int lk; { int i; if(x=knots[lk-1])return lk; for(i=1;i #include #include "R.h" #define Salloc(n, t) (t *)R_alloc((long)(n), (int)sizeof(t)) /* we want to be able to use those everywhere */ #define MAXSPACE 250 #define MAXKNOTS 10 #define DIM5 MAXSPACE+5 void F77_NAME(xdsifa)(double[][DIM5], int *, int *, int *, int *); void F77_NAME(xdsisl)(double[][DIM5], int *, int *, int *, double *); void F77_NAME(xdsidi)(double[][DIM5], int *, int *, int *, double *, int *, double *, int *); void F77_NAME(xdgefa)(double[][DIM5], int *, int *, int *, int *); void F77_NAME(xdgedi)(double[][DIM5], int *, int *, int *, double *, double *, int *); /* MAXSPACE - maximum dimensionality of the model MAXKNOTS - maximum number of knots for one covariate */ struct datastruct { int ndata,ncov,*bincov,nclass,*yy,*icov; double **work,**work2,*wgt,wgtsum; }; /* datastruct is a structure containing all information about the data. At any time there is only one datastruct, which is typically called data. ndata - number of datapoints ncov - number of covariates nclass - how many classes are there bincov - are the covariates binary? 0=no, 1=yes binary cov should be 0-1 yy - response cov - covariates cov[i][j] is covariate j for observation i work - also to keep exp(theta-c) work2 - also to keep theta-bar(theta) wgt - case weights */ struct space { int ndim,nbas; double aic,**info,*score,**infox,epsilon,logl; struct basisfunct *basis; struct subdim **sub; }; /* space is the basic structure containing a model. The main ingredients are a (sort of double) representation of the basisfunctions: by means of basis on a basisfunction by basisfunction scale and by means of sub on a subdimension scale ndim - the dimensionality of the space nbas - number of basis functions ndim=nbas*(nclass-1) aic - the aic value of the present model - only accurate after the model has been fitted. info - the hessian of the model infox - epsilon term for the hessian epsilon - epsilon for the penalty term score - the score vector of the model basis - the array of basisfunctions sub - the matrix of subdimensions element: [i][data.ncov] (0<=i0.){ pswapspace(current,new,data); /* announce the result */ if(silent!=1){ i=(*current).nbas-1; puuu(current,(*current).basis[i].b1,(*current).basis[i].b2, (*current).basis[i].t1,(*current).basis[i].t2,ncov,0); (void)Rprintf("(rao=%.2f)\n",criterion); } return 1; } /* failure */ else return 0; } /******************************************************************************/ /* this routine pearches a subdimension for a supspace to add */ static double padders1(int i0, int j0, struct space *new, struct space *newt, double crit, struct datastruct *data) /* i0,j0 - which subspace (see pstruct) new - will be the best space with additions up to now. newt - actually a copy of current, we play with it until we are done current - sometimes we need two of them (see newt) crit - the best rao statistic (chi-square p-value) up to now data - structure containing the data */ { int i,j,d1,d2,d3; /* pswapspace- copies one space into another i,j - counter pestbasis - does the work for 2d dimensions and 1d where no pearch needed critx - possibly optimal criterion d1,d2,d3 - save typing */ d1=(*newt).sub[i0][j0].dim1; d2=(*newt).sub[i0][(*data).ncov].dim1; d3=(*newt).sub[j0][(*data).ncov].dim1; /* a 1-d space */ if(j0==(*data).ncov){ /* a covariate that has not yet been entered */ if(d1==0) crit=pestbasis(new,newt,crit,data,i0,j0,0,-1,(double)0); /* a covariate that has been entered before */ else return crit; } /* a 2-d space */ else{ /* linear x linear */ if(d2>0 && d3>0 ){ if(d1==0){ crit=pestbasis(new,newt,crit,data,i0,j0,-1,-1,(double)0); } else{ for(i=0;i0){ /* knot x knot */ for(j=0;j0){ crit=pestbasis( new,newt,crit,data,i0,j0,i,j,(double)0); } } } else{ /* knot x linear */ crit=pestbasis(new,newt,crit,data,i0,j0,i,-1,(double)0); } } for(j=0;jcrit){ crit=critx; pswapspace(new,current,data); } } } return crit; } /******************************************************************************/ /* if a new knot is to be added in a one-covariate dimension or in time, we have to pearch, and that is what we do in this routine */ static double pearch(struct space *new, struct space *newt, struct datastruct *data, int i0, int mind, double crito) /* new - the best added space up to now newt - a space to which we can add data - data i0 - first coordinate of the subdimension (second is data.ncov) mind - minimum distance (in order statistics) between knots crito - old criterion */ { double *sorted,critnew,crit,crit2,*kts; int i,lgth,iloc=0,lloc=0,bloc,uloc=0,iloc2,ll,uu,nx,l; /* sorted - sorted data or covariate critnew - new criterion crit - best criterion up to now crit2 - alternate new criterion pestbasis - compute criterion for a basis kts - already used knots i - counter lgth - number of already used knots iloc - present location under study lloc - lower bound to best location bloc - best location up to now uloc - upper bound to best location iloc2 - other location under study ll - candidate for lloc uu - candidate for uloc nx - (*data).ndata l - emergency break Ppsort - sorting routine pind.. - pind location for new knot under various circumstances */ /* initialization */ ll=0; uu=0; bloc = -1; crit = -pow((double)10.,(double)20.); sorted = v4; /* find lgth, create kts: already used knots */ lgth = (*newt).sub[i0][(*data).ncov].dim1-1; kts = v3; for(i=0;i0 && i== -2)i=0; /* before first knot */ if(i== 0 && lgth>0) iloc=pindl(&ll,&uu,mind,sorted,nx,kts[0]); /* after last knot */ if(i== lgth&& lgth>0) iloc=pindr(&ll,&uu,mind,sorted,nx,kts[lgth-1]); /* first knot */ if(i== 0 && lgth==0)iloc=pindx(&ll,&uu,nx,0,mind); if(i== -1 && lgth==0)iloc=pindx(&ll,&uu,nx,1,mind); if(i== -2 && lgth==0)iloc=pindx(&ll,&uu,nx,2,mind); /* in between knots */ if(i>0 && i=0){ critnew=pestbasis(new,newt,crit,data,i0,(*data).ncov,0,0,sorted[iloc]); /* improvement */ if(critnew>crit){ lloc=ll; uloc=uu; bloc=iloc; crit=critnew; } } } if(bloc<0)return -1; if(crit=1 && crit=3 && critsorted[lloc]){ iloc2=pindyr(uloc,bloc,sorted); /* two pearch points, the upper one */ if(iloc2>=0){ crit2=pestbasis(new,newt,crit,data,i0,(*data).ncov,0, 0,sorted[iloc2]); } else crit2=crit; /* two pearch points, the lower one */ iloc=pindyl(bloc,lloc,sorted); if(iloc>=0){ critnew=pestbasis(new,newt,crit2,data,i0,(*data).ncov,0, 0,sorted[iloc]); } else critnew=crit; /* the middle one is the best, we call it quits */ if(crit>=critnew && crit>=crit2){ lloc=uloc; } else{ /* the lower pearch point is the best */ if(critnew>crit2){ uloc=bloc; bloc=iloc; crit=critnew; } else{ /* the upper pearch point is the best */ lloc=bloc; bloc=iloc2; crit=crit2; } } } }while(sorted[uloc]>sorted[lloc]); return crit; } /******************************************************************************/ /* after another routine has decided to check the rao-criterion for a model with an added basis, this routine first adds the basis (addbasis), then it checks the criterion (cripswap) - there are lots of possibilities to check. */ static double pestbasis(struct space *new, struct space *newt, double criterion, struct datastruct *data, int i0, int j0, int ki, int kj, double ti) /* new - best space with added dimensions newt - space to which dimensions are added data - data criterion - best rao statistic up to now i0,j0 - indicate which subdimension is going to be changed ki,kj - ranknumber of knots to be added ti - some sort of knot to be added */ { double arg[4]; int ncov=(*data).ncov; /* cripswap - computes rao and if there is improvement swaps the space ncov - save typing */ /* most common occurences - preset for linear in covariates */ arg[0]= -1.; arg[1]= -1.; arg[2]= -1.; arg[3]= -1.; /* 1 covariate subdimension */ /* this is not the first (i.e. linear) space */ if(j0==ncov) if((*newt).sub[i0][j0].dim1>0){ /* what is the knot to be added */ arg[0]=ti; arg[2]=(*newt).sub[i0][ncov].dim1-1; (*newt).sub[i0][ncov].ktsc[(*newt).sub[i0][ncov].dim1-1] =ti; } /* a crossproduct subdimension */ if(j0=0){ arg[2]=ki; arg[0]=(*newt).sub[j0][ncov].ktsc[(int)arg[2]]; } if(kj>=0){ arg[3]=kj; arg[1]=(*newt).sub[j0][ncov].ktsc[(int)arg[3]]; } (*newt).sub[i0][j0].kts1[ki+1][kj+1]=1; } paddbasis(i0,j0,arg,data,&((*newt).basis[(*newt).nbas])); /* compute rao. possibly swap */ criterion=cripswap(newt,data,new,criterion,i0,j0); if(j0criterion){ pswapspace(new,newt,data); criterion=crit; } /* change back the dimensions */ ((*newt).ndim) -= (*data).nclass; ((*newt).nbas) -= 1; ((*newt).sub[i0][j0].dim1) -= 1; return criterion; } /******************************************************************************/ /* this routine computes the extra elements of hessian and score then it computes rao - the routine is very much like the routine complog, which is part of Newton, except that it does not compute the log-likelihood and it makes use of the fact that part of b0, b1 and b2 might be known and completely at the end, it computes the rao statistic. */ static double prao(struct space *spc, struct datastruct *data) /* spc - the present model data - the data */ { double raoc=0,**hhh,*ss,*ss2,rtemp,xx,epsi=(*spc).epsilon,yy,yy4,d0,d1,**hh2; int i,j,k,k2,itemp,nclass=(*data).nclass,nbas=(*spc).nbas,k3; int ndim=(*spc).ndim,extra=nbas-1,alhere=(nbas-1)*nclass,ncl; double *wh1,*wh2,*wh3; /* i,j,k,k2 - counters ss,ss2 - score raoc - rao hhh,hh2 - hessian nclass, nbas, ndim, extra, alhere - save typing rtmep, itemp - frequently used xx,epsi - save typing yy, yy4, d0, d1, k3 - half products wh1, wh2, wh3 - half products */ /* allocation and initlization equal to 0 */ xx=epsi*2./(nclass+1.); ncl=nclass+1; hhh=w1; hh2=w2; ss=v1; ss2=v2; /* initialization equal to zero */ for(i=alhere;i<=ndim;i++){ ss[i-alhere]=0.; ss2[i-alhere]=0.; for(j=0;j<=i;j++){ hhh[i][j]=0.; hhh[j][i]=0.; } } /* now circle the datapoints */ for(i=0;i<(*data).ndata;i++){ wh1=(*data).work[i]; wh2=(*data).work2[i]; petvector(spc,data,v7,v8,i); yy= -xx*(*data).wgt[i]; for(k=0;k0) for(j=0;j1000 && nbas>3)raoc=0.; return raoc; } /******************************************************************************/ /* pinds a new location in an interval (l,b) - that is the lower end might not have been tested yet */ static int pindyl(int u,int l,double *x) { int i; if(x[l]==x[u])return -1; i=(u+l-1)/2; if(x[i]!=x[u])return i; i=(i+l)/2; if(x[i]!=x[u])return i; return l; } /******************************************************************************/ /* pinds a new location in an interval (l,u) - that is the upper end might not have been tested yet */ static int pindyr(int u,int l,double *x) { int i; if(x[l]==x[u])return -1; i=(u+l+1)/2; if(x[i]!=x[l])return i; i=(i+u)/2; if(x[i]!=x[l])return i; return u; } /******************************************************************************/ /* Finds a possible location for a knot on the interval (0,knot1) */ static int pindl(int *ll, int *uu, int mind, double *x, int nx, double knt) /* ll - lowest number we can pearch on in the future uu - highest number we can pearch on in the future mind minimum distance between knots x - data nx - length of data knt- knot */ { /* i - utility plocation - pinds uu */ int i; (*uu)=plocation(0,x,nx,knt); if((*uu)<2*mind)return -1; i=((*uu)-1)/2; if((*uu)-inx-mind-1)(*uu)=nx-mind-1; } if(i==1){ *ll=nx/4; if((*ll)>mind)(*ll)=mind; *uu=3*nx/4; if((*uu)>nx-mind-1)(*uu)=nx-mind-1; } if(i==2){ *ll=nx/2; if((*ll)>mind)(*ll)=mind; *uu=nx-1-mind; } if((*ll)>(*uu))return -1; return (int)((*ll)+(*uu))/2; } /******************************************************************************/ /* Finds a possible location for a knot on the interval (k0,k1) */ static int pindm(int *ll, int *uu, int mind, double *x, int nx, double k0, double k1) /* ll - lowest number we can pearch on in the future uu - highest number we can pearch on in the future mind minimum distance between knots x - data nx - length of data k0 - knot k1 - knot */ { /* plocation - pinds ll */ (*ll)=plocation(1,x,nx,k0); (*uu)=plocation(0,x,nx,k1); if((*uu)-(*ll)<2*mind+1)return -1; *uu=(*uu)-mind-1; *ll=(*ll)+mind+1; return ((*uu)+(*ll))/2; } /******************************************************************************/ /* finds the lowest (if what = 0) or the highest (if what = 1) index of x for which x==k */ static int plocation(int what, double *x, int nx, double k) /* what - see above x - data nx - length data k - see above */ { int i; if(what==1){ if(x[0]>k)return 0; if(x[nx-1]<=k)return nx-1; for(i=0;ik && x[i]<=k) return i; } } if(x[nx-1]=k)return 0; for(i=1;i=k && x[i-1]=bb1 && i0){ (*best).nbas=fitter/(*data).nclass; (*best).ndim=fitter; j=0; /* record the knots from cckk */ for(i=0;i<(*data).ncov;i++){ j++; (*best).sub[i][(*data).ncov].dim1=cckk[j]; for(k=1;k0 && (*best).basis[i].t1== -1){ ((*best).sub [(*best).basis[i].b1][(*best).basis[i].b2].dim1)++; } } } strt = -1; } /* do the work */ poly(best,data,loss,-(*penalty),ndmax,mindis,exclude,strt,silent,meas,ad, lins,tdata,it,losses[cvx],s1,s2,s3,naction,il,sngle,s4); /* organize for cv */ if(it==2) numbers[cvx]=aicbest(ad,ranges[cvx],losses[cvx],meas[0]); else for(i=0;i=0){ (*spc).basis[j].b1+=1; } if((*spc).basis[j].b2>=0){ (*spc).basis[j].b2+=1; if((*spc).basis[j].b2>(*data).ncov) (*spc).basis[j].b2= -1; } (*spc).basis[j].t1+=1; (*spc).basis[j].t2+=1; /* which variable, which knot, which variable#2, which knot #2, beta variable=0: time, knot=0: constant, otherwise: knot number variable>0: covariate, knot=0: linear, otherwise: knot number variable#2 = -1: 1d basisfunction */ bbtt[j*(4+(*data).nclass)+0]=(*spc).basis[j].b1; bbtt[j*(4+(*data).nclass)+1]=(*spc).basis[j].t1; bbtt[j*(4+(*data).nclass)+2]=(*spc).basis[j].b2; bbtt[j*(4+(*data).nclass)+3]=(*spc).basis[j].t2; for(k=0;k<(*data).nclass;k++) bbtt[j*(4+(*data).nclass)+4+k]=(*spc).basis[j].beta[k]; } } /******************************************************************************/ /* gets the basisfunctions */ static double petvector2(struct space *best, struct datastruct *data, int i, int k) /* best - the model data - the data */ { int j,b1,b2,t1,t2,ncov=(*data).ncov; double xx,val; float *cc; /* j - counter b1,b2,t1,t2 - b1,b2,t1,t2 for the present basisfunction xx - the second half ndata - number of datapoints ncov - number of covariates cov - covariates */ b1=(*best).basis[i].b1; t1=(*best).basis[i].t1; b2=(*best).basis[i].b2; t2=(*best).basis[i].t2; /* circle the basisfunctions */ j=k; k=(*data).icov[j]; if(k>0)cc= &(trcov[k-1]); else cc= &(tecov[-k-1]); /* if it is time only it is easy */ val=0.; if(b1==ncov){ val=1.; } else{ /* then first take the first component of the basisfunction */ val=cc[b1]; /* -1 means linear, otherwise it is piecewise linear */ if(t1> -1){ val-=(*best).sub[b1][ncov].ktsc[t1]; if(val<0.) val=0.; } } /* and then the second component of the basisfunction */ if(b2!=ncov && b2!= -1){ xx=cc[b2]; /* -1 means linear, otherwise it is piecewise linear */ if(t2> -1){ xx-=(*best).sub[b2][ncov].ktsc[t2]; if(xx<0.) xx=0.; } val=val*xx; } return val; } /******************************************************************************/ /* gets the basisfunctions */ static void petvector(struct space *best, struct datastruct *data, double *val, double *wal, int j) /* best - the model data - the data */ { int i,k,b1,b2,t1,t2,ncov=(*data).ncov; double xx; float *cc; /* i - counter b1,b2,t1,t2 - b1,b2,t1,t2 for the present basisfunction xx - the second half ndata - number of datapoints ncov - number of covariates cov - covariates */ /* circle the basisfunctions */ k=(*data).icov[j]; if(k>0)cc= &(trcov[k-1]); else cc= &(tecov[-k-1]); for(i=0;i<(*best).nbas;i++){ /* if it is time only it is easy */ val[i]=0.; b1=(*best).basis[i].b1; if(b1==ncov){ val[i]=1.; } else{ t1=(*best).basis[i].t1; /* then first take the first component of the basisfunction */ val[i]=cc[b1]; /* -1 means linear, otherwise it is piecewise linear */ if(t1> -1){ val[i]-=(*best).sub[b1][ncov].ktsc[t1]; if(val[i]<0.) val[i]=0.; } } /* and then the second component of the basisfunction */ b2=(*best).basis[i].b2; if(b2!=ncov && b2!= -1){ xx=cc[b2]; t2=(*best).basis[i].t2; /* -1 means linear, otherwise it is piecewise linear */ if(t2> -1){ xx-=(*best).sub[b2][ncov].ktsc[t2]; if(xx<0.) xx=0.; } val[i]=val[i]*xx; } wal[i]=val[i]*((*data).wgt[j]); } } /******************************************************************************/ /* this function allocates storage for a data structure */ static struct datastruct *pdefinedata(int ndata, int ncov, int nclass, int xndata, int *cls, double *wgt, int icov) { struct datastruct *newdata; int i; newdata=(struct datastruct *)Salloc(1,struct datastruct); (*newdata).work=dpmatrix(ndata,nclass+1); (*newdata).work2=dpmatrix(ndata,nclass+2); (*newdata).bincov=ispvector(ncov); (*newdata).wgt=dspvector(ndata); (*newdata).yy=ispvector(ndata); (*newdata).icov=ispvector(ndata); (*newdata).ndata=xndata; (*newdata).nclass=nclass-1; (*newdata).ncov=ncov; (*newdata).wgtsum=0.; for(i=0;imaxu)maxu=ranges[i][numbers[i]-1]; } for(i=0;imaxu){ bestu=maxu; bestu=1.0e+30; xio[1]= -1.; } if(bestl<=0)bestl=0.; xio[3]=sqrt(bestl*bestu); return xio[3]; } /******************************************************************************/ static void aicb2(int *ads, double *aics, double **meas, double *logls) { int i,j,k,*k1,*k2; double *d1,*d3,*d4,*d2; k1=iv1; k2=iv2; d1=v1; d2=v2; d3=v3; d4=v6; j=0; for(i=0;i=0){ k1[j]=i+1; k2[j]=ads[i]; d1[j]=meas[0][i]; d2[j]=aics[i]; d3[j]= -2.; d4[j]= -1.; j++; } if(j>1){ for(i=0;id3[i]) d3[i]=(d1[k]-d1[i])/(k1[k]-k1[i]); } d4[i+1]=(d1[0]-d1[i+1])/(k1[0]-k1[i+1]); for(k=1;k<=i;k++){ if((d1[k]-d1[i+1])/(k1[k]-k1[i+1])0 && i=d3[i]){ logls[i*11+10]=2.*d3[i]; logls[i*11+11]=2.*d4[i]; } else{ logls[i*11+10]= -1; logls[i*11+11]= -1; } } } } /******************************************************************************/ static int aicbest(int *ads, double *ranges, double *losses, double *logls) { int i,j,k,l,*k1,*k2; double *d1,*d3,*d4,*d2; k1=iv1; k2=iv2; d1=v1; d2=v2; d3=v3; d4=v6; j=0; for(i=0;i=0){ k1[j]=i+1; d1[j]=logls[i]; d2[j]=losses[i]; d3[j]= -2.; d4[j]= -1.; j++; } if(j>1){ for(i=0;id3[i]) d3[i]=(d1[k]-d1[i])/(k1[k]-k1[i]); } d4[i+1]=(d1[0]-d1[i+1])/(k1[0]-k1[i+1]); for(k=1;k<=i;k++){ if((d1[k]-d1[i+1])/(k1[k]-k1[i+1])0){ if(i==j-1)d3[l]=0.; else d3[l]=2.*d3[i]; k2[l]=k1[i]; d2[l]=d2[i]; l++; } for(i=0;i=0 ){ for(i=1;i=0){ for(i=1;i=0 && iw1[j][3]<0){ for(i=1;i=0 && iw1[j][3]>=0){ for(i=1;i7){ logl=pcompall(spc,data,1); if(logl<(*data).ndata*log((double)(1./((*data).nclass+1.)))){ for(j=0;j<(*spc).nbas;j++) for(k=0;k<(*data).nclass;k++) (*spc).basis[j].beta[k]=0.; logl=pcompall(spc,data,1); } i=lusolinv((*spc).info,(*spc).ndim,v2,1); mm=2; } else{ if(mm==7){ iter=1; mm=1; for(j=0;j<(*spc).nbas;j++) for(k=0;k<(*data).nclass;k++) (*spc).basis[j].beta[k]=0.; logl=pcompall(spc,data,1); } else{ for(j=0;j<(*spc).nbas;j++) for(k=0;k<(*data).nclass;k++){ i=dlink(spc,j,k); if(i>=0) v5[i]=(*spc).basis[j].beta[k]; } logl=pcomp2(spc,data); mm=1; } } /* Rprintf("%d %d %f\n",iter,mm,logl);fflush(stdout); */ /* solve system */ for(j=0;j<(*spc).ndim;j++)v3[j]=(*spc).score[j]; for(j=0;j<(*spc).nbas;j++){ for(k=0;k<(*data).nclass;k++){ i=dlink(spc,j,k); if(i>=0) v6[i]=(*spc).basis[j].beta[k]; } } for(i=0;i<(*spc).ndim;i++){ (*spc).score[i]=0.; for(j=0;j<(*spc).ndim;j++)(*spc).score[i]+=v3[j]*(*spc).info[i][j]; } ihalf=1; do{ /* compute new loglikelihood (cheat on beta) */ for(j=0;j<(*spc).nbas;j++){ for(k=0;k<(*data).nclass;k++){ i=dlink(spc,j,k); if(i>=0) (*spc).basis[j].beta[k] -= (*spc).score[i]; } } lnew=pcompall(spc,data,0); /* Rprintf("%f ",lnew);fflush(stdout); */ /* get beta back again */ for(j=0;j<(*spc).nbas;j++){ for(k=0;k<(*data).nclass;k++){ i=dlink(spc,j,k); if(i>=0) (*spc).basis[j].beta[k] += (*spc).score[i]; } } /* step halving if required */ if(lnew8192 && mm==2 && iter>0)return 200.; if(ihalf>8192 && mm==2)mm=7; if(ihalf>8192 && mm!=7){ mm=3; (void)Rprintf("step half ouch...\n"); } /* the actual halving */ ihalf=ihalf*2; for(j=0;j<(*spc).ndim;j++) (*spc).score[j]=(*spc).score[j]/2; } }while(lnew=0) (*spc).basis[j].beta[k] -= (*spc).score[i]; } } /* did we converge */ if(plumbertester(logl)+plumbertester(lnew)!=6 &&mm!=3 &&mm!=7) return 200.; if(lnew-logl=0) v5[i]=(*spc).basis[j].beta[k]; } /* lnew=pcomp2(spc,data); */ lnew=pcompall(spc,data,2); for(i=0;i<(*spc).ndim;i++)for(j=0;j<(*spc).ndim;j++) w3[i][j]=(*spc).info[i][j]; i=lusolinv(w3,(*spc).ndim,v2,1); return lnew; } /******************************************************************************/ /* this routine computes hessian score and log-likelihood */ static double pcompall(struct space *spc, struct datastruct *data, int what) /* spc - the present model data - the data what - loglikelihood (0) or also score and hessian? */ { int i,j,k,j2,k2,i2,i1,itemp,i3,j4; int nclass=(*data).nclass,nbas=(*spc).nbas,j3,ncl; double logl,rtemp,**xinfo,*xscore,**dwk,**dwk2,epsilon=(*spc).epsilon,xx; double d1,*dwl,*dwl2; /* i - typically counter data j - typically counter basisfunctions k - typically counter classes j2 - typically counter basisfunctions k2 - typically counter classes logl - loglikelihood itemp,rtemp,i2 - save typing nclass,nbas,dwk - save typing xinfo and xscore - info and score were all basis functions independent dlink - link combination */ /* the computations are first all carried out as if all elements are independent lumping is done afterwards */ /* initializations and allocations */ ncl=nclass+1; dwk=(*data).work; dwk2=(*data).work2; xinfo=w1; xscore=v1; logl=0.; if(what!=0){ for(i=0;i=0){ i2=j*nclass+k; (*spc).score[i1] += xscore[i2]; if(what<=2)for(j2=0;j2=0) (*spc).info[i3][i1]+=xinfo[j2*nclass+k2][i2]; } } } } (*spc).logl=logl; return logl; } /******************************************************************************/ /* get one link element */ static int dlink(struct space *spc, int j, int k) { if((*spc).basis[j].link1[k]< 0)return -1; return (*spc).basis[j].link2[(*spc).basis[j].link1[k]]; } /******************************************************************************/ /* get the info-x term */ static void getinfox(struct space *spc, struct datastruct *data) { int ndata=(*data).ndata,nclass=(*data).nclass,i,j1,k1,j2,k2,l1,j3; int nbas=(*spc).nbas,kk=nclass+1; double x,y,epsilon=2.*(*spc).epsilon,xkk; epsilon=epsilon/(double)(nclass+1); for(j1=0;j1=0){ i2=j*nclass+k; (*spc).score[i1] += xscore[i2]; } } for(j=0;j<(*spc).ndim;j++){ v5[j]-=v6[j]; v6[j]=(*spc).score[j]-v3[j]; } for(j=0;j<(*spc).ndim;j++){ v3[j]=0.; for(i=0;i<(*spc).ndim;i++) v3[j]+=v6[i]*(*spc).info[i][j]; } d0=0.; d1=0.; for(j=0;j<(*spc).ndim;j++){ d0+=v6[j]*v5[j]; d1+=v3[j]*v6[j]; } for(j=0;j<(*spc).ndim;j++) for(i=0;i<(*spc).ndim;i++) (*spc).info[i][j]+=v5[i]*v5[j]/d0-v3[i]*v3[j]/d1; (*spc).logl=logl; return logl; } /******************************************************************************/ /* this routine pearches all dimensions for a basis function to remove */ static int prembas(struct space *spc, struct datastruct *data, int silent) /* spc - the model from which to remove something data - data silent- should diagnostic output be printed? */ { int nclass=(*data).nclass,ncov=(*data).ncov; int nb1,nt1,nb2,nt2,j,k,j2,eligible,i,bbi,l,i1; int nbas=(*spc).nbas,bb1,bb2,bt1,bt2,**tlink; double criterion,wald,**tinfo; /* nclass,ncov,nbas- save typing nb1,nt1,nb2,nt2 - b and t attributes of the basis function being studied aj,ak - a beta which corresponds to them sj,sk - their score components j,k - the independent components that we try to equate j2 - possible conflicting basis function bbi,bbj,bbk - best i, j and k n - if 0, a potential conflict eligilble - conflicting basisfunction i - the basis function that we study l - for initialization of links k1,k2,k3,k4 - used for old-new link relations tlink - present link relations tinfo - used when sweeping info baj,bak,bsj,bsk - best aj,ak,sj,sk ii,i1,j1 - counters bb1,bb2,bt1 - b's and t's for removal wald - wald statistic criterion - best wald up to now baj,bak - best aj and ak dlink - find a double link */ tlink=iw1; for(i=0;i= 0 && (*spc).basis[j2].t2==nt2)eligible=0; if(nt1>= 0 && nt2== -1 && (*spc).basis[j2].t1==nt1)eligible=0; } } } /* are they already the same on a higher level? */ } /* if we are eligible, compute wald */ if(eligible==1){ for(j=0;j<(*data).nclass;j++){ for(k=0;k<(*data).nclass;k++){ w3[j][k]=(*spc).info[dlink(spc,i,j)][dlink(spc,i,k)]; } } for(j=0;j<(*data).nclass;j++)v1[j]=(*spc).basis[i].beta[j]; (void)lusolinv(w3,(*data).nclass,v1,2); wald=0.; for(j=0;j<(*data).nclass;j++) wald+=(*spc).basis[i].beta[j]*v1[j]; wald=fabs(wald); /* did we improve ? */ if(plumbertester(wald)!=2 && wald0){ /* first in the basisfunctions */ for(j=0;jbt1)(*spc).basis[j].t1-=1; if((*spc).basis[j].b2==bb1) if((*spc).basis[j].t2>bt1)(*spc).basis[j].t2-=1; } } /* in the knots themselves */ for(j=bt1;j>(-1)&&j<(*spc).sub[bb1][ncov].dim1;j++){ (*spc).sub[bb1][ncov].ktsc[j]=(*spc).sub[bb1][ncov].ktsc[j+1]; } } else{ /* if it is a two variable dimension */ (*spc).sub[bb1][bb2].dim1-=1; } /* shift the beta */ for(j=0;j<(*spc).nbas;j++){ for(i=0;i<(*data).nclass;i++){ (*spc).basis[j].beta[i]+=v3[j*(*data).nclass+i]; } } /* initialize link2 */ l= -1; for(j=0;j<(*spc).nbas;j++){ for(k=0;k<(*spc).basis[j].ib;k++){ l++; (*spc).basis[j].link2[k]=l; } } } return bbi; } /******************************************************************************/ /* this routine pearches all dimensions for something to remove - it is a mess*/ static void premdim(struct space *spc, struct datastruct *data, int silent, double *dwald, int *iwald) /* spc - the model from which to remove something data - data silent- should diagnostic output be printed? */ { int nclass=(*data).nclass,ncov=(*data).ncov; int nb1,nt1,nb2,nt2,aj=0,ak=0,sj=0,sk=9,j,k,j2,n,eligible,i,bbi=0,bbj=0,bbk=0,l; int nbas=(*spc).nbas,bb1,bb2,bt1,ii,baj=0,bak=0,bsj=0,bsk=0,**tlink; int k1,k2,k3,k4,i1,j1; double criterion,wald,xx,**tinfo; /* nclass,ncov,ndata,nbas - save typing nb1,nt1,nb2,nt2 - b and t attributes of the basis function being studied aj,ak - a beta which corresponds to them sj,sk - their score components j,k - the independent components that we try to equate j2 - possible conflicting basis function bbi,bbj,bbk - best i, j and k n - if 0, a potential conflict eligilble - conflicting basisfunction i - the basis function that we study l - for initialization of links k1,k2,k3,k4 - used for old-new link relations tlink - present link relations tinfo - used when sweeping info baj,bak,bsj,bsk - best aj,ak,sj,sk ii,i1,j1 - counters bb1,bb2,bt1 - b's and t's for removal wald - wald statistic criterion - best wald up to now baj,bak - best aj and ak dlink - find a double link */ tlink=iw1; for(i=0;i= 0 && (*spc).basis[j2].t2==nt2)n=0; if(nt1>= 0 && nt2== -1 && (*spc).basis[j2].t1==nt1)n=0; } } } /* are they already the same on a higher level? */ if(n==0){ if(j==k && (*spc).basis[j2].link1[aj]!= -1)eligible=0; if(j!=k && (*spc).basis[j2].link1[aj] !=(*spc).basis[j2].link1[ak])eligible=0; } if(eligible==0)j2=nbas; } /* if we are eligible, compute wald */ if(eligible==1){ /* easy if a beta has to be put equal to 0 */ if(j==k){ wald=fabs((*spc).basis[i].beta[aj]/ sqrt(fabs((*spc).info[sj][sj]))); sk= -1; ak= -1; } else{ /* otherwise select a 2x2 part of score and beta */ wald=fabs((*spc).basis[i].beta[aj]-(*spc).basis[i].beta[ak])/ sqrt(fabs(-(*spc).info[sj][sj]+2*(*spc).info[sj][sk] -(*spc).info[sk][sk])); } /* did we improve ? */ if(wald=0){ if(k==(*spc).ndim)k=bsj; (*spc).basis[i].beta[j]-=v6[k]; } } /* announce the results */ if(silent!=1){ if((*spc).basis[bbi].ib>1) puuu(spc,(*spc).basis[bbi].b1, (*spc).basis[bbi].b2,(*spc).basis[bbi].t1,(*spc).basis[bbi].t2, (*data).ncov,2); else puuu(spc,(*spc).basis[bbi].b1, (*spc).basis[bbi].b2,(*spc).basis[bbi].t1,(*spc).basis[bbi].t2, (*data).ncov,1); (void)Rprintf("(wald=%.2f)\n",criterion*criterion); } /* now remove the worst dimension; if ib==1 this is everything */ if((*spc).basis[bbi].ib==1){ (*spc).nbas-=1; nbas-=1; bb1=(*spc).basis[bbi].b1; bb2=(*spc).basis[bbi].b2; bt1=(*spc).basis[bbi].t1; /* move the last basisfunction to the one that is removed */ (*spc).basis[bbi].b1=(*spc).basis[nbas].b1; (*spc).basis[bbi].b2=(*spc).basis[nbas].b2; (*spc).basis[bbi].t1=(*spc).basis[nbas].t1; (*spc).basis[bbi].t2=(*spc).basis[nbas].t2; (*spc).basis[bbi].ib=(*spc).basis[nbas].ib; for(i=0;i0){ /* first in the basisfunctions */ for(j=0;jbt1)(*spc).basis[j].t1-=1; if((*spc).basis[j].b2==bb1) if((*spc).basis[j].t2>bt1)(*spc).basis[j].t2-=1; } } /* in the knots themselves */ for(j=bt1;j>(-1)&&j<(*spc).sub[bb1][ncov].dim1;j++){ (*spc).sub[bb1][ncov].ktsc[j]=(*spc).sub[bb1][ncov].ktsc[j+1]; } } else{ /* if it is a two variable dimension */ (*spc).sub[bb1][bb2].dim1-=1; } } /* or merge two links */ else { i=(*spc).basis[bbi].link1[baj]; if(bbj==bbk){ /* a merger with emptiness */ for(j=0;ji) (*spc).basis[bbi].link1[j]-= 1; } } else{ /* a true merger */ k=(*spc).basis[bbi].link1[bak]; if(k>i){ j=k; k=i; i=j; } xx=(*spc).basis[bbi].beta[bak]; for(j=0;ji) (*spc).basis[bbi].link1[j]-= 1; } } (*spc).basis[bbi].ib -= 1; } (*iwald)=(*iwald)+1; (*dwald)=(*dwald)+criterion*criterion; /* initialize link2 */ l= -1; for(j=0;j<(*spc).nbas;j++){ for(k=0;k<(*spc).basis[j].ib;k++){ l++; (*spc).basis[j].link2[k]=l; } } for(i=0;i=0){ k2=tlink[i][j]; if(bsk!= -1&&k2==bsj)k2=bsk; for(i1=0;i1=0){ k4=tlink[i1][j1]; if(bsk!= -1&&k4==bsj)k4=bsk; (*spc).info[k1][k3]=tinfo[k2][k4]; } } } } } /******************************************************************************/ static void puuu(struct space *spc, int b1, int b2, int t1, int t2, int ncov, int ii) { if(ii==0)(void)Rprintf(" add: "); if(ii==1)(void)Rprintf("remove: "); if(ii==2)(void)Rprintf(" merge: "); if(b1!=ncov){ (void)Rprintf("cov(%d",b1+1); if(b2==ncov)(void)Rprintf(")=("); else (void)Rprintf(",%d)=(",b2+1); if(t1!= -1)(void)Rprintf("knot=%.2f",(*spc).sub[b1][ncov].ktsc[t1]); else (void)Rprintf("linear"); if(b2==ncov)(void)Rprintf(") "); else { if(t2!= -1)(void)Rprintf(",%.2f)",(*spc).sub[b2][ncov].ktsc[t2]); else (void)Rprintf(",linear) "); } } else (void)Rprintf("constant "); } /******************************************************************************/ /* This program does the main control */ static void poly(struct space *best, struct datastruct *data, double **loss, double pen, int ndmax, int mind, int **exclude, int strt, int silent, double **logs, int *ad, int *lins, struct datastruct *tdata, int it, double *aics, struct space *current, struct space *new, struct space *trynew, int naction, int il, int xsingle, struct space *newx) /* best - the best model up to now data - the data loss - the loss function. pen - penalty ndmax - maximum number of basisfunctions mind - minimum distance (in order statistics) between knots naction - number of possible different actions exclude - which terms should be excluded from the model strt - 0: start with constant, 1 start with linear, -1 start with fit silent - should diagnostic output be printed? ad - is the best model during addition or deletion lins - dimensions that can only be added linear tdata - testset data it - are we using a testset or aic? aics - all the losses */ { double dwald; int add=1,i,ndm2,iwald,okd=0; /* getcrit - computes the criterion (AIC or loss) pnewton - fits a model using NR current - the present model new,trynew - storage for a space, used by padddim, prembas and premdim pdefinespace-allocates storage for a space add - are we still adding? padddim - adds dimensions to a space i - counter ndm2 - copy of ndmax on entrance ndim - save typing pconstant - initializes a constant hazard space pswapspace - copies one space into another prembas - remove basisfunctions from a space premdim - remove dimensions from a space */ /* swap spaces */ pswapspace(current,best,data); /* initialization */ if(silent==0 && it==0)(void)Rprintf ("dim AIC log-likeli log-like/n resub-ls/n sq-error/n\n"); if(silent==0 && it!=0){ (void)Rprintf("dim measure <== training set / n ==>"); (void)Rprintf(" <==== test set / n ====>\n"); if(il==0)(void)Rprintf(" log-like "); if(il==1)(void)Rprintf(" loss "); if(il==2)(void)Rprintf(" sq-error "); (void)Rprintf("log-like loss sq-err "); (void)Rprintf("log-like loss sq-err\n"); } ndm2=ndmax; if(ndmax<0)ndmax= -ndmax; (*best).aic=pow((double)10.,(double)150.); for(i=0;i=0)pconstant(current,data); /* we start in adding mode */ do{ /* fits the model */ (*current).aic=pnewton(current,data); if((*current).aic>190){ pswapspace(current,newx,data); add=(int)pnewton(current,data); ndmax=(*current).nbas; add=0; Rprintf("warning - model size was reduced\n"); } else{ /* compute aic */ (*current).aic=getcrit(current,tdata,data,it,loss,silent,logs,ad,1, aics,&pen,naction,il); if((*current).ndim>=ndmax-(*data).nclass+1)add=0; /* did we improve */ if((*current).aic<=(*best).aic+0.00000001){ pswapspace(best,current,data); if(silent==0)(void)Rprintf(" best up to now!"); } if(silent==0)(void)Rprintf("\n"); /* adds dimensions, computes new starting values */ if(add==1 && ndm2<0){ for(i=2;i<(*current).nbas-2;i++){ if(logs[0][(*current).ndim-1]- logs[0][i-1]<((*current).nbas-i)/2.-0.5){ add=0; ndmax=(*current).nbas; } } } if(add==1){ pswapspace(newx,current,data); add=padddim(current,new,trynew,data,mind,exclude,silent,lins); if(add!=1) ndmax=(*current).nbas; } } /* keep on adding? */ }while(add==1); /* start deleting */ if(xsingle!=0)do{ /* removes dimensions, computes new starting values */ if(xsingle==1){ dwald=0.; iwald=0; do{ if(ndmax>1) premdim(current,data,silent,&dwald,&iwald); }while(iwald< 10 && dwald<2.5 && (*current).ndim>25); } else{ okd = prembas(current,data,silent); } if(okd!=-1){ (*current).aic=pnewton(current,data); if((*current).aic > 190.)add=17; else{ /* compute aic */ (*current).aic=getcrit(current,tdata,data,it,loss,silent,logs,ad,0, aics,&pen,naction,il); /* did we improve */ if((*current).aic<=(*best).aic+0.00000001){ pswapspace(best,current,data); if(silent==0)(void)Rprintf(" best up to now!"); } if(silent==0)(void)Rprintf("\n"); } } /* does further deleting make sense */ }while(okd!=-1 && ( ((*current).aic-(*best).aic< -pen*((*current).ndim-(*data).nclass)&&it==0)|| ((*current).ndim>(*data).nclass && it!=0 && add!=17))); } /******************************************************************************/ /* this function initializes a constant hazard space */ static void pconstant(struct space *spc, struct datastruct *data) /* spc - space to be initialized data - the data */ { int i,ncov=(*data).ncov,nclass=(*data).nclass; /* i - counter ncov,nclass,ndata - save typing */ (*spc).ndim=(*data).nclass; (*spc).nbas=1; (*spc).basis[0].b1=ncov; (*spc).basis[0].b2=ncov; /* initialize the values and the starting beta */ for(i=0;i0){ for(k=0;k0.0000001)ll=0; if(i!=j && fabs(loss[i][j]-1)>0.0000001)ll=0; if(ll==0){i=nclass;j=nclass;} } /* circle the data points */ for(i=0;i<(*data).ndata;i++){ j=(*data).icov[i]; if(j>0)cc= &(trcov[j-1]); else cc= &(tecov[-j-1]); /* initialize */ for(j=0;j<=nclass;j++) chances[j]=0.; /* circle the basis functions */ for(k=0;k<(*spc).nbas;k++){ /* compute the basis function: the first component */ if(k>0){ value=1; i1=(*spc).basis[k].t1; i2=(*spc).basis[k].b1; if(i1== -1)value=cc[i2]; else{ value=cc[i2]-(*spc).sub[i2][ncov].ktsc[i1]; if(value<0) value=0.; } /* the second component */ i2=(*spc).basis[k].b2; if(i2!=ncov && value!=0.){ value2=1.; i1=(*spc).basis[k].t2; if(i1== -1)value2=cc[i2]; else{ value2=cc[i2]-(*spc).sub[i2][ncov].ktsc[i1]; if(value2<0)value2=0.; } value= value*value2; } for(j=0;jaics[(*spc).ndim-1]&&it==0) || ad[(*spc).ndim-1]== -1 || ii==1){ ad[(*spc).ndim-1]=ii; aics[(*spc).ndim-1]=crit; for(i=0;i<3;i++)logs[i][(*spc).ndim-1]=res[i]; if(it==0)for(i=3;i<6;i++)logs[i][(*spc).ndim-1]=0; else for(i=3;i<6;i++)logs[i][(*spc).ndim-1]=tes[i-3]; } if(silent==0){ if(it==0) (void)Rprintf("%3d %10.4f %10.4f %10.4f %10.4f %10.4f ", (*spc).ndim,-crit,res[0],res[0]/(*data).wgtsum,res[1]/(*data).wgtsum, res[2]/(*data).wgtsum); else{ (void)Rprintf("%3d %8.3f %8.3f %7.3f %7.3f ",(*spc).ndim,crit, res[0]/(*data).wgtsum,res[1]/(*data).wgtsum,res[2]/(*data).wgtsum); (void)Rprintf("%8.3f %7.3f %7.3f ", tes[0]/(*tdata).wgtsum,tes[1]/(*tdata).wgtsum,tes[2]/(*tdata).wgtsum); } } if(it!=0 && il==0)crit= -crit; if(it==0)crit= -crit; return crit; } /******************************************************************************/ /* checks a number */ static int plumbertester(double aa) /* if aa = -Inf: 0 aa = +Inf: 1 aa = NaN: 2 otherwise: 3 */ { int i1=0,i2=0,i3=0,i4=0; if(aa< 2.)i1=1; if(aa> 0.)i2=1; if(aa< pow(10.,200.))i3=1; if(aa> -pow(10.,200.))i4=1; if(i1+i2+i3+i4>=3)return 3; if(i2==1 && i4==1)return 1; if(i1==1 && i3==1)return 0; return 2; } /******************************************************************************/ /* sort, put result in rb */ static void Ppsort(double *ra, int n) { xpsort(ra-1,n); } /******************************************************************************/ /* sort */ static void xpsort(double *ra, int n) { int l,j,ir,i; double rra; l=(n >> 1)+1; ir=n; for (;;) { if (l > 1) rra=ra[--l]; else { rra=ra[ir]; ra[ir]=ra[1]; if (--ir == 1) { ra[1]=rra; return; } } i=l; j=l << 1; while (j <= ir) { if (j < ir && ra[j] < ra[j+1]) ++j; if (rra < ra[j]) { ra[i]=ra[j]; j += (i=j); } else j=ir+1; } ra[i]=rra; } } /******************************************************************************/ static int lusolinv(double **a, int n, double *b, int k) /* various lu things k=0 inverse, non symmetric k=1 inverse, symmetric k=2 solve, symmetric */ { double aa[DIM5][DIM5],bb[DIM5],det[2]; int kpvt[DIM5],info,i,j,inert[3]; if(k<2) for(i=0;i #include #include "R.h" #define Salloc(n, t) (t *)R_alloc((long)(n), (int)sizeof(t)) #define MAXKNOTS 60 struct datastruct { int ndata; double *data; int *idata; short *same; }; /* ndata; ndat - # number of cases dat - data idat - the ips are the integration points: idat indicates what the integration point immediately to the left of a datapoint is same - is the observation the same as the previous in the same category? kdata - relates the total order to the data, if kdata[37]=(0,18), the 37th datapoint is #18 in dat0: a first index of 2 refers to dat2 3 to dat3, 4 to the first column of dat4 and 5 to the second column of dat4 */ struct space { int ndim,nk,nip,*iknots,ilow,iupp; double *knots,aic,**info,*score,*ips,low,upp,cth; struct basisfunct *basis; }; /* ndim - dimension nk - number of knots (=ndim+1) nip - number of integration points iknots - datapoint at or just left of knot ilow - is the lower bound -infinity? (1=yes) iupp - is the upper bound +infinity? (1=yes) knots - the knots aic - present value of aic info - the hessian score - score function ips - integration points low - lower integration boundary upp - upper integration boundary cth - ctheta */ struct basisfunct { double beta,*c1,**c2,sumunc; int c3[2],iks[5]; }; /* beta - coefficient c1 - to translate the basis function in the truncated power basis c2 - to translate the basisfunction at an integration point in a polynomial c3 - first and last integration point for which this function is nonzero iks - which knots are involved with this basisfunction - integrationpt sumunc - sum_i B(x_i) over the uncensored data */ void nlogcensorx(int *intpars); void nlogcensor(int *intpars, double *data0, double *dpars, double *logs, int *ad, double *kts); static int nlsd(struct space *best, struct datastruct *data, double alpha, int ndmax, int mind, int strt, int silent, double *logs, int *ad); static struct space *definespace(int nd); static void getsame(double *x, int n, short *s); static void five(double *data, double *kts, int *intpars, short *same); static void five01(double *rr, int k, int n, int il); static void five00(double *rr, int k, int n); static void luinverse(double **a, int n); static int lusolve2(double **a, int n, double *b); static void lubksb(double **a, int n, int *indx, double b[]); static int ludcmp(double **a, int n, int *indx, double *d); static int adddim(struct space *spc, struct space *spc2, struct datastruct *data, int mind, int silent); static int findyl(int u, int l, double *x); static int findyr(int u, int l, double *x); static int findl(int *ll, int *uu, int mind, double *x, int nx, double knt); static int findr(int *ll, int *uu, int mind, double *x, int nx, double knt); static int findm(int *ll, int *uu, int mind, double *x, int nx, double k0, double k1); static int dlocation(int what, double *x, int nx, double k); static void betaadd(struct space *spc, struct space *spc2, int besti); static int iter(struct space *spc, struct datastruct *data, int silent, double *xxa); static int iterx(struct space *spc, struct datastruct *data, int silent, double *xxa); static double pompall(struct space *spc, struct datastruct *data, int what, int *xp); static void savecode1(struct space *spc, int j, double *cz, double **czz, double *what); static int savecoden(struct space *spc, int i0, int i1, double *cz, double **czz); static void initk(int i, int ndim, double *v, double **mm, double *v2, double **mm2); static double rao(struct space *spc, struct datastruct *data, double loc); static double praox(struct space *spc, struct datastruct *data, struct basisfunct *bb, double *iext, double intext[7], double c2ext[4], int j0ext); static int getnewc2(struct space *spc, struct datastruct *data, double loc, struct basisfunct *bb, double intext[7], double c2ext[4]); static double save22coden(struct space *spc, double *czz, struct basisfunct *bb, double int2ext[7], int j0ext, double c2ext[4]); static void remdim(struct space *spc, struct datastruct *data, struct space *spc2, int silent); static void betarem(struct space *spc2, struct space *spc, int irmax); static void redo1(struct space *spc, int irmax, int k); static void redo2(struct space *spc, int irmax, int k); static void solver(double **mm2, int i, int j, double *r1, struct space *spc); static void getc2(struct space *spc, struct datastruct *data); static void getc1(double *t, double *c, int i, int k); static void getonec1(double *c, int i, double *t, int j); static void setupspace(struct space *spc, struct datastruct *data); static int startspace(struct space *spc, struct datastruct *data, int strt, int silent); static void startnow(struct space *spc, struct datastruct *data); static int rearrange(struct space *spc, struct datastruct *data); static void getip(struct space *spc, struct datastruct *data); void rpqlsd(double *coef, double *knots, double *bnd, int *ipq, double *pq, int *lk, int *lp); static void getp0(double *q, double *p, int f, int l, double *cf, double k, double b, double cr); static void getq0(double *p, double *q, int f, int l, double *cf, double k, double b, double cr); static void getp2(double *q, double *p, int f, int l, double *cf, double k, double b, double cr); static void getq2(double *p, double *q, int f, int l, double *cf, double k, double b, double cr); static void getp1(double *q, double *p, int f, int l, double *cf, double k0, double k1, double p0, double p1); static void getq1(double *p, double *q, int f, int l, double *cf, double k0, double k1, double p0, double p1); static double z1int(double t1, double *c0, int j); static double z2int(double t1, double t2, double *c0); static double z3int(double k1, double k2, double *coef, int accuracy); static double pqexpi(int version, double t, double p, double *cf); static double *dsvector(int l); static double getf(double *c, double x); static double mylog(double x); static double myexp(double x); static short *issvector(int l); static int *isvector(int l); static void m1int(double *vv, double k1, double k2, int what, double *coef, int accuracy); static void l1int(double *results, double t1, double *coef, int j, int what); static void l2int(double *results, double t1, double t2, double *coef, int what); static double fctf1(double b0, double b1, double t1, double f1, int j); static double fctf2(double b0, double b1, double t1, double t2, double f1, double f2); static double pol3(double *coef, double x); static double inp3(double *c1, double *c2); static double mat3(double *c1, double *c2, double *c3); static void swapspace(struct space *s1, struct space *s2); static void quadalloc(void); static double **dsmatrix(int r, int c); /* matrix inversion, solve a system */ static double ctheta,*betaaddsorted; static double **kints,*cuu; /* see piter - partial integrals and so on, which we want to keep */ static struct basisfunct *bbx; /* storage */ static double ww6[7],yy6[7],ww7[33],yy7[33],*pompalcy,**pompalcyy; static int *rearix,*getiips,*luwi; static double *fiveee,*fiveh1,*fiverr,*betaaddv1,*betaremr1,*raoss,*luw,*luw2,**luww; static double *itertmp1,*itertmp2,*rearsorted,**solc1,**solc2,**solc3; static double **itertmp3,**pompcoef,**betaaddt1,**raoii,**raoc2,**betaremm2; /******************************************************************************/ void nlogcensorx(int *intpars) { intpars[0]=MAXKNOTS+5; } void nlogcensor(int *intpars, double *data0, double *dpars, double *logs, int *ad, double *kts) /* data0 - uncensored data; coefs on exit intpars- integer parameters dpars - double parameters ad - is a model added during addition (1), deletion (2) or not at all kts - knots */ { struct datastruct *data; struct space *spc; int i,j,strt,mind,ndmax,silent; double x,y,alpha; /* data - datastructure for all the data spc - datastructure for a model definespace - allocation for a model i,j - counters k - one line for kdata nlsd- does the work strt - where starting knots provided mind - minimum distance between knots ndmax - maximum dimension, the sign indicates whether it should be attained silent- print diagnostic output? (1=yes) alpha - penalty parameter x,y - utility */ /* we only want parameters and leave... */ if(intpars[0]<-10){ intpars[0]=MAXKNOTS+5; return; } /* define the data */ data=(struct datastruct *)Salloc(1,struct datastruct); (*data).ndata=intpars[0]; (*data).data=data0; (*data).same=issvector(intpars[0]+1); /* get the "same" vectors */ getsame(data0,intpars[0],(*data).same); (*data).idata=isvector(intpars[0]); /* allocate the space */ spc=definespace((*data).ndata); getiips=isvector((*spc).nip+10); luwi=isvector(2*MAXKNOTS+20); rearix=isvector((*data).ndata); fiverr=dsvector((*data).ndata+2*MAXKNOTS); fiveee=dsvector((*data).ndata+MAXKNOTS+5); fiveh1=dsvector((*data).ndata+MAXKNOTS+5); betaaddv1=dsvector((*data).ndata+MAXKNOTS+5); betaremr1=dsvector((*data).ndata+MAXKNOTS+5); raoss=dsvector((*data).ndata+MAXKNOTS+5); itertmp1=dsvector((*data).ndata+MAXKNOTS+5); itertmp2=dsvector((*data).ndata+MAXKNOTS+5); rearsorted=dsvector((*data).ndata+MAXKNOTS+5); luw=dsvector(2*MAXKNOTS+20); luw2=dsvector(2*MAXKNOTS+20); itertmp3=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); solc1=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); solc2=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); solc3=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); luww=dsmatrix(2*MAXKNOTS+20,2*MAXKNOTS+20); pompcoef=dsmatrix((*spc).nip+2,4); betaaddt1=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); betaremm2=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); raoii=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); raoc2=dsmatrix((*spc).nip+10,(*spc).nip+10); pompalcy=dsvector(2*MAXKNOTS+10); betaaddsorted=dsvector((*data).ndata); pompalcyy=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); bbx=(struct basisfunct *)Salloc(MAXKNOTS,struct basisfunct); /* get the integer and double parameters */ (*bbx).beta=0; (*bbx).sumunc=0; (*bbx).c3[0]=0; (*bbx).c3[1]=0; (*bbx).iks[0]=0; (*bbx).iks[1]=0; (*bbx).iks[2]=0; (*bbx).iks[3]=0; (*bbx).iks[4]=0; ndmax=intpars[1]; mind=intpars[6]; if(mind<1){ mind=2.5*pow((double)(*data).ndata,(double)0.2)+0.5; if((*data).ndata/mind<10)mind=(*data).ndata/10; if(mind<3)mind=3; } intpars[6]=mind; strt=intpars[2]; silent=intpars[3]; alpha=dpars[0]; if(strt==547) { strt= floor(2.5*pow((double)intpars[0],(double)0.2)); if(strt>25)strt=25; if(strt>intpars[0]/4)strt=intpars[0]/4; } if(alpha<0) alpha= mylog((double)intpars[0]); (*spc).ilow=intpars[4]; (*spc).iupp=intpars[5]; (*spc).low=dpars[1]; (*spc).upp=dpars[2]; i=0; /* starting knots */ if(ndmax==0) ndmax = - floor(4.*pow((double)intpars[0],(double)0.2)+1); if(ndmax>MAXKNOTS)ndmax=MAXKNOTS; if(strt<=0){ if(intpars[2]<0)intpars[2]= -intpars[2]; else intpars[2]=floor(2.5*pow((double)intpars[0],(double)0.2)+1); if(intpars[2]<0)intpars[2]= -intpars[2]; if(intpars[2]<3)intpars[2]=3; five(data0,kts,intpars,(*data).same); strt= intpars[2]; } if(ndmax>0 && strt>ndmax){ strt=floor((ndmax+3)/2.); } if(ndmax<0 && strt>(-ndmax)){ strt=floor((3-ndmax)/2.); } /* they were user provided */ if(strt>0){ (*spc).nk=strt; (*spc).ndim=strt-1; for(i=0;i(*spc).knots[j]){ (*spc).iknots[j]=i; j++; i--; if(j==(*spc).nk)i=(*data).ndata+10; } else y=x; } if(j==((*spc).nk)-1) (*spc).iknots[(*spc).nk-1]=(*data).ndata-1; /* two knots outside the range of the data is not allowed */ if(j<((*spc).nk)-1){ intpars[0]=17; return; } if((*spc).iknots[1]==0){ intpars[0]=18; return; } } /* allocations */ cuu = dsvector(MAXKNOTS+5); kints = dsmatrix((*spc).nip+10,7); quadalloc(); /* do the work */ intpars[0]=nlsd(spc,data,alpha,ndmax,mind,strt,silent,logs,ad); dpars[0]= alpha; /* output */ if(intpars[0]>0 && intpars[0]<100)return; intpars[1]=(*spc).nk; intpars[2]=(*spc).ndim; for(i=0;i<((*spc).nk)+2;i++){ data0[i] = 0.; for(j=0;j<(*spc).nk-1;j++) data0[i]+=(*spc).basis[j].beta*(*spc).basis[j].c1[i]; } data0[0]+=mylog((*spc).cth); for(i=0;i<((*spc).nk);i++)kts[i]=(*spc).knots[i]; } /******************************************************************************/ /* the work */ static int nlsd(struct space *best, struct datastruct *data, double alpha, int ndmax, int mind, int strt, int silent, double *logs, int *ad) /* best - best space up to now data - the data alpha - penalty parameter ndmax - maximum dimension size: negative: does not have to be attained mind - minimum distance between knots strt - were starting knots provided (1=yes) silent- should diagnostic info be printed? (1=yes) logs - log-likelihood of models ad - fit during addition (1), deletion (2), not at all (0) */ { struct space *current,*trynew; int add=1,i,oops=0,ndm2,oops2=0,oops3=0,j,coco=0; double xxa=0; /* current - present space trynew - needed during addition and deletion definespace- allocates a space add - adding=1, deleting=something else i - counter oops - error status ndm2 - sign of ndmax iter - fits a model swapspace - copies a model adddim- adds a dimension remdim- removes a dimension startspace- the starting model */ /* allocates storage for spaces */ trynew=definespace((*data).ndata); current=definespace((*data).ndata); /* starting */ swapspace(current,best); i=startspace(current,data,strt,silent); if(i==0)return 39; /* initialization */ ndm2=ndmax; if(ndmax<0)ndmax= -ndmax; (*best).aic=pow((double)10.,(double)150.); for(i=0;i0 || oops3>0)&& ndmax > (*current).ndim ){ /* problems. Jonge vriend, verzin een list! */ do{ for(i= -1;i> -4; i--){ /* begin opnieuw */ xxa=0.; coco=coco+1; j=startspace(current,data,i,silent); if(j==0)return 39; if(coco==10)return 39; oops=iter(current,data,silent,&xxa); oops2++; if(oops==0)i= -10; } }while(oops!=0 && ndmax > (*current).ndim); } if(oops2>2)oops2--; if(oops!=0){ if((*best).aic< -1.0e149)return 40; else swapspace(current,best); add=0; } if(oops==0){ /* compute aic */ logs[(*current).ndim-1]=(*current).aic; ad[(*current).ndim-1]=1; (*current).aic=(*current).ndim*alpha-2*(*current).aic; if((*current).ndim==ndmax)add=0; /* did we improve */ if((*current).aic<(*best).aic) swapspace(best,current); } /* continue */ if(add==1 && ndm2<0){ /* was there any recent improvement? */ for(i=2;i<(*current).ndim-2;i++){ if(logs[(*current).ndim-1]-logs[i-1]<((*current).ndim-i)/2.-0.5){ add=0; ndmax=(*current).ndim; } } } /* adds dimensions, computes new starting values */ if(add==1){ add=adddim(current,trynew,data,mind,silent); if(add!=1 && oops2<2) ndmax=(*current).ndim; if(add!=1 && oops2>=2){ oops3=1; add=1; } } /* keep on adding? */ }while(add==1); /* start deleting */ if((*current).ndim>2)do{ /* removes dimensions, computes new starting values */ if(ndmax>2)remdim(current,data,trynew,silent); /* fits the model */ oops=iter(current,data,silent,&xxa); if(oops!=0){ oops=oops+100; (*best).ndim=ndmax-1; return oops; } /* compute aic */ if((*current).aic>logs[(*current).ndim-1]){ logs[(*current).ndim-1]=(*current).aic; ad[(*current).ndim-1]=2; } (*current).aic=(*current).ndim*alpha-2*(*current).aic; /* did we improve */ if((*current).aic<(*best).aic) swapspace(best,current); /* does further deleting make sense */ }while((*current).aic-(*best).aic0)return 100; return 0; } /******************************************************************************/ /* allocates storage for a space, and initializes elements */ static struct space *definespace(int nd) { int i,j,k; struct space *spc; spc=(struct space *)Salloc(1,struct space); (*spc).aic=pow(10.,100.); (*spc).ndim=0; (*spc).nk=0; (*spc).nip=0; (*spc).ilow=0; (*spc).iupp=0; (*spc).low=0.; (*spc).upp=0.; (*spc).cth=0.; (*spc).iknots=isvector(MAXKNOTS+5); (*spc).knots=dsvector(MAXKNOTS+5); (*spc).score=dsvector(MAXKNOTS+5); (*spc).info=dsmatrix(MAXKNOTS+5,MAXKNOTS+5); k=MAXKNOTS+10+nd/100+300; (*spc).ips=dsvector(k); (*spc).basis=(struct basisfunct *)Salloc(MAXKNOTS,struct basisfunct); for(i=0;ih3)h3=h1[i]; } for(i=0;ig1)g1=j; if(h1[j]>rr[i] && j0) eps1 = 0; eps2=fi-1; for(i=0;i0.0001){ eps = (eps1+eps2)/2.; s=1; w=fi; for(i=1;i<=j2;i++){ v=i; s+=w; rr[i]=s; rr[k-i-1]=n+1.-s; v=fi-v*eps; if(v<1)v=1; w*=v; } if(2*j==k)s+=w/2.; else rr[j]=(n+1)/2.; if(2.*s>=n+1)eps1=eps; else eps2=eps; } else i1=100; for(i=0;i=1;i--) { sum=b[i]; for (j=i+1;j<=n;j++) sum -= a[i][j]*b[j]; b[i]=sum/a[i][i]; } } /******************************************************************************/ #define TINY 1.0e-20; static int ludcmp(double **a, int n, int *indx, double *d) { int i,imax=0,j,k; double big,dum,sum,temp,*vv; vv=luw; for(i=0;i<=n+1;i++)vv[i]=0.; *d=1.0; for (i=1;i<=n;i++) { big=0.0; for (j=1;j<=n;j++) if ((temp=fabs(a[i][j])) > big) big=temp; if (big == 0.0) return 0; vv[i]=1.0/big; } for (j=1;j<=n;j++) { for (i=1;i= big) { big=dum; imax=i; } } if (j != imax) { for (k=1;k<=n;k++) { dum=a[imax][k]; a[imax][k]=a[j][k]; a[j][k]=dum; } *d = -(*d); vv[imax]=vv[j]; } indx[j]=imax; if (a[j][j] == 0.0) a[j][j]=TINY; if (j != n) { dum=1.0/(a[j][j]); for (i=j+1;i<=n;i++) a[i][j] *= dum; } } return 1; } #undef TINY /******************************************************************************/ static int adddim(struct space *spc, struct space *spc2, struct datastruct *data, int mind, int silent) { int i,nx,uu=0,ll=0,nowloc1=0,loloc=0,uploc=0,bestloc= -1; int besti= -1,nowloc2; double *sorted,nowrao1,bestrao= -1.,nowrao2; sorted=betaaddsorted; swapspace(spc2,spc); for(i=0;i<(*data).ndata;i++) sorted[i]=(*data).data[i]; nx=(*data).ndata; /* find the interval */ for(i=0;i<=(*spc).nk;i++){ /* before first knot */ if(i==0) nowloc1=findl(&ll,&uu,mind,sorted,nx,(*spc).knots[0]); /* after last knot */ if(i==(*spc).nk) nowloc1=findr(&ll,&uu,mind,sorted,nx,(*spc).knots[(*spc).nk-1]); /* in between knots */ if(i>0 && i<(*spc).nk)nowloc1= findm(&ll,&uu,mind,sorted,nx,(*spc).knots[i-1],(*spc).knots[i]); /* possible location */ if(nowloc1>=0){ nowrao1=rao(spc,data,sorted[nowloc1]); if(nowrao1>bestrao){ loloc=ll; uploc=uu; bestloc=nowloc1; bestrao=nowrao1; besti=i; } } } if(bestloc<0)return -1; /* as long as the locations are different, do interval halving */ do{ if(sorted[uploc]>sorted[loloc]){ nowloc2=findyr(uploc,bestloc,sorted); /* two search points, the upper one */ if(nowloc2>=0) nowrao2=rao(spc,data,sorted[nowloc2]); else nowrao2=bestrao; /* two search points, the lower one */ nowloc1=findyl(bestloc,loloc,sorted); if(nowloc1>=0) nowrao1=rao(spc,data,sorted[nowloc1]); else nowrao1=bestrao; /* the middle one is the best, we call it quits */ if(bestrao>=nowrao2 && bestrao>=nowrao1) loloc=uploc; else{ /* the lower search point is the best */ if(nowrao1>bestrao){ uploc=bestloc; bestloc=nowloc1; bestrao=nowrao1; } /* the upper search point is the best */ else{ loloc=bestloc; bestloc=nowloc2; bestrao=nowrao2; } } } }while(sorted[uploc]>sorted[loloc]); /* failure */ if(bestloc<0)return bestloc; /* done record the new knot in its correct position */ if(besti==(*spc).nk){ (*spc).knots[(*spc).nk]=sorted[bestloc]; (*spc).iknots[(*spc).nk]=bestloc; } else{ for(i=(*spc).nk;i>besti;i=i-1){ (*spc).knots[i]=(*spc).knots[i-1]; (*spc).iknots[i]=(*spc).iknots[i-1]; } (*spc).knots[besti]=sorted[bestloc]; (*spc).iknots[besti]=bestloc; } ((*spc).nk)++; ((*spc).ndim)++; if(silent==1) (void)Rprintf("add(%.2f), rao=%.2f ",sorted[bestloc],bestrao); /* get (*spc).ips (*spc).nip (*data).idatx */ /* get (*spc).basis.c1 (*spc).basis.c2 (*spc).basis.c3 (*spc).basis.sumunc */ setupspace(spc,data); /* get (*spc).basis.beta */ betaadd(spc,spc2,besti); return 1; } /******************************************************************************/ /* finds location in an interval (l,b) - l might not have been tested yet */ static int findyl(int u, int l, double *x) { int i; if(x[l]==x[u])return -1; i=(u+l-1)/2; if(x[i]!=x[u])return i; i=(i+l)/2; if(x[i]!=x[u])return i; return l; } /******************************************************************************/ /* finds location in an interval (b,u) - u might not have been tested yet */ static int findyr(int u, int l, double *x) { int i; if(x[l]==x[u])return -1; i=(u+l+1)/2; if(x[i]!=x[l])return i; i=(i+u)/2; if(x[i]!=x[l])return i; return u; } /******************************************************************************/ /* Finds a possible location for a knot on the interval (0,knot1) ll - lowest number we can search on in the future uu - highest number we can search on in the future mind minimum distance between knots x - data nx - length of data knt- knot */ static int findl(int *ll, int *uu, int mind, double *x, int nx, double knt) { /* dlocation - finds uu */ int i; (*uu)=dlocation(0,x,nx,knt); if((*uu)k)return 0; if(x[nx-1]<=k)return nx-1; for(i=0;ik && x[i]<=k) return i; } if(x[nx-1]=k)return 0; for(i=1;i=k && x[i-1]besti;i=i-1) v1[i+2]=v1[i+1]; v1[besti+2]=0.; for(i=0;i0.01 && (*xxa)-logl > 100){ /* try alternate starting values */ lnew=logl; for(j=0;j<(*spc).ndim;j++){ tmp1[j]=(*spc).score[j]; tmp2[j]=(*spc).basis[j].beta; (*spc).basis[j].beta=0.;; for(i=0;i<(*spc).ndim;i++)tmp3[i][j]=(*spc).info[i][j]; } startnow(spc,data); logl=pompall(spc,data,2,&i2); if(lnew>logl ){ logl=lnew; for(j=0;j<(*spc).ndim;j++){ (*spc).score[j]=tmp1[j]; (*spc).basis[j].beta=tmp2[j]; for(i=0;i<(*spc).ndim;i++)(*spc).info[i][j]=tmp3[i][j]; } } else i1=i2; } /* serious ctheta problems */ if(i1==1)return 7; /* solve the system */ j=lusolve2((*spc).info,(*spc).ndim,(*spc).score); /* return 2 - something wrong with system */ if(j==0) return 2; /* adjust the tail shifts */ if((*spc).ilow==1){ (*spc).score[0]= -(*spc).score[0]/(*spc).basis[0].beta; if((*spc).score[0]<-100)(*spc).score[0]=-100; } if((*spc).iupp==1){ (*spc).score[1]= -(*spc).score[1]/(*spc).basis[1].beta; if((*spc).score[1]<-100)(*spc).score[1]=-100; } /* find the right step size */ factor= -1.; /* tail check */ if((*spc).ilow==1 && (*spc).iupp==1 && (*spc).basis[0].beta==0 && (*spc).basis[1].beta==0)return 6; if((*spc).ilow==1 && (*spc).basis[0].beta>=0)return 4; if((*spc).iupp==1 && (*spc).basis[1].beta>=0)return 3; /* adjust beta */ if((*spc).ilow==0)(*spc).basis[0].beta-=factor*(*spc).score[0]; else (*spc).basis[0].beta= -myexp(factor*(*spc).score[0]+mylog(-(*spc).basis[0].beta)); if((*spc).iupp==0)(*spc).basis[1].beta-=factor*(*spc).score[1]; else (*spc).basis[1].beta= -myexp(factor*(*spc).score[1]+mylog(-(*spc).basis[1].beta)); for(j=2;j<(*spc).ndim;j++)(*spc).basis[j].beta-=factor*(*spc).score[j]; do{ /* new logl */ if((*spc).ilow==1 && (*spc).iupp==1 && (*spc).basis[0].beta==0 && (*spc).basis[1].beta==0)return 6; if((*spc).ilow==1 && (*spc).basis[0].beta>=0)return 4; if((*spc).iupp==1 && (*spc).basis[1].beta>=0)return 3; lnew=pompall(spc,data,0,&i); /* did we win? */ kk=0; if((lnew-logl)< -zerror)kk=1; if((lnew-logl)< -zerror * 100 && (*spc).ilow==1 && (*spc).basis[0].beta> -1.e8 )kk=1; if((lnew-logl)< -zerror * 100 && (*spc).iupp==1 && (*spc).basis[1].beta> -1.e8 )kk=1; if(kk==1 || (i==1 && fabs(factor)>0.1)){ /* adjust the stepsize */ i=0; factor=factor/2.; if((*spc).ilow==0)(*spc).basis[0].beta+=factor*(*spc).score[0]; else (*spc).basis[0].beta= -myexp(-factor*(*spc).score[0]+mylog(-(*spc).basis[0].beta)); if((*spc).iupp==0)(*spc).basis[1].beta+=factor*(*spc).score[1]; else (*spc).basis[1].beta= -myexp(-factor*(*spc).score[1]+mylog(-(*spc).basis[1].beta)); for(j=2;j<(*spc).ndim;j++) (*spc).basis[j].beta+=factor*(*spc).score[j]; if(fabs(factor)< 0.00001 && (((*spc).iupp==1 && (*spc).basis[1].beta> -1.e8) || ((*spc).ilow==1 && (*spc).basis[0].beta> -1.e8))) return 5; if(fabs(factor)< 0.00001) return 8; /* return 5/8 - too much step-halving */ } if(i==1)return 7; } while(kk==1); /* convergence */ if(fabs(lnew-logl) 0.96 )iter=maxiter+1000; if(fabs(lnew-logl) -1.e8 )iter=maxiter+1000; if(fabs(lnew-logl) -1.e8 )iter=maxiter+1000; } if(iter0)(*xp)=0; else{ (*xp)=1.; return 0.; } ctheta=mylog(ctheta); /* logl - uncensored */ logl=0.; for(i=0;i<(*data).ndata;i++){ if((*data).same[i]==0) f=pol3(coef[(*data).idata[i]],(*data).data[i])-ctheta; logl+=f; } ctheta=myexp(-ctheta); if(what==0){ return logl; } /* get ctheta-j and ctheta-jk */ initk(0,ndim,(*spc).score,(*spc).info,cy,cyy); (void)savecoden(spc,0,nip-1,(*spc).score,(*spc).info); /* score and hessian - basic */ for(i=0;i=(*spc).basis[k].c3[0]&&j<=(*spc).basis[k].c3[1]){ cz[k]+=inp3(what,(*spc).basis[k].c2[j]); for(j2=0;j2<=k;j2++){ if(j>=(*spc).basis[j2].c3[0]&&j<=(*spc).basis[j2].c3[1]) czz[k][j2]+= mat3(what,(*spc).basis[k].c2[j],(*spc).basis[j2].c2[j]); } } } } /******************************************************************************/ static int savecoden(struct space *spc,int i0,int i1,double *cz,double **czz) { int j; for(j=i0;j=0)for(i=0;i<7;i++)int2ext[i]=kints[j0ext][i]-intext[i]; /* get ctheta-j and ctheta-jk */ for(j=0;j<=ndim;j++) iext[j]=0.; sext=save22coden(spc,iext,bb,int2ext,j0ext,c2ext); for(j=0;j<=ndim;j++) iext[j]= (*data).ndata*iext[j]*ctheta; sext= -(*data).ndata*sext*ctheta; for(j=0;j=t[j]){ ii[j]=i; i=(*spc).nip; } } (*bb).c3[0]=ii[0]-1; if(ii[1]=ii[j1]){ (*bb).c2[j][3]+=cc[j1]; (*bb).c2[j][2]-=3.*cc[j1]*t[j1]; (*bb).c2[j][1]+=3.*cc[j1]*t[j1]*t[j1]; (*bb).c2[j][0]-=cc[j1]*t[j1]*t[j1]*t[j1]; } /* get j0ext */ j0ext=(*spc).nip+100; if(t[0]<(*spc).ips[1])j0ext=0; else for(i=1;i<(*spc).nip-2;i++){ if(t[0]==(*spc).ips[i])j0ext= -1; else if(t[0]<(*spc).ips[i+1])j0ext=i; if(j0ext<(*spc).nip+50)i=(*spc).nip; } if(j0ext>(*spc).nip+50)j0ext=(*spc).nip-2; /* get c2ext */ for(i=0;i<4;i++)c2ext[i]=0.; for(j1=0;j1<3;j1++) if(t[j1]<=t[0]){ c2ext[3]+=cc[j1]; c2ext[2]-=3.*cc[j1]*t[j1]; c2ext[1]+=3.*cc[j1]*t[j1]*t[j1]; c2ext[0]-=cc[j1]*t[j1]*t[j1]*t[j1]; } /* get intext */ if(j0ext>=0){ for(j=0;j<4;j++){ coef[j]=0.; for(k=0;k<(*spc).ndim;k++) coef[j]+=(*spc).basis[k].beta*(*spc).basis[k].c2[j0ext][j]; } if(j0ext==0){ if((*spc).ilow==1) l1int(rrr,t[0],coef,1,1); else l2int(rrr,(*spc).low,t[0],coef,1); } if(j0ext==((*spc).nip)-2) l2int(rrr,(*spc).ips[j0ext],t[0],coef,1); if(j0ext>0&&j0ext<((*spc).nip)-2) m1int(rrr,(*spc).ips[j0ext],t[0],1,coef,0); for(i=0;i<7;i++)intext[i]=rrr[i]; } /* get (*spc).basis.sumunrc */ (*bb).sumunc=0.; for(j1=0;j1<(*data).ndata;j1++){ j0=(*data).idata[j1]; if(j0>=(*bb).c3[0]&&j0<=(*bb).c3[1]){ if(j0!=j0ext || t[0]>(*data).data[j1]) (*bb).sumunc+=pol3((*bb).c2[j0],(*data).data[j1]); else (*bb).sumunc+=pol3(c2ext,(*data).data[j1]); } } return j0ext; } /******************************************************************************/ /* integrates all steps for score and hessian */ static double save22coden(struct space *spc, double *czz, struct basisfunct *bb, double int2ext[7], int j0ext, double c2ext[4]) { int j,k,i1=((*spc).nip)-1; double cz=0; /* correct the new one */ if(j0ext>=0 && j0ext=(*bb).c3[0]&&j<=(*bb).c3[1]){ for(k=0;k<(*spc).ndim;k++) if(j>=(*spc).basis[k].c3[0]&&j<=(*spc).basis[k].c3[1]) czz[k]+=mat3(kints[j],(*spc).basis[k].c2[j],(*bb).c2[j]); cz+=inp3(kints[j],(*bb).c2[j]); czz[(*spc).ndim]+=mat3(kints[j],(*bb).c2[j],(*bb).c2[j]); } } /* correct the new one part II */ if(j0ext>=0 && j0ext=(*spc).basis[k].c3[0]&&j0ext<=(*spc).basis[k].c3[1]) if(j0ext>=(*bb).c3[0]&&j0ext<=(*bb).c3[1]) czz[k]+=mat3(int2ext,(*spc).basis[k].c2[j0ext],c2ext); cz+=inp3(int2ext,c2ext); czz[(*spc).ndim]+=mat3(int2ext,c2ext,c2ext); for(k=0;k<7;k++)kints[j0ext][k]+=int2ext[k]; } return cz; } /******************************************************************************/ static void remdim(struct space *spc,struct datastruct *data,struct space *spc2,int silent) /* spc - model to be worked on spc2 - temporary copy of the space data - data silent- should info be printed? (1=yes) */ { double ratmax=0.,se,phi; int i,j,k,irmax=1,ndim=(*spc).ndim; /* ratmax - largest phi/se ratio phi - coefficient in power basis se - standard errors i,j,k - counters irmax - for which coefficient is ratmax attained getip - gets the setupspace - sets up a new space swapspace - copies a space betarem - new starting values */ /* invert the Hessian */ luinverse((*spc).info,ndim); /* copy for later use */ swapspace(spc2,spc); for(i=0;i<(*spc).nk;i++){ /* compute the coefficient */ phi = 0.; for(j=0;j phi * ratmax){ ratmax = se / phi; irmax = i; } } if(silent==1) (void)Rprintf("rem(%.2f), wald=%.2f ", (*spc).knots[irmax],1./(ratmax*ratmax)); /* get (*spc).nk and (spc).ndim */ (*spc).nk -= 1; (*spc).ndim -= 1; /* remove the knot */ for(i=irmax;i<(*spc).nk;i++){ (*spc).iknots[i]=(*spc).iknots[i+1]; (*spc).knots[i]=(*spc).knots[i+1]; } /* get (*spc).ips (*spc).nip (*data).idatx and (*spc).basis.iks */ /* get (*spc).basis.c1 (*spc).basis.c2 (*spc).basis.c3 (*spc).basis.sumunc */ setupspace(spc,data); /* get (*spc).basis.beta */ betarem(spc2,spc,irmax); } /******************************************************************************/ static void betarem(struct space *spc2,struct space *spc,int irmax) { int i,j,k; double **mm2,*r1,x,y; k=(*spc2).ndim; mm2=betaremm2; r1=betaremr1; /* find A, the restriction */ for(i=0;i=0 */ if(((*spc).ilow==1 && r1[0]>=0) ||( (*spc).iupp==1 && r1[1]>=0)){ /* only restrictions on the lower tail */ if((*spc).ilow==1 && (*spc).iupp==0){ if(irmax<=2){ for(i=0;i<((*spc2).nk)+2;i++){ r1[i] = 0.; for(j=0;j<(*spc2).ndim;j++) r1[i]+=(*spc2).basis[j].beta*(*spc2).basis[j].c1[i]; } redo1(spc2,irmax,k); for(i=0;i=k-2){ for(i=0;i<((*spc2).nk)+2;i++){ r1[i] = 0.; for(j=0;j<(*spc2).ndim;j++) r1[i]+=(*spc2).basis[j].beta*(*spc2).basis[j].c1[i]; } redo2(spc2,irmax,(*spc2).nk); for(i=0;ik-3 || irmax<=2){ for(i=0;i<((*spc2).nk)+2;i++){ r1[i] = 0.; for(j=0;j<(*spc2).ndim;j++) r1[i]+=(*spc2).basis[j].beta*(*spc2).basis[j].c1[i]; } if(irmax<=2)redo1(spc2,irmax,k); if(irmax>k-3) redo2(spc2,irmax,(*spc2).nk); for(i=0;i2) (*bn).c3[1]=(*bn).iks[4]+1; /* get (*spc).basis.c2 */ for(j=0;j<(*spc).nip;j++) for(k=0;k<4;k++)(*bn).c2[j][k]=0.; for(j=(*bn).c3[0];j<=(*bn).c3[1];j++){ l=5; if(i==0||i==1)l=3; if(i==2)l=4; if(i==0){ (*bn).c2[j][0]+=(*bn).c1[0]; (*bn).c2[j][1]+=(*bn).c1[1]; } for(n=0;n2)m=i+n-3; a=(*spc).knots[m]; b=(*bn).c1[2+m]; if(j>=(*bn).iks[n]){ (*bn).c2[j][3]+=b; b=a*b; (*bn).c2[j][2]-=3.*b; b=a*b; (*bn).c2[j][1]+=3.*b; b=a*b; (*bn).c2[j][0]-=b; } } } /* get (*spc).basis.sumunc */ (*bn).sumunc=0.; for(m=0;m<(*data).ndata;m++){ l=(*data).idata[m]; if(l>=(*bn).c3[0]&&l<=(*bn).c3[1]) (*bn).sumunc+=pol3((*bn).c2[l],(*data).data[m]); } } } /******************************************************************************/ /* get c1 - the power basis representation - for a basisfunction */ static void getc1(double *t,double *c,int i,int k) { /* get (*spc).basis.c1 */ double a,b,d[10],r; int j; for(j=0;j<=k+1;j++)c[j]=0.; if(i==0){ a=t[2]-t[0]; b=t[2]-t[1]; c[2]= 1.; c[3]= -a/b; c[4]= -c[2]-c[3]; c[1]= -3.*(t[0]*t[0]+c[3]*t[1]*t[1]+c[4]*t[2]*t[2]); c[0]= -t[2]*c[1]-c[2]*a*a*a-c[3]*b*b*b; } if(i==1){ c[k-1]=1.; c[k]=(t[k-3]-t[k-1])/(t[k-1]-t[k-2]); c[k+1]= -c[k]-c[k-1]; } if(i==2) getonec1(c,k-2,t,k-4); if(i>2){ getonec1(c,i-1,t,i-3); getonec1(d,0,t,i-2); a=0.; b=0.; for(j=0;j<4;j++){ r=(t[k-1]-t[i+j-2]); a+=d[j]*r*r*r; r=(t[k-1]-t[i+j-3]); b+=c[i+j-1]*r*r*r; } for(j=0;j<4;j++)c[i+j]-=d[j]*b/a; } } /******************************************************************************/ static void getonec1(double *c,int i,double *t,int j) { c[i]=1.; c[i+3]=(t[j+2]-t[j])*(t[j]-t[j+1])/((t[j+2]-t[j+3])*(t[j+1]-t[j+3])); c[i+2]=(c[i+3]*(t[j+1]-t[j+3])+t[j+1]-t[j])/(t[j+2]-t[j+1]); c[i+1]=-1.-c[i+3]-c[i+2]; } /******************************************************************************/ static void setupspace(struct space *spc, struct datastruct *data) { int i; /* get (*spc).ips (*spc).nip (*data).idatx and (*spc).basis.iks */ getip(spc,data); /* get (*spc).basis.c1 */ for(i=0;i<(*spc).ndim;i++)getc1((*spc).knots,(*spc).basis[i].c1,i,(*spc).nk); /* get (*spc).basis.c2 (*spc).basis.c3 and (*spc).basis.sumunc */ getc2(spc,data); } /******************************************************************************/ static int startspace(struct space *spc, struct datastruct *data, int strt, int silent) { int i,k,l=0,ok; double r,s; /* place the knots */ k=(*data).ndata; ok=1; if(strt==0){ (*spc).iknots[0]=0; (*spc).iknots[1]=(int)(k/2); (*spc).iknots[2]=k-1; for(i=0;i<3;i++) (*spc).knots[i]=(*data).data[(*spc).iknots[i]]; (*spc).nk=3; if(silent==1)(void)Rprintf("Starting knots at %.2f, %.2f and %.2f ", (*spc).knots[0],(*spc).knots[1],(*spc).knots[2]); (*spc).ndim=2; } if(strt<0){ if(strt== -1){ l=((*spc).nk); r=l+2.; if(l>3){ s=(double)l/((double)l-3.); for(i=1;i3){ s=(double)(l+2)/((double)l-3.); for(i=1;i3) s=(double)(l)/((double)l-3.); for(i=1;i0)if((*spc).knots[i]<=(*spc).knots[i-1])ok=0; } (*spc).nk=l; if(ok==0)ok=rearrange(spc,data); if(ok==0)return ok; (*spc).ndim=l-1; if(silent==1){ (void)Rprintf("\nRestart: knots at "); for(i=0;ir1){ s1+= (*data).data[i]-r1; j1+=2; } } s0=2.*s0/(double)j0; s1=2.*s1/(double)j1; if((*spc).ilow==1) (*spc).basis[0].beta= -1./fabs(s0*(*spc).basis[0].c1[1]); if((*spc).iupp==1)(*spc).basis[1].beta= -1./fabs(s1*(*spc).basis[1].c2[(*spc).nip][1]); } /******************************************************************************/ static int rearrange(struct space *spc,struct datastruct *data) { int i,k,*ix,jx[500],nk=(*spc).nk,is,j,l; double *sorted; sorted=rearsorted; ix=rearix; for(i=0;i<(*data).ndata;i++){ sorted[i]=(*data).data[i]; ix[i]=i; } k=1; for(i=1;i<(*data).ndata;i++){ if(sorted[i]>sorted[k-1]){ sorted[k]=sorted[i]; ix[k]=ix[i]; k++; } } is=0; for(i=0;ijx[j])jx[j]++; for(j=nk-2;j>0;j--) if(jx[j]==jx[j+1]) if(jx[j-1]=0 && j<(*data).ndata) (*data).idata[j]=i; } /* get (*spc).basis.iks */ kips=iips; for(i=0;i<(*spc).nk;i++){ j=(*spc).iknots[i]; kips[i]=(*data).idata[j]; } for(i=0;i<3;i++)(*spc).basis[0].iks[i]=kips[i]; for(i=0;i<3;i++)(*spc).basis[1].iks[i]=kips[i-3+(*spc).nk]; if((*spc).ndim>2)for(i=0;i<4;i++)(*spc).basis[2].iks[i]=kips[i-4+(*spc).nk]; for(j=3;j<(*spc).ndim;j++)for(i=0;i<5;i++)(*spc).basis[j].iks[i]=kips[j+i-3]; } void rpqlsd(double *coef, double *knots, double *bnd, int *ipq, double *pq, int *lk, int *lp) { double *kpl,**cpl,*ppl,*pqx,r; double *zz,cor; int i,j,nk,fst,lst,jx; /* Gaussian quadrature coefficients */ ww6[1 ]= 0.467913934572691; yy6[1 ]= 0.238619186083197; ww6[2 ]= 0.360761573048139; yy6[2 ]= 0.661209386466265; ww6[3 ]= 0.171324429379170; yy6[3 ]= 0.932469514203152; ww7[1 ]= 0.00178328072169643; yy7[1 ]= 0.99930504173577217; ww7[2 ]= 0.00414703326056247; yy7[2 ]= 0.99634011677195533; ww7[3 ]= 0.00650445796897836; yy7[3 ]= 0.99101337147674429; ww7[4 ]= 0.00884675982636395; yy7[4 ]= 0.98333625388462598; ww7[5 ]= 0.01116813946013113; yy7[5 ]= 0.97332682778991098; ww7[6 ]= 0.01346304789671864; yy7[6 ]= 0.96100879965205377; ww7[7 ]= 0.01572603047602472; yy7[7 ]= 0.94641137485840277; ww7[8 ]= 0.01795171577569734; yy7[8 ]= 0.92956917213193957; ww7[9 ]= 0.02013482315353021; yy7[9 ]= 0.91052213707850282; ww7[10]= 0.02227017380838325; yy7[10]= 0.88931544599511414; ww7[11]= 0.02435270256871087; yy7[11]= 0.86599939815409277; ww7[12]= 0.02637746971505466; yy7[12]= 0.84062929625258032; ww7[13]= 0.02833967261425948; yy7[13]= 0.81326531512279754; ww7[14]= 0.03023465707240248; yy7[14]= 0.78397235894334139; ww7[15]= 0.03205792835485155; yy7[15]= 0.75281990726053194; ww7[16]= 0.03380516183714161; yy7[16]= 0.71988185017161088; ww7[17]= 0.03547221325688239; yy7[17]= 0.68523631305423327; ww7[18]= 0.03705512854024005; yy7[18]= 0.64896547125465731; ww7[19]= 0.03855015317861563; yy7[19]= 0.61115535517239328; ww7[20]= 0.03995374113272034; yy7[20]= 0.57189564620263400; ww7[21]= 0.04126256324262353; yy7[21]= 0.53127946401989457; ww7[22]= 0.04247351512365359; yy7[22]= 0.48940314570705296; ww7[23]= 0.04358372452932345; yy7[23]= 0.44636601725346409; ww7[24]= 0.04459055816375657; yy7[24]= 0.40227015796399163; ww7[25]= 0.04549162792741814; yy7[25]= 0.35722015833766813; ww7[26]= 0.04628479658131442; yy7[26]= 0.31132287199021097; ww7[27]= 0.04696818281621002; yy7[27]= 0.26468716220876742; ww7[28]= 0.04754016571483031; yy7[28]= 0.21742364374000708; ww7[29]= 0.04799938859645831; yy7[29]= 0.16964442042399283; ww7[30]= 0.04834476223480295; yy7[30]= 0.12146281929612056; ww7[31]= 0.04857546744150343; yy7[31]= 0.07299312178779904; ww7[32]= 0.04869095700913972; yy7[32]= 0.02435029266342443; /* allocation */ kpl=dsvector((*lk)*4); ppl=dsvector((*lk)*4); cpl=dsmatrix((*lk)*4,4); pqx=dsvector((*lp)); /* get the integration points: the knots */ nk=(*lk)+1; for(i=0;i<=nk;i++){ if(i0)kpl[i]=knots[i-1]; if(i==0){ kpl[0]=knots[0]-1; if(bnd[0]>0.5)kpl[0]=bnd[1]; else if(pq[0]0.5)kpl[nk]=bnd[3]; else if(pq[(*lp)-1]+1.>kpl[nk])kpl[nk]=pq[(*lp)-1]+1.; } /* get the coeffiecients */ cpl[i][0]=coef[0]; cpl[i][1]=coef[1]; cpl[i][2]=0.; cpl[i][3]=0.; for(j=0;i>j && j<(*lk);j++){ cpl[i][3]+=coef[j+2]; cpl[i][2]-=3.*coef[j+2]*knots[j]; cpl[i][1]+=3.*coef[j+2]*knots[j]*knots[j]; cpl[i][0]-=coef[j+2]*knots[j]*knots[j]*knots[j]; } if(i>=nk-1){ cpl[i][3]=0.; cpl[i][2]=0.; } } /* compute the density */ ppl[0]=0.; if(bnd[0]>0.5)ppl[1]=z2int(kpl[0],kpl[1],cpl[0]); else ppl[1]=z1int(kpl[1],cpl[0],1); for(i=1;i0.5) ppl[nk]=z2int(kpl[nk-1],kpl[nk],cpl[nk-1])+ppl[nk-1]; else ppl[nk]=z1int(kpl[nk-1],cpl[nk-1],-1)+ppl[nk-1]; /* higher precision needed */ if(ppl[nk]<0.99999 || ppl[nk]>1.00001){ /* integration points: knots times four */ nk=4*(*lk)-2; for(i=0;i<=nk;i++){ if(i0){ j=floor((double)(i-1)/4.); r=(double)i/4.-j-0.25; if(r>0.01){ kpl[i]=(1.-r)*knots[j]+r*knots[j+1]; } else { kpl[i]=(1.-r)*knots[j]; } } if(i==0){ kpl[0]=knots[0]-1; if(bnd[0]>0.5)kpl[0]=bnd[1]; else if(pq[0]0.5)kpl[nk]=bnd[3]; else if(pq[(*lp)-1]+1>kpl[nk])kpl[nk]=pq[(*lp)-1]+1.; } /* get the coeffiecients */ cpl[i][0]=coef[0]; cpl[i][1]=coef[1]; cpl[i][2]=0.; cpl[i][3]=0.; for(j=0;i>j*4 && j<(*lk);j++){ cpl[i][3]+=coef[j+2]; cpl[i][2]-=3.*coef[j+2]*knots[j]; cpl[i][1]+=3.*coef[j+2]*knots[j]*knots[j]; cpl[i][0]-=coef[j+2]*knots[j]*knots[j]*knots[j]; } if(i>=nk-1){ cpl[i][3]=0.; cpl[i][2]=0.; } } /* compute the density */ if(bnd[0]>0.5)ppl[1]=z2int(kpl[0],kpl[1],cpl[0]); else ppl[1]=z1int(kpl[1],cpl[0],1); for(i=1;i0.5) ppl[nk]=z2int(kpl[nk-1],kpl[nk],cpl[nk-1])+ppl[nk-1]; else ppl[nk]=z1int(kpl[nk-1],cpl[nk-1],-1)+ppl[nk-1]; } /* correction factor */ cor=1.; /* correct the density */ for(i=0;i<=nk;i++)cpl[i][0]=cpl[i][0]+log(1./ppl[nk]); for(i=0;i<=nk;i++)ppl[i]=ppl[i]/ppl[nk]; j=0; /* initialize */ if((*ipq)==0)zz=ppl; else zz=kpl; /* before the first point */ for(j=0;j<(*lp) && pq[j]<=zz[0];j++){ if((*ipq)==0){ if(bnd[0]>0.5)pqx[j]=kpl[0]; else pqx[j]= -1.0e100; } else pqx[j]=0.; } /* before the first knot */ fst=j; lst=j-1; jx=j; for(j=jx;j<(*lp) && pq[j]<=zz[1];j++) lst=j; if(lst>=fst){ if((*ipq)==0) getq0(pq,pqx,fst,lst,cpl[0],kpl[0],bnd[0],cor); else getp0(pq,pqx,fst,lst,cpl[0],kpl[0],bnd[0],cor); } /* per interval between integration points */ for(i=1;i=fst){ if((*ipq)==0) getq1(pq,pqx,fst,lst,cpl[i],kpl[i],kpl[i+1],ppl[i],ppl[i+1]); else getp1(pq,pqx,fst,lst,cpl[i],kpl[i],kpl[i+1],ppl[i],ppl[i+1]); } } /* beyond the last knot */ fst=j; lst=j-1; jx=j; for(j=jx;j<(*lp) && pq[j]=fst){ if((*ipq)==0) getq2(pq,pqx,fst,lst,cpl[nk-1],kpl[nk],bnd[2],cor); else getp2(pq,pqx,fst,lst,cpl[nk-1],kpl[nk],bnd[2],cor); } /* outside the range */ jx=j; for(j=jx;j<(*lp);j++){ if((*ipq)==0){ if(bnd[2]>0.5)pqx[j]=kpl[nk]; else pqx[j]= 1.0e100; } else pqx[j]=1.; } for(j=0;j<(*lp);j++)pq[j]=pqx[j]; } /******************************************************************************/ static void getp0(double *q, double *p, int f, int l, double *cf, double k, double b, double cr) { int i; if(b>0.5) for(i=f;i<=l;i++) p[i]=z2int(k,q[i],cf)/cr; else for(i=f;i<=l;i++) p[i]=z1int(q[i],cf,1)/cr; } /******************************************************************************/ static void getq0(double *p, double *q, int f, int l, double *cf, double k, double b, double cr) { int i; if(b>0.5)for(i=f;i<=l;i++) q[i]=pqexpi(2,k,p[i]/cr,cf); else for(i=f;i<=l;i++) q[i]=pqexpi(1,k,p[i]/cr,cf); } /******************************************************************************/ static void getp2(double *q, double *p, int f, int l, double *cf, double k, double b, double cr) { int i; if(b>0.5) for(i=f;i<=l;i++) p[i]=1.-z2int(q[i],k,cf)/cr; else for(i=f;i<=l;i++) p[i]=1.-z1int(q[i],cf,-1)/cr; } /******************************************************************************/ static void getq2(double *p, double *q, int f, int l, double *cf, double k, double b, double cr) { int i; if(b>0.5)for(i=f;i<=l;i++) q[i]=pqexpi(4,k,1.-p[i]/cr,cf); else for(i=f;i<=l;i++) q[i]=pqexpi(3,k,1.-p[i]/cr,cf); } /******************************************************************************/ static void getp1(double *q, double *p, int f, int l, double *cf, double k0, double k1, double p0, double p1) { int i,j=0; double r; if(l-f>5)j=1; p[f]=z3int(k0,q[f],cf,j); r=p[f]+z3int(q[l],k1,cf,j); for(i=f+1;i<=l;i++) p[i]=z3int(q[i-1],q[i],cf,j)+p[i-1]; r=p[l]+z3int(q[l],k1,cf,j); r=(p1-p0)/r; for(i=f;i<=l;i++)p[i]=p0+p[i]*r; } /******************************************************************************/ static void getq1(double *p, double *q, int f, int l, double *cf, double k0, double k1, double p0, double p1) { int i,j; double y[51],f1[101],r,s; r=(k1-k0)/100.; for(i=0;i<101;i++) f1[i]=getf(cf,(double)(k0+r*i)); y[0]=0.; for(i=1;i<=50;i++)y[i]=y[i-1]+r*(f1[2*(i-1)]+4*f1[2*i-1]+f1[2*i])/3.; s=(p1-p0)/y[50]; for(i=0;i<=50;i++)y[i]=p0+y[i]*s; y[0]=p0; y[50]=p1; i=0; s=2.*r; for(j=f;j<=l;j++){ q[j]=k0-1.; do{ if(p[j]>=y[i] && p[j]<=y[i+1]) q[j]=k0+s*i+s*(p[j]-y[i])/(y[i+1]-y[i]); else i++; } while ((q[j]600.) f1=600.; return (double)(j*myexp(f1)); } /******************************************************************************/ /* computes integrals from t1 to t2 of exp(polynomial(c0)) */ static double z2int(double t1,double t2,double *c0) { int i1=1; double f1,f2; if(t2==t1)return 0.; if(c0[1]!=0){ if(c0[1]<0) i1 = -1; f1 = mylog(fabs(1./c0[1])) + c0[1]*t1+c0[0]; f2 = f1 + c0[1]*(t2-t1); if(f1>600.) f1=600.; if(f2>600.) f2=600.; return (double)(i1*myexp(f2)-i1*myexp(f1)); } else return (t2-t1)*myexp(c0[0]); } /******************************************************************************/ /* computes integrals from t1 to t2 of exp(polynomial(coef)) */ static double z3int(double k1,double k2,double *coef,int accuracy) { double r1,r2,x,y,v,vv=0.; int i1; if(k2==k1)return 0.; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); if(accuracy==1){ for(i1=1;i1<4;i1++){ y=yy6[i1]*r1; v=r1*ww6[i1]; x=r2-y; vv+=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); x=r2+y; vv+=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); } } else{ for(i1=1;i1<33;i1++){ y=yy7[i1]*r1; v=r1*ww7[i1]; x=r2-y; vv+=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); x=r2+y; vv+=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); } } return vv; } /******************************************************************************/ /* 1: -inf -> x / 2: t -> x / 3: x -> inf / 4: x -> t */ static double pqexpi(int version,double t,double p,double *cf) { if(cf[1]!=0. || version == 1 || version == 3){ p=p*cf[1]; if(version == 1 && p < 0)return myexp((double)600.); if(version == 3 && p > 0)return -myexp((double)600.); if(version==2 || version ==4)t=myexp(t*cf[1]+cf[0]); if(version == 2 && t+p < 0)return myexp((double)600.); if(version == 4 && t-p < 0)return -myexp((double)600.); if(version==1)return (mylog(p)-cf[0])/cf[1]; if(version==2)return (mylog(t+p)-cf[0])/cf[1]; if(version==3)return (mylog(-p)-cf[0])/cf[1]; return (mylog(t-p)-cf[0])/cf[1]; } if(version==2)return t+p/myexp(cf[0]); return t-p/myexp(cf[0]); } /******************************************************************************/ static double *dsvector(int l) /* allocate a double vector with subscript range v[0...l] */ { double *v; int i; v=(double *)Salloc(l+1,double); for(i=0;i<=l;i++)v[i]=0.; return v; } /******************************************************************************/ static double getf(double *c,double x) { return exp(c[0]+x*(c[1]+x*(c[2]+x*c[3]))); } /******************************************************************************/ static double mylog(double x) { if(x < 10.e-250)return (double)(-575.64627); else return log(x); } /******************************************************************************/ static double myexp(double x) { if(x > 576.)return exp((double)576.); else return exp(x); } /******************************************************************************/ /* allocate an short vector with subscript range v[0...l] */ static short *issvector(int l) { int i; short *v; v=(short *)Salloc(l+1,short); for(i=0;i<=l;i++)v[i]=0; return v; } /******************************************************************************/ /* allocate an int vector with subscript range v[0...l] */ static int *isvector(int l) { int *v,i; v=(int *)Salloc(l+1,int); for(i=0;i<=l;i++)v[i]=0; return v; } /******************************************************************************/ /* computes integrals from t1 to t2 (numerically) of x^i (i<1, what=0; i<7 o.w.) times exp(polynomial(coef)) */ static void m1int(double *vv, double k1, double k2, int what, double *coef, int accuracy) /* accuracy - accuracy r1 and r2 - from (k1,k2) to (-1,1) */ { double r1,r2,x,y,z,v; int i1,i2,j; r1 = ((k2 - k1) / 2); r2 = ((k2 + k1) / 2); for(i1=0;i1<7;i1++)vv[i1]=0.; if(k2==k1)return; j=7; if(what==0)j=1; if(accuracy==1){ for(i1=1;i1<4;i1++){ y=yy6[i1]*r1; v=r1*ww6[i1]; x=r2-y; z=v*myexp(coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3]))); vv[0]+=z; for(i2=1;i2600.) f1=600.; return (double)(j*myexp(f1)); } /******************************************************************************/ static double fctf2(double b0, double b1, double t1, double t2, double f1, double f2) { int i1=1,i2=1; if(f1<0) i1 = -1; f1 = mylog(fabs(f1)) + b1*t1+b0; if(f1>600.) f1=600.; if(f2<0) i2 = -1; f2 = mylog(fabs(f2)) + b1*t2+b0; if(f2>600.) f2=600.; return (double)(i2*myexp(f2)-i1*myexp(f1)); } /******************************************************************************/ static double pol3(double *coef, double x) { return coef[0]+x*(coef[1]+x*(coef[2]+x*coef[3])); } /******************************************************************************/ static double inp3(double *c1, double *c2) { return c1[0]*c2[0]+c1[1]*c2[1]+c1[2]*c2[2]+c1[3]*c2[3]; } /******************************************************************************/ static double mat3(double *c1, double *c2, double *c3) { double x=0.; int i,j; for(i=0;i<4;i++)for(j=0;j<4;j++)x+=c1[i+j]*c2[i]*c3[j]; return x; } /******************************************************************************/ /* copies one space into another space */ static void swapspace(struct space *s1, struct space *s2) { int i,j,k; (*s1).ndim=(*s2).ndim; (*s1).nk=(*s2).nk; (*s1).cth=(*s2).cth; (*s1).nip=(*s2).nip; (*s1).aic=(*s2).aic; (*s1).low=(*s2).low; (*s1).upp=(*s2).upp; (*s1).ilow=(*s2).ilow; (*s1).iupp=(*s2).iupp; for(i=0;i<(*s1).nip;i++) (*s1).ips[i]=(*s2).ips[i]; for(i=0;i<(*s1).nk;i++){ (*s1).knots[i]=(*s2).knots[i]; (*s1).iknots[i]=(*s2).iknots[i]; } for(i=0;i<(*s1).ndim;i++){ for(j=0;j<5;j++)(*s1).basis[i].iks[j]=(*s2).basis[i].iks[j]; (*s1).score[i]=(*s2).score[i]; for(j=0;j<(*s1).ndim;j++) (*s1).info[i][j]=(*s2).info[i][j]; (*s1).basis[i].beta=(*s2).basis[i].beta; for(j=0;j<2;j++)(*s1).basis[i].c3[j]=(*s2).basis[i].c3[j]; (*s1).basis[i].sumunc=(*s2).basis[i].sumunc; for(j=0;j<(*s1).nk+2;j++)(*s1).basis[i].c1[j]=(*s2).basis[i].c1[j]; for(j=0;j<4;j++)for(k=0;k<(*s1).nip;k++) (*s1).basis[i].c2[k][j]=(*s2).basis[i].c2[k][j]; } } /******************************************************************************/ static void quadalloc(void) { /* Gaussian quadrature coefficients */ ww6[1 ]= 0.467913934572691; yy6[1 ]= 0.238619186083197; ww6[2 ]= 0.360761573048139; yy6[2 ]= 0.661209386466265; ww6[3 ]= 0.171324429379170; yy6[3 ]= 0.932469514203152; ww7[1 ]= 0.00178328072169643; yy7[1 ]= 0.99930504173577217; ww7[2 ]= 0.00414703326056247; yy7[2 ]= 0.99634011677195533; ww7[3 ]= 0.00650445796897836; yy7[3 ]= 0.99101337147674429; ww7[4 ]= 0.00884675982636395; yy7[4 ]= 0.98333625388462598; ww7[5 ]= 0.01116813946013113; yy7[5 ]= 0.97332682778991098; ww7[6 ]= 0.01346304789671864; yy7[6 ]= 0.96100879965205377; ww7[7 ]= 0.01572603047602472; yy7[7 ]= 0.94641137485840277; ww7[8 ]= 0.01795171577569734; yy7[8 ]= 0.92956917213193957; ww7[9 ]= 0.02013482315353021; yy7[9 ]= 0.91052213707850282; ww7[10]= 0.02227017380838325; yy7[10]= 0.88931544599511414; ww7[11]= 0.02435270256871087; yy7[11]= 0.86599939815409277; ww7[12]= 0.02637746971505466; yy7[12]= 0.84062929625258032; ww7[13]= 0.02833967261425948; yy7[13]= 0.81326531512279754; ww7[14]= 0.03023465707240248; yy7[14]= 0.78397235894334139; ww7[15]= 0.03205792835485155; yy7[15]= 0.75281990726053194; ww7[16]= 0.03380516183714161; yy7[16]= 0.71988185017161088; ww7[17]= 0.03547221325688239; yy7[17]= 0.68523631305423327; ww7[18]= 0.03705512854024005; yy7[18]= 0.64896547125465731; ww7[19]= 0.03855015317861563; yy7[19]= 0.61115535517239328; ww7[20]= 0.03995374113272034; yy7[20]= 0.57189564620263400; ww7[21]= 0.04126256324262353; yy7[21]= 0.53127946401989457; ww7[22]= 0.04247351512365359; yy7[22]= 0.48940314570705296; ww7[23]= 0.04358372452932345; yy7[23]= 0.44636601725346409; ww7[24]= 0.04459055816375657; yy7[24]= 0.40227015796399163; ww7[25]= 0.04549162792741814; yy7[25]= 0.35722015833766813; ww7[26]= 0.04628479658131442; yy7[26]= 0.31132287199021097; ww7[27]= 0.04696818281621002; yy7[27]= 0.26468716220876742; ww7[28]= 0.04754016571483031; yy7[28]= 0.21742364374000708; ww7[29]= 0.04799938859645831; yy7[29]= 0.16964442042399283; ww7[30]= 0.04834476223480295; yy7[30]= 0.12146281929612056; ww7[31]= 0.04857546744150343; yy7[31]= 0.07299312178779904; ww7[32]= 0.04869095700913972; yy7[32]= 0.02435029266342443; } /******************************************************************************/ static double **dsmatrix(int r, int c) /* allocate a double matrix with subscript range m[0..r][0..c] */ { int i; double **m; m=(double **) Salloc(r+1,double*); for(i=0;i<=r;i++) m[i]=dsvector(c); return m; } polspline/src/registerDynamicSymbol.c0000644000176200001440000000520614516535017017543 0ustar liggesusers#include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void heftpq(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void logcensor(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void nlogcensor(void *, void *, void *, void *, void *, void *); extern void nlogcensorx(void *); extern void polymarsF(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void rpqlsd(void *, void *, void *, void *, void *, void *, void *); extern void share(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sharex(void *, void *); extern void sheft(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sheftx(void *); extern void sphare(void *, void *, void *, void *, void *, void *, void *, void *); extern void spoly(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void spolyx(void *); extern void ssumm(void *, void *, void *, void *, void *, void *, void *, void *); extern void tspsps(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void tspspsx(void *); static const R_CMethodDef CEntries[] = { {"heftpq", (DL_FUNC) &heftpq, 10}, {"logcensor", (DL_FUNC) &logcensor, 13}, {"nlogcensor", (DL_FUNC) &nlogcensor, 6}, {"nlogcensorx", (DL_FUNC) &nlogcensorx, 1}, {"polymarsF", (DL_FUNC) &polymarsF, 37}, {"rpqlsd", (DL_FUNC) &rpqlsd, 7}, {"share", (DL_FUNC) &share, 17}, {"sharex", (DL_FUNC) &sharex, 2}, {"sheft", (DL_FUNC) &sheft, 16}, {"sheftx", (DL_FUNC) &sheftx, 1}, {"sphare", (DL_FUNC) &sphare, 8}, {"spoly", (DL_FUNC) &spoly, 16}, {"spolyx", (DL_FUNC) &spolyx, 1}, {"ssumm", (DL_FUNC) &ssumm, 8}, {"tspsps", (DL_FUNC) &tspsps, 9}, {"tspspsx", (DL_FUNC) &tspspsx, 1}, {NULL, NULL, 0} }; void R_init_polspline(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } polspline/src/polymars.c0000644000176200001440000051501114516535017015072 0ustar liggesusers/* * Copyright (C) 1997--2018 Charles Kooperberg and Martin O'Connor * * 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. * * The text of the GNU General Public License, version 2, is available * as http://www.gnu.org/copyleft or by writing to the Free Software * Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * * MARS is a registered trademark of Jeril, Inc and is used here with * permission. Commercial licenses and versions of PolyMARS may be obtained * from Salford Systems at http://www.salford-systems.com * */ /* This file contains the main body of the program to be loaded into Splus. */ /* The only other file needed is ``f2c.h'' */ #include #include #include "R.h" #define Salloc(n, t) (t *)R_alloc((long)(n), (int)sizeof(t)) #include "x2c.h" #define TRUE 1 #define FALSE 0 #define DIM5 255 static double tolerance; void F77_NAME(xdsico)(double[][DIM5], int *, int *, int *, double *, double *); static int predictors;/*number of predictors in the dataset*/ static int responses;/*number of responses in dataset*/ static int cases;/*number of cases in dataset*/ static int max_knots;/*maximum number of knots allowed in any of the predictors*/ /*This is used for memory allocation */ static int model_size; /*holds current model size in the fitting procedure*/ static int *knots_per_pred;/*a pointer to an array which holds the number of knots */ /*availible for each predictor in the model fitting */ static int max_model_size;/*maximum size that the model is allowed to grow to in */ /*fitting procedure*/ static int *order_keeper1;/*These matricies hold information about the oder in which*/ static int *order_keeper2;/*the spline functions can be added. A predictor must*/ static int *order_keeper3;/* have a linear spline before one with a knot*/ static int *best_model;/*A pointer to an array that holds the best model*/ static int additive;/*A boolean as to whether the user wanrts an additive model or not.*/ static double GCV;/*A boolean as to whether the user wanrts an additive model or not.*/ /*measure for the best model so far. Used as critirium for choosing */ /*best overall model.*/ static double GCVconstant;/*This value is used in calculating GCV and can be specified by */ /*the user.*/ static double *best_coefficents;/*This is a pointer to an array that stores the coefficients*/ /*of the best model so far*/ static double *coefficents;/*Used in testset to calculate coefficients for testset RSS. */ /*Usually the coefficeients are stored in a standardised form*/ /*for numerical stability.*/ static int *steps, step_count ;/*Information about each step of the fitting is recorded*/ static int *bestmodel_size;/*A pointer to the size of best bestmodel. The variable is */ /*passed in through Splus.*/ static double *best_XtXinv;/*The X transpose X matrix of the best model */ /* Used to compute the standard errors of the coefficients*/ static double *coef_sd_const;/*Constants to multiply the residual standard error by */ /* to get SEs for coefficients */ static double *rssgcv;/*A pointer to an array passed from Splus. Details of RSS and GCV */ /*for each step stored here.*/ static int *startmodel;/*A starting model may be passed in by Splus*/ static double *startknots;/*A pointer to an array passed from Splus number of knots for */ /* specified by user*/ static int *weighted;/*A boolean as to whether weights are specified for the model fitting*/ static double weight_sum;/*A sum of the weights- used in calculating GCV in weighted */ static int interaction_specs_size;/*If certain predictor are not to has interaction*/ static int *interaction_specs; /* terms together they are specified in an array*/ /*with the size of this array (divided by 2).*/ static int not_remove_size; /*If certain terms in the start model are not to be removed*/ static int *not_remove_specs;/* an array holds the information and a variable hold the */ /* size of this array*/ static int knot_space;/* The minimum number of order statistics between knots allowed when */ /* the possible knots are computed(compute_mesh)*/ static int testset;/*A boolean as to whether the model are selected using a testset or not. */ static double *testset_weights;/*A pointer to an array of testset weights*/ static int testset_weighted;/*A boolean as to whether weights are specified for testset*/ static double *tset_RSS;/*Used to hold testset RSS in function testset_RSS*/ static int *response_class;/*The class assigned to a fitted response in testset_RSS when*/ /*using classification.*/ static double *response_max;/* Used to classify in testset_RSS when using classification.*/ static int classification;/*A boolean to use classification or not(normally false)*/ static int Verbose;/*A boolean to use have the function printout as it goes along*/ static struct matrix1 *weight_matrix; static struct matrix1 *YtY;/* Y are the responses-this is Y-transpose by Y*/ static struct matrix1 *data_matrix; static struct matrix1 *testset_matrix;/* testset datamatrix*/ static struct matrix1 *X_matrix;/* X is the design matrix*/ static struct matrix1 *XtX_inverse; static struct matrix1 *XtX_newinverse; static struct matrix1 *new_XtXcolumn; static struct matrix1 *function_values;/*- list of function values at knot location-*/ static struct matrix1 *function_values_2;/*used in computing inner products*/ static struct matrix1 *Rao_B;/*These are matricies used in computing a new XtX*/ static struct matrix1 *Rao_F;/*matrix from an X matrix that has 1 column more or less*/ static struct matrix1 *Rao_E;/*than the previous one. From an example in Rao's linear*/ static struct matrix1 *Rao_E_inverse;/* algebra */ static struct matrix1 *Rao_F_E_inverse_Ft; static struct matrix1 *Rao_F_E_inverse; static struct matrix1 *YtXXtX_newinverseXtY; static struct matrix1 *XtX_newinverseXtY; static struct matrix1 *YtX; static struct matrix1 *new_X_matrix; static struct matrix1 *temp_matrix;/*Used in matrix multiplication when weights are*/ /* multiplied in fit_as_candidate and initial_model*/ static double *best_model_sd_mean; /*all columns of the X matrix are standardised*/ /* coefficients of the best model */ static double *model_sd_mean; /*----------------------------------------------------------------*/ struct link{ struct link *next; double *data; struct basis_function *function; }; struct list { struct link *list; int length; }; struct matrix1 { double *matrix; int nrow; int ncol; }; /*--this matrix is used for the YtransposeY and XtY matricies as column must be added and switched around--*/ struct matrix2 { struct link *column_list; int nrow; int ncol; }; struct basis_function /* A basis function is a spline (truncated power spline) or tensor product of a spline. These may have knots(elbow functions). There entries in the design (X) matrix are given as z-scores : minus the mean of the column then diveded by the standard dev. */ { int predictor1; int knot1_index; double knot1_value; int predictor2; int knot2_index; double knot2_value; struct basis_function *link; double SD; double mean; }; struct basis_function_matrix /* This is a matrix with number of rows equal to the number of predictors and number of columns variable for each row depending on the number of basis functions that are either candidates or in the model for that predictor (there is a model matrix and a candidates matrix. */ { struct basis_function *functions; int predictor_index; int number_of_basis_functions; struct basis_function_matrix *next_predictor; }; /*Two types of matrix used */ static struct matrix1 *create_matrix1(int nrow, int ncol); static struct matrix2 *create_matrix2(int nrow, int ncol); /* for matrix2*/ static void switch_columns(int col1, int col2, struct matrix2 *object_matrix); /*void print_matrix1(struct matrix1 *object_matrix );*/ /*void print_matrix2(struct matrix2 *object_matrix );*/ /*to multiply matricies of type 1*/ static void matrix_multiplication1(struct matrix1 *object_matrixA, struct matrix1 *object_matrixB, struct matrix1 *result, int flag); /*to multiple matrix of type 1 to type 2 */ static void matrix_multiplication2(struct matrix1 *object_matrixA, struct matrix2 *object_matrixB, struct matrix1 *result, int flag); /* prints a basis_function_matrix */ /*void print_functions(struct basis_function_matrix *functions_matrix);*/ /*------functions --*/ /* find possible knot locations for basis functions. Subset of order statistics. An array of double. knots_per_pred is used to access this array. Also holds levels of categorical variables---*/ static double *compute_mesh(void); /* Sets up dynamically created variables controlls model selection*/ static int fit_model(double *mesh); /*find candidate basis functions*/ static void find_candidates(struct matrix2 *YtXXtX_expanded, double *mesh, struct basis_function_matrix *model, struct basis_function_matrix *candidates); /*Is a function already in the model*/ static int in_model(int predictor1, int knot1_index, int predictor2, int knot2_index, struct basis_function_matrix *model); /*Compute the relevant inner products for YtX and XtX as if it was in the model*/ static void fit_as_candidate(int predictor1, int knot1_index, int predictor2, int knot2_index, struct matrix2 *YtXXtX_expanded, double *mesh); /*Function checks whether a basis function can become a new candidate and if it can put it in the candidates matrix*/ static int new_candidate(int predictor1, int knot1_index, int predictor2, int knot2_index, struct basis_function_matrix *candidates, struct basis_function_matrix *model, struct matrix2 *YtXXtX_expanded); /*find the candidate to be added to the model*/ static int find_best_candidate(struct matrix2 *YtXXtX_expanded, struct basis_function_matrix *model, struct basis_function_matrix *candidates, double *mesh); /*After the best candidate to be added is found the modelis updated*/ static void update_model(struct matrix2 *YtXXtX_expanded, struct basis_function_matrix *model, struct basis_function_matrix *candidates, int candidate, double *mesh); /*the deletion stage consists of one function to decide which basis function to delete and updates everything*/ static int reduce_model(struct matrix2 *YtXXtX_expanded, struct basis_function_matrix *model); /* fits an initial model if one is specified*/ static int initial_model(struct basis_function_matrix *model, struct matrix2 **YtXXtX_expanded); /* standardises each column of the X matrix substracting the mean and dividing by the standard deviation*/ static void standardise_array(double *numbers,int length_of_list,double *mean,double *SD); /*checks the initial model if given, as it must be consistant with how the proceure adds functions*/ static int check_input(void); /*use lapack inversion function. Some preprocessing of the matrix in done first*/ static int invert_matrix(struct matrix1 *object_matrix); /* computes testset RSS if required*/ static double testset_RSS(struct matrix2 *YtXXtX_expanded,int model_size); /* static double condition(struct matrix1 *); */ static double condition(void); static logical lsame(char *, char *); static int xerbla(char *, int *); static int idamax(int *n, double *dx, int *incx); static int dswap(int *, double *, int *, double *, int *); static int dspr(char * , int *, double *, double *, int *, double *); static int dscal(int *, double *, double *, int *); static int dlaev2(double *, double *, double *, double *, double *, double *, double *); static int drot(int *, double *, int *, double *, int *, double *, double *); static int dcopy(int *, double *, int *, double *, int *); static int dspmv(char *, int *, double *, double *, double *, int *, double *, double *, int *); static double ddot(int *, double *, int *, double *, int *); static int dsptrf(char *uplo, int *n, double *ap, int * ipiv, int *info); static int dsptri(char *uplo, int *n, double *ap, int * ipiv, double *work, int *info); /*----------------------------------------------------------------*/ /* This function is called from Splus function polymars*/ /*==============================================================*/ void polymarsF(int *pred, int *resp, int *ncases, double *datamatrix, int *knotinfo, double *given_mesh, int *is_mesh_specified, int *maxmodel, double *gcvvalue, int *addflag, int *start_model_size, int *start_model, double *start_knots, int *weights_indictor, double *caseweights, int *nointeraction, int *nointeractionrule, int *noremove, int *noremoverule, int *knotspace, int *testset_flag, double *testsetmatrix, int *testset_ncases, int *testset_weights_indictor, double *testset_weights, int *classify, double *stability1, int* verbose, int *model_returned, double *coefs_returned, int *steps_in_fitting, double *rss_and_gcvs, int *resultmodel_size, double *model_knots, double *sd_constants, int *end_condition, int *nstep) /*==============================================================*/ { double *mesh,*mesh_ptr;/*mesh is the matrix of possible knot values*/ int i,j,k; /* bogus to prevent warning */ mesh=gcvvalue; /*Matching up the S variables with global variables in this file */ startmodel = start_model; startknots = start_knots; model_size = *start_model_size; weighted = weights_indictor; step_count = 0; predictors = *pred; responses = *resp; cases = *ncases; GCVconstant = *gcvvalue; max_model_size = *maxmodel; knots_per_pred = knotinfo; additive = *addflag; bestmodel_size = resultmodel_size; *bestmodel_size = 1; interaction_specs_size = *nointeraction; interaction_specs = nointeractionrule; not_remove_size = *noremove; not_remove_specs = noremoverule; knot_space = *knotspace; testset = *testset_flag; classification = *classify; testset_weighted = *testset_weights_indictor; best_model = model_returned; best_coefficents = coefs_returned; coef_sd_const = sd_constants; steps = steps_in_fitting; rssgcv = rss_and_gcvs; tolerance = *stability1; Verbose = *verbose; data_matrix = (struct matrix1 *)Salloc(1,struct matrix1); data_matrix->ncol = predictors + responses; data_matrix->nrow = cases; data_matrix->matrix = datamatrix; if(*testset_flag == TRUE) { testset_matrix = (struct matrix1 *)Salloc(1,struct matrix1); testset_matrix->ncol = predictors + responses; testset_matrix->nrow = *testset_ncases; testset_matrix->matrix = testsetmatrix; } if(*weighted == TRUE) { weight_sum = 0.0; for(i=0;inrow = cases; weight_matrix->ncol = cases; weight_matrix->matrix = caseweights; } else { weight_sum = cases; } *end_condition =0;/* records why the program ended*/ /*checking that the input is consistant with requirements of the procedure*/ /*Just checks that a startmodel doesn't contradict the hierarchy rules of which*/ /*terms must be in the model before which*/ *end_condition = check_input(); if(*end_condition ==0) { if(*is_mesh_specified == FALSE) {mesh = compute_mesh();} else {mesh = given_mesh;} *end_condition = fit_model(mesh); /* number of steps of adding deleting given to variable to return to Splus*/ *nstep = step_count; } if(*bestmodel_size !=1) { /*get the knots for the model from the mesh to return to the Splus function. Only its index has been recorded by which it is found in the 'mesh'*/ for(i=0;i<2*(*bestmodel_size-1);i++) { mesh_ptr = mesh; if(best_model[(2*i)+1]!=0) { for(j=0;jmatrix = (double *)Salloc(max_model_size*max_model_size,double); XtX_newinverse = create_matrix1(0,0); XtX_newinverse->matrix = (double *)Salloc(max_model_size*max_model_size,double); new_XtXcolumn = create_matrix1(0,0); new_XtXcolumn->matrix = (double *)Salloc(max_model_size,double); function_values = create_matrix1(0,0); function_values->matrix = (double *)Salloc(cases,double); function_values->nrow=cases; function_values->ncol = 1; function_values_2 = create_matrix1(0,0); function_values_2->matrix = (double *)Salloc(cases,double); function_values_2->nrow= 1; function_values_2->ncol = 1; Rao_B = create_matrix1(0,0); Rao_B->matrix = (double *)Salloc(max_model_size-1,double); Rao_F = create_matrix1(0,0); Rao_F->matrix = (double *)Salloc(max_model_size-1,double); Rao_E = create_matrix1(0,0);/*always a 1x1 matrix*/ Rao_E_inverse = create_matrix1(0,0); Rao_F_E_inverse_Ft = create_matrix1(0,0); Rao_F_E_inverse_Ft->matrix = (double *)Salloc((max_model_size-1)*(max_model_size-1),double); Rao_F_E_inverse = create_matrix1(0,0); Rao_F_E_inverse->matrix = (double *)Salloc(max_model_size-1,double); YtXXtX_newinverseXtY = create_matrix1(0,0); YtXXtX_newinverseXtY->matrix = (double *)Salloc(responses*responses,double); XtX_newinverseXtY = create_matrix1(0,0); XtX_newinverseXtY->matrix = (double *)Salloc(max_model_size*responses,double); YtX = create_matrix1(0,0); YtX->matrix = (double *)Salloc(max_model_size*responses,double); new_X_matrix = create_matrix1(0,0); new_X_matrix->matrix = (double *)Salloc(max_model_size*cases,double); temp_matrix = create_matrix1(0,0); if(responses < max_model_size){i = max_model_size;}else{i=responses;} temp_matrix->matrix = (double *)Salloc(i*cases,double); best_model_sd_mean = (double *)Salloc(max_model_size*2,double); if(testset == TRUE) { model_sd_mean = (double *)Salloc(max_model_size*2,double); coefficents = (double *)Salloc(max_model_size*responses,double); if(classification == FALSE) { tset_RSS = (double *)Salloc(responses,double); } else { response_class = (int *)Salloc(cases,int); response_max = (double *)Salloc(cases,double); } } best_XtXinv = (double *)Salloc(max_model_size*max_model_size,double); /*---Creating structure to hold the model functions------------------*/ for(i = 0;inext_predictor = model; predictor_basis_functions->number_of_basis_functions=0; predictor_basis_functions->predictor_index=predictors-i; model = predictor_basis_functions; } /*---Creating the structure for candidate functions--------------*/ for(i = 0;inext_predictor = candidates; candidate_basis_functions->number_of_basis_functions=0; candidate_basis_functions->predictor_index=predictors-i; candidates = candidate_basis_functions; } /*--computes YtY ----Y is just the first column(s) of the data matrix---*/ col_minder = data_matrix -> ncol; data_matrix -> ncol = responses; /*--reduce the dimensions of the matrix to just the part contain Y for multiplication--*/ YtY=create_matrix1(0,0); YtY->nrow=responses; YtY->ncol=responses; YtY->matrix = (double *)Salloc (responses*responses,double); matrix_multiplication1(data_matrix,data_matrix,YtY,1); data_matrix -> ncol =col_minder; /*--create matricies that control the order of addition and deletion. A non-linear basis function can be added only where a linear one already exists--*/ /*-- these matricies hold information on whether linear functions are in model as a function with a knot can only be added after a linear function ------------------------------------------------*/ order_keeper1 = (int *)Salloc(predictors,int); for(i = 0;imax_knots) { max_knots = knots_per_pred[i]; } } } if(max_knots < 0)max_knots = 0; order_keeper2 = (int *)Salloc(predictors*predictors,int); for(i = 0;inrow = model_size; temp_matrix->ncol = cases; matrix_multiplication1(X_matrix,weight_matrix,temp_matrix,3); matrix_multiplication1(temp_matrix,X_matrix,XtX_inverse,0); } else { matrix_multiplication1(X_matrix,X_matrix,XtX_inverse,1); } ok = invert_matrix(XtX_inverse); } } j=model_size; for(i=0;i 1) { coef_sd_const[0] = best_XtXinv[0]; for(i=1;i<*bestmodel_size;i++) { coef_sd_const[0] = coef_sd_const[0] + ((best_model_sd_mean[((i-1)*2)+1]*best_model_sd_mean[((i-1)*2)+1])/ (best_model_sd_mean[((i-1)*2)]*best_model_sd_mean[((i-1)*2)]))* best_XtXinv[i+(*bestmodel_size)*i]; } for(i=1;i<*bestmodel_size;i++) { coef_sd_const[0] = coef_sd_const[0] - 2*best_XtXinv[i]*best_model_sd_mean[((i-1)*2)+1]/ best_model_sd_mean[((i-1)*2)]; } for(i=1;i<*bestmodel_size;i++) { for(j=i+1;j<*bestmodel_size;j++) { coef_sd_const[0] = coef_sd_const[0] + 2*best_XtXinv[i*(*bestmodel_size)+j] *(best_model_sd_mean[((i-1)*2)+1]/ best_model_sd_mean[((i-1)*2)]) *best_model_sd_mean[((j-1)*2)+1]/ best_model_sd_mean[((j-1)*2)]; } } } else { coef_sd_const[0] = 1; } /*For the standard errors of the non-transformed basis functions the variances of the transformed functions are adjusted using their SD, means and covariances*/ for(i=1;i<*bestmodel_size;i++) { coef_sd_const[i]=best_XtXinv[i*(*bestmodel_size)+i] /(best_model_sd_mean[((i-1)*2)]*best_model_sd_mean[((i-1)*2)]); } for(i=0;i=0) { if(!(in_model(i+1,0,0,0,model)) && new_candidate(i+1,0,0,0,candidates,model,YtXXtX_expanded)) { fit_as_candidate(i+1,0,0,0,YtXXtX_expanded,mesh); } } /*if the linear function has been added basis functions with knots can be added to candidates. In any case if it is categorical all possible levels become candidates at start.*/ if(current_predictor->number_of_basis_functions !=0 || (knots_per_pred[i]<0 &&model_size==1) ) { for(j=0;j<(int)abs(knots_per_pred[i]);j++) { if(!(in_model(i+1,j+1,0,0,model))&& new_candidate(i+1,j+1,0,0,candidates,model,YtXXtX_expanded)) { fit_as_candidate(i+1,j+1,0,0,YtXXtX_expanded,mesh); } } } /*categorical variables are not allowed in interactions--*/ if(additive == FALSE || knots_per_pred[i] <0) { /*--------------------------------------------------------------------------- two term candidates - interaction terms every predictor function in the model can be combined with another according to hierarchical rules ----------------------------------------------------------------------------*/ if(current_predictor->number_of_basis_functions !=0 && inext_predictor; for(j=i+1;jnumber_of_basis_functions !=0) { function_in_model = in_model(i+1,0,j+1,0,model); /*never true for categorical variables--*/ if((!function_in_model) && new_candidate(i+1,0,j+1,0,candidates,model,YtXXtX_expanded)) { fit_as_candidate(i+1,0,j+1,0, YtXXtX_expanded, mesh); } if(function_in_model) { for(k=0;knext_predictor; } } } current_predictor = current_predictor->next_predictor; } } /*==============================================================*/ static int in_model(int predictor1, int knot1_index, int predictor2, int knot2_index, struct basis_function_matrix *model) /*==============================================================*/ { /* Check to see if a certain function given by its knots and predictor numbers is in the model */ /* the basis function is specified by it's predictor an knot indicies*/ struct basis_function_matrix* current_predictor; struct basis_function *current_function; int i, predictor_functions; current_predictor = model; if(model_size == 1) { return FALSE; } else { while(current_predictor->predictor_index < predictor1) { current_predictor = current_predictor->next_predictor; } predictor_functions = current_predictor->number_of_basis_functions; if(predictor_functions==0) { return FALSE; } current_function = current_predictor->functions; /*scan through the predictors basis functions looking for a match*/ /*Predictor1 is always a lower value than predictor2 so there isn't a basis function that is symatric (with predictor1 and predictor2 swapped)*/ for(i=0;iknot1_index == knot1_index && current_function->predictor1==predictor1 && current_function->knot2_index == knot2_index && current_function->predictor2== predictor2) { return TRUE; } if(i != predictor_functions-1) { current_function= current_function->link; } } } return FALSE; } /*--------------------------------------------------------------*/ static void fit_as_candidate(int predictor1, int knot1_index, int predictor2, int knot2_index, struct matrix2 *YtXXtX_expanded, double *mesh) /*--------------------------------------------------------------*/ { /* fits a candidate which was found in "find candidate". The column of YtXXtX and the entry in the candidates matrix are already in place. It must evaluate the inner product between the new candidate and the functions already in the model also its inner product with the responses and all is stored in the YtXXtX matrix*/ int i,j; double *current_predictor1,*current_predictor2; int mesh_index; double knot1_value=0,knot2_value=0; double entry; struct link *new_column;/*----index of last row of matrix-----*/ double *function_value,SD,mean; /*--function value stores the value of the function at the predictor values for each case */ /*---put new entries into YtXXtX for new candidate-------------------*/ new_column= YtXXtX_expanded->column_list; for(i=0;i ncol-1;i++) { new_column=new_column->next; } /*--evaluate and store candidate function value for each case ---*/ function_value = function_values->matrix; /*-find the knot values using the indicies for the mesh----------*/ if(knot1_index != 0) { mesh_index=0; for(i=0;ifunction->knot1_value = knot1_value; } if(knot2_index != 0) { mesh_index=0; for(i=0;ifunction->knot2_value = knot2_value; } /*--find the data values for the corresponding predictor(s) in the function move to row of predictor of interest in data matrix---*/ current_predictor1 = &data_matrix->matrix[((predictor1-1)+responses)*cases]; current_predictor2 = &data_matrix->matrix[((predictor2-1)+responses)*cases]; for(i=0;i=0) { *function_value = *current_predictor1; if(knot1_index!=0) { *function_value = *function_value - knot1_value; if(*function_value <0){*function_value = 0.0;} } } else { /*else it is categorical*/ if((int)*current_predictor1 == (int)knot1_value) {*function_value =1;} else {*function_value =0;} } if(predictor2 != 0) { if(knots_per_pred[predictor2-1]>=0) { if(knot2_index == 0) { *function_value= *function_value* (*current_predictor2); } else { if(*current_predictor2-knot2_value < 0.0) {*function_value =0.0;} else {*function_value =*function_value*(*current_predictor2-knot2_value);} } } else { /*else it is categorical*/ if((int)*current_predictor2 == (int)knot2_value) {*function_value =1;} else {*function_value =0;} } } function_value++; current_predictor1++; current_predictor2++; } mean = 0.0; SD = 1.0; standardise_array(function_values->matrix,cases,&mean,&SD); /*--put the info about the mean and standard deviation into the function--*/ new_column->function->SD=SD; new_column->function->mean=mean; /*--YtX inner product--------------------------*/ for(i = 0; i < responses; i++) { entry = 0.0; for(j=0;jmatrix[(i*cases)+j]) *function_values->matrix[j]; } new_column->data[i]=entry; } /*get XtX inner products by matrix multiplication*/ new_XtXcolumn->nrow=model_size; new_XtXcolumn->ncol=1; if(*weighted == TRUE) { temp_matrix->nrow=model_size; temp_matrix->ncol=cases; matrix_multiplication1(X_matrix,weight_matrix,temp_matrix,3); matrix_multiplication1(temp_matrix,function_values,new_XtXcolumn,0); } else { matrix_multiplication1(X_matrix,function_values,new_XtXcolumn,1); } for(i = 0; i < model_size; i++) { new_column->data[responses+i]=new_XtXcolumn->matrix[i]; } if(*weighted == TRUE) { temp_matrix->nrow=1; temp_matrix->ncol=cases; matrix_multiplication1(function_values, weight_matrix, temp_matrix, 3); matrix_multiplication1(temp_matrix, function_values, function_values_2, 0); } else { matrix_multiplication1(function_values, function_values, function_values_2, 1); } new_column->data[responses+model_size]=function_values_2->matrix[0]; } /*==============================================================*/ static int new_candidate(int predictor1, int knot1_index, int predictor2, int knot2_index, struct basis_function_matrix *candidates, struct basis_function_matrix *model, struct matrix2 *YtXXtX_expanded) /*==============================================================*/ { /*Checks to see whether the function described by its predictor and knot indicies is already a candidate. If it is not then it adds the the candidate to the "candidates matrix" and also create a column in YtXXtX for it. This function is only called if the function 'in model" returns false when finding candidates */ struct basis_function_matrix* current_predictor; struct basis_function *current_function; struct basis_function *new_function; struct link *current_column; struct link *new_column; double *new_column_data; int i; current_predictor = candidates; if(interaction_specs_size >0) { for(i=0;ipredictor_index != predictor1) { current_predictor = current_predictor->next_predictor; } if(current_predictor->number_of_basis_functions ==0) { new_function= (struct basis_function *)Salloc (1,struct basis_function); new_function->knot1_index = knot1_index; new_function->predictor1 = predictor1; new_function->predictor2 = predictor2; new_function->knot2_index = knot2_index; if(new_function->knot1_index == 0) new_function->knot1_value = 0.0; if(new_function->knot2_index == 0) new_function->knot2_value = 0.0; current_predictor->number_of_basis_functions = 1; current_predictor->functions = new_function; } else { current_function = current_predictor->functions; for(i=0;inumber_of_basis_functions;i++) { if(current_function->knot1_index == knot1_index && current_function->predictor2 == predictor2 && current_function->knot2_index == knot2_index) { return FALSE; } if(i != current_predictor->number_of_basis_functions-1) { current_function = current_function->link; } } new_function = (struct basis_function *)Salloc (1,struct basis_function); current_function->link = new_function; new_function->knot1_index = knot1_index; new_function->predictor1 = predictor1; new_function->predictor2 = predictor2; new_function->knot2_index = knot2_index; if(new_function->knot1_index == 0) new_function->knot1_value = 0.0; if(new_function->knot2_index == 0) new_function->knot2_value = 0.0; /*the actual values of the knots are entered later*/ current_predictor->number_of_basis_functions++; } /*--add a column to YtXXtX_expanded--*/ current_column = YtXXtX_expanded->column_list; for(i=0;incol-1;i++) { current_column=current_column->next; } new_column = (struct link *)Salloc(1,struct link); current_column->next = new_column; new_column_data = (double *)Salloc(max_model_size+responses+1,double); new_column->data = new_column_data; new_column->function = new_function; YtXXtX_expanded->ncol++; return TRUE; } /*==============================================================*/ static int find_best_candidate(struct matrix2 *YtXXtX_expanded, struct basis_function_matrix *model, struct basis_function_matrix *candidates, double *mesh) /*==============================================================*/ { /*- calculates the best candidate to add by adding it to the model and computing the "residual sum of squares". the function returns an index to the best candidate it finds*/ int number_of_candidates; int i, j, k,l,m,index,ok; int nrow; double column_minder,row_minder; double E, E_inv,dok3; struct basis_function *model_function; struct link *YtXXtX_column; double Rao_D; struct link *current_column, *trailing_column; double RSS_so_far; double rss_for_model,gcv_for_model,gcv_so_far; int best_candidate; int candidate_found; ok=0; RSS_so_far = -1; gcv_so_far = -1; best_candidate =0; candidate_found = FALSE; /*--computes XtX_inverse with new candidate added by Rao Linear algebra p33------*/ number_of_candidates = (YtXXtX_expanded->ncol)-model_size; XtX_newinverse->nrow=model_size+1; XtX_newinverse->ncol=model_size+1; for(i=0;icolumn_list; current_column = YtXXtX_expanded->column_list; for(k=0;knext; } Rao_B->nrow = model_size; Rao_B->ncol = 1; for(j=0;jmatrix[j]=current_column->data[j+responses]; } Rao_D = current_column->data[model_size+responses]; Rao_F->nrow = model_size; Rao_F->ncol = 1; matrix_multiplication1(XtX_inverse, Rao_B, Rao_F, 1); Rao_E->nrow=1; Rao_E->ncol=1; Rao_E->matrix = &E; matrix_multiplication1(Rao_B, Rao_F, Rao_E, 1); if(1/(Rao_D-Rao_E->matrix[0]) < tolerance || Rao_D-Rao_E->matrix[0] < tolerance) { trailing_column->next = current_column->next; i--; number_of_candidates--; YtXXtX_expanded->ncol--; } else { Rao_E->matrix[0] = Rao_D-Rao_E->matrix[0]; Rao_E_inverse->nrow=1; Rao_E_inverse->ncol=1; Rao_E_inverse->matrix = &E_inv; Rao_E_inverse->matrix[0]=1/Rao_E->matrix[0]; Rao_F_E_inverse->nrow = model_size; Rao_F_E_inverse->ncol = 1; matrix_multiplication1(Rao_F, Rao_E_inverse, Rao_F_E_inverse, 0); Rao_F_E_inverse_Ft ->nrow = model_size; Rao_F_E_inverse_Ft ->ncol = model_size; matrix_multiplication1(Rao_F,Rao_F_E_inverse,Rao_F_E_inverse_Ft,2); nrow = XtX_newinverse->nrow; for(j=0;jmatrix[(j*nrow)+k] = XtX_inverse->matrix[index] + Rao_F_E_inverse_Ft->matrix[index]; } } for(j=0;jmatrix[index] = -Rao_F_E_inverse->matrix[j]; index=(model_size*nrow) + j; XtX_newinverse->matrix[index]= -Rao_F_E_inverse->matrix[j]; } index = (model_size*nrow) + model_size; XtX_newinverse->matrix[index]=Rao_E_inverse->matrix[0]; /* dok3 = condition(XtX_newinverse); */ dok3 = condition(); /*---computes YtY-YtX(XtX)^1XtY--and- sums the diagonal to get the RSS------*/ /*---uses data matrix with nrow changed for Yt-----*/ /*- the column of the YtXXtX matrix corresponding to the candidate function being considered*/ /*switch the column of the candidate so it is adjacent to the model columns*/ switch_columns(model_size+i+1,model_size+1,YtXXtX_expanded); /*we wish to use only the YtX part of the YtXXtX matrix for the current model and the candidate being considered*/ column_minder=YtXXtX_expanded->ncol; row_minder=YtXXtX_expanded->nrow; YtXXtX_expanded->ncol=model_size+1; YtXXtX_expanded->nrow=responses; XtX_newinverseXtY->nrow = model_size+1; XtX_newinverseXtY->ncol = responses; matrix_multiplication2(XtX_newinverse, YtXXtX_expanded, XtX_newinverseXtY, 0); YtXXtX_newinverseXtY->nrow = responses; YtXXtX_newinverseXtY->ncol = responses; matrix_multiplication2(XtX_newinverseXtY, YtXXtX_expanded, YtXXtX_newinverseXtY, 1); YtXXtX_expanded->nrow=row_minder; YtXXtX_expanded->ncol=column_minder; rss_for_model =0.0; for(j=0;jmatrix[j*(responses+1)] +YtY->matrix[j*(responses+1)]; /* if the residual sum of squares is */ /* negative discard candidate */ if((YtY->matrix[j*(responses+1)] -YtXXtX_newinverseXtY->matrix[j*(responses+1)])<0.0) { rss_for_model = -1.0; j=responses; } } if(rss_for_model>=0.0) { for(j=0;jmatrix[j*(responses+1)] -YtXXtX_newinverseXtY->matrix[j*(responses+1)]) > rssgcv[(step_count)*(responses+1)+j]) { /* if the residual sum of squares go up for any reason*/ /* the candidate is rejected.*/ rss_for_model = -1; } } } if(dok3 0.0) { candidate_found =TRUE; if(RSS_so_far !=-1)/* if first candidate*/ { if(rss_for_model < RSS_so_far) { best_candidate = i; RSS_so_far = rss_for_model; for(j=0;jmatrix[j*(responses+1)] +YtY->matrix[j*(responses+1)]; } } } else { best_candidate = i; RSS_so_far = rss_for_model; for(j=0;jmatrix[j*(responses+1)] +YtY->matrix[j*(responses+1)]; } } /* gcv (or other criterion) is calculated, the best model in this call of the function if it is better than the best global model gets saved, in any case the gcv for this case is saved in rssgcv */ if(testset == FALSE) { gcv_for_model = (1.0 - (GCVconstant*(model_size+1)/cases)); if(gcv_for_model>0){ gcv_for_model = (rss_for_model /weight_sum)/(gcv_for_model*gcv_for_model); } else { gcv_for_model = gcv_so_far +100; } } else { gcv_for_model = testset_RSS(YtXXtX_expanded,model_size+1); } if(model_size == 1 ) { if(GCV == -1)/*GCV was initially set to -1*/ { GCV = gcv_for_model; } } if(gcv_for_model < gcv_so_far || gcv_so_far==-1.0) { gcv_so_far = gcv_for_model; } if(GCV == -1.0 || gcv_for_model ncol*XtX_newinverseXtY->nrow);l++) { best_coefficents[l] = XtX_newinverseXtY->matrix[l]; } for(l=0;l<(XtX_newinverse->ncol);l++) { for(m=0;m<(XtX_newinverse->ncol);m++) { best_XtXinv[l+m*XtX_newinverse->ncol]= XtX_newinverse->matrix[l+m*XtX_newinverse->ncol]; } } *bestmodel_size = model_size+1; YtXXtX_column = YtXXtX_expanded->column_list; /*storing the best model */ for(l=0;lfunction; best_model[(l-1)*4]= model_function->predictor1; best_model[((l-1)*4)+1]=model_function->knot1_index; best_model[((l-1)*4)+2]=model_function->predictor2; best_model[((l-1)*4)+3]=model_function->knot2_index; best_model_sd_mean[((l-1)*2)]=model_function->SD; best_model_sd_mean[((l-1)*2)+1]=model_function->mean; } YtXXtX_column = YtXXtX_column->next; } } } /* switch 'candidates column' back to its original position*/ switch_columns(model_size+i+1,model_size+1,YtXXtX_expanded); } rssgcv[(step_count+1)*(responses+1)+responses]=gcv_so_far; } if (candidate_found != FALSE) { update_model(YtXXtX_expanded, model, candidates, best_candidate, mesh); rss_for_model =0.0; RSS_so_far =0.0; for(i =0;icolumn_list; for(i=0;inext; } candidates_column->data[model_size+responses] = 0.0; new_model_function = candidates_column->function; if(Verbose == TRUE) { Rprintf("+ %d : %d ",model_size,new_model_function->predictor1); if(knots_per_pred[new_model_function->predictor1-1]>=0 && new_model_function->knot1_index != 0) { Rprintf("%f ",new_model_function->knot1_value); } else { if(knots_per_pred[new_model_function->predictor1-1]>=0) {Rprintf("NA ");} if(knots_per_pred[new_model_function->predictor1-1]<0) {Rprintf("%d ",(int)new_model_function->knot1_value);} } if(new_model_function->predictor2 == 0) { Rprintf("\n"); } else { if(new_model_function->knot2_index==0) {Rprintf("%d NA\n",new_model_function->predictor2);} else {Rprintf("%d %f\n",new_model_function->predictor2,new_model_function->knot1_value);} } } /*fflush(stdout);*/ predictor1 = new_model_function->predictor1; predictor2 = new_model_function->predictor2; /*---------find function in candidates----------*/ current_candidate_predictor = candidates; while(current_candidate_predictor->predictor_index != predictor1) { current_candidate_predictor = current_candidate_predictor->next_predictor; } current_candidate_function = current_candidate_predictor->functions; trailing_function = current_candidate_predictor->functions; while(current_candidate_function != new_model_function) { trailing_function = current_candidate_function; current_candidate_function = current_candidate_function->link; } /* take out of the candidates matrix*/ if(trailing_function == current_candidate_function) { current_candidate_predictor->functions = current_candidate_function->link; } else { trailing_function->link = current_candidate_function->link; } current_candidate_predictor->number_of_basis_functions--; /* add to model matrix*/ current_model_predictor=model; while(current_model_predictor->predictor_index != predictor1) { current_model_predictor = current_model_predictor->next_predictor; } current_model_function=current_model_predictor->functions; for(i=0;inumber_of_basis_functions-1;i++) { current_model_function= current_model_function->link; } if(current_model_predictor->number_of_basis_functions==0) { current_model_predictor->functions= new_model_function; } else { current_model_function->link=new_model_function; } current_model_predictor->number_of_basis_functions++; knot1_index = new_model_function->knot1_index; knot2_index = new_model_function->knot2_index; /*-----------------hierarchy terms----------------------------*/ if(predictor2 == 0) { if(knot1_index !=0) { order_keeper1[predictor1-1]++; } } else { if(knot1_index !=0 || knot2_index != 0) { order_keeper2[((predictor1-1)*predictors)+predictor2-1]++; order_keeper2[((predictor2-1)*predictors)+predictor1-1]++; } if(knot1_index ==0 || knot2_index == 0) { order_keeper1[predictor1-1]++; order_keeper1[predictor2-1]++; } if(max_knots != 0) { if(knot1_index !=0) { order_keeper3[(predictor1-1)*max_knots+knot1_index-1]++; } if(knot2_index != 0) { order_keeper3[(predictor2-1)*max_knots+knot2_index-1]++; } } } /*------------------update X_matrix----------------------------*/ /*calculate the basis function values at the points of the data matrix*/ X_matrix->ncol++; X_matrix_ptr = &X_matrix->matrix[(model_size-1)*cases]; /*--move to row of predictor of interest in data matrix---*/ current_predictor_values1 = &data_matrix->matrix[((predictor1-1)+responses)*cases]; current_predictor_values2 = current_predictor_values1; if(predictor2!=0) { current_predictor_values2 = &data_matrix->matrix[((predictor2-1)+responses)*cases]; } /*---find the knot values for the basis function--*/ if(new_model_function->knot1_index !=0) { knot1_value = new_model_function->knot1_value; } if(new_model_function->knot2_index !=0) { knot2_value = new_model_function->knot2_value; } for(i=0;i= 0) { *X_matrix_ptr=current_predictor_values1[i]; if(knot1_index != 0) { *X_matrix_ptr = *X_matrix_ptr - knot1_value; if(*X_matrix_ptr <0){*X_matrix_ptr = 0;} } } else { /*else it is categorical*/ if((int)current_predictor_values1[i] == (int)knot1_value) {*X_matrix_ptr =1;} else {*X_matrix_ptr =0;} } if(predictor2 != 0) { if(knots_per_pred[predictor2-1] >= 0) { if(knot2_index == 0) { *X_matrix_ptr = *X_matrix_ptr * current_predictor_values2[i]; } else { if(current_predictor_values2[i] - knot2_value <0.0) {*X_matrix_ptr = 0.0;} else { *X_matrix_ptr = *X_matrix_ptr*(current_predictor_values2[i] - knot2_value); } } } else { /*else it is categorical*/ if((int)current_predictor_values2[i] != (int)knot2_value) {*X_matrix_ptr=0;} } } X_matrix_ptr++; } /*--Standardise the new column of the X matrix---------------------*/ for(i=0;imatrix[((model_size-1)*cases)+i]= (X_matrix->matrix[((model_size-1)*cases)+i]- new_model_function->mean)/new_model_function->SD; } /*--computes XtX_inverse with new candidate added by Rao Linear algebra p33------*/ Rao_B->nrow = model_size-1; Rao_B->ncol = 1; for(j=0;jmatrix[j]=candidates_column->data[j+responses]; } Rao_D = candidates_column->data[model_size-1+responses]; /*-----------------------------------------------------------------*/ Rao_F->nrow = model_size-1; Rao_F->ncol = 1; matrix_multiplication1(XtX_inverse,Rao_B,Rao_F,1); /*-----------------------------------------------------------------*/ Rao_E->matrix = &E; matrix_multiplication1(Rao_B,Rao_F,Rao_E,1); Rao_E->matrix[0] = Rao_D-Rao_E->matrix[0]; Rao_E_inverse->nrow =1; Rao_E_inverse->ncol = 1; Rao_E_inverse->matrix = &E_inv; Rao_E_inverse->matrix[0]=1/Rao_E->matrix[0]; Rao_F_E_inverse->ncol= 1; Rao_F_E_inverse->nrow = model_size-1; matrix_multiplication1(Rao_F,Rao_E_inverse,Rao_F_E_inverse,0); Rao_F_E_inverse_Ft->nrow = model_size-1; Rao_F_E_inverse_Ft->ncol = model_size-1; matrix_multiplication1(Rao_F,Rao_F_E_inverse,Rao_F_E_inverse_Ft,2); XtX_inverse->nrow++; XtX_inverse->ncol++; nrow = XtX_inverse->nrow; for(j=0;j<(model_size-1);j++) { for(k=0;k<(model_size-1);k++) { XtX_newinverse->matrix[(model_size*j)+k] = XtX_inverse->matrix[((model_size-1)*j)+k] + Rao_F_E_inverse_Ft->matrix[((model_size-1)*j)+k]; } } for(i=0;imatrix[i]= XtX_newinverse->matrix[i]; } for(j=0;jmatrix[index] = -Rao_F_E_inverse->matrix[j]; index=(model_size-1)*nrow + j; XtX_inverse->matrix[index]= -Rao_F_E_inverse->matrix[j]; } index = (model_size*model_size)-1; XtX_inverse->matrix[index]=Rao_E_inverse->matrix[0]; /*---------------------------------------------------------------- update YtXXtX_expanded the new inner product between candidate and new function in model are calculated and inserted, the number of rows grows by 1 ----------------------------------------------------------------*/ YtXXtX_expanded->nrow++; nrow = YtXXtX_expanded->nrow; current_column = YtXXtX_expanded->column_list; for(i=0;idata[nrow-2]= candidates_column->data[responses+i]; current_column = current_column->next; } function_values->nrow=cases; function_values->ncol=1; /*--move to first candidate column of the matrix to update it--*/ current_column = candidates_column->next; /*move through all the candidates in the YtXXtX matrix */ for(i=0;incol-model_size;i++) { current_function = current_column->function; knot1_index = current_function->knot1_index; predictor1=current_function->predictor1; knot2_index = current_function->knot2_index; predictor2=current_function->predictor2; /*--move to row of predictor of interest in data matrix---*/ current_predictor_values1 = &data_matrix->matrix[(current_function->predictor1+responses-1) *cases]; /*--evaluate the functions at each case-- to calculate inner products--*/ if(predictor2!=0) { current_predictor_values2= &data_matrix->matrix[(current_function->predictor2+ responses-1) *cases]; } function_value = function_values->matrix; if(knot1_index==0) { for(j=0;j0) { function_value[j] = matrix_entry; } else { function_value[j] = 0.0; } } } } } if(predictor2!=0) { if(knot2_index==0) { for(j=0;j0) { function_value[j] = function_value[j] *(current_predictor_values2[j]- knot1_value); } else { function_value[j] = 0.0; } } } } } standardise_array(function_value,cases,&dummy1,&dummy2); matrix_entry =0.0; for(j=0;jmatrix[(model_size-1)*cases+j] *weight_matrix->matrix[j]); } else { matrix_entry = matrix_entry+ function_value[j]*X_matrix->matrix[(model_size-1)*cases+j]; } } current_column->data[YtXXtX_expanded->nrow-1]= current_column->data[YtXXtX_expanded->nrow-2]; current_column->data[YtXXtX_expanded->nrow-2]= matrix_entry; current_column = current_column->next; } } /*================================================================*/ static int reduce_model(struct matrix2 *YtXXtX_expanded, struct basis_function_matrix *model) /*================================================================*/ { /*function reduces model by one function. Takes out each candidate in turn, computes RSS and the one resulting in the lowest RSS is taken out and everthing is updated. some function may have been specified to stay in the model*/ int i,j,k,l,m; int predictor1, predictor2,knot1_index,knot2_index; int column_minder; int best_candidate; int candidate_to_remove; double *switch_matrix; double rss_for_model,rss_so_far=0,gcv_for_model,gcv_so_far ; struct link *current_predictor_col, *trailing_column; struct basis_function *current_predictor; struct basis_function *trailing_function; struct basis_function *current_model_function; struct basis_function *discard_model_function; struct basis_function_matrix* current_model_predictor; int cant_remove;/*boolean*/ gcv_so_far = -1.0; steps[(step_count+1)*2]=0; steps[(step_count+1)*2+1]=model_size-1; best_candidate = -1; XtX_newinverse->nrow = model_size-1; XtX_newinverse->ncol = model_size-1; new_X_matrix->nrow=cases; new_X_matrix->ncol =model_size-1; current_predictor_col = YtXXtX_expanded->column_list; trailing_column = YtXXtX_expanded->column_list; candidate_to_remove = FALSE; for(i=1;inext; current_predictor=current_predictor_col->function; /*------------------------------- Check is the function must remain in the model because of input specifications -------------------------------*/ if(not_remove_size > 0) { for(j=0;jpredictor1 && startmodel[((not_remove_specs[j]-1)*4)+1] == current_predictor->knot1_index && startmodel[((not_remove_specs[j]-1)*4)+2] == current_predictor->predictor2 && startmodel[((not_remove_specs[j]-1)*4)+3] == current_predictor->knot2_index) { cant_remove= TRUE; } } } /*------------------------------------------------------------ Certain order of removal rules are followed if 1 knot is 0 check that there is no double knot interaction if 1 term with knot check that it is not part of interaction if linear check that there no knot terms or interaction etc. -------------------------------------------------------------*/ if(current_predictor->predictor2 ==0) { if(current_predictor->knot1_index == 0) { if(order_keeper1[current_predictor->predictor1-1]>0) {cant_remove = TRUE;} } else { if(max_knots != 0) { if(order_keeper3[(current_predictor->predictor1-1) *max_knots+current_predictor->knot1_index-1]>0) {cant_remove = TRUE;} } } } else { if(current_predictor->knot1_index == 0) { for(j=0;jpredictor1-1]);j++) { if(in_model(current_predictor->predictor1, j+1, current_predictor->predictor2, current_predictor->knot2_index, model)) {cant_remove = TRUE;} } } if(current_predictor->knot2_index == 0) { for(j=0;jpredictor2-1]);j++) { if(in_model(current_predictor->predictor1, current_predictor->knot1_index, current_predictor->predictor2, j+1, model)) { cant_remove = TRUE; } } } /* }*/ } if(cant_remove != TRUE) { candidate_to_remove = TRUE; /*-------create new XtX_inverse_without the one predictor----------*/ /*using backwards version of the method in addition stage*/ for(j = 0;j=i){l=j+1;}else{l=j;} if(k>=i){m=k+1;}else{m=k;} XtX_newinverse->matrix[(j*(model_size-1))+k] = XtX_inverse->matrix[(l*model_size)+m] - ((XtX_inverse->matrix[l*(model_size)+i]) *(XtX_inverse->matrix[i*(model_size)+m]) /XtX_inverse->matrix[(i)*(model_size)+i]); } } /*making a new X matrix*/ for(j=0;jmatrix[(j*cases)+k] = X_matrix->matrix[l]; } } /*calculating RSS */ column_minder = data_matrix->ncol; data_matrix->ncol = responses; YtX->nrow = responses; YtX->ncol = model_size-1; matrix_multiplication1(data_matrix,new_X_matrix,YtX,1); data_matrix->ncol = column_minder; XtX_newinverseXtY->nrow=model_size-1; XtX_newinverseXtY->ncol= responses; matrix_multiplication1(XtX_newinverse,YtX,XtX_newinverseXtY,2); YtXXtX_newinverseXtY->nrow=responses; YtXXtX_newinverseXtY->ncol=responses; matrix_multiplication1(YtX,XtX_newinverseXtY,YtXXtX_newinverseXtY,0); rss_for_model =0.0; for(j=0;jmatrix[j*(responses+1)] +YtY->matrix[j*(responses+1)]; } if(testset == FALSE) { gcv_for_model = (1.0 - (GCVconstant*(model_size+1)/cases)); if(gcv_for_model>0){ gcv_for_model = (rss_for_model /weight_sum)/(gcv_for_model*gcv_for_model); } else { gcv_for_model = gcv_so_far +100; } } else { gcv_for_model =testset_RSS(YtXXtX_expanded,model_size-1); } if(best_candidate !=-1)/* if it is not the first iteration*/ { if(rss_for_model < rss_so_far) { best_candidate = i; rss_so_far = rss_for_model; for(j=0;jmatrix[j*(responses+1)] +YtY->matrix[j*(responses+1)]; } } } else { best_candidate = i; rss_so_far = rss_for_model; for(j=0;jmatrix[j*(responses+1)] +YtY->matrix[j*(responses+1)]; } } if(gcv_so_far == -1.0) { gcv_so_far = gcv_for_model; } else { if(gcv_for_model < gcv_so_far) { gcv_so_far = gcv_for_model; } } if(gcv_for_model < GCV) { for(j=0;j<(XtX_newinverseXtY->ncol*XtX_newinverseXtY->nrow);j++) { best_coefficents[j] = XtX_newinverseXtY->matrix[j]; } for(l=0;l<(XtX_newinverse->ncol);l++) { for(m=0;m<(XtX_newinverse->ncol);m++) { best_XtXinv[l+m*XtX_newinverse->ncol]= XtX_newinverse->matrix[l+m*XtX_newinverse->ncol]; } } } } } if(candidate_to_remove == FALSE) { return FALSE; } step_count++; rssgcv[(step_count)*(responses+1)+responses]=gcv_so_far; /*-----------------------------------------------------------------*/ /*candidate to remove is found and now it will be removed*/ /*reduce model*/ /*-----------------------------------------------------------------*/ /*-find the function in the YtXXtX matrix by its index--*/ current_predictor_col = YtXXtX_expanded->column_list; for(i=0;inext; } trailing_column->next = current_predictor_col->next; discard_model_function=current_predictor_col->function; if(Verbose == TRUE) { Rprintf("- %d : %d ",model_size-1,discard_model_function->predictor1); if(knots_per_pred[discard_model_function->predictor1-1]>=0 && discard_model_function->knot1_index != 0) { Rprintf("%f ",discard_model_function->knot1_value); } else { if(knots_per_pred[discard_model_function->predictor1-1]>=0) {Rprintf("NA ");} if(knots_per_pred[discard_model_function->predictor1-1]<0) {Rprintf("%d ",(int)discard_model_function->knot1_value);} } if(discard_model_function->predictor2 == 0) { Rprintf("\n"); } else { if(discard_model_function->knot2_index==0) {Rprintf("%d NA\n",discard_model_function->predictor2);} else {Rprintf("%d %f\n",discard_model_function->predictor2,discard_model_function->knot1_value);} } } /*fflush(stdout);*/ /*-find the function in the model matrix and remove it--*/ predictor1 = discard_model_function->predictor1; current_model_predictor = model; while(current_model_predictor->predictor_index != predictor1) { current_model_predictor = current_model_predictor->next_predictor; } current_model_function = current_model_predictor->functions; trailing_function = current_model_predictor->functions; while(current_model_function != discard_model_function) { trailing_function = current_model_function; current_model_function = current_model_function->link; } if(trailing_function== current_model_function) { current_model_predictor->functions= current_model_function->link; } else { trailing_function->link = current_model_function->link; } current_model_predictor->number_of_basis_functions--; /*-update the matrix for deletion order-*/ knot1_index = discard_model_function->knot1_index; predictor2 = discard_model_function->predictor2; knot2_index = discard_model_function->knot2_index; if(predictor2 ==0) { if(knot1_index!=0) { order_keeper1[predictor1-1]--; } } else { if(knot1_index !=0 || knot2_index !=0) { order_keeper2[((predictor1-1)*predictors)+predictor2-1]--; order_keeper2[((predictor2-1)*predictors)+predictor1-1]--; } if(knot1_index ==0 || knot2_index ==0) { order_keeper1[predictor1-1]--; order_keeper1[predictor2-1]--; } if(max_knots != 0) { if(knot1_index!= 0) { order_keeper3[(predictor1-1)*max_knots+knot1_index-1]--; } if(knot2_index!= 0) { order_keeper3[(predictor2-1)*max_knots+knot2_index-1]--; } } } /*--------------update---X_matrix--------------------------------*/ for(j=1;jmatrix[(j*cases)+k] = X_matrix->matrix[l]; } } switch_matrix =new_X_matrix->matrix; new_X_matrix->matrix = X_matrix->matrix; X_matrix->matrix = switch_matrix; X_matrix->ncol--; /*--------------update---XtX_invmatrix--------------------------------*/ XtX_inverse->ncol--; XtX_inverse->nrow--; if(*weighted == TRUE) { temp_matrix->nrow = model_size; temp_matrix->ncol = cases; matrix_multiplication1(X_matrix,weight_matrix,temp_matrix,3); matrix_multiplication1(temp_matrix,X_matrix,XtX_inverse,0); } else { matrix_multiplication1(X_matrix,X_matrix,XtX_inverse,1); } invert_matrix(XtX_inverse); model_size--; /*-save new global best model if this iteration produced better gcv*/ if(gcv_so_far < GCV) { GCV = gcv_so_far; *bestmodel_size = model_size; current_predictor_col = YtXXtX_expanded->column_list; for(l=0;lfunction; best_model[(l-1)*4]= current_predictor->predictor1; best_model[((l-1)*4)+1]=current_predictor->knot1_index; best_model[((l-1)*4)+2]=current_predictor->predictor2; best_model[((l-1)*4)+3]=current_predictor->knot2_index; best_model_sd_mean[(l-1)*2]= current_predictor->SD; best_model_sd_mean[((l-1)*2)+1]= current_predictor->mean; } current_predictor_col = current_predictor_col->next; } } return TRUE; } /*----------------------------------------------------------*/ static int initial_model(struct basis_function_matrix *model, struct matrix2 **YtXXtX_expanded) /*---------------------------------------------------------*/ { /* Set up the initial model, by default it is a model containing only the intercept*/ int i,j,l,m,predictor_1,predictor_2,ok,knot_1_index,knot_2_index; double *X_ptr , knot_1_value=0,knot_2_value=0; double rss_for_model; struct link *YtXXtX_column; int column_minder; double mean,SD; double *means,*SDs; struct basis_function_matrix* current_predictor; struct basis_function *current_function; struct basis_function *new_function; ok = 0; if(model_size != 1) { means= (double *)Salloc (model_size-1,double); SDs= (double *)Salloc (model_size-1,double); } else{ means= (double *)Salloc (1,double); SDs= (double *)Salloc (1,double); } /*create matrix to hold YtX and XtX for model and candidates */ (*YtXXtX_expanded)= create_matrix2(max_model_size+responses+1,model_size); (*YtXXtX_expanded)->nrow = responses+model_size+1; (*YtXXtX_expanded)->ncol = model_size; X_matrix=create_matrix1(0,0); X_matrix->ncol=model_size; X_matrix->nrow = cases; X_matrix->matrix= (double *)Salloc (max_model_size*cases,double); X_ptr = X_matrix->matrix; /* fit the constant function (intercept) over all predictors */ for(i=0;i= 0) { *X_ptr = data_matrix->matrix[((responses+(predictor_1-1))*cases)+j]; if(knot_1_index != 0) { *X_ptr = *X_ptr - knot_1_value; if (*X_ptr < 0.0){*X_ptr = 0.0;} } } else { /*else it is categorical*/ if((int)data_matrix->matrix[((responses+(predictor_1-1))*cases)+j] == (int)knot_1_value) {*X_ptr =1;} else {*X_ptr =0;} } if(predictor_2 != 0) { if(knots_per_pred[predictor_2-1] >= 0) { if(knot_2_index == 0) { *X_ptr = *X_ptr*data_matrix ->matrix[((responses+(predictor_2-1))*cases)+j]; } else { if(data_matrix->matrix[((responses+(predictor_2-1))*cases)+j] - knot_2_value < 0.0) { *X_ptr =0.0; } else { *X_ptr = *X_ptr * (data_matrix->matrix[((responses+(predictor_2-1)) *cases)+j]- knot_2_value); } } } else { /*else it is categorical*/ if((int)data_matrix->matrix[((responses+(predictor_1-1))*cases)+j] != (int)knot_2_value) {*X_ptr =0;} } } X_ptr++; } mean=0.0; SD=1.0; standardise_array(X_ptr-cases,cases,&mean,&SD); means[i]=mean; SDs[i] = SD; } /*--Making the XtY bit of the the YtXXtX matrix------------*/ if(*weighted == TRUE) { column_minder = data_matrix->ncol; data_matrix->ncol = responses; YtX->nrow = responses; YtX->ncol = model_size; temp_matrix->ncol = cases; temp_matrix->nrow = responses; matrix_multiplication1(data_matrix,weight_matrix,temp_matrix,3); YtX->nrow = responses; YtX->ncol = model_size; matrix_multiplication1(temp_matrix,X_matrix,YtX,0); } else { column_minder = data_matrix->ncol; data_matrix->ncol = responses; YtX->nrow = responses; YtX->ncol = model_size; matrix_multiplication1(data_matrix,X_matrix,YtX,1); } data_matrix->ncol = column_minder; YtXXtX_column = (*YtXXtX_expanded)->column_list; for(i=0;i data[j]=YtX->matrix[(i*responses)+j]; } if(i != model_size-1){YtXXtX_column = YtXXtX_column->next;} } /*--Making the XtX bit of the the YtXXtX matrix------------*/ XtX_inverse->ncol = model_size; XtX_inverse->nrow = model_size; if(*weighted == TRUE) { temp_matrix->nrow = model_size; temp_matrix->ncol = cases; matrix_multiplication1(X_matrix,weight_matrix,temp_matrix,3); matrix_multiplication1(temp_matrix,X_matrix,XtX_inverse,0); } else { matrix_multiplication1(X_matrix,X_matrix,XtX_inverse,1); } YtXXtX_column = (*YtXXtX_expanded)->column_list; for(i=0;i data[j+responses]=XtX_inverse->matrix[(i*model_size)+j]; } if(i != model_size-1){YtXXtX_column = YtXXtX_column->next;} } /*---Inserting the model into the model functions structure--*/ YtXXtX_column = (*YtXXtX_expanded)->column_list; for(i=0;i next; current_predictor = model; predictor_1= startmodel[(i*4)]; knot_1_index = startmodel[(i*4)+1]; predictor_2 = startmodel[(i*4)+2]; knot_2_index = startmodel[(i*4)+3]; while(current_predictor->predictor_index != predictor_1) { current_predictor = current_predictor->next_predictor; } if(current_predictor->number_of_basis_functions ==0) { new_function= (struct basis_function *)Salloc (1,struct basis_function); new_function->knot1_index = knot_1_index; new_function->knot1_value =startknots[i*2]; new_function->predictor1 = predictor_1; new_function->predictor2 = predictor_2; new_function->knot2_index = knot_2_index; new_function->knot2_value =startknots[(i*2)+1]; new_function->SD = SDs[i]; new_function->mean= means[i]; current_predictor->number_of_basis_functions = 1; current_predictor->functions = new_function; } else { /* move to the end of the column to add a new basis function*/ current_function = current_predictor->functions; for(j=0;jnumber_of_basis_functions;j++) { if(j != current_predictor->number_of_basis_functions-1) { current_function = current_function->link; } } new_function = (struct basis_function *)Salloc (1,struct basis_function); current_function->link = new_function; new_function->knot1_index = knot_1_index; new_function->predictor1 = predictor_1; new_function->predictor2 = predictor_2; new_function->knot2_index = knot_2_index; new_function->knot1_value =startknots[i*2]; new_function->knot2_value =startknots[(i*2)+1]; new_function->SD = SDs[i]; new_function->mean =means[i]; current_predictor->number_of_basis_functions++; } YtXXtX_column->function = new_function; /*-updating the matricies which control the order in which new candidates can be added-*/ if(predictor_2 == 0) { if(knot_1_index !=0) { order_keeper1[predictor_1-1]++; } } else { if(knot_1_index !=0 || knot_2_index != 0) { order_keeper2[((predictor_1-1)*predictors)+predictor_2-1]++; order_keeper2[((predictor_2-1)*predictors)+predictor_1-1]++; } if(knot_1_index ==0 || knot_2_index == 0) { order_keeper1[predictor_1-1]++; order_keeper1[predictor_2-1]++; } if(max_knots != 0) { if(knot_1_index !=0) { order_keeper3[(predictor_1-1)*max_knots+knot_1_index-1]++; } if(knot_2_index != 0) { order_keeper3[(predictor_2-1)*max_knots+knot_2_index-1]++; } } } } /*--inverting the XtX_matrix----------------*/ if(model_size ==1) { XtX_inverse->matrix[0] = 1/XtX_inverse->matrix[0]; } else { /*--Lapack inversion for indefinite double precision real symmetric matricies----two step--factorisation and inversion-------*/ ok = invert_matrix(XtX_inverse); } if (ok == 0) { /*computes YtY-YtX(XtX)^1XtY--and- sums the diagonal to get the RSS*/ /*uses data matrix with number of rows changed to be number of responses for Yt. */ (*YtXXtX_expanded)->nrow=responses; XtX_newinverseXtY->nrow = model_size; XtX_newinverseXtY->ncol = responses; matrix_multiplication2(XtX_inverse, *YtXXtX_expanded, XtX_newinverseXtY, 0); YtXXtX_newinverseXtY->nrow = responses; YtXXtX_newinverseXtY->ncol = responses; matrix_multiplication2(XtX_newinverseXtY, *YtXXtX_expanded, YtXXtX_newinverseXtY, 1); (*YtXXtX_expanded)->nrow=responses+model_size+1; rss_for_model =0.0; for(j=0;jmatrix[j*(responses+1)] +YtY->matrix[j*(responses+1)]; } for(j=0;jmatrix[j*(responses+1)] +YtY->matrix[j*(responses+1)]; } if(testset == FALSE) { GCV = (rss_for_model /weight_sum)/ ((1.0 - (GCVconstant*(model_size)/cases)) *(1.0 - (GCVconstant*(model_size)/cases))); } else { GCV = testset_RSS((*YtXXtX_expanded),model_size); } rssgcv[responses]=GCV; for(j=0;j<(XtX_newinverseXtY->nrow*XtX_newinverseXtY->ncol);j++) { best_coefficents[j] = XtX_newinverseXtY->matrix[j]; } for(l=0;l<(XtX_newinverse->ncol);l++) { for(m=0;m<(XtX_newinverse->ncol);m++) { best_XtXinv[l+m*XtX_newinverse->ncol]= XtX_newinverse->matrix[l+m*XtX_newinverse->ncol]; } } *bestmodel_size = model_size; YtXXtX_column = (*YtXXtX_expanded)->column_list; /*storing the best model */ for(i=0;ifunction; best_model[(i-1)*4]= current_function->predictor1; best_model[((i-1)*4)+1]=current_function->knot1_index; best_model[((i-1)*4)+2]=current_function->predictor2; best_model[((i-1)*4)+3]=current_function->knot2_index; best_model_sd_mean[(i-1)*2]=current_function->SD; best_model_sd_mean[((i-1)*2)+1]=current_function->mean; } YtXXtX_column = YtXXtX_column->next; } steps[0]=1; steps[1]=model_size; } return ok; } /*==============================================================*/ static void standardise_array(double *numbers,int length_of_list,double *mean,double *SD) /*==============================================================*/ { /*---------------------------------------------------------------- Finds the mean and standard deviation of a list of numbers and returns the array standard normalised, with mean and standard deviatioN ------------------------------------------------------------------*/ int i; double mina,maxi; *mean = 0; mina = numbers[0]; maxi = numbers[0]; for(i=0;i maxi){maxi=numbers[i];} } if((mina-maxi)*(mina-maxi)>=1) { *mean = (*mean)/length_of_list; for(i=0;i=0) { prereq =FALSE; for(j = 0;j< model_size-1;j++) { /*---checks that linear is present when initial model includes knot term-*/ if((startmodel[(j*4)] == startmodel[i*2] && startmodel[(j*4)+1] ==0) && startmodel[(j*4)+2] ==0) { prereq = TRUE; } } if(prereq == FALSE){return 2;} } } /*-checks the prerequisites for compound functions and whether the initial model contains the same terms more than once--*/ for(i = 0;i< model_size-1;i++) { for(j = 0;j< model_size-1;j++) { if(i !=j) { if(startmodel[(i*4)] == startmodel[(j*4)] && startmodel[(i*4)+1] == startmodel[(j*4)+1] && startmodel[(i*4)+2] == startmodel[(j*4)+2] && startmodel[(i*4)+3] == startmodel[(j*4)+3]) { /*if both are linear*/ if(startmodel[(i*4)+1] == 0 && startmodel[(i*4)+3]==0) { return 1; } /* if knots are the same */ if(startmodel[(i*4)+1] == 0 && startmodel[(i*4)+3] != 0) { if(startknots[(i*2)+1] == startknots[(j*2)+1]) { return 1; } } if(startmodel[(i*4)+1] != 0 && startmodel[(i*4)+3] == 0) { if(startknots[i*2] == startknots[j*2]) { return 1; } } if(startmodel[(i*4)] ==startmodel[(j*4)+2] && startmodel[(i*4)+1] == startmodel[(j*4)+3] && startmodel[(i*4)+2] == startmodel[(j*4)] && startmodel[(i*4)+3] == startmodel[(j*4)+1]) { if(startmodel[(i*4)+1] == 0 && startmodel[(i*4)+3]==0) { return 1; } if(startmodel[(i*4)+1] == 0 && startmodel[(i*4)+3] != 0) { if(startknots[(i*2)+1] == startknots[j*2]) { return 1; } } if(startmodel[(i*4)+1] != 0 && startmodel[(i*4)+3] == 0) { if(startknots[i*2] == startknots[(j*2)+1]) { return 1; } } } } } } /* a basis function with 2 linear terms then must have each linear term also in model*/ if((startmodel[(i*4)] !=0 && startmodel[(i*4)+1] == 0) && startmodel[(i*4)+2] != 0 && startmodel[(i*4)+3] ==0) { prereq = FALSE; prereq2 = FALSE; for(j = 0;j< model_size-1;j++) { if(startmodel[(j*4)] ==startmodel[(i*4)] && startmodel[(j*4)+1] == 0 && startmodel[(j*4)+2] == 0 && startmodel[(j*4)+3] == 0) {prereq = TRUE;} if(startmodel[(j*4)] ==startmodel[(i*4)+2] && startmodel[(j*4)+1] == 0 && startmodel[(j*4)+2] == 0 && startmodel[(j*4)+3] == 0) {prereq2 = TRUE;} } if(prereq == FALSE || prereq2 == FALSE) {return 3;} } /*if a model has two knoted terms the two linear term model must be present, also each two term with both predictors and one knot*/ if((startmodel[(i*4)] !=0 && startmodel[(i*4)+2] != 0) && startmodel[(i*4)+1] != 0 && startmodel[(i*4)+3] !=0) { prereq=FALSE; for(j = 0;j< model_size-1;j++) { if((startmodel[(i*4)] == startmodel[j*4] && startmodel[(j*4)+1] == 0 && startmodel[(i*4)+2] == startmodel[(j*4)+2] && startmodel[(i*4)+3] ==0) || (startmodel[(i*4)] == startmodel[(j*4)+2] && startmodel[(i*4)+3] ==0 && startmodel[(i*4)+2] == startmodel[j*4] && startmodel[(j*4)+1] == 0 )) { prereq = TRUE; } } if(prereq==FALSE){return 3;} prereq=FALSE; prereq2=FALSE; for(j = 0;j< model_size-1;j++) { if(startmodel[(i*4)] == startmodel[j*4] && 0 ==startmodel[(j*4)+1] && startmodel[(i*4)+2] == startmodel[(j*4)+2] && startmodel[(i*4)+3] == startmodel[(j*4)+3]) { prereq = TRUE; } if(startmodel[(i*4)] == startmodel[(j*4)+2] && 0 == startmodel[(j*4)+3] && startmodel[(i*4)+2] == startmodel[(j*4)] && startmodel[(i*4)+3] == startmodel[(j*4)+1]) { prereq = TRUE; } if(startmodel[(i*4)] == startmodel[j*4] &&startmodel[(i*4)+1] == startmodel[(j*4)+1] &&startmodel[(i*4)+2] == startmodel[(j*4)+2] && 0 == startmodel[(j*4)+3]) { prereq2 = TRUE; } if(startmodel[(i*4)] == startmodel[(j*4)+2] &&startmodel[(i*4)+1] == startmodel[(j*4)+3] &&startmodel[(i*4)+2] == startmodel[j*4] && 0 == startmodel[(j*4)+1]) { prereq2 = TRUE; } } if(prereq == FALSE || prereq2 == FALSE){return 3;} } } } return 0; } /*==============================================================*/ static double testset_RSS(struct matrix2 *YtXXtX_expanded,int model_size ) /*==============================================================*/ { /*computes test set RSS, coefficients must be transformed as they apply to the standarised data */ double totalRSS,fitted; struct basis_function *model_function; struct link *YtXXtX_column; double standardise_const; int i,j,k,cases; double temp_value1,temp_value2,x; cases = testset_matrix->nrow; YtXXtX_column = YtXXtX_expanded->column_list; for(i=0;i<(XtX_newinverseXtY->ncol*XtX_newinverseXtY->nrow);i++) { coefficents[i]=XtX_newinverseXtY->matrix[i]; } /*get mean and standard deviations */ for(i=0;inext; model_sd_mean[i*2] = YtXXtX_column->function->SD; model_sd_mean[(i*2)+1] = YtXXtX_column->function->mean; } /*untransform the transformed data*/ for(i=0;icolumn_list; standardise_const=0.0; for(j=1;jnext; standardise_const = standardise_const +(coefficents[j+(i*model_size)]*model_sd_mean[((j-1)*2)+1])/model_sd_mean[(j-1)*2]; } coefficents[i*(model_size)] = coefficents[i*model_size]-standardise_const; } for(i=0;ifunction->predictor1] < 0 && YtXXtX_column->function->predictor2 == 0 )) { coefficents[j+(i*model_size)] =coefficents[j+(i*model_size)] /model_sd_mean[(j-1)*2]; } } } for(i=0;icolumn_list; fitted = coefficents[i*(XtX_newinverseXtY->nrow)]; for(k=0;knext; model_function = YtXXtX_column->function; temp_value2 = 1; if(knots_per_pred[model_function->predictor1-1]>=0) { temp_value1 = testset_matrix->matrix[((responses+model_function->predictor1-1)*cases)+j]; if(model_function->knot1_index != 0) { x=temp_value1 - model_function->knot1_value; if(x>0){temp_value1 = x;}else{temp_value1 = 0.0;} } } else { if((int)testset_matrix->matrix[((responses+model_function->predictor1-1)*cases)+j] == (int)model_function->knot1_value) {temp_value1 =1.0;}else{temp_value1 = 0.0;} } if(model_function->predictor2 != 0) { temp_value2 = testset_matrix->matrix[((responses+model_function->predictor2-1)*cases)+j]; if(model_function->knot1_index != 0) { x=temp_value2 - model_function->knot2_value; if(x>0){temp_value2 = x;}else{temp_value2 = 0.0;} } } fitted = fitted + (temp_value1*temp_value2*coefficents[i*(XtX_newinverseXtY->nrow)+k+1]); } if(classification != TRUE) { tset_RSS[i] = tset_RSS[i] + (fitted - testset_matrix->matrix[i*cases+j])* (fitted - testset_matrix->matrix[i*cases+j]); } else { /* in classification the class is the index of the largest response for a case*/ if(i==0) { response_max[j] = fitted; response_class[j] = 0; } else { if(fitted>response_max[j]) { response_max[j]=fitted; response_class[j] = i; } } } } } totalRSS = 0.0; if(classification == TRUE) { for(j=0;jmatrix[response_class[j]*cases+j]) ==0 ) { totalRSS = totalRSS + 1; } } } else { if(testset_weighted == TRUE) { for(i=0;incol = ncol; new_matrix->nrow = nrow; return(new_matrix); } /*==============================================================*/ static struct matrix2 *create_matrix2(int nrow, int ncol) /*==============================================================*/ { /*--------------------------------------------------------------- Creates a matrix which is a linked list of columns. Each link also has a linkl to the model or candidate matrix as each column corresponds to one basis function -----------------------------------------------------------------*/ int i; struct matrix2 *new_matrix; struct link *column; struct link *current_link=0; new_matrix = (struct matrix2 *)Salloc(1,struct matrix2); for(i=0;idata =(double *)Salloc(nrow,double); column->next = current_link; current_link= column; } new_matrix->ncol = ncol; new_matrix->nrow = nrow; new_matrix->column_list = current_link; return(new_matrix); } /*==============================================================*/ static void switch_columns(int col1, int col2, struct matrix2 *object_matrix) /*==============================================================*/ { /*---------------------------------------------------------------- Switching rows means just swapping the pointers to the rows in the list that binds the column together ----------------------------------------------------------------*/ int i; struct link *current_column1, *current_column2; struct basis_function *function_holder; double *ptr_holder; if(col1==col2){return;} current_column1= object_matrix->column_list; current_column2= object_matrix->column_list; for(i=0;inext; } for(i=0;inext; } ptr_holder= current_column1->data; function_holder = current_column1->function; current_column1->function = current_column2->function; current_column1->data= current_column2->data; current_column2->data=ptr_holder; current_column2->function = function_holder; } /*============================================================== static void print_matrix1(struct matrix1 *object_matrix ) ============================================================== { int i,j,nrow,ncol; nrow = object_matrix->nrow; ncol = object_matrix->ncol; for(i=0;imatrix[(j*nrow)+i]); } Rprintf("\n"); } } */ /*============================================================== static void print_matrix2(struct matrix2 *object_matrix ) ============================================================== { int i,j,k,nrow,ncol; struct link *current_column; nrow = object_matrix->nrow; ncol = object_matrix->ncol; current_column = object_matrix->column_list; for(i=0;inext; } Rprintf("%f\t",current_column->data[i]); current_column = object_matrix->column_list; } Rprintf("\n"); } } */ /*==============================================================*/ static void matrix_multiplication1(struct matrix1 *object_matrixA, struct matrix1 *object_matrixB, struct matrix1 *result, int flag) /*==============================================================*/ { /*---------------------------------------------------------------- Flag: 0 for AB (regular multiplicaion (A,B,0)->AB 1 for AB (multiply transpose of A by B (A,B,1)->AtB) 2 for AB (multiply A by transpose of B (A,B,2)->ABt 3 for special multiplication AW where W is a weight matrix n*n with only the n diagonal elements stored ----------------------------------------------------------------*/ int i,j,k,nrowA,nrowB,ncolA,ncolB; double *A_pointer; double *B_pointer; double product; nrowA = object_matrixA-> nrow; ncolA = object_matrixA-> ncol; nrowB = object_matrixB-> nrow; ncolB = object_matrixB-> ncol; if(flag==1) { /*if(nrowA != nrowB) { Rprintf("Multiplication error \n"); exit(1); } if(ncolA != result->nrow || ncolB != result->ncol) { Rprintf("Multiplication error \n"); exit(1); }*/ for(i=0;imatrix; for(j=0;jmatrix[i*nrowA]; for(k=0;kmatrix[j*ncolA+i]=product; } } } if(flag==0) { A_pointer = object_matrixA->matrix; B_pointer = object_matrixB->matrix; /*if(ncolA != nrowB) { Rprintf("Multiplication error3 \n"); exit(1); } if(nrowA != result->nrow || ncolB != result->ncol) { Rprintf("Multiplication error4 \n"); exit(1); } */ for(i=0;imatrix; for(j=0;jmatrix[i+result->nrow*j]=product; } } } if(flag==2) { /* if(ncolA != ncolB) { Rprintf("Multiplication error4 \n"); exit(1); } if(nrowA != result->nrow || nrowB != result->ncol) { Rprintf("Multiplication error \n"); exit(1); } */ A_pointer = object_matrixA->matrix; B_pointer = object_matrixB->matrix; for(i=0;imatrix[i+nrowA*j]=product; } } } if(flag==3) { /* if(nrowA != nrowB) { Rprintf("Multiplication error \n"); exit(1); } if(ncolA != result->nrow || ncolB != result->ncol) { Rprintf("Multiplication error\n"); exit(1); } */ B_pointer = object_matrixB->matrix; for(i=0;imatrix[i*nrowA]; k=0; for(j=0;jmatrix[j*ncolA+i]=product; } } } } /*==============================================================*/ static void matrix_multiplication2(struct matrix1 *object_matrixA, struct matrix2 *object_matrixB, struct matrix1 *result, int flag) /*==============================================================*/ { /* multipling a matrix1 with a matrix2 flag for whether matrix2 is transposed or not*/ int i,j,k,l,nrowA,nrowB,ncolA,ncolB; double *A_pointer; double *B_pointer; double product; struct link *column_pointer; nrowA = object_matrixA-> nrow; ncolA = object_matrixA-> ncol; nrowB = object_matrixB-> nrow; ncolB = object_matrixB-> ncol; if(flag==0) { /*if(ncolA != ncolB) { Rprintf("Multiplication error \n"); exit(1); } if (nrowA != result->nrow || nrowB != result->ncol) { Rprintf("Multiplication error \n"); exit(1); } */ A_pointer=object_matrixA->matrix; for(i=0;icolumn_list; for(l=0;lnext; } B_pointer=column_pointer->data; product=product+(A_pointer[i+nrowA*k]*B_pointer[j]); } result->matrix[i+(nrowA*j)]=product; } } } else { /*if(nrowA != ncolB) { Rprintf("Multiplication error\n"); exit(1); }*/ /*if(nrowB != result->nrow || ncolA != result->ncol) { Rprintf("Multiplication error \n"); exit(1); } */ for(i=0;imatrix; for(j=0;jcolumn_list; for(l=0;lnext; } B_pointer=column_pointer->data; product = product + B_pointer[i]*A_pointer[0]; A_pointer++; } result->matrix[i+(nrowB*j)]=product; } } } } /*============================================================== static void print_functions(struct basis_function_matrix *functions_matrix) ============================================================== { int i,j; struct basis_function_matrix *current_predictor; struct basis_function *function; current_predictor = functions_matrix; for(i=0;inumber_of_basis_functions != 0) {function = current_predictor->functions;} for(j=0;jnumber_of_basis_functions;j++) { Rprintf("%d\t%d\t%f\t%d\t%d\t%f\n",function->predictor1, function->knot1_index, function->knot1_value, function->predictor2, function->knot2_index, function->knot2_value); if(j!=current_predictor->number_of_basis_functions-1) {function = function->link;} } current_predictor= current_predictor->next_predictor; } } */ /*---------------------------------------------------------------*/ static logical lsame(char *ca, char *cb) { /* -- LAPACK auxiliary routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= LSAME returns .TRUE. if CA is the same letter as CB regardless of case. Arguments ========= CA (input) CHARACTER*1 CB (input) CHARACTER*1 CA and CB specify the single characters to be compared. ===================================================================== Test if the characters are equal */ /* System generated locals */ logical ret_val; /* Local variables */ static int inta, intb, zcode; ret_val = *(unsigned char *)ca == *(unsigned char *)cb; if (ret_val) { return ret_val; } /* Now test for equivalence if both characters are alphabetic. */ zcode = 'Z'; /* Use 'Z' rather than 'A' so that ASCII can be detected on Prime machines, on which ICHAR returns a value with bit 8 set. ICHAR('A') on Prime machines returns 193 which is the same as ICHAR('A') on an EBCDIC machine. */ inta = *(unsigned char *)ca; intb = *(unsigned char *)cb; if (zcode == 90 || zcode == 122) { /* ASCII is assumed - ZCODE is the ASCII code of either lower o r upper case 'Z'. */ if (inta >= 97 && inta <= 122) { inta += -32; } if (intb >= 97 && intb <= 122) { intb += -32; } } else if (zcode == 233 || zcode == 169) { /* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or upper case 'Z'. */ if ((inta >= 129 && inta <= 137)||(inta >= 145 && inta <= 153)||(inta >= 162 && inta <= 169)) { inta += 64; } if ((intb >= 129 && intb <= 137)||(intb >= 145 && intb <= 153)||(intb >= 162 && intb <= 169)) { intb += 64; } } else if (zcode == 218 || zcode == 250) { /* ASCII is assumed, on Prime machines - ZCODE is the ASCII cod e plus 128 of either lower or upper case 'Z'. */ if (inta >= 225 && inta <= 250) { inta += -32; } if (intb >= 225 && intb <= 250) { intb += -32; } } ret_val = inta == intb; /* RETURN End of LSAME */ return ret_val; } /* lsame_ */ static int xerbla(char *srname, int *info) { /* -- LAPACK auxiliary routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= XERBLA is an error handler for the LAPACK routines. It is called by an LAPACK routine if an input parameter has an invalid value. A message is printed and execution stops. Installers may consider modifying the STOP statement in order to call system-specific exception-handling facilities. Arguments ========= SRNAME (input) CHARACTER*6 The name of the routine which called XERBLA. INFO (input) INT The position of the invalid parameter in the parameter list of the calling routine. ===================================================================== */ Rprintf("** On entry to %6s, parameter number %2i had an illegal value\n", srname, *info); /* End of XERBLA */ return 0; } /* xerbla */ /* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int idamax(int *n, double *dx, int *incx) { /* System generated locals */ int ret_val; double d__1; /* Local variables */ static double dmax__; static int i, ix; /* finds the index of element having max. absolute value. jack dongarra, linpack, 3/11/78. modified 3/93 to return if incx .le. 0. modified 12/3/93, array(1) declarations changed to array(*) Parameter adjustments Function Body */ #define DX(I) dx[(I)-1] ret_val = 0; if (*n < 1 || *incx <= 0) { return ret_val; } ret_val = 1; if (*n == 1) { return ret_val; } if (*incx == 1) { goto L20; } /* code for increment not equal to 1 */ ix = 1; dmax__ = abs(DX(1)); ix += *incx; for (i = 2; i <= *n; ++i) { if ((d__1 = DX(ix), abs(d__1)) <= dmax__) { goto L5; } ret_val = i; dmax__ = (d__1 = DX(ix), abs(d__1)); L5: ix += *incx; /* L10: */ } return ret_val; /* code for increment equal to 1 */ L20: dmax__ = abs(DX(1)); for (i = 2; i <= *n; ++i) { if ((d__1 = DX(i), abs(d__1)) <= dmax__) { goto L30; } ret_val = i; dmax__ = (d__1 = DX(i), abs(d__1)); L30: ; } return ret_val; } /* idamax */ /* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int dswap(int *n, double *dx, int *incx, double *dy, int *incy) { /* System generated locals */ /* Local variables */ static int i, m; static double dtemp; static int ix, iy, mp1; /* interchanges two vectors. uses unrolled loops for increments equal one. jack dongarra, linpack, 3/11/78. modified 12/3/93, array(1) declarations changed to array(*) Parameter adjustments Function Body */ #define DY(I) dy[(I)-1] if (*n <= 0) { return 0; } if (*incx == 1 && *incy == 1) { goto L20; } /* code for unequal increments or equal increments not equal to 1 */ ix = 1; iy = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } for (i = 1; i <= *n; ++i) { dtemp = DX(ix); DX(ix) = DY(iy); DY(iy) = dtemp; ix += *incx; iy += *incy; /* L10: */ } return 0; /* code for both increments equal to 1 clean-up loop */ L20: m = *n % 3; if (m == 0) { goto L40; } for (i = 1; i <= m; ++i) { dtemp = DX(i); DX(i) = DY(i); DY(i) = dtemp; /* L30: */ } if (*n < 3) { return 0; } L40: mp1 = m + 1; for (i = mp1; i <= *n; i += 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; /* L50: */ } return 0; } /* dswap */ /* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int dspr(char *uplo, int *n, double *alpha, double *x, int *incx, double *ap) { /* System generated locals */ /* Local variables */ static int info; static double temp; static int i, j, k; static int kk, ix, jx, kx; /* Purpose ======= DSPR performs the symmetric rank 1 operation A := alpha*x*x' + A, where alpha is a real scalar, x is an n element vector and A is an n by n symmetric matrix, supplied in packed form. Parameters ========== UPLO - CHARACTER*1. On entry, UPLO specifies whether the upper or lower triangular part of the matrix A is supplied in the packed array AP as follows: UPLO = 'U' or 'u' The upper triangular part of A is supplied in AP. UPLO = 'L' or 'l' The lower triangular part of A is supplied in AP. Unchanged on exit. N - INT. On entry, N specifies the order of the matrix A. N must be at least zero. Unchanged on exit. ALPHA - DOUBLE PRECISION. On entry, ALPHA specifies the scalar alpha. Unchanged on exit. X - DOUBLE PRECISION array of dimension at least ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremented array X must contain the n element vector x. Unchanged on exit. INCX - INT. On entry, INCX specifies the increment for the elements of X. INCX must not be zero. Unchanged on exit. AP - DOUBLE PRECISION array of DIMENSION at least ( ( n*( n + 1 ) )/2 ). Before entry with UPLO = 'U' or 'u', the array AP must contain the upper triangular part of the symmetric matrix packed sequentially, column by column, so that AP( 1 ) contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) respectively, and so on. On exit, the array AP is overwritten by the upper triangular part of the updated matrix. Before entry with UPLO = 'L' or 'l', the array AP must contain the lower triangular part of the symmetric matrix packed sequentially, column by column, so that AP( 1 ) contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) respectively, and so on. On exit, the array AP is overwritten by the lower triangular part of the updated matrix. Level 2 Blas routine. -- Written on 22-October-1986. Jack Dongarra, Argonne National Lab. Jeremy Du Croz, Nag Central Office. Sven Hammarling, Nag Central Office. Richard Hanson, Sandia National Labs. Test the input parameters. Parameter adjustments Function Body */ #define AP(I) ap[(I)-1] #define X(I) x[(I)-1] info = 0; if (! lsame(uplo, "U") && ! lsame(uplo, "L")) { info = 1; } else if (*n < 0) { info = 2; } else if (*incx == 0) { info = 5; } if (info != 0) { xerbla("DSPR ", &info); return 0; } /* Quick return if possible. */ if (*n == 0 || *alpha == 0.) { return 0; } /* Set the start point in X if the increment is not unity. */ if (*incx <= 0) { kx = 1 - (*n - 1) * *incx; } else if (*incx != 1) { kx = 1; } /* Start the operations. In this version the elements of the array AP are accessed sequentially with one pass through AP. */ kk = 1; if (lsame(uplo, "U")) { /* Form A when upper triangle is stored in AP. */ if (*incx == 1) { for (j = 1; j <= *n; ++j) { if (X(j) != 0.) { temp = *alpha * X(j); k = kk; for (i = 1; i <= j; ++i) { AP(k) += X(i) * temp; ++k; /* L10: */ } } kk += j; /* L20: */ } } else { jx = kx; for (j = 1; j <= *n; ++j) { if (X(jx) != 0.) { temp = *alpha * X(jx); ix = kx; for (k = kk; k <= kk+j-1; ++k) { AP(k) += X(ix) * temp; ix += *incx; /* L30: */ } } jx += *incx; kk += j; /* L40: */ } } } else { /* Form A when lower triangle is stored in AP. */ if (*incx == 1) { for (j = 1; j <= *n; ++j) { if (X(j) != 0.) { temp = *alpha * X(j); k = kk; for (i = j; i <= *n; ++i) { AP(k) += X(i) * temp; ++k; /* L50: */ } } kk = kk + *n - j + 1; /* L60: */ } } else { jx = kx; for (j = 1; j <= *n; ++j) { if (X(jx) != 0.) { temp = *alpha * X(jx); ix = jx; for (k = kk; k <= kk+*n-j; ++k) { AP(k) += X(ix) * temp; ix += *incx; /* L70: */ } } jx += *incx; kk = kk + *n - j + 1; /* L80: */ } } } return 0; /* End of DSPR . */ } /* dspr */ /* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int dscal(int *n, double *da, double *dx, int *incx) { /* System generated locals */ /* Local variables */ static int i, m, nincx, mp1; /* scales a vector by a constant. uses unrolled loops for increment equal to one. jack dongarra, linpack, 3/11/78. modified 3/93 to return if incx .le. 0. modified 12/3/93, array(1) declarations changed to array(*) Parameter adjustments Function Body */ if (*n <= 0 || *incx <= 0) { return 0; } if (*incx == 1) { goto L20; } /* code for increment not equal to 1 */ nincx = *n * *incx; for (i = 1; *incx < 0 ? i >= nincx : i <= nincx; i += *incx) { DX(i) = *da * DX(i); /* L10: */ } return 0; /* code for increment equal to 1 clean-up loop */ L20: m = *n % 5; if (m == 0) { goto L40; } for (i = 1; i <= m; ++i) { DX(i) = *da * DX(i); /* L30: */ } if (*n < 5) { return 0; } L40: mp1 = m + 1; for (i = mp1; i <= *n; i += 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); /* L50: */ } return 0; } /* dscal */ static int dlaev2(double *a, double *b, double *c, double *rt1, double *rt2, double *cs1, double *sn1) { /* -- LAPACK auxiliary routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University October 31, 1992 Purpose ======= DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix [ A B ] [ B C ]. On return, RT1 is the eigenvalue of larger absolute value, RT2 is the eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right eigenvector for RT1, giving the decomposition [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. Arguments ========= A (input) DOUBLE PRECISION The (1,1) element of the 2-by-2 matrix. B (input) DOUBLE PRECISION The (1,2) element and the conjugate of the (2,1) element of the 2-by-2 matrix. C (input) DOUBLE PRECISION The (2,2) element of the 2-by-2 matrix. RT1 (output) DOUBLE PRECISION The eigenvalue of larger absolute value. RT2 (output) DOUBLE PRECISION The eigenvalue of smaller absolute value. CS1 (output) DOUBLE PRECISION SN1 (output) DOUBLE PRECISION The vector (CS1, SN1) is a unit right eigenvector for RT1. Further Details =============== RT1 is accurate to a few ulps barring over/underflow. RT2 may be inaccurate if there is massive cancellation in the determinant A*C-B*B; higher precision or correctly rounded or correctly truncated arithmetic would be needed to compute RT2 accurately in all cases. CS1 and SN1 are accurate to a few ulps barring over/underflow. Overflow is possible only if RT1 is within a factor of 5 of overflow. Underflow is harmless if the input data is 0 or exceeds underflow_threshold / macheps. ===================================================================== Compute the eigenvalues */ /* System generated locals */ double d__1; /* Builtin functions */ double sqrt(double); /* Local variables */ static double acmn, acmx, ab, df, cs, ct, tb, sm, tn, rt, adf, acs; static int sgn1, sgn2; sm = *a + *c; df = *a - *c; adf = abs(df); tb = *b + *b; ab = abs(tb); if (abs(*a) > abs(*c)) { acmx = *a; acmn = *c; } else { acmx = *c; acmn = *a; } if (adf > ab) { /* Computing 2nd power */ d__1 = ab / adf; rt = adf * sqrt(d__1 * d__1 + 1.); } else if (adf < ab) { /* Computing 2nd power */ d__1 = adf / ab; rt = ab * sqrt(d__1 * d__1 + 1.); } else { /* Includes case AB=ADF=0 */ rt = ab * sqrt(2.); } if (sm < 0.) { *rt1 = (sm - rt) * .5; sgn1 = -1; /* Order of execution important. To get fully accurate smaller eigenvalue, next line needs to be executed in higher precision. */ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else if (sm > 0.) { *rt1 = (sm + rt) * .5; sgn1 = 1; /* Order of execution important. To get fully accurate smaller eigenvalue, next line needs to be executed in higher precision. */ *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b; } else { /* Includes case RT1 = RT2 = 0 */ *rt1 = rt * .5; *rt2 = rt * -.5; sgn1 = 1; } /* Compute the eigenvector */ if (df >= 0.) { cs = df + rt; sgn2 = 1; } else { cs = df - rt; sgn2 = -1; } acs = abs(cs); if (acs > ab) { ct = -tb / cs; *sn1 = 1. / sqrt(ct * ct + 1.); *cs1 = ct * *sn1; } else { if (ab == 0.) { *cs1 = 1.; *sn1 = 0.; } else { tn = -cs / tb; *cs1 = 1. / sqrt(tn * tn + 1.); *sn1 = tn * *cs1; } } if (sgn1 == sgn2) { tn = *cs1; *cs1 = -(*sn1); *sn1 = tn; } return 0; /* End of DLAEV2 */ } /* dlaev2 */ /* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int drot(int *n, double *dx, int *incx, double *dy, int *incy, double *c, double *s) { /* System generated locals */ /* Local variables */ static int i; static double dtemp; static int ix, iy; /* applies a plane rotation. jack dongarra, linpack, 3/11/78. modified 12/3/93, array(1) declarations changed to array(*) Parameter adjustments Function Body */ if (*n <= 0) { return 0; } if (*incx == 1 && *incy == 1) { goto L20; } /* code for unequal increments or equal increments not equal to 1 */ ix = 1; iy = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } for (i = 1; i <= *n; ++i) { dtemp = *c * DX(ix) + *s * DY(iy); DY(iy) = *c * DY(iy) - *s * DX(ix); DX(ix) = dtemp; ix += *incx; iy += *incy; /* L10: */ } return 0; /* code for both increments equal to 1 */ L20: for (i = 1; i <= *n; ++i) { dtemp = *c * DX(i) + *s * DY(i); DY(i) = *c * DY(i) - *s * DX(i); DX(i) = dtemp; /* L30: */ } return 0; } /* drot */ /* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int dcopy(int *n, double *dx, int *incx, double *dy, int *incy) { /* System generated locals */ /* Local variables */ static int i, m, ix, iy, mp1; /* copies a vector, x, to a vector, y. uses unrolled loops for increments equal to one. jack dongarra, linpack, 3/11/78. modified 12/3/93, array(1) declarations changed to array(*) Parameter adjustments Function Body */ if (*n <= 0) { return 0; } if (*incx == 1 && *incy == 1) { goto L20; } /* code for unequal increments or equal increments not equal to 1 */ ix = 1; iy = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } for (i = 1; i <= *n; ++i) { DY(iy) = DX(ix); ix += *incx; iy += *incy; /* L10: */ } return 0; /* code for both increments equal to 1 clean-up loop */ L20: m = *n % 7; if (m == 0) { goto L40; } for (i = 1; i <= m; ++i) { DY(i) = DX(i); /* L30: */ } if (*n < 7) { return 0; } L40: mp1 = m + 1; for (i = mp1; i <= *n; i += 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); /* L50: */ } return 0; } /* dcopy */ /* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int dspmv(char *uplo, int *n, double *alpha, double *ap, double *x, int *incx, double *beta, double *y, int *incy) { /* Local variables */ static int info; static double temp1, temp2; static int i, j, k; static int kk, ix, iy, jx, jy, kx, ky; /* Purpose ======= DSPMV performs the matrix-vector operation y := alpha*A*x + beta*y, where alpha and beta are scalars, x and y are n element vectors and A is an n by n symmetric matrix, supplied in packed form. Parameters ========== UPLO - CHARACTER*1. On entry, UPLO specifies whether the upper or lower triangular part of the matrix A is supplied in the packed array AP as follows: UPLO = 'U' or 'u' The upper triangular part of A is supplied in AP. UPLO = 'L' or 'l' The lower triangular part of A is supplied in AP. Unchanged on exit. N - INT. On entry, N specifies the order of the matrix A. N must be at least zero. Unchanged on exit. ALPHA - DOUBLE PRECISION. On entry, ALPHA specifies the scalar alpha. Unchanged on exit. AP - DOUBLE PRECISION array of DIMENSION at least ( ( n*( n + 1 ) )/2 ). Before entry with UPLO = 'U' or 'u', the array AP must contain the upper triangular part of the symmetric matrix packed sequentially, column by column, so that AP( 1 ) contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) respectively, and so on. Before entry with UPLO = 'L' or 'l', the array AP must contain the lower triangular part of the symmetric matrix packed sequentially, column by column, so that AP( 1 ) contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) respectively, and so on. Unchanged on exit. X - DOUBLE PRECISION array of dimension at least ( 1 + ( n - 1 )*abs( INCX ) ). Before entry, the incremented array X must contain the n element vector x. Unchanged on exit. INCX - INT. On entry, INCX specifies the increment for the elements of X. INCX must not be zero. Unchanged on exit. BETA - DOUBLE PRECISION. On entry, BETA specifies the scalar beta. When BETA is supplied as zero then Y need not be set on input. Unchanged on exit. Y - DOUBLE PRECISION array of dimension at least ( 1 + ( n - 1 )*abs( INCY ) ). Before entry, the incremented array Y must contain the n element vector y. On exit, Y is overwritten by the updated vector y. INCY - INT. On entry, INCY specifies the increment for the elements of Y. INCY must not be zero. Unchanged on exit. Level 2 Blas routine. -- Written on 22-October-1986. Jack Dongarra, Argonne National Lab. Jeremy Du Croz, Nag Central Office. Sven Hammarling, Nag Central Office. Richard Hanson, Sandia National Labs. Test the input parameters. Parameter adjustments Function Body */ #define Y(I) y[(I)-1] info = 0; if (! lsame(uplo, "U") && ! lsame(uplo, "L")) { info = 1; } else if (*n < 0) { info = 2; } else if (*incx == 0) { info = 6; } else if (*incy == 0) { info = 9; } if (info != 0) { xerbla("DSPMV ", &info); return 0; } /* Quick return if possible. */ if (*n == 0 ||(*alpha == 0. && *beta == 1.)) { return 0; } /* Set up the start points in X and Y. */ if (*incx > 0) { kx = 1; } else { kx = 1 - (*n - 1) * *incx; } if (*incy > 0) { ky = 1; } else { ky = 1 - (*n - 1) * *incy; } /* Start the operations. In this version the elements of the array AP are accessed sequentially with one pass through AP. First form y := beta*y. */ if (*beta != 1.) { if (*incy == 1) { if (*beta == 0.) { for (i = 1; i <= *n; ++i) { Y(i) = 0.; /* L10: */ } } else { for (i = 1; i <= *n; ++i) { Y(i) = *beta * Y(i); /* L20: */ } } } else { iy = ky; if (*beta == 0.) { for (i = 1; i <= *n; ++i) { Y(iy) = 0.; iy += *incy; /* L30: */ } } else { for (i = 1; i <= *n; ++i) { Y(iy) = *beta * Y(iy); iy += *incy; /* L40: */ } } } } if (*alpha == 0.) { return 0; } kk = 1; if (lsame(uplo, "U")) { /* Form y when AP contains the upper triangle. */ if (*incx == 1 && *incy == 1) { for (j = 1; j <= *n; ++j) { temp1 = *alpha * X(j); temp2 = 0.; k = kk; for (i = 1; i <= j-1; ++i) { Y(i) += temp1 * AP(k); temp2 += AP(k) * X(i); ++k; /* L50: */ } Y(j) = Y(j) + temp1 * AP(kk + j - 1) + *alpha * temp2; kk += j; /* L60: */ } } else { jx = kx; jy = ky; for (j = 1; j <= *n; ++j) { temp1 = *alpha * X(jx); temp2 = 0.; ix = kx; iy = ky; for (k = kk; k <= kk+j-2; ++k) { Y(iy) += temp1 * AP(k); temp2 += AP(k) * X(ix); ix += *incx; iy += *incy; /* L70: */ } Y(jy) = Y(jy) + temp1 * AP(kk + j - 1) + *alpha * temp2; jx += *incx; jy += *incy; kk += j; /* L80: */ } } } else { /* Form y when AP contains the lower triangle. */ if (*incx == 1 && *incy == 1) { for (j = 1; j <= *n; ++j) { temp1 = *alpha * X(j); temp2 = 0.; Y(j) += temp1 * AP(kk); k = kk + 1; for (i = j + 1; i <= *n; ++i) { Y(i) += temp1 * AP(k); temp2 += AP(k) * X(i); ++k; /* L90: */ } Y(j) += *alpha * temp2; kk += *n - j + 1; /* L100: */ } } else { jx = kx; jy = ky; for (j = 1; j <= *n; ++j) { temp1 = *alpha * X(jx); temp2 = 0.; Y(jy) += temp1 * AP(kk); ix = jx; iy = jy; for (k = kk + 1; k <= kk+*n-j; ++k) { ix += *incx; iy += *incy; Y(iy) += temp1 * AP(k); temp2 += AP(k) * X(ix); /* L110: */ } Y(jy) += *alpha * temp2; jx += *incx; jy += *incy; kk += *n - j + 1; /* L120: */ } } } return 0; /* End of DSPMV . */ } /* dspmv */ /* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static double ddot(int *n, double *dx, int *incx, double *dy, int *incy) { /* System generated locals */ double ret_val; /* Local variables */ static int i, m; static double dtemp; static int ix, iy, mp1; /* forms the dot product of two vectors. uses unrolled loops for increments equal to one. jack dongarra, linpack, 3/11/78. modified 12/3/93, array(1) declarations changed to array(*) Parameter adjustments Function Body */ ret_val = 0.; dtemp = 0.; if (*n <= 0) { return ret_val; } if (*incx == 1 && *incy == 1) { goto L20; } /* code for unequal increments or equal increments not equal to 1 */ ix = 1; iy = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } for (i = 1; i <= *n; ++i) { dtemp += DX(ix) * DY(iy); ix += *incx; iy += *incy; /* L10: */ } ret_val = dtemp; return ret_val; /* code for both increments equal to 1 clean-up loop */ L20: m = *n % 5; if (m == 0) { goto L40; } for (i = 1; i <= m; ++i) { dtemp += DX(i) * DY(i); /* L30: */ } if (*n < 5) { goto L60; } L40: mp1 = m + 1; for (i = mp1; i <= *n; i += 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); /* L50: */ } L60: ret_val = dtemp; return ret_val; } /* ddot */ static int invert_matrix(struct matrix1 *object_matrix) { char flag; int i,j,dim,k; int ok,info; int *int_array; double *packed_matrix,*workspace; ok =0; dim = object_matrix->nrow; /*--pack top half of this matrix into array for inversion routine-*/ packed_matrix= (double *)Salloc(1+(dim*(dim+1))/2,double); k=-1; for(i=0;imatrix[(i*dim)+j]; } } int_array = (int *)Salloc(dim+1,int); flag = 'U'; info=0; /*--factorisation step -----------------------------------*/ ok = dsptrf(&flag,&dim,packed_matrix,int_array,&info); /*--inversion step----------------------------------------*/ workspace = (double *)Salloc(dim*dim+1,double); ok = dsptri(&flag,&dim,packed_matrix,int_array,workspace,&info); /*--unpacking into back into matrix ----------------------*/ k=0; for(j=0;jmatrix[(j*dim)+i]=packed_matrix[i + j*(j+1)/2]; } } for(j=1;jmatrix[j+(i*dim)]=object_matrix->matrix[(j*dim)+i]; } } return ok; } static int dsptrf(char *uplo, int *n, double *ap, int * ipiv, int *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= DSPTRF computes the factorization of a real symmetric matrix A stored in packed format using the Bunch-Kaufman diagonal pivoting method: A = U*D*U**T or A = L*D*L**T where U (or L) is a product of permutation and unit upper (lower) triangular matrices, and D is symmetric and block diagonal with 1-by-1 and 2-by-2 diagonal blocks. Arguments ========= UPLO (input) CHARACTER*1 = 'U': Upper triangle of A is stored; = 'L': Lower triangle of A is stored. N (input) INT The order of the matrix A. N >= 0. AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, the upper or lower triangle of the symmetric matrix A, packed columnwise in a linear array. The j-th column of A is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. On exit, the block diagonal matrix D and the multipliers used to obtain the factor U or L, stored as a packed triangular matrix overwriting A (see below for further details). IPIV (output) INT array, dimension (N) Details of the interchanges and the block structure of D. If IPIV(k) > 0, then rows and columns k and IPIV(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. INFO (output) INT = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, D(i,i) is exactly zero. The factorization has been completed, but the block diagonal matrix D is exactly singular, and division by zero will occur if it is used to solve a system of equations. Further Details =============== If UPLO = 'U', then A = U*D*U', where U = P(n)*U(n)* ... *P(k)U(k)* ..., i.e., U is a product of terms P(k)*U(k), where k decreases from n to 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as defined by IPIV(k), and U(k) is a unit upper triangular matrix, such that if the diagonal block D(k) is of order s (s = 1 or 2), then ( I v 0 ) k-s U(k) = ( 0 I 0 ) s ( 0 0 I ) n-k k-s s n-k If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), and A(k,k), and v overwrites A(1:k-2,k-1:k). If UPLO = 'L', then A = L*D*L', where L = P(1)*L(1)* ... *P(k)*L(k)* ..., i.e., L is a product of terms P(k)*L(k), where k increases from 1 to n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as defined by IPIV(k), and L(k) is a unit lower triangular matrix, such that if the diagonal block D(k) is of order s (s = 1 or 2), then ( I 0 0 ) k-1 L(k) = ( 0 I 0 ) s ( 0 v I ) n-k-s+1 k-1 s n-k-s+1 If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static int c__1 = 1; /* System generated locals */ int i__1; double d__1, d__2, d__3; /* Builtin functions */ double sqrt(double); /* Local variables */ static int imax, jmax; static double c; static int j, k; static double s, t, alpha; static int kstep; static logical upper; static double r1, r2; static int kc, kk, kp; static double absakk; static int kx; static double colmax, rowmax; static int knc, kpc, npp; #define IPIV(I) ipiv[(I)-1] #define AP(I) ap[(I)-1] *info = 0; upper = lsame(uplo, "U"); if (! upper && ! lsame(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla("DSPTRF", &i__1); return 0; } /* Initialize ALPHA for use in choosing pivot block size. */ alpha = (sqrt(17.) + 1.) / 8.; if (upper) { /* Factorize A as U*D*U' using the upper triangle of A K is the main loop index, decreasing from N to 1 in steps of 1 or 2 */ k = *n; kc = (*n - 1) * *n / 2 + 1; L10: knc = kc; /* If K < 1, exit from loop */ if (k < 1) { goto L70; } kstep = 1; /* Determine rows and columns to be interchanged and whether a 1-by-1 or 2-by-2 pivot block will be used */ absakk = (d__1 = AP(kc + k - 1), abs(d__1)); /* IMAX is the row-index of the largest off-diagonal element in column K, and COLMAX is its absolute value */ if (k > 1) { i__1 = k - 1; imax = idamax(&i__1, &AP(kc), &c__1); colmax = (d__1 = AP(kc + imax - 1), abs(d__1)); } else { colmax = 0.; } if (max(absakk,colmax) == 0.) { /* Column K is zero: set INFO and continue */ if (*info == 0) { *info = k; } kp = k; } else { if (absakk >= alpha * colmax) { /* no interchange, use 1-by-1 pivot block */ kp = k; } else { /* JMAX is the column-index of the largest off-di agonal element in row IMAX, and ROWMAX is its absolut e value */ rowmax = 0.; jmax = imax; kx = imax * (imax + 1) / 2 + imax; i__1 = k; for (j = imax + 1; j <= k; ++j) { if ((d__1 = AP(kx), abs(d__1)) > rowmax) { rowmax = (d__1 = AP(kx), abs(d__1)); jmax = j; } kx += j; /* L20: */ } kpc = (imax - 1) * imax / 2 + 1; if (imax > 1) { i__1 = imax - 1; jmax = idamax(&i__1, &AP(kpc), &c__1); /* Computing MAX */ d__2 = rowmax, d__3 = (d__1 = AP(kpc + jmax - 1), abs( d__1)); rowmax = max(d__2,d__3); } if (absakk >= alpha * colmax * (colmax / rowmax)) { /* no interchange, use 1-by-1 pivot block */ kp = k; } else if ((d__1 = AP(kpc + imax - 1), abs(d__1)) >= alpha * rowmax) { /* interchange rows and columns K and IMAX , use 1-by-1 pivot block */ kp = imax; } else { /* interchange rows and columns K-1 and IM AX, use 2-by-2 pivot block */ kp = imax; kstep = 2; } } kk = k - kstep + 1; if (kstep == 2) { knc = knc - k + 1; } if (kp != kk) { /* Interchange rows and columns KK and KP in the leading submatrix A(1:k,1:k) */ i__1 = kp - 1; dswap(&i__1, &AP(knc), &c__1, &AP(kpc), &c__1); kx = kpc + kp - 1; i__1 = kk - 1; for (j = kp + 1; j <= kk-1; ++j) { kx = kx + j - 1; t = AP(knc + j - 1); AP(knc + j - 1) = AP(kx); AP(kx) = t; /* L30: */ } t = AP(knc + kk - 1); AP(knc + kk - 1) = AP(kpc + kp - 1); AP(kpc + kp - 1) = t; if (kstep == 2) { t = AP(kc + k - 2); AP(kc + k - 2) = AP(kc + kp - 1); AP(kc + kp - 1) = t; } } /* Update the leading submatrix */ if (kstep == 1) { /* 1-by-1 pivot block D(k): column k now holds W(k) = U(k)*D(k) where U(k) is the k-th column of U Perform a rank-1 update of A(1:k-1,1:k-1) as A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k )' */ r1 = 1. / AP(kc + k - 1); i__1 = k - 1; d__1 = -r1; dspr(uplo, &i__1, &d__1, &AP(kc), &c__1, &AP(1)); /* Store U(k) in column k */ i__1 = k - 1; dscal(&i__1, &r1, &AP(kc), &c__1); } else { /* 2-by-2 pivot block D(k): columns k and k-1 now hold ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) where U(k) and U(k-1) are the k-th and (k-1)-t h columns of U Perform a rank-2 update of A(1:k-2,1:k-2) as A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W( k) )' Convert this to two rank-1 updates by using th e eigen- decomposition of D(k) */ dlaev2(&AP(kc - 1), &AP(kc + k - 2), &AP(kc + k - 1), &r1, & r2, &c, &s); r1 = 1. / r1; r2 = 1. / r2; i__1 = k - 2; drot(&i__1, &AP(knc), &c__1, &AP(kc), &c__1, &c, &s); i__1 = k - 2; d__1 = -r1; dspr(uplo, &i__1, &d__1, &AP(knc), &c__1, &AP(1)); i__1 = k - 2; d__1 = -r2; dspr(uplo, &i__1, &d__1, &AP(kc), &c__1, &AP(1)); /* Store U(k) and U(k-1) in columns k and k-1 */ i__1 = k - 2; dscal(&i__1, &r1, &AP(knc), &c__1); i__1 = k - 2; dscal(&i__1, &r2, &AP(kc), &c__1); i__1 = k - 2; d__1 = -s; drot(&i__1, &AP(knc), &c__1, &AP(kc), &c__1, &c, &d__1); } } /* Store details of the interchanges in IPIV */ if (kstep == 1) { IPIV(k) = kp; } else { IPIV(k) = -kp; IPIV(k - 1) = -kp; } /* Decrease K and return to the start of the main loop */ k -= kstep; kc = knc - k; goto L10; } else { /* Factorize A as L*D*L' using the lower triangle of A K is the main loop index, increasing from 1 to N in steps of 1 or 2 */ k = 1; kc = 1; npp = *n * (*n + 1) / 2; L40: knc = kc; /* If K > N, exit from loop */ if (k > *n) { goto L70; } kstep = 1; /* Determine rows and columns to be interchanged and whether a 1-by-1 or 2-by-2 pivot block will be used */ absakk = (d__1 = AP(kc), abs(d__1)); /* IMAX is the row-index of the largest off-diagonal element in column K, and COLMAX is its absolute value */ if (k < *n) { i__1 = *n - k; imax = k + idamax(&i__1, &AP(kc + 1), &c__1); colmax = (d__1 = AP(kc + imax - k), abs(d__1)); } else { colmax = 0.; } if (max(absakk,colmax) == 0.) { /* Column K is zero: set INFO and continue */ if (*info == 0) { *info = k; } kp = k; } else { if (absakk >= alpha * colmax) { /* no interchange, use 1-by-1 pivot block */ kp = k; } else { /* JMAX is the column-index of the largest off-di agonal element in row IMAX, and ROWMAX is its absolut e value */ rowmax = 0.; kx = kc + imax - k; i__1 = imax - 1; for (j = k; j <= imax-1; ++j) { if ((d__1 = AP(kx), abs(d__1)) > rowmax) { rowmax = (d__1 = AP(kx), abs(d__1)); jmax = j; } kx = kx + *n - j; /* L50: */ } kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1; if (imax < *n) { i__1 = *n - imax; jmax = imax + idamax(&i__1, &AP(kpc + 1), &c__1); /* Computing MAX */ d__2 = rowmax, d__3 = (d__1 = AP(kpc + jmax - imax), abs( d__1)); rowmax = max(d__2,d__3); } if (absakk >= alpha * colmax * (colmax / rowmax)) { /* no interchange, use 1-by-1 pivot block */ kp = k; } else if ((d__1 = AP(kpc), abs(d__1)) >= alpha * rowmax) { /* interchange rows and columns K and IMAX , use 1-by-1 pivot block */ kp = imax; } else { /* interchange rows and columns K+1 and IM AX, use 2-by-2 pivot block */ kp = imax; kstep = 2; } } kk = k + kstep - 1; if (kstep == 2) { knc = knc + *n - k + 1; } if (kp != kk) { /* Interchange rows and columns KK and KP in the trailing submatrix A(k:n,k:n) */ if (kp < *n) { i__1 = *n - kp; dswap(&i__1, &AP(knc + kp - kk + 1), &c__1, &AP(kpc + 1), &c__1); } kx = knc + kp - kk; i__1 = kp - 1; for (j = kk + 1; j <= kp-1; ++j) { kx = kx + *n - j + 1; t = AP(knc + j - kk); AP(knc + j - kk) = AP(kx); AP(kx) = t; /* L60: */ } t = AP(knc); AP(knc) = AP(kpc); AP(kpc) = t; if (kstep == 2) { t = AP(kc + 1); AP(kc + 1) = AP(kc + kp - k); AP(kc + kp - k) = t; } } /* Update the trailing submatrix */ if (kstep == 1) { /* 1-by-1 pivot block D(k): column k now holds W(k) = L(k)*D(k) where L(k) is the k-th column of L */ if (k < *n) { /* Perform a rank-1 update of A(k+1:n,k+1: n) as A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/ D(k))*W(k)' */ r1 = 1. / AP(kc); i__1 = *n - k; d__1 = -r1; dspr(uplo, &i__1, &d__1, &AP(kc + 1), &c__1, &AP(kc + *n - k + 1)); /* Store L(k) in column K */ i__1 = *n - k; dscal(&i__1, &r1, &AP(kc + 1), &c__1); } } else { /* 2-by-2 pivot block D(k): columns K and K+1 now hold ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) where L(k) and L(k+1) are the k-th and (k+1)-t h columns of L */ if (k < *n - 1) { /* Perform a rank-2 update of A(k+2:n,k+2: n) as A := A - ( L(k) L(k+1) )*D(k)*( L(k) L( k+1) )' = A - ( W(k) W(k+1) )*inv(D(k))*( W( k) W(k+1) )' Convert this to two rank-1 updates by u sing the eigen- decomposition of D(k) */ dlaev2(&AP(kc), &AP(kc + 1), &AP(knc), &r1, &r2, &c, &s); r1 = 1. / r1; r2 = 1. / r2; i__1 = *n - k - 1; drot(&i__1, &AP(kc + 2), &c__1, &AP(knc + 1), &c__1, &c, &s); i__1 = *n - k - 1; d__1 = -r1; dspr(uplo, &i__1, &d__1, &AP(kc + 2), &c__1, &AP(knc + * n - k)); i__1 = *n - k - 1; d__1 = -r2; dspr(uplo, &i__1, &d__1, &AP(knc + 1), &c__1, &AP(knc + * n - k)); /* Store L(k) and L(k+1) in columns k and k+1 */ i__1 = *n - k - 1; dscal(&i__1, &r1, &AP(kc + 2), &c__1); i__1 = *n - k - 1; dscal(&i__1, &r2, &AP(knc + 1), &c__1); i__1 = *n - k - 1; d__1 = -s; drot(&i__1, &AP(kc + 2), &c__1, &AP(knc + 1), &c__1, &c, &d__1); } } } /* Store details of the interchanges in IPIV */ if (kstep == 1) { IPIV(k) = kp; } else { IPIV(k) = -kp; IPIV(k + 1) = -kp; } /* Increase K and return to the start of the main loop */ k += kstep; kc = knc + *n - k + 2; goto L40; } L70: return 0; /* End of DSPTRF */ } /* dsptrf_ */ static int dsptri(char *uplo, int *n, double *ap, int * ipiv, double *work, int *info) { /* -- LAPACK routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University March 31, 1993 Purpose ======= DSPTRI computes the inverse of a double symmetric indefinite matrix A in packed storage using the factorization A = U*D*U**T or A = L*D*L**T computed by DSPTRF. Arguments ========= UPLO (input) CHARACTER*1 Specifies whether the details of the factorization are stored as an upper or lower triangular matrix. = 'U': Upper triangular, form is A = U*D*U**T; = 'L': Lower triangular, form is A = L*D*L**T. N (input) INT The order of the matrix A. N >= 0. AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) On entry, the block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by DSPTRF, stored as a packed triangular matrix. On exit, if INFO = 0, the (symmetric) inverse of the original matrix, stored as a packed triangular matrix. The j-th column of inv(A) is stored in the array AP as follows: if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. IPIV (input) INT array, dimension (N) Details of the interchanges and the block structure of D as determined by DSPTRF. WORK (workspace) DOUBLE PRECISION array, dimension (N) INFO (output) INT = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its inverse could not be computed. ===================================================================== Test the input parameters. Parameter adjustments Function Body */ /* Table of constant values */ static int c__1 = 1; static double c_b11 = -1.; static double c_b13 = 0.; /* System generated locals */ int i__1; double d__1; /* Local variables */ static double temp, akkp1, d; static int j, k; static double t; static int kstep; static logical upper; static double ak; static int kc, kp, kx; static int kcnext, kpc, npp; static double akp1; #define WORK(I) work[(I)-1] #define IPIV(I) ipiv[(I)-1] #define AP(I) ap[(I)-1] *info = 0; upper = lsame(uplo, "U"); if (! upper && ! lsame(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } if (*info != 0) { i__1 = -(*info); xerbla("DSPTRI", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Check that the diagonal matrix D is nonsingular. */ if (upper) { /* Upper triangular storage: examine D from bottom to top */ kp = *n * (*n + 1) / 2; for (*info = *n; *info >= 1; --(*info)) { if (IPIV(*info) > 0 && AP(kp) == 0.) { return 0; } kp -= *info; /* L10: */ } } else { /* Lower triangular storage: examine D from top to bottom. */ kp = 1; i__1 = *n; for (*info = 1; *info <= i__1; ++(*info)) { if (IPIV(*info) > 0 && AP(kp) == 0.) { return 0; } kp = kp + *n - *info + 1; /* L20: */ } } *info = 0; if (upper) { /* Compute inv(A) from the factorization A = U*D*U'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ k = 1; kc = 1; L30: /* If K > N, exit from loop. */ if (k > *n) { goto L50; } kcnext = kc + k; if (IPIV(k) > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ AP(kc + k - 1) = 1. / AP(kc + k - 1); /* Compute column K of the inverse. */ if (k > 1) { i__1 = k - 1; dcopy(&i__1, &AP(kc), &c__1, &WORK(1), &c__1); i__1 = k - 1; dspmv(uplo, &i__1, &c_b11, &AP(1), &WORK(1), &c__1, &c_b13, & AP(kc), &c__1); i__1 = k - 1; AP(kc + k - 1) -= ddot(&i__1, &WORK(1), &c__1, &AP(kc), & c__1); } kstep = 1; } else { /* 2 x 2 diagonal block Invert the diagonal block. */ t = (d__1 = AP(kcnext + k - 1), abs(d__1)); ak = AP(kc + k - 1) / t; akp1 = AP(kcnext + k) / t; akkp1 = AP(kcnext + k - 1) / t; d = t * (ak * akp1 - 1.); AP(kc + k - 1) = akp1 / d; AP(kcnext + k) = ak / d; AP(kcnext + k - 1) = -akkp1 / d; /* Compute columns K and K+1 of the inverse. */ if (k > 1) { i__1 = k - 1; dcopy(&i__1, &AP(kc), &c__1, &WORK(1), &c__1); i__1 = k - 1; dspmv(uplo, &i__1, &c_b11, &AP(1), &WORK(1), &c__1, &c_b13, & AP(kc), &c__1); i__1 = k - 1; AP(kc + k - 1) -= ddot(&i__1, &WORK(1), &c__1, &AP(kc), & c__1); i__1 = k - 1; AP(kcnext + k - 1) -= ddot(&i__1, &AP(kc), &c__1, &AP(kcnext) , &c__1); i__1 = k - 1; dcopy(&i__1, &AP(kcnext), &c__1, &WORK(1), &c__1); i__1 = k - 1; dspmv(uplo, &i__1, &c_b11, &AP(1), &WORK(1), &c__1, &c_b13, & AP(kcnext), &c__1); i__1 = k - 1; AP(kcnext + k) -= ddot(&i__1, &WORK(1), &c__1, &AP(kcnext), & c__1); } kstep = 2; kcnext = kcnext + k + 1; } kp = (i__1 = IPIV(k), abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the leading submatrix A(1:k+1,1:k+1) */ kpc = (kp - 1) * kp / 2 + 1; i__1 = kp - 1; dswap(&i__1, &AP(kc), &c__1, &AP(kpc), &c__1); kx = kpc + kp - 1; i__1 = k - 1; for (j = kp + 1; j <= k-1; ++j) { kx = kx + j - 1; temp = AP(kc + j - 1); AP(kc + j - 1) = AP(kx); AP(kx) = temp; /* L40: */ } temp = AP(kc + k - 1); AP(kc + k - 1) = AP(kpc + kp - 1); AP(kpc + kp - 1) = temp; if (kstep == 2) { temp = AP(kc + k + k - 1); AP(kc + k + k - 1) = AP(kc + k + kp - 1); AP(kc + k + kp - 1) = temp; } } k += kstep; kc = kcnext; goto L30; L50: ; } else { /* Compute inv(A) from the factorization A = L*D*L'. K is the main loop index, increasing from 1 to N in steps of 1 or 2, depending on the size of the diagonal blocks. */ npp = *n * (*n + 1) / 2; k = *n; kc = npp; L60: /* If K < 1, exit from loop. */ if (k < 1) { goto L80; } kcnext = kc - (*n - k + 2); if (IPIV(k) > 0) { /* 1 x 1 diagonal block Invert the diagonal block. */ AP(kc) = 1. / AP(kc); /* Compute column K of the inverse. */ if (k < *n) { i__1 = *n - k; dcopy(&i__1, &AP(kc + 1), &c__1, &WORK(1), &c__1); i__1 = *n - k; dspmv(uplo, &i__1, &c_b11, &AP(kc + *n - k + 1), &WORK(1), & c__1, &c_b13, &AP(kc + 1), &c__1); i__1 = *n - k; AP(kc) -= ddot(&i__1, &WORK(1), &c__1, &AP(kc + 1), &c__1); } kstep = 1; } else { /* 2 x 2 diagonal block Invert the diagonal block. */ t = (d__1 = AP(kcnext + 1), abs(d__1)); ak = AP(kcnext) / t; akp1 = AP(kc) / t; akkp1 = AP(kcnext + 1) / t; d = t * (ak * akp1 - 1.); AP(kcnext) = akp1 / d; AP(kc) = ak / d; AP(kcnext + 1) = -akkp1 / d; /* Compute columns K-1 and K of the inverse. */ if (k < *n) { i__1 = *n - k; dcopy(&i__1, &AP(kc + 1), &c__1, &WORK(1), &c__1); i__1 = *n - k; dspmv(uplo, &i__1, &c_b11, &AP(kc + (*n - k + 1)), &WORK(1), &c__1, &c_b13, &AP(kc + 1), &c__1); i__1 = *n - k; AP(kc) -= ddot(&i__1, &WORK(1), &c__1, &AP(kc + 1), &c__1); i__1 = *n - k; AP(kcnext + 1) -= ddot(&i__1, &AP(kc + 1), &c__1, &AP(kcnext + 2), &c__1); i__1 = *n - k; dcopy(&i__1, &AP(kcnext + 2), &c__1, &WORK(1), &c__1); i__1 = *n - k; dspmv(uplo, &i__1, &c_b11, &AP(kc + (*n - k + 1)), &WORK(1), &c__1, &c_b13, &AP(kcnext + 2), &c__1); i__1 = *n - k; AP(kcnext) -= ddot(&i__1, &WORK(1), &c__1, &AP(kcnext + 2), & c__1); } kstep = 2; kcnext -= *n - k + 3; } kp = (i__1 = IPIV(k), abs(i__1)); if (kp != k) { /* Interchange rows and columns K and KP in the trailing submatrix A(k-1:n,k-1:n) */ kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1; if (kp < *n) { i__1 = *n - kp; dswap(&i__1, &AP(kc + kp - k + 1), &c__1, &AP(kpc + 1), &c__1); } kx = kc + kp - k; i__1 = kp - 1; for (j = k + 1; j <= kp-1; ++j) { kx = kx + *n - j + 1; temp = AP(kc + j - k); AP(kc + j - k) = AP(kx); AP(kx) = temp; /* L70: */ } temp = AP(kc); AP(kc) = AP(kpc); AP(kpc) = temp; if (kstep == 2) { temp = AP(kc - *n + k - 1); AP(kc - *n + k - 1) = AP(kc - *n + kp - 1); AP(kc - *n + kp - 1) = temp; } } k -= kstep; kc = kcnext; goto L60; L80: ; } return 0; /* End of DSPTRI */ } /* dsptri_ */ /*==============================================================*/ static double *compute_mesh(void) /*==============================================================*/ { /*-------------------------------------------------------------- Computes the mesh of possible knots for the spline functions. The number of knots per predictor is an arguement to the main function and they are stored in `knots_per_pred' Returns a pointer to the mesh which is a double array --------------------------------------------------------------*/ int i,j,k,l,m; double data_value; double *mesh; double *levels; int mesh_size, knots, nstartknots; int level_present; double *matrix_ptr,*mesh_ptr, *mesh_ptr2; /*---levels is an array to hold the different levels of the categorical variables. The levels will be put into the mesh matrix as knots are put in for continuous variables it is also used to sort predictor values into order statistics to calculate knots in continuous predictors-*/ mesh = (double *)Salloc(10,double); levels = (double *)Salloc(2*cases+1,double); for(i=0;i<2*cases+1;i++)levels[i]=0.; matrix_ptr = data_matrix->matrix; mesh_size = 0; /*----------------------------------- Knots in the initial model are treated as extra and put in after the usual knots for each predictor -------------------------------------*/ if(model_size >1) { for(i=0;i<2*(model_size-1);i++) { if(startmodel[(i*2)+1] == 1 && knots_per_pred[startmodel[(i*2)]-1] >-1) { knots_per_pred[startmodel[(i*2)]-1]++; } } } /*------------------------------------------*/ /*--counting the total number of knots--*/ for(i=0;i=0) { mesh_size = mesh_size + knots_per_pred[i]; } } /*-the number of levels per pred are added to mesh size--*/ for(i=0;imatrix[(responses+i)*cases]; k=0; for(j=0;jmatrix[(responses+i)*cases]; k=0; for(j=0;jmatrix[(responses+i)*cases]; /*-add new level to levels matrix-*/ for(j=0;j=0 && levels[k] >data_value) { levels[k+1]=levels[k]; k--; } levels[k+1]=data_value; } /*m counts the number of values that are the present more than once in a predictor*/ m = 0; for(j=0;j=knot_space) && (j <=cases-m-knot_space) ) { *mesh_ptr = levels[j]; mesh_ptr++; l = j; } else { if(knots_per_pred[i]>0) { knots_per_pred[i]=knots_per_pred[i]-1; } } } knots = knots_per_pred[i]; k=1; for(j=0;j<(model_size-1)*2;j++) { if(startmodel[j*2]-1 == i && startmodel[(j*2)+1]==1) { *mesh_ptr =startknots[j]; startmodel[(j*2)+1] = knots+k-nstartknots; k=k+1; mesh_ptr++; } } } } } return mesh; } /* static double condition(a) struct matrix1 *a; */ static double condition(void) { double aa[DIM5][DIM5],bb[DIM5],rcond; int kpvt[DIM5]; int i,j,n,na; n = XtX_newinverse->nrow; if(nmatrix[j+i*n]; } else{ na=n-DIM5; n=DIM5; for(i=0;imatrix[j+na+(i+na)*(n+na)]; } i=DIM5; F77_CALL(xdsico)(aa,&i,&n,kpvt,&rcond,bb); return rcond; } polspline/src/hareall.c0000644000176200001440000033722214516535017014642 0ustar liggesusers/* * Copyright (C) 1993--2018 Charles Kooperberg * * 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. * * The text of the GNU General Public License, version 2, is available * as http://www.gnu.org/copyleft or by writing to the Free Software * Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* this file contains the main body of the program, a few small routines on which it depends and two routines that deal with space-structures */ /* this function describes the basis data structure */ #include #include #include "R.h" #define Salloc(n, t) (t *)R_alloc((long)(n), (int)sizeof(t)) /* we want to be able to use those everywhere */ #define MAXSPACE 53 #define MAXKNOTS 20 #define DIM5 MAXSPACE+5 /* MAXSPACE - maximum dimensionality of the model MAXKNOTS - maximum number of knots for one covariate */ void F77_NAME(xdsifa)(double[][DIM5], int *, int *, int *, int *); void F77_NAME(xdsisl)(double[][DIM5], int *, int *, int *, double *); void F77_NAME(xdsidi)(double[][DIM5], int *, int *, int *, double *, int *, double *, int *); void F77_NAME(xdsico)(double[][DIM5], int *, int *, int *, double *, double *); struct datastruct { int ndata,ncov,*delta,*bincov,*same; double *times,**cov; }; /* datastruct is a structure containing all information about the data. At any time there is only one datastruct, which is called data. ndata - number of datapoints ncov - number of covariates delta - delta (censor indiactor) 0=censored 1=uncensored bincov - are the covariates binary? 0=no, 1=yes binary cov should be 0-1 same - if the covariate structure of case i is the same as for case i-1 times - observation/censoring times cov - covariates cov[i][j] is covariate j for observation i */ struct space { int ndim,nknots; double *knots,aic,**info,*score,**b0,**b1,*b2,**xtx; struct basisfunct *basis; struct subdim **sub; }; /* space is the basic structure containing a model. The main ingredients are a (sort of double) representation of the basisfunctions: by means of basis on a basisfunction by basisfunction scale and by means of sub on a subdimension scale ndim - the dimensionality of the space nknots - the number of time-knots knots - the time-knots aic - the aic value of the present model - only accurate after the model has been fitted. info - the hessian of the model score - the score vector of the model b0 - first element constant term of lambda[between-2-knots,datapoint] others constant term basisfunction(j)[between-2-knots,datapoint] b1 - b1, but linear term b2 - first element, lambda in a datapoint others, basisfunction(j) in a datapoint basis - the array of basisfunctions sub - the matrix of subdimensions element: [i][data.ncov] (0<=i=0)constant(current,data,strt); swapgspace(trynew,current,(*data).ndata,(*data).ncov); /* we start in adding mode */ do{ /* fits the model */ (*current).aic=newton(current,data,0,silent,&oops); if(oops!=17){ /* compute aic */ logs[(*current).ndim-1]=(*current).aic; ad[(*current).ndim-1]=1; (*current).aic=(*current).ndim*alpha-2*(*current).aic; if((*current).ndim==ndmax)add=0; /* did we improve */ if((*current).aic<(*best).aic){ getse(current); swapgspace(best,current,(*data).ndata,(*data).ncov); } /* adds dimensions, computes new starting values */ if(add==1 && ndm2<0){ for(i=2;i<(*current).ndim-2;i++){ if(logs[(*current).ndim-1]-logs[i-1]<((*current).ndim-i)/2.-0.5){ add=0; ndmax=(*current).ndim; } } } if(add==1){ add=gadddim(current,new,trynew,data,mind,exclude,silent,lins); if(add!=1) ndmax=(*current).ndim; } } else{ Rprintf("Convergence problems.... stopping addition\n"); swapgspace(current,trynew,(*data).ndata,(*data).ncov); ndmax=(*current).ndim; add=0; } /* keep on adding? */ }while(add==1); /* the last addition space is the first best space */ (*current).aic=newton(current,data,1,silent,&oops); logs[(*current).ndim-1]=(*current).aic; (*current).aic=(*current).ndim*alpha-2*(*current).aic; /* start deleting */ do{ /* removes dimensions, computes new starting values */ if(ndmax>1)gremdim(current,(*data).ncov,(*data).ndata,silent); if((*best).ndim==(*current).ndim+1 && ad[(*best).ndim-1]==0){ for(i=0;i<(*best).ndim;i++){ (*best).basis[i].se=(*current).basis[i].se; } } (*current).aic=newton(current,data,1,silent,&oops); if(oops==1)(*current).aic=newton(current,data,2,silent,&oops); /* compute aic */ if((*current).aic>logs[(*current).ndim-1]){ logs[(*current).ndim-1]=(*current).aic; ad[(*current).ndim-1]=0; } (*current).aic=(*current).ndim*alpha-2*(*current).aic; /* did we improve */ if((*current).aic<(*best).aic){ swapgspace(best,current,(*data).ndata,(*data).ncov); } /* does further deleting make sense */ }while((*current).aic-(*best).aic0){ for(k=0;k<(*spout).sub[i][ncov].dim1+1;k++){ for(l=0;l<(*spout).sub[j][ncov].dim1+1;l++){ (*spout).sub[i][j].kts1[k][l]=(*spin).sub[i][j].kts1[k][l]; } } } } } /* the subdimensions part, the 1-covariate and time ones */ m=MAXKNOTS+1; if((*spin).ndim0){ for(k=0;k0.){ swapgspace(newt,current,(*data).ndata,(*data).ncov); swapgspace(current,new,(*data).ndata,(*data).ncov); i=(*current).ndim-1; if(silent!=1)uuu(current,(*current).basis[i].b1,(*current).basis[i].b2, (*current).basis[i].t1,(*current).basis[i].t2,(*data).ncov,0); if(silent!=1)(void)Rprintf("(rao= %.2f) ",criterion); return 1; } /* failure */ else{ return 0; } } /******************************************************************************/ /* this routine searches a subdimension for a supspace to add */ static double adders(int i0, int j0, struct space *current, struct space *new, struct space *newt, double criterion, struct datastruct *data, int mind, int *lins) /* i0,j0 - which subspace (see hstruct) current - sometimes we need two of them (see newt) new - will be the best space with additions up to now. newt - actually a copy of current, we play with it until we are done criterion - the best rao statistic (chi-square p-value) up to now data - structure containing the data mind - minimum distance (in order statistics) between knots */ { int i,j; double crit1=0.; /* swapspace- copies one space into another i,j - counter testbasis- does the work for 2d dimensions search - does the work for 1d dimensions crit1 - possibly optimal criterion */ /* a 1-d space */ if(j0==(*data).ncov){ if(i0==(*data).ncov){ /* search for a t-knot */ if((*newt).nknotscriterion && lins[i0]==0){ criterion=crit1; swapgspace(new,current,(*data).ndata,(*data).ncov); } } } } } } /* a 2-d space */ else{ /* covariate x time */ if(i0==(*data).ncov && (*newt).sub[j0][(*data).ncov].dim1>0){ for(i=0;i<(*newt).nknots;i++){ if((*newt).sub[i0][j0].kts1[i+1][0]>0){ for(j=0;j<(*newt).sub[j0][(*data).ncov].dim1-1;j++){ if((*newt).sub[i0][j0].kts1[i+1][j+1]==0){ /* knot x knot */ criterion=testbasis(new,newt,criterion,data,i0,j0,i,j, (double)0); } } } /* knot x linear */ else{ criterion=testbasis(new,newt,criterion,data,i0,j0,i,-1, (double)0); } } } if(i0!=(*data).ncov){ /* linear x linear */ if((*newt).sub[i0][j0].dim1==0){ if((*newt).sub[i0][(*data).ncov].dim1>0 && (*newt).sub[j0][(*data).ncov].dim1>0 ){ criterion= testbasis(new,newt,criterion,data,i0,j0,-1,-1,(double)0); } } else{ for(i=0;i<(*newt).sub[i0][(*data).ncov].dim1-1;i++){ if((*newt).sub[i0][j0].kts1[i+1][0]>0){ for(j=0;j<(*newt).sub[j0][(*data).ncov].dim1-1;j++){ if((*newt).sub[i0][j0].kts1[i+1][j+1]==0 && (*newt).sub[i0][j0].kts1[0][j+1]>0){ /* knot x knot */ criterion=testbasis(new,newt,criterion,data,i0,j0,i,j, (double)0); } } } else{ /* knot x linear */ criterion=testbasis(new,newt,criterion,data,i0,j0,i,-1, (double)0); } } for(j=0;j<(*newt).sub[j0][(*data).ncov].dim1-1;j++){ if((*newt).sub[i0][j0].kts1[0][j+1]==0){ /* linear x knot */ criterion=testbasis(new,newt,criterion,data,i0,j0,-1,j, (double)0); } } } } } return criterion; } /******************************************************************************/ /* if a new knot is to be added in a one-covariate dimension or in time, we have to search, and that is what we do in this routine */ static double search(struct space *new, struct space *newt, struct datastruct *data, int i0, int mind) /* new - the best added space up to now newt - a space to which we can add data - data i0 - first coordinate of the subdimension (second is data.ncov) mind - minimum distance (in order statistics) between knots */ { int lloc=0,uloc=0; int i,lgth,iloc=0,bloc,iloc2,ll,uu,nx; double *sorted,*sorted2,critnew,crit,crit2,*kts; /* sorted - sorted data or covariate sorted2 - uncensored data critnew - new criterion crit - best criterion up to now crit2 - alternate new criterion testbasis - compute criterion for a basis i - counter kts - already used knots lgth - number of already used knots iloc - present location under study lloc - lower bound to best location bloc - best location up to now uloc - upper bound to best location iloc2 - other location under study sort - sorting routine ll - candidate for lloc uu - candidate for uloc nx - (*data).ndata find.. - find location for new knot under various circumstances */ /* initialization */ ll=0; uu=0; lloc=0; uloc=0; bloc=-1; crit=-pow((double)10.,(double)20.); sorted=searchsorted; sorted2=searchsorted2; /* find lgth, create kts: already used knots */ if(i0==(*data).ncov){ lgth=(*newt).nknots; kts=searchkts; for(i=0;i0 && i==-2)i=0; /* before first knot */ if(i==0 && lgth>0) iloc=gindl(&ll,&uu,mind,sorted,nx,kts[0]); /* after last knot */ if(i==lgth&& lgth>0) iloc=gindr(&ll,&uu,mind,sorted,nx,kts[lgth-1]); /* first knot */ if(i==0 && lgth==0)iloc=gindx(&ll,&uu,nx,0); if(i==-1 && lgth==0)iloc=gindx(&ll,&uu,nx,1); if(i==-2 && lgth==0)iloc=gindx(&ll,&uu,nx,2); /* in between knots */ if(i>0 && i=0){ critnew=testbasis(new,newt,crit,data,i0,(*data).ncov,0,0,sorted[iloc]); /* improvement */ if(critnew>crit){ lloc=ll; uloc=uu; bloc=iloc; crit=critnew; } } } if(bloc<0)return -1; /* as long as the locations are different, do interval halving */ do{ if(sorted[uloc]>sorted[lloc]){ iloc2=gindyr(uloc,bloc,sorted); /* two search points, the upper one */ if(iloc2>=0){ crit2=testbasis(new,newt,crit,data,i0,(*data).ncov,0, 0,sorted[iloc2]); } else crit2=crit; /* two search points, the lower one */ iloc=gindyl(bloc,lloc,sorted); if(iloc>=0){ critnew=testbasis(new,newt,crit2,data,i0,(*data).ncov,0, 0,sorted[iloc]); } else critnew=crit; /* the middle one is the best, we call it quits */ if(crit>=critnew && crit>=crit2){ lloc=uloc; } else{ /* the lower search point is the best */ if(critnew>crit2){ uloc=bloc; bloc=iloc; crit=critnew; } else{ /* the upper search point is the best */ lloc=bloc; bloc=iloc2; crit=crit2; } } } }while(sorted[uloc]>sorted[lloc]); /* clean up and leave */ return crit; } /******************************************************************************/ /* after another routine has decided to check the rao-criterion for a model with an added basis, this routine first adds the basis (addbasis), then it checks the criterion (critswap) - there are lots of possibilities to check. */ static double testbasis(struct space *new, struct space *newt, double criterion, struct datastruct *data, int i0, int j0, int ki, int kj, double ti) /* new - best space with added dimensions newt - space to which dimensions are added data - data criterion - best rao statistic up to now i0,j0 - indicate which subdimension is going to be changed ki,kj - ranknumber of knots to be added ti - some sort of knot to be added */ { double arg[4]; int position; /* arg - arguments for fct1 and fct2 in addbasis critswap - computes rao and if there is improvement swaps the space addbasis - adds a basis function tswapout - removes a t-knot from a space tswapin - adds a t-knot to a space position - which position has the new t-knot */ /* most common occurences - preset for linear in covariates */ arg[0]=-1.; arg[1]=-1.; arg[2]=-1.; arg[3]=-1.; /* for 1-d subspaces this is */ /* if we are adding a t-knot everything is different */ if(j0==(*data).ncov && i0==(*data).ncov){ /* which is the knot */ (*newt).knots[(*newt).nknots]=ti; /* add the basisfunction */ arg[0]=ti; arg[2]=(*newt).nknots; addbasis(i0,j0,arg,data,&((*newt).basis[(*newt).ndim])); /* change the ordering of the space */ position=tswapin(newt,(*data).ncov); /* compute rao */ criterion=critswap(newt,data,new,criterion,i0,j0,0); /* change the ordering of the space back */ tswapout(newt,(*data).ncov,position); /* done */ return criterion; } /* 1 covariate subdimension */ if(j0==(*data).ncov && i0<(*data).ncov){ /* this is not the first (i.e. linear) space */ if((*newt).sub[i0][j0].dim1>0){ /* what is the knot to be added */ arg[0]=ti; arg[2]=(*newt).sub[i0][(*data).ncov].dim1-1; (*newt).sub[i0][(*data).ncov].ktsc[(*newt).sub[i0][(*data).ncov].dim1-1] =ti; } } /* a crossproduct subdimension */ if(j0<(*data).ncov){ /* if it is the first one, it is linear*time-knot[ki] */ if(ki>=0){ arg[2]=ki; if(i0<(*data).ncov) arg[0]=(*newt).sub[j0][(*data).ncov].ktsc[(int)arg[2]]; if(i0==(*data).ncov) arg[0]=(*newt).knots[(int)arg[2]]; } if(kj>=0){ arg[3]=kj; arg[1]=(*newt).sub[j0][(*data).ncov].ktsc[(int)arg[3]]; } (*newt).sub[i0][j0].kts1[ki+1][kj+1]=1; } addbasis(i0,j0,arg,data,&((*newt).basis[(*newt).ndim])); /* compute rao. possibly swap */ criterion=critswap(newt,data,new,criterion,i0,j0,1); if(j0<(*data).ncov)(*newt).sub[i0][j0].kts1[ki+1][kj+1]=0; /* done */ return criterion; } /******************************************************************************/ /* After a new time-knot is introduced, we need to reorganize the indices. That is, all other time knots that are larger than the new knot are shifted one position. The output argument position is the position of the new basis function */ static int tswapin(struct space *spc, int ncov) /* spc - the space that has to be reorganized ncov - number of covariates */ { int position,i,j,k; /* i,j - counter position - position of the new knot hsort - sort a double array */ /* if there is only 1 knot, don't bother */ if((*spc).nknots==0) return -1; /* if the knot is in the right position, don't bother either */ if((*spc).knots[(*spc).nknots]>(*spc).knots[(*spc).nknots-1]) return -1; /* first find the correct position */ position=0; for(i=0;i<(*spc).nknots;i++){ if((*spc).knots[(*spc).nknots]>(*spc).knots[i]) position=i+1; } /* the last basis function refers to the best position */ (*spc).basis[(*spc).ndim].iknots=position; (*spc).basis[(*spc).ndim].t1=position; /* check for all other basis functions whether the reference changes */ for(i=0;i<(*spc).ndim;i++){ if((*spc).basis[i].iknots>=position){ ((*spc).basis[i].iknots)++; if((*spc).basis[i].b1==ncov) (*spc).basis[i].t1=(*spc).basis[i].iknots; else (*spc).basis[i].t2=(*spc).basis[i].iknots; } } /* check up the subdimensions that are time * covariate */ for(i=0;iposition;k--){ (*spc).sub[ncov][i].kts1[k+1][j]=(*spc).sub[ncov][i].kts1[k][j]; } (*spc).sub[ncov][i].kts1[position+1][j]=0; } } /* finally, reorder the knots, just use sort */ hsort((*spc).knots,(*spc).nknots+1); return position; } /******************************************************************************/ /* removes the time knot on position from a space */ static void tswapout(struct space *spc, int ncov, int position) /* spc - the space to remove a time-knot from ncov - number of covariates position - position of the time knot to remove */ { int i,j,k; /* if the position is -1 there is nothing to worry about */ if(position== -1) return; /* check out the basisfunctions */ for(i=0;i<(*spc).ndim;i++){ if((*spc).basis[i].iknots>position){ ((*spc).basis[i].iknots)-=1; if((*spc).basis[i].b1==ncov) (*spc).basis[i].t1=(*spc).basis[i].iknots; else (*spc).basis[i].t2=(*spc).basis[i].iknots; } } /* check up the subdimensions that are time * covariate */ for(i=0;i0 the function is proportional to (x-t[0(or 1)])+.*/ static double fct1(double x, double *t, int i) /* t - see description above x - value in dimension 1 i - elements 0 and 2 of t (i=1) or 1 and 3 (i=2) */ { if(i==0){ if(t[2]<0)return (double) 1.; if(x>=t[0])return (double)0.; return t[0]-x; } if(i==1){ if(t[2]<0)return x; if(x<=t[0])return (double)0.; return x-t[0]; } else{ if(t[3]<0)return x; if(x<=t[1])return (double)0.; return x-t[1]; } } /******************************************************************************/ /* this function is used to compute the version component of a basis-function of two covariates. If t[2]<0/t[3]<0, the function is linear in x/y while if t[2]>0/t[3]>=0 the function is proportional to (x-t[1])+/(y-t[1])+. */ static double fct2(double x, double y, double *t) /* t - see description above x - value in dimension 1 y - value in dimension 2 */ { if(t[2]> -0.5){ x=x-t[0]; if(x<0.)return (double)0.; } if((int)t[3]> -0.5){ y=y-t[1]; if(y<0.)return (double)0.; } return x*y; } /******************************************************************************/ /* after the space newt has been updated with extra new basisfunctions, it computes the criterion. If this is an improvement it copies the basis into new, then it restores newt. */ static double critswap(struct space *newt, struct datastruct *data, struct space *new, double criterion, int i0, int j0, int ij) /* criterion - best rao p-value up to now data - the data i0,j0 - which subdimension is being altered ij - which of the dimension attributes are to be altered new - best model with additions newt - model tested whether it is better */ { double crit,r1; int i,j; /* crit - present value of criterion grao - computes rao-criterion swapspace - copies one space into another */ for(i=0;i<(*newt).ndim;i++){ (*newt).xtx[i][(*newt).ndim]=0.; for(j=0;j<(*data).ndata;j++){ (*newt).xtx[i][(*newt).ndim]+=(*newt).basis[i].values2[j]* (*newt).basis[(*newt).ndim].values2[j]; } (*newt).xtx[(*newt).ndim][i]=(*newt).xtx[i][(*newt).ndim]; } (*newt).xtx[(*newt).ndim][(*newt).ndim]=0.; for(j=0;j<(*data).ndata;j++){ (*newt).xtx[(*newt).ndim][(*newt).ndim]+= (*newt).basis[(*newt).ndim].values2[j]* (*newt).basis[(*newt).ndim].values2[j]; } r1=condition((*newt).xtx,(*newt).ndim+1); if(r1criterion){ swapgspace(new,newt,(*data).ndata,(*data).ncov); criterion=crit; } /* change back the dimensions */ ((*newt).ndim)-=1; if(ij==0)((*newt).nknots)-=1; else ((*newt).sub[i0][j0].dim1)-=1; return criterion; } /******************************************************************************/ /* this routine computes the extra elements of hessian and score then it computes rao - the routine is very much like the routine complog, which is part of Newton, except that it does not compute the log-likelihood and it makes use of the fact that part of b0, b1 and b2 might be known and completely at the end, it computes the rao statistic. */ static double grao(struct space *spc,struct datastruct *data) /* spc - the present model data - the data */ { double l0,raoc=0.,*scorecopy,r[3],rr[4],**hhh,*ss; int i,j,l,where,whereold=0,naaap,extra,again1,again2; /* extra - (*spc).ndim-1 l0 - lower integration bound raoc - rao-score statistic veint - computes integral (see newton for this routine) upbasis - updates basis for one point (see newton for this routine) i,j,l - counter r -integrals where - in which interval is the datapoint whereold- where was the previous case naaap - is this case similar to the previous one hhh - old, still useful, hessian integrals ss - old, still useful, score integrals again1 - how many follow up cases are exactly the same again2 - how many of these have delta=1 */ /* initializations */ extra=(*spc).ndim-1; (*spc).score[extra]=0.; for(j=0;j<(*spc).ndim;j++){ (*spc).info[extra][j]=0.; (*spc).info[j][extra]=0.; } /* allocation */ hhh=raohhh; ss=raoss; /* now circle the datapoints */ for(i=0;i<(*data).ndata;i++){ /* get the again things */ again1=1; again2=(*data).delta[i]; for(j=i+1;j<(*data).ndata;j++){ if((*data).same[j]==1 && (*data).times[i]==(*data).times[j]){ again1++; if((*data).delta[j]==1)again2++; } else{ j=(*data).ndata; } } if((*spc).basis[extra].iknots>-1){ l0=(*spc).knots[(*spc).basis[extra].iknots]; if((*data).times[i]>l0){ for(j=i+again1;j<(*data).ndata;j++){ if((*data).same[j]==1 && (*data).times[j]> l0)again1++; else j=(*data).ndata; } } } /* in which interval is the datapoint ? */ where=(*spc).nknots; for(j=0;j<(*spc).nknots;j++){ if((*spc).knots[j]>(*data).times[i]){ where=j; j=(*spc).nknots; } } naaap=0; if((*data).same[i]==1 && whereold==where) naaap=1; whereold=where; /* initialize basis */ if(naaap==0){ for(j=0;j<=(*spc).nknots;j++){ (*spc).b0[j][0]=0.; (*spc).b1[j][0]=0.; } } (*spc).b2[0]=0.; /* update spc.b2,spc.b0,spc.b1 per basisfunction */ for(j=0;j<(*spc).ndim;j++){ if(naaap==0){ upbasis((*spc).knots,(*spc).nknots,(*spc).b0,(*spc).b1,(*spc).b2,i, j+1,&((*spc).basis[j]),where,0); } else{ (*spc).b2[j+1]=(*spc).basis[j].values2[i]; (*spc).b2[0]+=(*spc).b2[j+1]*(*spc).basis[j].beta; } } /* add the delta terms to spc.score */ (*spc).score[extra]+=(*spc).b2[extra+1]*again2; /* the numerical integrals, all quite straight forward */ if(naaap==0){ ss[extra]=0.; for(l=0;l<(*spc).ndim;l++) hhh[extra][l]=0.; for(j=0;j0) for(l=0;l<(*spc).ndim;l++) raoc+=scorecopy[l]*(*spc).score[l]; else raoc=0.; return -raoc; } static void getse(struct space *spc) { int i,j; double **xx; xx=getsexx; for(i=0;i<(*spc).ndim;i++){ for(j=0;j<(*spc).ndim;j++)xx[i][j]=(*spc).info[i][j]; } gluinverse(xx,(*spc).ndim); for(i=0;i<(*spc).ndim;i++)(*spc).basis[i].se=sqrt(-xx[i][i]); } /******************************************************************************/ /* finds a new location in an interval (l,b) - that is the lower end might not have been tested yet */ static int gindyl(int u, int l, double *x) { int i; if(x[l]==x[u])return -1; i=(u+l-1)/2; if(x[i]!=x[u])return i; i=(i+l)/2; if(x[i]!=x[u])return i; return l; } /******************************************************************************/ /* finds a new location in an interval (b,u) - that is the upper end might not have been tested yet */ static int gindyr(int u, int l, double *x) { int i; if(x[l]==x[u])return -1; i=(u+l+1)/2; if(x[i]!=x[l])return i; i=(i+u)/2; if(x[i]!=x[l])return i; return u; } /******************************************************************************/ /* Finds a possible location for a knot on the interval (0,knot1) ll - lowest number we can search on in the future uu - highest number we can search on in the future mind minimum distance between knots x - data nx - length of data knt- knot */ static int gindl(int *ll, int *uu, int mind, double *x, int nx, double knt) { /* i - utility zlocation - finds uu */ int i; (*uu)=zlocation(0,x,nx,knt); if((*uu)k)return 0; if(x[nx-1]<=k)return nx-1; for(i=0;ik && x[i]<=k) return i; } } if(x[nx-1]=k)return 0; for(i=1;i=k && x[i-1]2048 || (ihalf >256 && precision==1)){ if(precision==1){ (*oops)=1; return 0.; } (*oops)=17; return 0.; } /* the actual halving */ ihalf=ihalf*2; for(j=0;j<(*spc).ndim;j++) (*spc).score[j]=(*spc).score[j]/2; } }while(lnewdata[i]){ where[i]=j; j=(*spc).nknots; } } } /* is this the same interval as the previous point (with the same covariates) */ naaap=0; if(same[i]==1 && whereold==where[i]) naaap=1; whereold=where[i]; /* initialize basis */ if(naaap==0){ for(j=0;j<=(*spc).nknots;j++){ (*spc).b0[j][0]=0.; (*spc).b1[j][0]=0.; } } (*spc).b2[0]=0.; /* update spc.b2, spc.b0 and spc.b1 per basisfunction */ for(j=0;j<(*spc).ndim;j++){ if(naaap==0){ upbasis((*spc).knots,(*spc).nknots,(*spc).b0,(*spc).b1,(*spc).b2,i, j+1,&((*spc).basis[j]),where[i],0); } else { (*spc).b2[j+1]=(*spc).basis[j].values2[i]; (*spc).b2[0]+=(*spc).b2[j+1]*(*spc).basis[j].beta; } } /* add the delta terms to spc.score and loglikelihood */ if(delta[i]==1){ logl+=(*spc).b2[0]; for(j=0;j<(*spc).ndim;j++) (*spc).score[j]+=(*spc).b2[j+1]; } /* the numerical integrals, all quite straight forward */ if(naaap==0){ lala=0.; for(k=0;k<(*spc).ndim;k++){ ss[k]=0.; for(l=0;l<=k;l++) hhh[k][l]=0.; } /* for all the intervals between knots */ for(j=0;j0){ for(j=0;j<(*spc).ndim;j++) (*spc).basis[j].beta-=(*spc).score[j]; } for(i=ik1;idata[i]){ where=j; j=(*spc).nknots; } } } else{ where=vwhere[i]; } /* can we use old stuff? */ naaap=0; if(same[i]==1 && ndata>0 && whereold==where) naaap=1; whereold=where; /* initialize */ if(naaap==0){ for(j=0;j<=(*spc).nknots;j++){ basis0[j]=0.; basis1[j]=0.; } } basis2=0.; /* update basis0, basis1 and basis2 */ for(j=0;j<(*spc).ndim;j++){ if(naaap==0){ upbasis2((*spc).knots,basis0,basis1,&basis2,i,&((*spc).basis[j]), where); } else{ basis2+=(*spc).basis[j].values2[i]*(*spc).basis[j].beta; } } /* the delta part */ if(delta[i]==1) logl+=basis2; /* the integrals */ if(naaap==0){ rall=0; /* per interval between knots */ for(j=0;j0){ for(j=0;j<(*spc).ndim;j++) (*spc).basis[j].beta+=(*spc).score[j]; } return logl; } /******************************************************************************/ /* comprable to upbasis, but does less, since only the loglikelihood will be computed */ static void upbasis2(double *knots, double *basis0, double *basis1, double *basis2, int idt, struct basisfunct *basf, int where) /* knots - time-knots basis2 - lambda in a datapoint basis0 - element constant term of lambda[between-2-knots,datapoint] basis1 - basis0, but linear term idt - number of datapoint on which we are working basf - one basisfunction where - in between which knots is the basisfunction */ { int j; double x; /* j - counter x - save typing (see below) */ x=(*basf).values[idt]*(*basf).beta; *basis2+=(*basf).values2[idt]*(*basf).beta; /* no t-knots, basisfunction is constant */ if((*basf).iknots== -1){ for(j=0;j<=where;j++) basis0[j]+=x; } /* 1 t-knot, basisfunction is 0 after knot, and has slope -1 before knot */ else{ for(j=0;j<=where&&j<=(*basf).iknots;j++){ basis0[j]+=knots[(*basf).iknots]*x; basis1[j]-=x; } } } /******************************************************************************/ /* u / | (b1*x+b2) |e dx | / l */ static double eint(double b1, double b2, double l, double u) /* just work it out */ { double c1,c2; if(b1!=0.){ c1=b1*u+b2; c2=b1*l+b2; /* take the numerically most stable exponents */ if(c1*c2<= 0.){ return (exp(c1)-exp(c2))/b1; } if(fabs(c1)>fabs(c2)){ return (exp(c1-c2)-1.)*exp(c2)/b1; } return (1.-exp(c2-c1))*exp(c1)/b1; } return (u-l)*exp(b2); } /******************************************************************************/ /* u / | 2 (b1*x+b2) |(a1*x +a2*x+a3)e dx | / l */ static void veint(double r[3], double b1, double b2, double l, double u) /* just work it out */ { double d21,d22,d12,d11,c1,c2,xx,e1,e2; if(b1!=0.){ xx=2./b1; d21=(u*(u-xx)+xx/b1); d22=(l*(l-xx)+xx/b1); d11=(u-1./b1); d12=(l-1./b1); c1=b1*u+b2; c2=b1*l+b2; /* take the numerically most stable exponents */ if(c1*c2<= 0.){ e1=exp(c1)/b1; e2=exp(c2)/b1; r[2]=(d21*e1-d22*e2); r[1]=(d11*e1-d12*e2); r[0]=(e1-e2); return; } if(fabs(c1)>fabs(c2)){ e1=exp(c1-c2); e2=exp(c2)/b1; r[2]=(d21*e1-d22)*e2; r[1]=(d11*e1-d12)*e2; r[0]=(e1-1.)*e2; return; } e1=exp(c2-c1); e2=exp(c1)/b1; r[2]=(d21-d22*e1)*e2; r[1]=(d11-d12*e1)*e2; r[0]=(1.-e1)*e2; return; } e1=exp(b2); r[0]=(u-l)*e1; r[1]=(u*u-l*l)*e1/2.; r[2]=(u*u*u-l*l*l)*e1/3.; } /******************************************************************************/ /* this routine searches all dimensions for something to remove */ static void gremdim(struct space *spc, int ncov, int ndata, int silent) /* spc - the model from which to remove something ncov - number of covariates ndata- number of observations silent- should diagnostic output be printed? */ { int i,j,k,n,bb1=0,bt1=0,nb1,nb2,nt1,nt2,bb2=0,is,bw=0; double criterion,wald=0.,*y,**xtx,*xty; /* i,j,k - counter n - can this basisfunction be removed? 1=yes, 0=no bb1/bt1/bb1/bw - the b1/t1/b2 components and ranknumber of a basisfunction of the basisfunction which is the candidate to be removed. nb1/nb2/nt1/nt2 - the b1/b2/t1/t2 components of the present basis function under examination criterion - best wald criterion up to now wald - criterion for the dimension now to be removed basisswap - cuts out a basisfunction; cleanupt/cleanup1 - removes basisfunctions and knots from spc y - fitted values before removal x - inner products of basisfunctions versus data xtx - x'x xty - x'y and after solving, the new starting values is - should we compute new starting values */ /* initializations, allocation of storage */ criterion=pow((double)10.,(double)100.); y=remdimy; is=1; for(i=0;i10000)is=0; if(is==1){ for(i=0;i= 0 && (*spc).basis[j].t2==nt2) n=0; if(nt1>= 0 && nt2==-1 && (*spc).basis[j].t1==nt1) n=0; } } if(n==0) j=(*spc).ndim; } /* if we can still remove, compute wald */ if(n>0){ wald=-(*spc).basis[i].beta*(*spc).basis[i].beta/(*spc).info[i][i]; /* record if we improve */ if(wald0){ /* first in the basisfunctions */ for(j=0;j<(*spc).ndim;j++){ if((*spc).basis[j].b1==ncov && (*spc).basis[j].t1>ki){ (*spc).basis[j].t1-=1; (*spc).basis[j].iknots-=1; } } /* in the knots themselves */ for(j=ki;j<(*spc).nknots;j++) (*spc).knots[j]=(*spc).knots[j+1]; } } /******************************************************************************/ /* this routine removes a covariate knot from the space */ static void cleanup1(int i0, int ki, struct space *spc, int ncov) /* spc - space to be reduced i0 - which covariate ki - ranknumber of knot ncov - number of covariates */ { int j; /* j - counters */ /* change the number of knots */ (*spc).sub[i0][ncov].dim1-=1; /* change all the other pointers */ if((*spc).sub[i0][ncov].dim1>0){ /* first in the basisfunctions */ for(j=0;j<(*spc).ndim;j++){ if((*spc).basis[j].b1==i0&&(*spc).basis[j].t1>ki)(*spc).basis[j].t1-=1; if((*spc).basis[j].b2==i0&&(*spc).basis[j].t2>ki)(*spc).basis[j].t2-=1; } /* in the knots themselves */ for(j=ki;j>(-1)&&j<(*spc).sub[i0][ncov].dim1;j++){ (*spc).sub[i0][ncov].ktsc[j]=(*spc).sub[i0][ncov].ktsc[j+1]; } } } /******************************************************************************/ /* copy one basisfunction into another */ static void basisswap(struct basisfunct *bs1, struct basisfunct *bs2, int ndata) /* bs1 - basisfunction out bs2 - basisfunction in ndata - number of datapoints */ { int i; /* i - counter */ /* routine should be obvious */ (*bs1).b1=(*bs2).b1; (*bs1).b2=(*bs2).b2; (*bs1).t1=(*bs2).t1; (*bs1).t2=(*bs2).t2; (*bs1).beta=(*bs2).beta; (*bs1).iknots=(*bs2).iknots; for(i=0;i0){ (*best).ndim=*fitter; (*best).nknots=cckk[0]; for(i=0;i<(*best).nknots;i++) (*best).knots[i]=cckk[(i+1)*(*ncov+1)]; for(i=0;i<(*ncov);i++){ (*best).sub[i][*ncov].dim1=cckk[i+1]+1; for(k=0;k<(*best).sub[i][*ncov].dim1-1;k++){ (*best).sub[i][*ncov].ktsc[k]=cckk[(k+1)*(*ncov+1)+1+i]; } } for(i=0;i<(*best).ndim;i++){ j=bbtt[i*6+0]; k=bbtt[i*6+2]; (*best).basis[i].t1=bbtt[i*6+1]; (*best).basis[i].t2=bbtt[i*6+3]; (*best).basis[i].beta=bbtt[i*6+4]; if(j==0) (*best).basis[i].b1=(*ncov); else (*best).basis[i].b1=j-1; if(k<=0) (*best).basis[i].b2=(*ncov); else(*best).basis[i].b2=k-1; if((*best).basis[i].t1> -1)((*best).basis[i].t1)-=1; if((*best).basis[i].t2> -1)((*best).basis[i].t2)-=1; if((*best).basis[i].b1==(*ncov)){ (*best).basis[i].iknots=(*best).basis[i].t1; } else{ ((*best).basis[i].iknots)=-1; } if((*best).basis[i].b2!=(*ncov)){ j=(*best).basis[i].b1; k=(*best).basis[i].b2; k2=(*best).basis[i].t1; k3=(*best).basis[i].t1; (*best).sub[j][k].kts1[k2+1][k3+1]=1; } } for(i=0;i<(*ncov);i++){ if((*best).sub[i][*ncov].dim1==1){ for(j=0;j<(*best).ndim;j++){ if((*best).basis[j].b1==i) j=((*best).ndim)+100; } if(*strt==0){ if(j<((*best).ndim)+50)(*best).sub[i][*ncov].dim1=0; } else{ if(j<((*best).ndim)+50){ (*best).basis[(*best).ndim].b1=i; (*best).basis[(*best).ndim].b2=(*ncov); (*best).basis[(*best).ndim].t1=-1; (*best).basis[(*best).ndim].t2=-1; (*best).basis[(*best).ndim].iknots=-1; (*best).basis[(*best).ndim].beta=0.; ((*best).ndim)+=1; } } } } getvector(best,(*data).ndata,(*ncov),(*data).cov,(*data).times); *strt = -1; } /* do the work */ hare(best,data,*penalty,*ndmax,*mindis,exclude,*strt,*silent,logs,ad,lins); /* admire the results */ soutgspace(best,data,bbtt,cckk); *ndata=(*best).ndim; } /******************************************************************************/ /* this is an output routine, it writes the matrices bbtt and cckk - which are given as output to S */ static void soutgspace(struct space *spc, struct datastruct *data, double *bbtt, double *cckk) /* spc - structure describing the model data - data bbtt - matrix describing the basisfunctions cckk - matrix describing the 1d subspaces */ { int i,j,k,l; l=MAXKNOTS+1; /* cckk */ /* second line - 0, number of time knots, time knots */ cckk[0]=(*spc).nknots; for(k=0;k<(*spc).nknots;k++) cckk[k+1]=(*spc).knots[k]; for(k=(*spc).nknots+1;k<=MAXKNOTS;k++)cckk[k]=0.; /* lines 3-ncov+2- covariate number, dimension of space (#kts+1), kts */ for(j=0;j<(*data).ncov;j++){ cckk[(j+1)*l]=(*spc).sub[j][(*data).ncov].dim1-1; for(i=0;i<(*spc).sub[j][(*data).ncov].dim1-1;i++){ cckk[(j+1)*l+i+1]=(*spc).sub[j][(*data).ncov].ktsc[i]; } for(k=(*spc).sub[j][(*data).ncov].dim1;k<=MAXKNOTS;k++)cckk[(j+1)*l+k]=0.; } /* rest: basisfunctions (bbtt) */ for(j=0;j<(*spc).ndim;j++){ if((*spc).basis[j].b1>=0){ (*spc).basis[j].b1+=1; if((*spc).basis[j].b1>(*data).ncov) (*spc).basis[j].b1=0; } if((*spc).basis[j].b2>=0){ (*spc).basis[j].b2+=1; if((*spc).basis[j].b2>(*data).ncov) (*spc).basis[j].b2= -1; } (*spc).basis[j].t1+=1; (*spc).basis[j].t2+=1; /* which variable, which knot, which variable#2, which knot #2, beta variable=0: time, knot=0: constant, otherwise: knot number variable>0: covariate, knot=0: linear, otherwise: knot number variable#2 = -1: 1d basisfunction */ bbtt[j*6+0]=(*spc).basis[j].b1; bbtt[j*6+1]=(*spc).basis[j].t1; bbtt[j*6+2]=(*spc).basis[j].b2; bbtt[j*6+3]=(*spc).basis[j].t2; bbtt[j*6+4]=(*spc).basis[j].beta; bbtt[j*6+5]=(*spc).basis[j].se; } } /******************************************************************************/ static void getvector(struct space *best, int ndata, int ncov, double **cov, double *data) /* best - the model ndata - number of datapoints ncov - number of covariates cov - covariates */ { int i,j,k,b1,b2,t1,t2; double xx,*vv,*ww; /* i,j - counter b1,b2,t1,t2 - b1,b2,t1,t2 for the present basisfunction vv,ww - save typing xx - the second half */ /* circle the basisfunctions */ for(i=0;i<(*best).ndim;i++){ /* allocate storage */ vv=dgvector(ndata); ww=dgvector(ndata); /* if it is time only it is easy */ for(j=0;j -1){ vv[j]-=(*best).sub[b1][ncov].ktsc[t1]; if(vv[j]<0.) vv[j]=0.; } } /* and then the second component of the basisfunction */ b2=(*best).basis[i].b2; t2=(*best).basis[i].t2; if(b2!=ncov && b2!=-1){ xx=cov[b2][j]; /* -1 means linear, otherwise it is piecewise linear */ if(t2> -1){ xx-=(*best).sub[b2][ncov].ktsc[t2]; if(xx<0.) xx=0.; } vv[j]=vv[j]*xx; } /* now values 2 */ ww[j]=vv[j]; t1=(*best).basis[i].t1; if(b1==ncov && t1>=0){ xx= -data[j]; xx+=(*best).knots[t1]; if(xx<0.) xx=0.; ww[j]=ww[j]*xx; } } (*best).basis[i].values=vv; (*best).basis[i].values2=ww; } for(i=0;i<(*best).ndim;i++){ for(j=i;j<(*best).ndim;j++){ (*best).xtx[i][j]=0.; for(k=0;k 0.)i2=1; if(aa< pow(10.,500.))i3=1; if(aa> -pow(10.,500.))i4=1; if(i1+i2+i3+i4>=3)return 3; if(i2==1 && i4==1)return 1; if(i1==1 && i3==1)return 0; return 2; } /******************************************************************************/ static void glusolve(double **a,int n,double *b) { double aa[DIM5][DIM5],bb[DIM5]; int kpvt[DIM5],info; int i,j; for(i=0;i> 1)+1; ir=n; for (;;) { if (l > 1) rra=ra[--l]; else { rra=ra[ir]; ra[ir]=ra[1]; if (--ir == 1) { ra[1]=rra; return; } } i=l; j=l << 1; while (j <= ir) { if (j < ir && ra[j] < ra[j+1]) ++j; if (rra < ra[j]) { ra[i]=ra[j]; j += (i=j); } else j=ir+1; } ra[i]=rra; } } /******************************************************************************/ static double condition(double **a,int n) { double aa[DIM5][DIM5],bb[DIM5],rcond; int kpvt[DIM5]; int i,j; for(i=0;i1){ for(i=0;id3[i]) d3[i]=(d1[k]-d1[i])/(k1[k]-k1[i]); } d4[i+1]=(d1[0]-d1[i+1])/(k1[0]-k1[i+1]); for(k=1;k<=i;k++){ if((d1[k]-d1[i+1])/(k1[k]-k1[i+1])0)(void)Rprintf(" %7.2f",2*d3[i]); if(i==0)(void)Rprintf(" Inf"); if(d3[i]<0 && i!=0 && i!=j-1)(void)Rprintf(" NA"); if(i==j-1)(void)Rprintf(" 0.00"); if(d4[i]>0)(void)Rprintf(" %7.2f",2*d4[i]); if(d4[i]<0 && i!=j-1 && i!=0)(void)Rprintf(" NA"); (void)Rprintf("\n"); } (void)Rprintf("\nthe present optimal number of dimensions is %d.\n",k1[k]); if((int)exp(*penalty) == *sample){ (void)Rprintf("penalty(AIC) was the default: BIC=log(samplesize): log("); (void)Rprintf("%d)=%.2f\n",*sample,*penalty); } else{ (void)Rprintf("penalty(AIC) was %.2f",*penalty); (void)Rprintf(", the default (BIC), would have been %.2f.\n", log((double)*sample)); } if(k1[0]>1){ (void)Rprintf("models with fewer than %d dims ",k1[0]); (void)Rprintf("can be fitted, but they are not optimal for the\n"); (void)Rprintf("present choice of penalty - choose penalty in "); (void)Rprintf("hare.fit larger to see these fits.\n"); } (void)Rprintf("\n"); (void)Rprintf(" dim1 dim2 beta SE Wald\n"); for(i=0;i<(*ndim);i++){ if(i==0) (void)Rprintf("Constant "); else{ if((int)fcts[i*6]==0)(void)Rprintf("Time"); else (void)Rprintf("Co-%d",(int)fcts[i*6]); if((int)fcts[i*6+1]==0)(void)Rprintf(" linear "); else (void)Rprintf(" %9.2g",spcs[(int)(fcts[i*6]+fcts[i*6+1]*(1+(*ncov)))]); } if((int)fcts[i*6+2]<=0)(void)Rprintf(" "); else{ (void)Rprintf(" Co-%d",(int)fcts[i*6+2]); if((int)fcts[i*6+3]==0)(void)Rprintf(" linear "); else (void)Rprintf(" %9.2g",spcs[(int)(fcts[i*6+2]+fcts[i*6+3]*(1+(*ncov)))]); } d1[0]=(fcts[i*6+4]/fcts[i*6+5]); (void)Rprintf(" %10.2g %10.2g %7.2f\n",fcts[i*6+4],fcts[i*6+5],d1[0]); } } /******************************************************************************/ /* this routine contains phare/dhare/qhare/share = S routine */ /******************************************************************************/ /* the C-I/O routine */ void sphare(int *ncov, int *ndim, int *ndata, double *xcov, int *ip, double *pdh, double *cckk, double *bbtt) /* ncov - number of covariates ndim - dimensionality of the space ndata - number of datapoints xcov - covariates ip - do we want quantiles (ip=1) or probabilities (ip=0) or hazards (ip=2) or densities (ip=3) pdh - probabilities/density/hazard/quantiles cckk - the info about the 1d subspaces bbtt - the info about the basisfunctions */ { int i,j,k; struct space *best; double **cov,*qqq; /* i,j,k - counters best - the final fitted model hdefinegspace - allocates storage for a space houtgspace - gets the output (ip=0/2/3) poutgspace - gets the output (ip=1) getvectors - defines the vector part of the basisfunctions cov - covariates qqq - quantiles */ /* allocate space for the model */ qqq=dgvector(*ndata); if(ncov==0) best=hdefinegspace(2,*ndata); else best=hdefinegspace(*ncov,*ndata); /* essentially we need two copies */ for(i=0;i<(*ndata);i++) qqq[i]=pdh[i]; /* read in the model - spaces */ (*best).ndim=*ndim; (*best).nknots=cckk[0]; for(i=0;i<(*best).nknots;i++) (*best).knots[i]=cckk[(i+1)*(*ncov+1)]; for(i=0;i<(*ncov);i++){ (*best).sub[i][*ncov].dim1=cckk[i+1]+1; for(k=0;k<(*best).sub[i][*ncov].dim1-1;k++){ (*best).sub[i][*ncov].ktsc[k]=cckk[(k+1)*(*ncov+1)+1+i]; } } /* read in the model - basis functions */ for(i=0;i<(*ndim);i++){ j=bbtt[i*6+0]; k=bbtt[i*6+2]; (*best).basis[i].t1=bbtt[i*6+1]; (*best).basis[i].t2=bbtt[i*6+3]; (*best).basis[i].beta=bbtt[i*6+4]; /* adjust certain indices time becomes n (was 0) and covariates 0 to (n-1) (was 1 to n) */ if(j==0) (*best).basis[i].b1=(*ncov); else (*best).basis[i].b1=j-1; if(k<=0) (*best).basis[i].b2=(*ncov); else(*best).basis[i].b2=k-1; /* adjust the knots by one too */ ((*best).basis[i].t1)-=1; ((*best).basis[i].t2)-=1; if((*best).basis[i].b1==(*ncov)){ (*best).basis[i].iknots=(*best).basis[i].t1; } else{ ((*best).basis[i].iknots)=-1; } } /* put the covariates in a matrix */ cov=dgmatrix((*ncov)+1,*ndata); for(i=0;i<(*ncov);i++){ for(j=0;j<(*ndata);j++) cov[i][j]=xcov[i*((*ndata))+j]; } /* get vectors component of basisfunctions */ getvectors(best,*ndata,*ncov,cov); /* get probabilities/densities/hazard from quantiles case */ if((*ip)!=1){ houtgspace(best,pdh,qqq,*ndata,*ip); } /* get quantiles from probabilities case */ else{ poutgspace(best,pdh,qqq,*ndata); for(i=0;i<(*ndata);i++)pdh[i]=qqq[i]; } } /******************************************************************************/ /* this routine is used in the qhare case */ static void poutgspace(struct space *spc, double *ppp, double *qqq, int ndata) /* spc - the model fitted ppp - the probabilities (in) qqq - the quantiles (out) ndata - number of datapoints */ { int i,j,k; double *lin,*con; /* i,j,k,l - counters lin - linear term[i] is between knots (i-1) and (i) con - constant term[i] is between knots (i-1) and (i) getthosep - gets those q from those p */ /* allocation */ lin=dgvector((*spc).nknots+1); con=dgvector((*spc).nknots+1); /* gets the linear and constant term relevant to the next set of covariates */ for(i=0;idata){ where=j; j=(*spc).nknots; } } /* update basis0, basis1 and basis2 */ for(j=0;j<(*spc).ndim;j++) upbasis3((*spc).knots,basis0,basis1,&basis2,idt, &((*spc).basis[j]),where,data); /* the delta part */ logl+=basis2; /* the integrals */ for(j=0;j<=where;j++){ /* lower bound */ if(j==0) l0=0.; else l0=(*spc).knots[j-1]; /* upper bound */ if(j==where) l1=data; else l1=(*spc).knots[j]; /* integrals */ logl-=eint(basis1[j],basis0[j],l0,l1); } /* clean up */ return exp(logl); } /******************************************************************************/ /* comprable to upbasis, but does less, since only the loglikelihood will be computed */ static void upbasis3(double *knots, double *basis0, double *basis1, double *basis2, int idt, struct basisfunct *basf, int where, double time) /* knots - time-knots basis0 - element constant term of lambda[between-2-knots,datapoint] basis1 - basis0, but linear term basis2 - lambda in a datapoint idt - number of datapoint on which we are working basf - one basisfunction where - in between which knots is the basisfunction time - datapoint */ { int j; double x; /* j - counter x - save typing (see below) */ x=(*basf).values[idt]*(*basf).beta; /* no t-knots, basisfunction is constant */ if((*basf).iknots== -1){ *basis2+=x; for(j=0;j<=where;j++) basis0[j]+=x; } /* 1 t-knot, basisfunction is 0 after knot, and has slope -1 before knot */ else{ if(time <= knots[(*basf).iknots]){ *basis2+=x*(knots[(*basf).iknots]-time); } for(j=0;j<=where&&j<=(*basf).iknots;j++){ basis0[j]+=knots[(*basf).iknots]*x; basis1[j]-=x; } } } /******************************************************************************/ /* this function computes the vector part of a basisfunction */ static void getvectors(struct space *best,int ndata,int ncov,double **cov) /* best - the model ndata - number of datapoints ncov - number of covariates cov - covariates */ { int i,j,b1,b2,t1,t2; double xx,*vv; /* i,j - counter b1,b2,t1,t2 - b1,b2,t1,t2 for the present basisfunction vv - save typing xx - the second half */ /* circle the basisfunctions */ for(i=0;i<(*best).ndim;i++){ /* allocate storage */ /* if it is time only it is easy */ vv=dgvector(ndata+5); for(j=0;j -1){ vv[j]-=(*best).sub[b1][ncov].ktsc[t1]; if(vv[j]<0.) vv[j]=0.; } } /* and then the second component of the basisfunction */ b2=(*best).basis[i].b2; t2=(*best).basis[i].t2; if(b2!=ncov && b2!=-1){ xx=cov[b2][j]; /* -1 means linear, otherwise it is piecewise linear */ if(t2> -1){ xx-=(*best).sub[b2][ncov].ktsc[t2]; if(xx<0.) xx=0.; } vv[j]=vv[j]*xx; } } (*best).basis[i].values=vv; } } /******************************************************************************/ /* t / | (b1*x+b2) solves for t c= |e dx | / l */ static double xeint(double b1,double b2,double l,double c) /* just work it out */ { if(b1!=0.){ c=log(c*b1/exp(b2)+exp(b1*l))/b1; return c; } return l+c/exp(b2); } /******************************************************************************/ /* this function allocates storage for a space */ static struct space *hdefinegspace(int ncov,int ndata) /* ncov - number of covariates */ { struct space *newspace; int i,j; /* this routine is mainly a copy from the numerical recipes routines i,j,k - counters newspace - thing to be initialized definebasis - initializes an array of basisfunctions definedim - initializes a matrix of subdimensions */ /* basic allocation */ newspace=(struct space *)Salloc(1,struct space); /* if(!newspace) { nrerror("allocation error in definegspace"); } */ /* the simple elements */ (*newspace).knots=dgvector(MAXKNOTS); (*newspace).info=dgmatrix(MAXSPACE,MAXSPACE); (*newspace).score=dgvector(MAXSPACE); (*newspace).b0=dgmatrix(MAXKNOTS+1,MAXSPACE+1); (*newspace).b1=dgmatrix(MAXKNOTS+1,MAXSPACE+1); (*newspace).b2=dgvector(MAXSPACE+1); /* defines the basisfunctions, initializes */ (*newspace).basis=hdefinebasis(); for(i=0;i2) y<- cbind(c(x[,1]),c(x[,2]),c(x[,3])) if(dd2>3)for(i in 4:dd2) y <- cbind(y,c(x[,i])) y } if(length(dd)==1 || length(dd)==0){ y <- c(unlist(c(unlist(x)))) names(y) <- NULL } y } hare <- function(data, delta, cov, penalty, maxdim, exclude, include, prophaz = FALSE, additive = FALSE, linear, fit, silent = TRUE) { # get the parameters from the C-program call <- match.call() if(!missing(data)) data <- unstrip(data) if(!missing(delta)) delta <- unstrip(delta) if(!missing(cov)) cov <- unstrip(cov) if(!missing(exclude)) exclude <- unstrip(exclude) if(!missing(include)) include <- unstrip(include) MAXKNOTS <- -3 MAXSPACE <- -3 z <- .C("sharex", mk = as.integer(MAXKNOTS), ms = as.integer(MAXSPACE), PACKAGE = "polspline") MAXKNOTS <- z$mk MAXSPACE <- z$ms # # a few elementary data checks if(missing(data)) stop("there has to be data") if(length(data) < 25) stop("not enough data") if(min(data) < 0) stop("negative data") if(missing(delta)) delta <- data - data + 1 if(length(data) != length(delta)) stop("data and delta have different length") dd <- abs(delta - 0.5) if(min(dd) < 0.5 || max(dd) > 0.5) stop("delta not all 0 or 1") ndata <- length(data) # # dealing with the covariates, sorting the cases # first if there are no covariates if(missing(cov)) { ncov <- 0 cov <- 0 iia <- order(data) delta <- delta[iia] data <- data[iia] } else { if(length(cov) == ndata) cov <- matrix(cov, ncol = 1, nrow = ndata) if(length(cov[, 1]) != ndata) stop("covariates not ndata * ncov matrix") ncov <- length(cov[1, ]) cov <- cbind(cov, 1) y <- cbind(data, cov) keys <- 1:ndata for(i in (ncov + 2):1) keys <- keys[sort.list(y[keys, i])] data <- data[keys] delta <- delta[keys] cov <- cov[keys, 1:ncov] } if(additive) { if(!missing(exclude)) stop("cannot have exclude and additive") if(!missing(include)) stop("cannot have include and additive") prophaz <- FALSE include <- c(0, 0) } if(missing(exclude) + missing(include) == 0) stop("only 1 from exclude and include allowed") vexclude <- 0 # # using exclude if(missing(exclude) == FALSE) { if(length(exclude) == 2) exclude <- matrix(exclude, ncol = 2, nrow = 1) if(length(exclude[1, ]) != 2) stop("exclude has wrong shape") if(min(exclude) < 0 || max(exclude) > ncov) stop("exclude has wrong values") vexclude <- as.vector(t(exclude)) vexclude <- c(length(vexclude)/2, vexclude) # # proportional hazards model if(prophaz && ncov > 0) { vexclude <- c(vexclude, as.vector(rbind(1:ncov, 0))) vexclude[1] <- vexclude[1] + ncov } } # # using include if(missing(include) == FALSE || additive) { if(length(include) == 2) include <- matrix(include, ncol = 2, nrow = 1) if(length(include[1, ]) != 2) stop("include has wrong shape") if(min(include) < 0 || max(include) > ncov) stop("include has wrong values") include <- t(apply(include, 1, sort)) if(length(include) == 2) include <- matrix(include, ncol = 2, nrow = 1) if(prophaz) include <- include[include[, 1] > 0, ] vexclude <- as.vector(t(include)) vexclude <- c( - length(vexclude)/2, vexclude) } # # using proprtional hazards if(missing(include) && missing(exclude) && prophaz && ncov > 0) vexclude <- c(ncov, as.vector(rbind(1:ncov, 0))) # set parameters mindist <- 5 if(missing(penalty)) penalty <- log(ndata) if(missing(maxdim)) { maxdim <- floor(6 * (ndata)^0.2) if(maxdim > MAXSPACE - 1) maxdim <- MAXSPACE - 1 maxdim <- - maxdim } if(maxdim > MAXSPACE - 1) { maxdim <- MAXSPACE - 1 print(paste("maximum dimension reduced to", maxdim)) } lins <- rep(0, MAXSPACE) if(!missing(linear)) { linear[linear <= 0] <- ncov + 1 linear[linear > ncov + 1] <- ncov + 1 lins[linear] <- 1 } if(additive) vexclude <- c(-1, 0, 0) # do it fitter <- 0 bbtt <- matrix(0, ncol = 6, nrow = abs(maxdim)) cckk <- matrix(0, ncol = (MAXKNOTS + 1), nrow = (ncov + 1)) if(!missing(fit)) { if(!inherits(fit, "hare")) stop("fit is not a hare object") fitter <- fit$ndim if(fit$ncov != ncov) stop("ncov and fit's ncov are different") bbtt[1:fit$ndim, ] <- fit$fcts bbtt <- as.vector(t(bbtt)) bbtt[is.na(bbtt)] <- -1 a1 <- length(fit$knots[1, ]) cckk[, 1:a1] <- fit$knots cckk <- as.vector(cckk) cckk[is.na(cckk)] <- -1 } z <- .C("share", as.integer(ncov), ndim = as.integer(ndata), as.double(data), as.integer(delta), as.double(cov), as.double(penalty), as.integer(mindist), as.integer(maxdim), bbtt = as.double(bbtt), cckk = as.double(cckk), as.integer(vexclude), as.integer(lins), as.integer(silent), logl = as.double(rep(0, MAXSPACE)), as.integer(fitter), ad = as.integer(rep(0, MAXSPACE)), as.integer(0), # PACKAGE = "polspline") # organize bbtt and cckk maxdim <- abs(maxdim) z$bbtt <- matrix(z$bbtt, nrow = maxdim, ncol = 6, byrow = TRUE)[1:z$ndim, ] z$cckk <- matrix(z$cckk, nrow = ncov + 1, ncol = MAXKNOTS + 1, byrow = TRUE) z$cckk <- z$cckk[, 1:(1 + max(z$cckk[, 1]))] z$cckk <- matrix(z$cckk, nrow = ncov + 1) l1 <- max(z$cckk[, 1]) for(i in 1:(ncov + 1)) if(z$cckk[i, 1] != l1) z$cckk[i, (z$cckk[i, 1] + 2):(l1 + 1)] <- NA if(l1 > 0 && ncov > 0) dimnames(z$cckk) <- list(c("T", 1:ncov), c("K", 1:l1)) if(l1 > 0 && ncov == 0) dimnames(z$cckk) <- list(c("T"), c("K", 1:l1)) if(l1 == 0 && ncov > 0) dimnames(z$cckk) <- list(c("T", 1:ncov), "K") if(l1 == 0 && ncov == 0) dimnames(z$cckk) <- list(c("T"), "K") l1 <- max((1:MAXSPACE)[z$logl > -1e+100]) z$bbtt <- matrix(z$bbtt, ncol = 6) dimnames(z$bbtt) <- list(1:(z$ndim), c("dim1", "knot1", "dim2", "knot2", "beta", "SE")) z$bbtt[z$bbtt[, 3] == -1, 3:4] <- NA if(is.na(l1)) { z$logl <- z$logl[1] z$ad <- z$ad[1] } else { z$logl <- z$logl[1:l1] z$ad <- z$ad[1:l1] } z$ad[z$logl < -1e+100] <- NA z$logl[z$logl < -1e+100] <- NA z$logl <- cbind(z$logl, z$ad) dimnames(z$logl) <- list(NULL, c("log-lik", "A/D")) ranges <- NA if(ncov == 1) ranges <- matrix(range(cov), ncol = 1, nrow = 2) if(ncov > 1) ranges <- apply(cov, 2, range) # done fit <- list(call = call, ncov = ncov, ndim = z$ndim, fcts = z$bbtt, knots = z$cckk, penalty = penalty, max = max(data), ranges = ranges, logl = z$logl, sample = ndata) class(fit) <- "hare" fit } plot.hare <- function(x, cov, n = 100, which = 0, what = "d", time, add = FALSE, xlim, xlab, ylab, type, ...) { if(!inherits(x, "hare")) stop("x is not a hare object") if(!missing(cov))cov <- unstrip(cov) if(!missing(time))time <- unstrip(time) fit <- x nocov <- 0 if(fit$ncov == 0) nocov <- 1 else { if(length(cov) != fit$ncov) stop("covariates are wrong") } if(which == 0) { if(missing(xlim)) { if(nocov == 0) { u1 <- qhare(0.01, cov, fit) u2 <- qhare(0.99, cov, fit) } else { u1 <- qhare(0.01, fit = fit) u2 <- qhare(0.99, fit = fit) } u3 <- 1.1 * u1 - 0.1 * u2 u2 <- min(u2, fit$max) u4 <- 1.1 * u2 - 0.1 * u1 if(u3 < 0) u3 <- 0 else if(u4/u3 > 5) u3 <- 0 } else { u3 <- xlim[1] u4 <- xlim[2] } xx <- (0:(n - 1))/(n - 1) * (u4 - u3) + u3 if(fit$ncov > 0) yy <- cov } else { if(which < 0 || which > fit$ncov) stop("which is wrong") if(missing(time)) stop("time is missing") if(missing(xlim)) { u3 <- fit$ranges[1, which] u4 <- fit$ranges[2, which] } else { u3 <- xlim[1] u4 <- xlim[2] } xx <- (0:(n - 1))/(n - 1) * (u4 - u3) + u3 yy <- matrix(cov, ncol = fit$ncov, nrow = n, byrow = TRUE) yy[, which] <- xx xx <- time } iwhat <- 0 if(what == "d" || what == "D") iwhat <- 3 if(what == "h" || what == "H") iwhat <- 2 if(nocov == 0) yy <- xhare(iwhat, xx, yy, fit) else yy <- xhare(iwhat, xx, arg4 = fit) if(what == "s" || what == "S") yy <- 1 - yy if(missing(xlab)) xlab <- "" if(missing(ylab)) ylab <- "" if(missing(type)) type <- "l" xx <- (0:(n - 1))/(n - 1) * (u4 - u3) + u3 if(!add) plot(xx, yy, xlab = xlab, ylab = ylab, type = type, ...) else lines(xx, yy, type = type, ...) } print.hare <- function(x,...) { summary.hare(x) } summary.hare <- function(object,...) { if(!inherits(object, "hare")) stop("object is not a hare object") fit <- object s3 <- as.vector(t(fit$logl)) s3[is.na(s3)] <- 0 s1 <- as.vector(t(fit$fcts)) s2 <- as.vector(fit$knots) s1[is.na(s1)] <- -1 s2[is.na(s2)] <- -1 .C("ssumm", as.double(fit$penalty), as.integer(fit$sample), as.double(s3), as.integer(length(s3)/2), as.double(s2), as.double(s1), as.integer(fit$ndim), as.integer(fit$ncov), PACKAGE = "polspline") invisible() } dhare <- function(q,cov,fit) { if(!inherits(fit, "hare")) stop("fit is not a hare object") xhare(3, q,cov,fit) } hhare <- function(q,cov,fit) { if(!inherits(fit, "hare")) stop("fit is not a hare object") xhare(2, q,cov,fit) } phare <- function(q,cov,fit) { if(!inherits(fit, "hare")) stop("fit is not a hare object") xhare(0, q,cov,fit) } qhare <- function(p,cov,fit) { if(!inherits(fit, "hare")) stop("fit is not a hare object") xhare(1, p,cov,fit) } rhare <- function(n, cov,fit) { if(!inherits(fit, "hare")) stop("fit is not a hare object") xhare(1, runif(n), cov,fit) } xhare <- function(arg1,arg2,arg3,arg4) { # mainly messing with the covariates iwhat <- arg1 if(!missing(arg2))arg2 <- unstrip(arg2) if(!missing(arg3))arg3 <- unstrip(arg3) q <- arg2 cov <- arg3 fit <- arg4 if(!inherits(fit, "hare")) stop("fit is not a hare object") zz <- 0 if(missing(arg4)) { zz <- 7 fit <- cov if(is.null(fit$ncov)) stop("fit missing") } if(fit$ncov == 0) { if(!missing(arg3) && zz==0) stop("there should be no covariates") else cov <- 0 } else { if(is.matrix(cov) == FALSE) cov <- matrix(cov, ncol = fit$ncov) nd <- length(cov[, 1]) nc <- length(cov[1, ]) nq <- length(q) if(nc != fit$ncov) stop("not the right number of covariates") if(nd != 1 && nq != 1 && nd != nq) stop("no matching number of cases") if(nq == 1) q <- rep(q, nd) if(nd == 1 && nq != 1) cov <- matrix(cov, nrow = nq, ncol = nc, byrow = TRUE) } fit$fcts <- as.vector(t(fit$fcts)) fit$fcts[is.na(fit$fcts)] <- -1 fit$knots <- as.vector(fit$knots) fit$knots[is.na(fit$knots)] <- 0 z <- .C("sphare", as.integer(fit$ncov), as.integer(fit$ndim), as.integer(length(q)), as.double(cov), as.integer(iwhat), q = as.double(q), as.double(fit$knots), as.double(fit$fcts), PACKAGE = "polspline") z$q } heft <- function(data, delta, penalty, knots, leftlin, shift, leftlog, rightlog, maxknots, mindist, silent = TRUE) { call <- match.call() if(!missing(data))data <- unstrip(data) if(!missing(delta))delta <- unstrip(delta) if(!missing(knots))knots<- unstrip(knots) if(missing(leftlin))leftlin<-2 leftlin<-leftlin*1 nx <- -1 z <- .C("sheftx", z = as.integer(nx), PACKAGE = "polspline") lgth <- z$z lgth <- 40 if(missing(mindist)) mindist <- 5 if(mindist < 2) { warning("mindist reset to 2") mindist <- 2 } if(missing(delta)) delta <- data - data + 1 if(length(data) != length(delta)) stop("data and delta have different length") if(min(data) < 0) stop("negative data") if(min(data) == 0) { if(!missing(leftlog)){ if(leftlog != 0) stop("** hard-zeros, leftlog has to be 0 **") } else{ leftlog <- 0 warning("*** hard zeros: leftlog set to 0 ***") } if(leftlin==2){ warning("*** hard zeros: leftlin set to TRUE ***") leftlin <- 1 } } leftlin <- (leftlin==1) dd <- abs(delta - 0.5) if(min(dd) < 0.5 || max(dd) > 0.5) stop("delta not all 0 or 1") delta <- delta[order(data)] data <- sort(data) nx <- length(data) if(!missing(maxknots) && !missing(knots) && maxknots < length(knots)) stop("maxknots is smaller than length(knots)") if(missing(maxknots)) maxknots <- 0 if(missing(penalty)) penalty <- log(nx) if(maxknots > lgth - 5) { maxknots <- lgth - 5 warning(paste("maxknots reduced to", maxknots)) } if(!missing(shift)) if(shift <= - min(data)) stop("shift too small") if(missing(shift)) shift <- quantile(data[delta==1], 0.75) nknots <- 0 iauto <- 0 if(!missing(knots)) { nknots <- length(knots) if(nknots > lgth - 5) stop(paste("nknots can be at most", lgth - 5)) iauto <- 2 uu <- knots[2:nknots] - knots[1:(nknots - 1)] if(min(uu) < 0) stop("knots not in sequence") if(knots[1] < 0) stop("knot 1 is negative") knots <- c(knots, rep(0, lgth - nknots)) } if(iauto < 2) knots <- rep(0, lgth) error <- c(1, rep(0, 20)) if(silent != TRUE) error[7] <- 37 tails <- c(0, 0, 0, 0, 1) if(!missing(leftlog) || min(data) == 0) { if(leftlog <= -1) stop("leftlog should be smaller than -1") tails[1] <- 1 tails[2] <- leftlog } if(!missing(rightlog)) { if(rightlog < -1) stop("rightlog should be at least -1") tails[3] <- 1 tails[4] <- rightlog } if(leftlin) tails[5] <- 0 z <- .C("sheft", as.integer(nx), as.double(data), as.integer(delta), nk = as.integer(nknots), knots = as.double(knots), as.double(penalty), tails = as.double(tails), as.integer(iauto), logl = as.double(rep(0, lgth)), theta = as.double(rep(0, lgth)), iknots = as.integer(rep(0, lgth)), error = as.integer(error), as.double(shift), as.integer(maxknots), ad = as.integer(rep(0, lgth)), as.integer(mindist), PACKAGE = "polspline") error <- z$error if(z$nk < -100) error[2] <- 1 z$logl[abs(z$logl) < 1e-100] <- 0 z$logl[z$ad == 2] <- 0 if(error[2] == 0){ fit <-list(call = call, knots = z$knots[1:z$nk], logl = z$logl[2:(z$nk + 1)], thetak = z$theta[1:z$nk], thetap = z$theta[z$nk + (1:2)], thetal = z$theta[z$nk + (3:4)], penalty = penalty, shift = shift, sample = length(data), logse = z$tails[c(2, 4)], max = max(data), adddel = z$ad[2:(z$nk + 1)]) class(fit) <- "heft" fit } else { print("sorry......") invisible() } } plot.heft <- function(x, n = 100, what = "d", add = FALSE, xlim, xlab, ylab, type, ...) { if(!inherits(x, "heft")) stop("x is not a heft object") fit <- x if(missing(xlim)) { u2 <- min(qheft(0.99, fit), fit$max) u3 <- 0 u4 <- 1.1 * u2 xlim <- c(u3, u4) } u3 <- xlim[1] u4 <- xlim[2] xx <- (0:(n - 1))/(n - 1) * (u4 - u3) + u3 if(u3 == 0) xx <- (1:n)/n * u4 yy <- c(-10, -10) if(what == "d" || what == "D") yy <- dheft(xx, fit) if(what == "h" || what == "H") yy <- hheft(xx, fit) if(what == "f" || what == "F" || what == "p" || what == "P") yy <- pheft(xx, fit) if(what == "s" || what == "S") yy <- 1-pheft(xx, fit) if(yy[1] < -8) stop("What is wrong? Well: what is wrong.") if(missing(xlab)) xlab <- "" if(missing(ylab)) ylab <- "" if(missing(type)) type <- "l" if(!add) plot(xx, yy, xlim = xlim, xlab = xlab, ylab = ylab, type = type, ...) else lines(xx, yy, type = type, ...) } print.heft <- function(x,...) { summary.heft(x) } summary.heft <- function(object,...) { if(!inherits(object, "heft")) stop("object is not a heft object") fit <- object ul <- fit$penalty um <- fit$sample ll <- fit$logl kk <- (1:length(ll)) kk <- kk[fit$ad != 2] ll <- ll[fit$ad != 2] ad <- fit$ad[fit$ad != 2] bb <- -2 * ll + ul * (kk-2) if(fit$thetal[1]!=0) bb <- bb+ul if(fit$thetal[2]!=0) bb <- bb+ul if(fit$thetap[2]!=0) bb <- bb+ul if(fit$thetap[2]==0 && min(kk)==2) bb <- bb+ul cc1 <- bb cc2 <- bb cc2[1] <- Inf cc1[length(bb)] <- 0 if(length(bb) > 1) { for(i in 1:(length(bb) - 1)) { cc1[i] <- max((ll[(i + 1):(length(bb))] - ll[i])/(kk[(i + 1):(length(bb))] - kk[i])) cc2[i + 1] <- min((ll[1:i] - ll[i + 1])/(kk[1:i] - kk[i + 1])) } } c3 <- cc2 - cc1 cc1[c3 < 0] <- NA cc2[c3 < 0] <- NA uu <- cbind(kk, ad, ll, bb, 2 * cc1, 2 * cc2) ww <- rep("", length(bb)) dimnames(uu) <- list(ww, c("knots", "A(0)/D(1)", "loglik", "AIC", "minimum penalty", "maximum penalty")) print(round(uu, 2)) cat(paste("the present optimal number of knots is ", kk[bb == min(bb)], "\n")) if(ul == log(um)) cat(paste("penalty(AIC) was the default: BIC=log(samplesize): log(", um, ")=", round(ul, 2), "\n")) else cat(paste("penalty(AIC) was ", round(ul, 2), ", the default (BIC) ", "would have been", round(log(um ), 2), "\n")) if(min(kk) == 3 && fit$thetap[2] != 0) { cat(paste("models with fewer than", kk[1], "knots", "can be fitted, but they are not optimal for the\n")) cat(paste("present choice of penalty - choose penalty in", "heft larger to see these fits\n")) } if(min(kk) > 3) { cat(paste("models with fewer than", kk[1], "knots", "can be fitted, but they are not optimal for the\n")) cat(paste("present choice of penalty - choose penalty in", "heft larger to see these fits\n")) } uuu <- matrix(NA, ncol = 3, nrow = 2, dimnames = list(c("left tail", "right tail"), c("theta", "SE", "t"))) uuu[, 1] <- fit$thetal if(fit$logse[1] > 0) { uuu[1, 2] <- fit$logse[1] uuu[1, 3] <- abs(fit$thetal[1]/fit$logse[1]) } if(fit$logse[2] > 0) { uuu[2, 2] <- fit$logse[2] uuu[2, 3] <- abs(fit$thetal[2]/fit$logse[2]) } print(round(uuu, 2)) invisible() } dheft <- function(q, fit) { if(!inherits(fit, "heft")) stop("fit is not a heft object") y <- hheft(q, fit) z <- 1 - pheft(q, fit) y * z } hheft <- function(q, fit) { if(!inherits(fit, "heft")) stop("fit is not a heft object") q <- unstrip(q) y <- fit$thetap[1] + q * fit$thetap[2] + fit$thetal[1] * log(q/(q + fit$ shift)) + fit$thetal[2] * log(q + fit$shift) for(i in 1:length(fit$knots)) { if(fit$thetak[i] != 0) y <- y + fit$thetak[i] * ((abs(q - fit$knots[i]) + q - fit$knots[i])/2)^3 } exp(y) } pheft <- function(q, fit) { if(!inherits(fit, "heft")) stop("fit is not a heft object") q <- unstrip(q) sq <- rank(q) q <- sort(q) z <- .C("heftpq", as.double(c(fit$knots,rep(0,100))), as.double(c(fit$shift,rep(0,100))), as.double(c(fit$thetak,rep(0,100))), as.double(c(fit$thetal,rep(0,100))), as.double(c(fit$thetap,rep(0,100))), as.integer(1), pp = as.double(q), as.double(q), as.integer(length(fit$knots)), as.integer(length(q)), PACKAGE = "polspline") zz <- z$pp[sq] zz[q < 0] <- 0 zz } qheft <- function(p, fit) { if(!inherits(fit, "heft")) stop("fit is not a heft object") p <- unstrip(p) sp <- rank(p) p <- sort(p) z <- .C("heftpq", as.double(c(fit$knots,rep(0,100))), as.double(c(fit$shift,rep(0,100))), as.double(c(fit$thetak,rep(0,100))), as.double(c(fit$thetal,rep(0,100))), as.double(c(fit$thetap,rep(0,100))), as.integer(0), as.double(p), qq = as.double(p), as.integer(length(fit$knots)), as.integer(length(p)), PACKAGE = "polspline") zz <- z$qq[sp] zz[p < 0] <- NA zz[p == 0] <- 0 zz[p == 1] <- Inf zz[p > 1] <- NA zz } rheft <- function(n, fit) { if(!inherits(fit, "heft")) stop("fit is not a heft object") pp <- runif(n) qheft(pp, fit) } oldlogspline.to.logspline <- function(obj,data) { nobj <- list() nobj$call <- obj$call if(is.null(obj$call))nobj$call <- "translated from oldlogspline" nobj$knots <- sum(obj$coef[-(1:2)]!=0) nobj$coef.pol <- obj$coef[1:2] nobj$coef.kts <- obj$coef[-(1:2)] nobj$coef.kts <- nobj$coef.kts[nobj$coef.kts!=0] nobj$knots <- obj$knots[obj$coef[-(1:2)]!=0] nobj$maxknots <- length(obj$coef)-2 nobj$penalty <- obj$penalty nobj$bound <- obj$bound nobj$samples <- obj$sample nobj$logl <- obj$logl[obj$logl!=0] lx <- length(nobj$logl) nobj$logl <- cbind(nobj$maxknots+1-(lx:1),c(rep(2,lx-1),1),nobj$logl) class(nobj) <- "logspline" if(!missing(data))nobj$range <- obj$range else { lx <- 1/(nobj$samples+1) nobj$range <- qlogspline(c(lx,1-lx),nobj) } nobj$mind nobj } poldlogspline <- function(q, fit) { fitx <- oldlogspline.to.logspline(fit) plogspline(q,fitx) } qoldlogspline <- function(p, fit) { fitx <- oldlogspline.to.logspline(fit) qlogspline(p,fitx) } roldlogspline <- function(n, fit) { if(!inherits(fit, "oldlogspline")) stop("fit is not an oldlogspline object") pp <- runif(n) qoldlogspline(pp, fit) } doldlogspline <- function(q, fit) { x <- q if(!inherits(fit, "oldlogspline")) stop("fit is not an oldlogspline object") q <- unstrip(q) y <- fit$coef[1] + x * fit$coef[2] for(i in 1:length(fit$knots)) { if(fit$coef[i+2] != 0) y <- y + fit$coef[i+2] * ((abs(x - fit$knots[i]) + x - fit$knots[i])/2)^3 } y <- exp(y) if(fit$bound[1] > 0) y[x < fit$bound[2]] <- 0 if(fit$bound[3] > 0) y[x > fit$bound[4]] <- 0 y } plot.oldlogspline <- function(x, n = 100, what = "d", xlim, xlab = "", ylab = "", type = "l", add = FALSE, ...) { fit <- x if(!inherits(fit, "oldlogspline")) stop("fit is not an oldlogspline object") if(missing(xlim)) { u1 <- qoldlogspline(0.01, fit) u2 <- qoldlogspline(0.99, fit) u3 <- 1.1 * u1 - 0.1 * u2 u4 <- 1.1 * u2 - 0.1 * u1 } else { u3 <- xlim[1] u4 <- xlim[2] } xx <- (0:(n - 1))/(n - 1) * (u4 - u3) + u3 if(what == "d" || what == "D") yy <- doldlogspline(xx, fit) if(what == "f" || what == "F" || what == "p" || what == "P") yy <- poldlogspline(xx, fit) if(what == "s" || what == "S") yy <- 1 - poldlogspline(xx, fit) if(what == "h" || what == "H") yy <- doldlogspline(xx, fit)/(1 - poldlogspline(xx, fit)) if(missing(xlab)) xlab <- "" if(missing(ylab)) ylab <- "" if(missing(type)) type <- "l" if(add==FALSE)plot(xx, yy, xlab = xlab, ylab = ylab, type = type, ...) else lines(xx,yy, type = type, ...) } print.oldlogspline <- function(x,...) { summary.oldlogspline(x) } summary.oldlogspline <- function(object,...) { if(!inherits(object, "oldlogspline")) stop("fit is not an oldlogspline object") fit <- object if(fit$delete==FALSE)stop(paste("summary.oldlogspline can only provide", "information if delete in oldlogspline is TRUE")) ul <- fit$penalty um <- fit$sample ll <- fit$logl kk <- (1:length(ll)) kk <- kk[ll != 0] + 2 ll <- ll[ll != 0] error<-FALSE rr <- ll[1:(length(ll)-1)]-ll[2:length(ll)] if(length(ll)>1 && max(rr)>0)error<-TRUE bb <- -2 * ll + ul * kk cc1 <- bb cc2 <- bb cc2[1] <- Inf cc1[length(bb)] <- 0 if(length(bb) > 1) { for(i in 1:(length(bb) - 1)) { cc1[i] <- max((ll[(i + 1):(length(bb))] - ll[i])/( kk[(i + 1):(length(bb))] - kk[i])) cc2[i + 1] <- min((ll[1:i] - ll[i + 1])/(kk[1:i] - kk[i + 1])) } } c3 <- cc2 - cc1 cc1[c3 < 0] <- NA cc2[c3 < 0] <- NA uu <- cbind(kk, ll, bb, 2 * cc1, 2 * cc2) ww <- rep("", length(bb)) if(error){ cat("Warning - imprecision in loglikelihood (possibly due to heavy tails)\n") cat("the output of summary.oldlogspline might not be correct\n") } dimnames(uu) <- list(ww, c("knots", "loglik", "AIC", "minimum penalty", "maximum penalty")) print(round(uu, 2)) cat(paste("the present optimal number of knots is ", kk[bb== min(bb)],"\n")) if(ul == log(um)) cat(paste("penalty(AIC) was the default: BIC=log(samplesize): log(", um, ")=", round(ul, 2),"\n")) else cat(paste("penalty(AIC) was ", round(ul, 2),", the default (BIC) ", "would have been", round(log(um), 2),"\n")) if(min(kk) > 3 && fit$delete==TRUE){ cat(paste( "models with fewer than", kk[1],"knots ", "can be fitted, but they are not optimal for\n")) cat(paste("the present choice of penalty - choose penalty in", "oldlogspline larger\nto see these fits\n")) } if(min(kk) > 3 && fit$delete==3) cat(paste("models with fewer than", kk[1],"knots ", "were not fitted because of convergence problems\n")) invisible() } oldlogspline <- function(uncensored, right, left, interval, lbound, ubound, nknots, knots, penalty, delete = TRUE) { nsample <- rep(0, 6) # interval is the nterval censored data - a matrix with two columns if(!missing(uncensored))uncensored <- unstrip(uncensored) if(!missing(right))right <- unstrip(right) if(!missing(left))left <- unstrip(left) if(!missing(interval))interval <- unstrip(interval) if(!missing(knots))knots <- unstrip(knots) if(!missing(interval)) { if(length(interval[1, ]) != 2) stop("interval must have two columns") if(min(abs(interval[, 1] - interval[, 2])) < 0) stop( "not all lower bounds smaller than upper bounds") nsample[3] <- length(interval)/2 nsample[1] <- length(interval)/2 # grouping boundaries can not be beyond the boundaries of the density if(!missing(lbound)) interval[interval[, 1] < lbound, 1] <- lbound if(!missing(ubound)) interval[interval[, 2] > ubound, 2] <- ubound sample <- as.vector(t(interval)) ror <- order(interval[,1],interval[,2]) if(nsample[3]>1){ ro1 <- interval[ror[(1:(nsample[3]-1))],1]==interval[ror[2:nsample[3]],1] ro2 <- interval[ror[(1:(nsample[3]-1))],2]==interval[ror[2:nsample[3]],2] nsample[6] <- nsample[3]-sum(ro1+ro2==2) } else nsample[6] <- 1 } # uncensored is the uncensored data if(!missing(uncensored)) { uncensored2 <- uncensored[!is.na(uncensored)] u2 <- length(uncensored) - length(uncensored2) if(u2 > 0) print(paste("***", u2, " NAs ignored in uncensored")) uncensored <- uncensored2 if(nsample[1] > 0) sample <- c(uncensored, sample) if(nsample[1] == 0) sample <- uncensored nsample[1] <- length(uncensored) + nsample[1] nsample[2] <- length(uncensored) uncensored <- sort(uncensored) if(nsample[2]>1) nsample[6] <- sum(uncensored[2:nsample[2]] != uncensored[1:(nsample[2]-1)]) + 1 + nsample[6] else nsample[6] <- nsample[6]+1 } # we can not run on only right or left censored data if(nsample[1] == 0) stop("you either need uncensored or interval censored data") # right is the right censored data if(!missing(right)) { if(nsample[1] > 0) sample <- c(sample, right) if(nsample[1] == 0) sample <- right nsample[1] <- length(right) + nsample[1] nsample[4] <- length(right) right <- sort(right) if(nsample[4]>1){ nsample[6] <- sum(right[2:nsample[4]]!=right[1:(nsample[4]-1)])+ 1 + nsample[6] } else nsample[6] <- nsample[6]+1 } # left is the left censored data if(!missing(left)) { if(nsample[1] > 0) sample <- c(sample, left) if(nsample[1] == 0) sample <- left nsample[1] <- length(left) + nsample[1] nsample[5] <- length(left) left <- sort(left) if(nsample[5]>1){ nsample[6] <- sum(left[2:nsample[5]]!=left[1:(nsample[5]-1)])+ 1 + nsample[6] } else nsample[6] <- nsample[6]+1 } # the default for penalty is bic: log(length(sample)) if(missing(penalty)) penalty <- log(nsample[1]) n1 <- 4 * nsample[1]^0.2 + 1 if(!missing(nknots)) n1 <- nknots + 1 if(!missing(knots)) n1 <- length(knots) + 1 # user provides knots if(!missing(knots)) { nknots <- length(knots) knots <- sort(knots) iautoknot <- 0 if(knots[1] > min(sample)) stop("first knot must be smaller than smallest sample") if(knots[nknots] < max(sample)) stop("last knot should be larger than largest sample") } else { if(missing(nknots)) nknots <- 0 knots <- vector(mode = "double", length = max(nknots, 50)) iautoknot <- 1 } xbound <- c(1, 0, 0, 0, 0) if(!missing(lbound)) { xbound[2] <- 1 xbound[3] <- lbound if(lbound > min(sample)) stop("lbound should be smaller than smallest sample") } if(!missing(ubound)) { xbound[4] <- 1 xbound[5] <- ubound if(ubound < max(sample)) stop("ubound should be larger than largest sample") } # SorC will carry the error messages - in code form SorC <- vector(mode = "integer", length = 35) SorC[1] <- 1 # the actual function call SorC[17] <- 0 nsample[6] <- nsample[6]-1 if(length(table(sample))<3)stop("Not enough unique values") z <- .C("logcensor", as.integer(delete), as.integer(iautoknot), as.double(sample), as.integer(nsample), bd = as.double(xbound), SorC = as.integer(SorC), nk = as.integer(nknots), kt = as.double(knots), cf = as.double(c(knots, 0, 0)), as.double(penalty), as.double(sample), as.double(sample), logl = as.double(rep(0, n1 + 1)), PACKAGE = "polspline") SorC <- z$SorC # error messages if(SorC[1] == -1 && SorC[28] == 0 && nsample[1]!=nsample[2] && nsample[2]>15){ SorC <- vector(mode = "integer", length = 35) SorC[1] <- 1 # the actual function call SorC[17] <- 1 z <- .C("logcensor", as.integer(delete), as.integer(iautoknot), as.double(sample), as.integer(nsample), bd = as.double(xbound), SorC = as.integer(SorC), nk = as.integer(nknots), kt = as.double(knots), cf = as.double(c(knots, 0, 0)), as.double(penalty), as.double(sample), as.double(sample), logl = as.double(rep(0, n1 + 1)), PACKAGE = "polspline") } bound <- c(z$bd[2], z$bd[3], z$bd[4], z$bd[5]) SorC <- z$SorC # error messages if(abs(SorC[1]) > 2) { for(i in 3:abs(SorC[1])) cat(paste("===> warning: knot ", SorC[i - 1], " removed - double knot\n")) if(SorC[1] < 0) SorC[1] <- -1 if(SorC[1] == 23) SorC[1] <- -3 } if(abs(SorC[1]) > 3) { cat("* several double knots suggests that your data is *\n") cat("* strongly rounded, attention might be required *\n") SorC[1] <- 1 } if(SorC[1] == -3) stop("* too many double knots") if(SorC[1] == -1 && SorC[28] == 0) stop("* no convergence") if(SorC[28] > 0) cat(paste("* convergence problems, smallest number of knots", " tried is ", SorC[28] + 1," *\n")) if(SorC[1] == 2) stop("* sample is too small") if(SorC[1] == -2) stop(paste("* too many knots, at most ", SorC[2], "knots possible")) if(SorC[22] == 1) { cat("possible discontinuity at lower end\n") cat(paste("consider rerunning with lbound=", z$kt[1], "\n")) } if(SorC[22] == 3) { cat("possible infinite density at lower end\n") cat("running program with fewer knots\n") } if(SorC[21] == 1) cat("running with maximum degrees of freedom\n") if(SorC[25] >0) cat("* problems are possibly due to a very heavy right tail *\n") if(SorC[24] >0) cat("* problems are possibly due to a very heavy left tail *\n") if(SorC[23] == 3) { cat("possible infinite density at upper end\n") cat("running program with fewer knots\n") } if(SorC[23] == 1) { cat("possible discontinuity at upper end\n") cat(paste("consider rerunning with ubound=", z$kt[z$nk], "\n")) } if(delete && SorC[28]>0)delete<-3 coef <- z$cf[1:(z$nk + 2)] uu <- 3:z$nk if(delete == FALSE)uu <- 1 fit <- list(coef = coef, knots = z$kt[1:z$nk], bound = bound, logl = z$logl[ uu], penalty = penalty, sample = nsample[1], delete = delete) class(fit) <- "oldlogspline" fit } lspec <- function(data, period, penalty, minmass, knots, maxknots, atoms, maxatoms, maxdim, odd = FALSE, updown = 3,silent=TRUE) { call <- match.call() if(!missing(data))data <- unstrip(data) if(!missing(period))period <- unstrip(period) if(!missing(knots))knots <- unstrip(knots) if(!missing(atoms))atoms <- unstrip(atoms) if(missing(period) && missing(data)) stop(" either data or period should be specified ") if(!missing(period) && !missing(data)) stop(" only one of data or period should be specified ") if(!missing(period)) ny <- 2 * length(period) if(missing(period)) { ny <- length(data) period <- Mod(fft(data))^2/(ny * 2 * pi) period <- period[1:floor((length(period) + 2)/2)] odd <- TRUE if(floor(ny/2) == ny/2) odd <- FALSE } else{ if(odd) ny <- ny + 1 period <- c(1,period) } if(min(period) <= 0) stop(" all period elements should be larger than 0 ") if(length(period) < 10) stop("too few observations") z <- .C("tspspsx", z = as.integer(rep(-1, 12)), PACKAGE = "polspline") lgth <- z$z[1] nx <- length(period) if(missing(penalty)) penalty <- log(nx - 1) dimatt <- 0 ktsatt <- 1 spkatt <- 1 nknots <- 0 natoms <- 0 if(!missing(maxknots)){ maxknots <- max(1, maxknots) } else { maxknots <- -1 ktsatt <- 0 } if(!missing(maxatoms)){ maxatoms <- max(0, maxatoms) } else { maxatoms <- -1 spkatt <- 0 } if(missing(minmass)){ if(!missing(data)) minmass <- var(data)*(-log(1-0.95^(1/nx))-1)/ny else{ minmass <- mean(period[2:length(period)])*2*pi minmass <- minmass*(-log(1-0.95^(1/nx))-1)/ny } } minmass <- minmass * ny /(2*pi) if(!missing(knots)) { nknots <- length(knots) if(nknots>1){ uu <- knots[2:nknots] - knots[1:(nknots - 1)] if(min(uu) <= 0) stop("knots not in sequence") } if(knots[1] < 0) stop("knot 1 too small") if(knots[nknots] > pi) stop("last knot too large") knots <- c(knots, rep(0, lgth - nknots)) if(ktsatt * maxknots < ktsatt * nknots) stop("more knots than maxknots") } else{ knots <- rep(0, lgth) } if(!missing(atoms)) { natoms <- length(atoms) atoms <- round((atoms * ny)/(2 * pi)) if(natoms>1){ uu <- atoms[2:natoms] - knots[1:(natoms - 1)] if(min(uu) <= 0) stop("atoms not in sequence or too close") } if(atoms[1] < 1) stop("atom 1 too small") if(atoms[natoms] > ny/2) stop("last atom too large") atoms <- c(atoms, rep(0, lgth - natoms)) if(spkatt * maxatoms < spkatt * natoms) stop("more atoms than maxatoms") } else{ atoms <- rep(0, lgth) } u1 <- max(nknots, 1, maxknots) + max(natoms, maxatoms) if(u1 > lgth - 5) stop("too many dimensions") if(!missing(maxdim)) { dimatt <- 1 if(u1 > maxdim) stop("maxdim too small for other specifications") if(maxdim > lgth - 5) stop(paste("maxdim can be at most", lgth - 5)) } else{ maxdim <- max(4 * nx^0.2, 15, u1) } dims <- c(nx, maxdim, dimatt, maxknots, ktsatt, nknots, maxatoms, spkatt, natoms, odd, updown, 1*silent, 0) z <- .C("tspsps", dims = as.integer(dims), as.double(period), knots = as.double(c(knots,rep(0,nx))), atoms = as.integer(c(atoms,rep(0,nx))), as.double(penalty), logl = as.double(rep(0, lgth)), theta = as.double(rep(0, lgth)), ad = as.integer(rep(0, lgth)), minmass = as.double(minmass), PACKAGE = "polspline") dims <- z$dims minmass <- minmass /( ny /(2*pi)) if(dims[12] == 1) stop(paste("numerical problems -\n", "probably too many knots or knots too close together", " or a very sharp atom")) if(dims[12] == 2) stop("no convergence") z$logl[abs(z$logl) < 1e-100] <- 0 z$logl[z$ad == 2] <- 0 mass <- ((z$theta[(dims[6] + 4) + (1:dims[9])]) * 2 * pi)/ny atoms <- (z$atoms[1:dims[9]] * 2 * pi)/ny if(dims[9] == 0) { mass <- 0 atoms <- 0 } thetak <- z$theta[5:(dims[6] + 4)] knots <- z$knots[1:dims[6]] if(dims[6] == 0) { thetak <- 0 knots <- 0 } logl <- z$logl[dims[6]+dims[9]] fit <- list(call = call, thetap = z$theta[1:4], nknots = dims[6], knots = knots, thetak = thetak, natoms = dims[9], atoms = atoms, mass = mass, penalty = penalty, minmass = minmass, sample = ny, logl = logl, updown = dims[11]) class(fit) <- "lspec" fit } clspec <- function(lag, fit, cov = TRUE, mm) { if(!inherits(fit, "lspec")) stop("fit is not an lspec object") if(!missing(lag))lag <- unstrip(lag) llag <- abs(lag) if(max(abs(round(llag) - llag)) > 0.01) stop("some lags are not integer") if(missing(mm)) { mm <- max(c(1024, fit$sample, max(llag + 1))) mm <- 2^(1 + floor(log(mm - 0.1)/log(2))) } if(mm < max(llag + 1)) stop("mm too small") rr <- dlspec(((0:mm) * pi)/mm, fit)$d rr <- c(rr, rr[mm:2]) rr <- (Re(fft(rr)) * pi)/mm rr <- rr[llag + 1] if(fit$natoms>0){ for(i in 1:fit$natoms) { rr <- rr + 2 * cos(lag * fit$atoms[i]) * fit$mass[i] } } if(cov == FALSE) rr <- rr/rr[1] rr } dlspec <- function(freq, fit) { if(!inherits(fit, "lspec")) stop("fit is not an lspec object") if(!missing(freq))freq <- unstrip(freq) freq <- freq - floor(freq/(2 * pi)) * 2 * pi freq[freq > pi] <- 2 * pi - freq[freq > pi] y <- rep(fit$thetap[1], length(freq)) + freq * fit$thetap[2] y <- y + freq^2 * fit$thetap[3] + freq^3 * fit$thetap[4] if(fit$nknots > 0) { for(i in 1:fit$nknots) { z <- freq - fit$knots[i] y[z > 0] <- y[z > 0] + z[z > 0]^3 * fit$thetak[i] } } d1 <- exp(y) modfreq <- round((freq * fit$sample)/(2 * pi)) modmatch <- round((fit$atoms * fit$sample)/(2 * pi)) uu <- rep(0, round(fit$sample/2) + 2) uu[modmatch] <- fit$mass uu <- c(NA, uu) l1 <- uu[modfreq+1] modfreq <- ((2 * pi)/fit$sample) * modfreq list(d = d1, modfreq = modfreq, m = l1) } plspec <- function(freq, fit, mm) { if(!inherits(fit, "lspec")) stop("fit is not an lspec object") if(!missing(freq))freq <- unstrip(freq) if(missing(mm)) { mm <- max(c(4096, fit$sample)) mm <- 2^floor(log(mm - 0.1)/log(2)) } ff <- freq[freq >= - pi] ff <- ff[ff <= pi] gg <- c(abs(ff), pi) uu <- (c((1:mm) - 0.5) * pi)/mm tt <- dlspec(uu, fit)$d ss <- cumsum(tt)/mm ss <- (c(0, 0, ss, ss[mm]) * pi) tt <- (gg * mm)/pi vv <- floor(tt) tt <- tt - vv tt <- (1 - tt) * ss[vv + 2] + tt * ss[vv + 3] if(fit$natoms > 0) { for(i in 1:fit$natoms) tt[gg >= fit$atoms[i]] <- tt[gg >= fit$atoms[i]] + fit$ mass[i] } if(length(gg) < length(freq) + 1 || is.na(gg[1])) warning("plspec is only valid for frequencies between -pi and pi") ss <- rep(NA, length(freq)) ss[abs(freq) <= pi] <- tt[ - length(tt)] + tt[length(tt)] ss[freq < 0] <- 2 * tt[length(tt)] - ss[freq < 0] if(fit$natoms > 0) { for(i in 1:fit$natoms) ss[freq == - fit$atoms[i]] <- ss[freq == - fit$atoms[ i]] + fit$mass[i] } ss } rlspec <- function(n, fit, mean = 0, cosmodel = FALSE, mm) { if(!inherits(fit, "lspec")) stop("fit is not an lspec object") if(missing(mm)) { mm <- max(c(1024, fit$sample, n)) mm <- 2^(1 + floor(log(mm - 0.1)/log(2))) } if(mm < max(n/2 + 1)) stop("mm too small") rr <- (dlspec(((0:mm) * pi)/mm, fit)$d * pi)/(2 * mm) rr[1] <- rr[1] * 2 rr[mm + 1] <- rr[mm + 1] * 2 rr <- sqrt(rr) uu <- rnorm(rr, 0, rr) uu <- c(uu, uu[mm:2]) vv <- rnorm(rr, 0, rr) vv <- c(vv, - vv[mm:2]) vv[c(1, (mm + 1))] <- 0 uu <- uu + vv * (1i) uu <- Re(fft(uu)) uu <- uu[1:n] + mean if(fit$natoms > 0) { cc <- runif(1)*2*pi-pi if(cosmodel) aa <- 2*sqrt(fit$mass) else aa <- 2 * rnorm(fit$natoms, 0, sqrt(fit$mass)) aa[fit$atoms == pi] <- 2 * aa[fit$atoms == pi] for(i in 1:fit$natoms) uu <- uu + aa[i] * cos((1:n) * fit$atoms[i] + pi * cc) } uu } plot.lspec <- function(x, what = "b", n, add = FALSE, xlim, ylim, xlab, ylab, type, ...) { fit <- x if(!inherits(fit, "lspec")) stop("fit is not an lspec object") if(add) { plim <- (par()$usr)[1:2] if(!missing(xlim)) { plim[1] <- max(xlim[1], plim[1]) plim[2] <- min(xlim[2], plim[2]) } } else { plim <- c(0, pi) if(what =="p"||what=="P"||what=="f"||what=="F")plim[1]<- -pi if(!missing(xlim)) { plim[1] <- xlim[1] plim[2] <- xlim[2] } } if(missing(xlab)) xlab <- "" if(missing(ylab)) ylab <- "" if(what == "l" || what == "L") { if(missing(type)) type <- "h" if(fit$natoms>0){ x5 <- c(-fit$atoms,fit$atoms) tt <- round(plim[2]/(2*pi))+1 vv <- round(plim[1]/(2*pi))-1 x1 <- x5 for(i in vv:tt) if(i!=0)x1 <- c(x1, x5+i*2*pi) y1 <- dlspec(x1,fit)$m y1 <- y1[x1 <= plim[2]] x1 <- x1[x1 <= plim[2]] y1 <- y1[x1 > plim[1]] x1 <- x1[x1 > plim[1]] x1 <- c(x1[1], x1) y1 <- c(0, y1) if(!add) plot(x1, y1, xlim = plim, xlab = xlab, ylab = ylab, type = type, ...) else lines(x1, y1, type = type, ...) abline(h = 0)} else{ if(add) abline(h=0) else plot(plim,c(0,0),xlab = xlab, ylab = ylab,type="l",...) } } if(what == "d" || what == "D" || what == "b" || what == "B") { if(missing(type)) type <- "l" if(missing(n)) n <- max(100, fit$sample + 1) xx <- (0:(n - 1))/(n - 1) * (plim[2] - plim[1]) + plim[1] yy <- dlspec(xx, fit)$d if(fit$natoms == 0) what <- "d" if(missing(ylim))ylim<-range(yy) } if(what == "b" || what == "B") { type <- "l" x5 <- c(-fit$atoms,fit$atoms) tt <- round(plim[2]/(2*pi))+1 vv <- round(plim[1]/(2*pi))-1 x3 <- x5 for(i in vv:tt) if(i!=0)x3 <- c(x3, x5+i*2*pi) y3 <- dlspec(x3, fit) y3 <- max(yy)*1.1 if(fit$nknots==1)y3 <- 2*y3 if(!missing(ylim))y3 <- ylim[2] x2 <- x3 y2 <- dlspec(x2, fit)$d x4 <- x3 y4 <- y2 for(i in 1:length(x3)) { yy <- c(yy[xx < x2[i]], y2[i], y3, y4[i], yy[xx > x4[ i]]) xx <- c(xx[xx < x2[i]], x2[i], x3[i], x4[i], xx[xx > x4[ i]]) } if(missing(ylim))ylim<-range(yy) yy <- yy[xx >= plim[1]] xx <- xx[xx >= plim[1]] yy <- yy[xx <= plim[2]] xx <- xx[xx <= plim[2]] y2 <- y2[x2 >= plim[1]] x2 <- x2[x2 >= plim[1]] y2 <- y2[x2 <= plim[2]] x2 <- x2[x2 <= plim[2]] } if(what == "f" || what == "F" || what == "p" || what == "P") { if(!missing(xlim)){ if(xlim[1]< -pi || xlim[2]>pi) stop("for this plot the range cannot strecth beyond (-pi,pi)") } if(missing(xlim)){ plim[1] <- max(plim[1],-pi) plim[2] <- min(plim[2],pi) } if(missing(type)) type <- "l" if(missing(n)) n <- max(100, fit$sample + 1) xx <- (0:(n - 1))/(n - 1) * (plim[2] - plim[1]) + plim[1] yy <- plspec(xx, fit) if(missing(ylim))ylim<-range(yy) if(fit$natoms > 0) { x2 <- fit$atoms y3 <- plspec(x2, fit) y2 <- y3 - fit$mass for(i in 1:fit$natoms) { yy <- c(yy[xx < x2[i]], y2[i], y3[i], yy[xx > x2[i]]) xx <- c(xx[xx < x2[i]], x2[i], x2[i], xx[xx > x2[i]]) } x2 <- -fit$atoms y3 <- plspec(x2, fit) y2 <- y3 - fit$mass for(i in 1:fit$natoms) { yy <- c(yy[xx < x2[i]], y2[i], y3[i], yy[xx > x2[i]]) xx <- c(xx[xx < x2[i]], x2[i], x2[i], xx[xx > x2[i]]) } yy <- yy[xx >= plim[1]] xx <- xx[xx >= plim[1]] yy <- yy[xx <= plim[2]] xx <- xx[xx <= plim[2]] } } if(what != "l" && what != "L") { if(!add) plot(xx, yy, xlim = plim, xlab = xlab, ylab = ylab, type = type, ylim = ylim, ...) else lines(xx, yy, type = type, ...) if(what =="b" || what=="B")points(x2,y2) } invisible() } print.lspec <- function(x,...) { summary.lspec(x) } summary.lspec <- function(object,...) { fit <- object if(!inherits(fit, "lspec")) stop("fit is not an lspec object") aa <- " Logspline Spectral Estimation\n" aa <- paste(aa,"=============================\n") aa <- paste(aa,"The fit was obtained by the command:\n ") cat(aa) print(fit$call) aic <- round(-2*fit$logl+fit$penalty*(fit$nknots+fit$natoms),2) logl <- round(fit$logl,2) ns <- fit$natoms nk <- fit$nknots nd <- ns + nk if(ns==0 && nk==1) aa <- paste(" Only 1 basis function, a constant, was fitted.\n") if(ns==0 && nk>1) aa <- paste(" A spline with",nk,"knots, was fitted;", "there were no lines in the model.\n") if(ns>0 && nk>1) aa <- paste(" A spline with",nk,"knots, was fitted;", "there were also",ns,"lines in the model.\n") if(ns>0 && nk==1) aa <- paste(" There were",nd,"basisfunctions, a constant and", ns,"lines, in the model.\n") aa <- paste(aa,"The log-likelihood of the model was",logl, "which corresponds to an AIC\n value of",aic,".\n\n") aa <- paste(aa,"The program went though",abs(fit$updown)) if(fit$updown>0) aa <-paste(aa,"updown cycles, and reached a stable solution.\n") if(fit$updown<0) aa <-paste(aa,"updown cycles, and did not reach a stable solution.\n") p1 <- round(fit$penalty,2) n1 <- round(fit$minmass,4) nn <- floor(fit$sample/2) p2 <- round(log(nn),2) uu <- plspec(pi,fit) n2 <- round(uu*(-log(1-0.95^(1/nn))-1)/fit$sample,4) p3 <- (p1==p2) p4 <- TRUE if(n1/n2 > 1.2 || n2/n1 > 1.2) p4 <- FALSE if(p3==TRUE && p4==TRUE)aa<-paste(aa, "Both penalty (AIC) and minmass were the default values. For penalty this\n", "was log(n)=log(",nn,")=",p1," (as in BIC) and for minmass this was",n1,".\n") if(p3==TRUE && p4==FALSE)aa<-paste(aa, "Penalty (AIC) had the default values", "log(n)=log(",nn,")=",p1," (as in BIC).\n Minmass was",n1, ", the default would have been",n2,".\n") if(p3==FALSE && p4==FALSE)aa<-paste(aa, "Penalty was",p1,", the default would have been", "log(n)=log(",nn,")=",p2,"\n(as in BIC). Minmass was",n1, ", the default would have been",n2,".\n") if(p3==FALSE && p4==TRUE)aa<-paste(aa, "Penalty was",p1,", the default would have been, log(n)=log(",nn,")=", p2,"\n (as in BIC). Minmass was the default",n1,".\n\n") if(nk>1){aa<-paste(aa,"The locations of the knots were:") for(i in 1:nk)aa<-paste(aa,round(fit$knots[i],3)) aa<-paste(aa,"\n") } if(ns>0){ aa<-paste(aa,"The locations and the mass in each line were:\n") bb <- matrix(0,ncol=4,nrow=ns) for(i in 1:ns){ bb[i,1]<-round(fit$atoms[i],3) bb[i,2]<-2*pi/(fit$atoms[i]) bb[i,2]<-round(bb[i,2],2) bb[i,3]<-round(fit$mass[i],5) bb[i,4]<- round(100*fit$mass[i]/uu,2) } dimnames(bb) <- list(rep("",ns),c("angular frequency","period","mass", "% of total mass")) } cat(aa) if(ns>0)print(bb) invisible() } polymars <- function(responses, predictors, maxsize, gcv = 4., additive = FALSE, startmodel, weights, no.interact, knots, knot.space = 3, ts.resp, ts.pred, ts.weights, classify, factors, tolerance = 1e-06, verbose = FALSE) { #responses - a vector (or matrix) of responses. (Can be a a vector of characters for classification) #predictors - a matrix of predictors with same number of cases as response. Columns are predictors. #OPTIONAL ARGUEMENTS #maxsize - maximum number of basis function the model can contain #gcv - parameter for overall best model seletion #additive - boolean, is the model to be additive #startmodel - either a matrix (m*4 or m*5) or a polymars object from a previous call to polymars # an initial model the procedure should start with in model selection #weights - a vector of length equal to the number of cases #no.interact- a 2*l matrix of columns numbers of the predictor matrix( each row pair cannot # have interaction terms) #knots - a vector specifying many knots per predictor are wanted (with -1 for categorical # variables) ncol(predictors)==length(knots), or a matrix with ncol(predictors) == # ncol(knots) with actual knot specified and filled out with NA's. # Can also be a single number - "knots" number of knots per predictor #knot.space - minimum number of order statistics between knots #ts.resp - testset reponses, same format as responses #ts.pred - testset predictors, same format as predictors #ts.weights - testset weights, same format as weights #classify - whether classification is to be done, set = TRUE if the response vector is integer, if # if character classify is automatically true #factors - a vector of column numbers of the predictor matrix of categorical variables #tolerance - a numerical parameter which may need to be made smaller if the program crashes #store the call to the polymars function call <- match.call() ism0 <- missing(classify) ism1 <- missing(ts.resp) ism2 <- missing(maxsize) ism3 <- missing(ts.pred) ism4 <- missing(ts.weights) ism5 <- missing(knots) ism6 <- missing(factors) ism7 <- missing(startmodel) ism8 <- missing(weights) ism9 <- missing(no.interact) if(!missing(responses)) responses <- unstrip(responses) if(!missing(predictors)) predictors <- unstrip(predictors) if(!missing(weights)) weights <- unstrip(weights) if(!missing(no.interact)) no.interact <- unstrip(no.interact) if(!missing(knots)) knots <- unstrip(knots) if(!missing(ts.resp)) ts.resp <- unstrip(ts.resp) if(!missing(ts.pred)) ts.pred <- unstrip(ts.pred) if(!missing(ts.weights)) ts.weights <- unstrip(ts.weights) if(!missing(factors)) factors <- unstrip(factors) responses <- as.matrix(responses) predictors <- data.matrix(predictors) nresponses <- ncol(responses) npredictors <- ncol(predictors) ncases <- nrow(predictors) if(ism0) classify <- FALSE if(mode(responses) == "character" || classify == TRUE) { if(ncol(responses) > 1) { stop("When using character responses or classify = TRUE only 1 response per case is allowed\n" ) } char.responses <- responses int.responses <- as.integer(as.factor(responses)) nresponses <- length(unique(responses)) responses <- matrix(ncol = nresponses, nrow = ncases, data = int.responses) for(i in 1:nresponses) { responses[, i] <- (responses[, i] == (unique( int.responses)[i])) } conversion <- matrix(ncol = 2, nrow = nresponses, c(unique( char.responses), unique(int.responses))) classify <- TRUE if(!ism1) { char.responses.test <- ts.resp ts.resp <- matrix(ncol = nresponses, nrow = length( char.responses.test), data = 0) for(i in 1:nresponses) { ts.resp[, i] <- as.integer(char.responses.test == conversion[i, 1]) } } } else { conversion <- FALSE classify <- FALSE } #maxsize that the model can grow to if(ism2) maxsize <- ceiling(min(6 * (ncases^(1/3)), ncases/4, 100)) #if a testset is to be used in model selection if(!ism1 || !ism3) { if(ism1 || ism3) { stop("Both ts.resp (testsets responses) and ts.pred (testset predictors) should be specified\n" ) } if(!is.matrix(ts.resp)) ts.resp <- as.matrix(ts.resp) if(!is.matrix(ts.pred)) ts.pred <- as.matrix(ts.pred) if(ncol(ts.resp) != nresponses) { stop("Testset should have the same number of responses as the training set\n " ) } if(ncol(ts.pred) != npredictors) { stop("Testset should have the same number of predictors as the training set\n " ) } if(nrow(ts.resp) != nrow(ts.pred)) { stop("Testset ts.pred and ts.resp should have the same number of cases (rows)" ) } testsetmatrix <- cbind(ts.resp, ts.pred) testsetcases <- nrow(testsetmatrix) testset <- TRUE if(!ism4) { if(length(ts.weights) != testsetcases) { stop("length of testset weights misspecified\n" ) } testset.weighted <- TRUE testsetmatrix <- cbind(ts.resp * ts.weights, ts.pred) } else { testset.weighted <- FALSE ts.weights <- 0 } } else { testsetmatrix <- 0 testsetcases <- 0 testset <- FALSE testset.weighted <- FALSE ts.weights <- 0 } #If the mesh is specified by the knots arguement this will be changed to #true later mesh.specified <- FALSE mesh.vector <- 0 if(nrow(responses) != nrow(predictors)) { stop("The number of rows (cases) of the response and predictor matricies should be the same" ) } if(!ism5 && !is.matrix(knots) && length(knots) != npredictors && length( knots) != 1) { stop("Length of vector of `knots per predictor' should be equal to number of predictors or 1\n" ) } if(!ism5) { if(!is.matrix(knots)) { #if knots is specified as a single number it is expanded to a vector #length npredictors if(length(knots) == 1) { knots <- rep(knots, npredictors) if(!ism6) { for(i in 1:length(factors)) { if(!is.vector(factors)) { stop("`factors' should be a vector whose elements are indicies of predictors that are factors\n" ) } # in knots the number of knots(per predictor) is specified # or -1 if the predictor is a factor and all it values are levels knots[factors[i]] <- -1 } } } } else { mesh <- knots mesh.vector <- vector(length = ncol(mesh) * nrow(mesh), mode = "double") knots <- vector(length = npredictors, mode = "integer") k <- 0 for(i in 1:npredictors) { knots[i] <- length(unique(mesh[is.na(mesh[ , i]) == FALSE, i])) for(j in 1:knots[i]) { k <- k + 1 mesh.vector[k] <- unique(mesh[!is.na( mesh[, i]), i])[j] } } if(!ism6) { for(i in 1:length(factors)) { if(!is.vector(factors)) { stop("`factors' should be a vector whose elements are indicies of predictors that are factors\n" ) } # in knots the number of knots(per predictor) is specified # or -1 if the predictor is a factor and all it values are levels knots[factors[i]] <- -1 } } mesh.specified <- TRUE } } if(ism5) { knots <- rep(min(20, round(ncases/4)), npredictors) if(!ism6) { for(i in 1:length(factors)) { if(!is.vector(factors)) { stop("`factors' should be a vector whose elements are indicies of predictors that are factors\n" ) } # in knots the number of knots(per predictor) is specified # or -1 if the predictor is a factor and all it values are levels knots[factors[i]] <- -1 } } } startmodelsize <- 1 #A starting model must be specified as a object of class polymars #or a matrix with 4 or 5 columns no.remove <- 0 no.remove.size <- 0 if(!ism7) { if(is.vector(startmodel)) startmodel <- t(as.matrix(startmodel)) v1 <- (class(startmodel) == "polymars") if(length(v1) == 0) v1 <- FALSE if(!(is.matrix(startmodel) || v1) || (is.matrix(startmodel) && (ncol(startmodel) != 4 && (ncol(startmodel) != 5)))) { stop(paste( "startmodel should be a matrix with each row corresponding to", "a function with number of columns = 4 (or 5 for extra boolean\n", "column specifying predictors which cannot be removed)", "or startmodel should be a polymars object\n")) } if(is.matrix(startmodel)) { #Fifth column denotes which basis functions must remain in the model at #all times if(ncol(startmodel) == 5) { no.remove <- vector(length = (nrow(startmodel)) ) j <- 0 for(i in 1:nrow(startmodel)) { if(startmodel[i, 5] == TRUE) { j <- j + 1 no.remove[j] <- i } } no.remove.size <- j } #The startknots are taken from the startmodel and put into a vector #The startmodel becomes a 4*n matrix with a "1" in the 2nd and 4th #columns where knots appear startknots <- as.vector(t(cbind(startmodel[, 2], startmodel[, 4]))) startknots[is.na(startknots)] <- 0. startmodel <- matrix(startmodel[, 1:4], ncol = 4) startmodel[!is.na(startmodel[, 2]), 2] <- 1 startmodel[is.na(startmodel[, 2]), 2] <- 0 startmodel[is.na(startmodel[, 3]), 3] <- 0 startmodel[startmodel[, 3] == 0, 4] <- 0 for(i in 1:nrow(startmodel)) { if((!is.na(startmodel[i, 4])) && startmodel[ i, 3] != 0) startmodel[i, 4] <- 1 } startmodel[is.na(startmodel[, 4]), 4] <- 0 startmodelsize <- nrow(startmodel) + 1 } else { startmodelsize <- startmodel$model.size startmodel <- startmodel$model[-1, ] startknots1 <- startmodel$knot1 startknots2 <- startmodel$knot2 L1 <- FALSE if(!is.null(startmodel$level1)) { L1 <- TRUE level1 <- startmodel$level1 } if(L1) { startmodel$knot1[!is.na(level1)] <- 1 startknots1[!is.na(level1)] <- level1[!is.na( level1)] } startknots <- cbind(startknots1, startknots2) startknots <- as.vector(t(startknots)) startknots[is.na(startknots)] <- 0. startmodel <- cbind(startmodel[, "pred1"], startmodel[ , "knot1"], startmodel[, "pred2"], startmodel[ , "knot2"]) startmodel[, 2] <- !is.na(startmodel[, 2]) startmodel[, 4] <- !is.na(startmodel[, 4]) } } else { startmodel <- 0 startknots <- 0 } if(!ism8) { if(length(weights) != ncases) { stop("Number of weights not equal to the numnber of cases\n" ) } weighted <- TRUE responses <- responses * weights } else { weighted <- FALSE weights <- 0 } datamatrix <- cbind(responses, predictors) #Predictors which cannot interact together in the model are specified #by a 2*n matrix of predictor indicies if(!ism9) { if(!is.matrix(no.interact) || ncol(no.interact) != 2) { stop("list of interactions disallowed has been misspecified,must be a 2*n matrix" ) } no.interact <- t(no.interact) no.interact.size <- ncol(no.interact) } else { no.interact.size <- 0 no.interact <- 0 } if(startmodelsize > maxsize) { stop("start model should not be of greater size than the max model size\n" ) } #Some error checking on the startmodel if(startmodelsize != 1) { for(i in 1:(startmodelsize - 1)) { if(startmodel[i, 1] == 0) { stop("first column of startmodel cannot be zero\n" ) } if(startmodel[i, 2] == 1) { if(startknots[(i * 2) - 1] < min(predictors[ , startmodel[i, 1]]) || startknots[ (i * 2) - 1] > max(predictors[, startmodel[i, 1]])) { stop("Knot out of range of its predictor \n" ) } } if(startmodel[i, 4] == 1) { if(startknots[(i * 2)] <= min(predictors[, startmodel[i, 3]]) || startknots[( i * 2)] >= max(predictors[, startmodel[ i, 3]])) { stop("Knot out of range of its predictor\n" ) } } } if(max(startmodel[, c(1, 3)] > npredictors)) { stop("Initial model misspecified on input\n") } } startmodel <- t(startmodel) resultmodelsize <- 0 end.state <- 0 step.count <- 0 z <- .C("polymarsF", as.integer(npredictors), as.integer(nresponses), as.integer(ncases), as.double(datamatrix), as.integer(knots), as.double(mesh.vector), as.integer(mesh.specified), as.integer(maxsize), as.double(gcv), as.integer(additive), as.integer(startmodelsize), start.model = as.integer(startmodel), start.knots = as.double(startknots), as.integer(weighted), as.double(weights), as.integer(no.interact.size), as.integer(no.interact), as.integer(no.remove.size), as.integer(no.remove), as.integer(knot.space), as.integer(testset), as.double(testsetmatrix), as.integer(testsetcases), as.integer(testset.weighted), as.double(ts.weights), as.integer(classify), as.double(tolerance), as.integer(verbose), best.model = as.integer(matrix(nrow = maxsize, ncol = 4, data = rep(0, maxsize * 4))), coefficients = as.double(matrix(nrow = maxsize, ncol = nresponses, data = rep(0., maxsize * nresponses))), steps = as.integer(matrix(nrow = maxsize * 2, ncol = 2, data = rep(0, maxsize * 4))), rss.gcv = as.double(matrix(nrow = maxsize * 2, ncol = nresponses + 1, data = rep(0., maxsize * 2 * ( nresponses + 1)))), modelsize = as.integer(resultmodelsize), modelknots = as.double(matrix(nrow = maxsize, ncol = 2, data = rep(0., maxsize * 2))), coefficient.se.term = as.double(rep(0., maxsize)), end.state = as.integer(end.state), step.count = as.integer(step.count), PACKAGE = "polspline") #The C function returns information about how it ended if(z$end.state != 0 && z$end.state != 5) { switch(z$end.state, stop("Mis-specification of initial model\n"), stop("Initial model with non-linear function must contain the corresponding linear function\n" ), stop("Initial model contains two-predictor functions that require prerequisite functions\n" )) } else { model <- matrix(z$best.model[1:((z$modelsize - 1) * 4)], ncol = 4, byrow = TRUE) knot.values <- matrix(z$modelknots[1:((z$modelsize - 1) * 2)], ncol = 2, byrow = TRUE) for(i in 1:nrow(model)) { if(model[i, 2] != 0) { model[i, 2] <- knot.values[i, 1] } else { model[i, 2] <- NA } if(model[i, 4] != 0) { model[i, 4] <- knot.values[i, 2] } else { model[i, 4] <- NA } } if(length(knots[model[, 1]]) != 0 && min(knots[model[, 1]]) < 0) { factor1 <- TRUE levels1 <- rep(NA, z$modelsize - 1) factor.variables <- unique(model[knots[model[, 1]] < 0, 1]) for(i in 1:length(factor.variables)) { for(j in 1:length(model[, 1])) { if(model[j, 1] == factor.variables[ i]) { levels1[j] <- model[j, 2] } } model[model[, 1] == factor.variables[i], 2] <- NA } levels1 <- c(NA, levels1) } else { factor1 <- FALSE } coefs <- matrix(z$coefficients[1:(z$modelsize * nresponses)], ncol = nresponses) #The model that the C-function returns does not explicitly contain an intercept #so in formatting the output one is added if(z$modelsize > 1) { if(factor1 == FALSE) { model <- rbind(c(0, NA, 0, NA), model) model <- data.frame(model, coefs) if(nresponses == 1) { dimnames(model) <- list(1:z$modelsize, c("pred1", "knot1", "pred2", "knot2", "coefs")) } else { dimnames(model) <- list(1:z$modelsize, c("pred1", "knot1", "pred2", "knot2", paste("Coefs", 1: nresponses))) } } if(factor1 == TRUE) { model[(knots[model[, 1]] < 0), 2] <- NA model <- rbind(c(0, NA, 0, NA), model) model <- data.frame(model[, 1:2], levels1, model[, 3:4], coefs) if(nresponses == 1) { dimnames(model) <- list(1:z$modelsize, c("pred1", "knot1", "level1", "pred2", "knot2", "coefs")) } else { dimnames(model) <- list(1:z$modelsize, c("pred1", "knot1", "level1", "pred2", "knot2", paste("Coefs", 1:nresponses))) } } } else { model <- data.frame(0, NA, 0, NA, coefs) if(nresponses == 1) { dimnames(model) <- list(1:z$modelsize, c( "pred1", "knot1", "pred2", "knot2", "coefs")) } else { dimnames(model) <- list(1:z$modelsize, c( "pred1", "knot1", "pred2", "knot2", paste("Coefs", 1:nresponses))) } } #for later plotting the ranges and medians of the predictors are stored ranges.and.medians <- matrix(ncol = npredictors, nrow = 3, data = 0) for(i in 1:npredictors) { ranges.and.medians[1, i] <- min(predictors[, i]) } for(i in 1:npredictors) { ranges.and.medians[2, i] <- max(predictors[, i]) } for(i in 1:npredictors) { ranges.and.medians[3, i] <- median(predictors[, i]) } # A table with information from the fitting is formatted here steps <- matrix(z$steps[1:(2 * (z$step.count + 1))], ncol = 2, byrow = TRUE) rss.gcv <- matrix(z$rss.gcv[1:((nresponses + 1) * (z$step.count + 1))], ncol = nresponses + 1, byrow = TRUE) fitting <- data.frame(steps, rss.gcv) if(testset == FALSE) { if(nresponses == 1) { dimnames(fitting) <- list(1:(nrow(fitting)), c("0/1", "size", "RSS", "GCV")) } else { dimnames(fitting) <- list(1:nrow(fitting), c("0/1", "size", paste("RSS", 1: nresponses), "GCV")) } } else { if(classify == FALSE) { if(nresponses == 1) { dimnames(fitting) <- list(1:(nrow( fitting)), c("0/1", "size", "RSS", "T.S. RSS")) } else { dimnames(fitting) <- list(1:nrow( fitting), c("0/1", "size", paste("RSS", 1:nresponses), "T.S. RSS")) } } else { if(nresponses == 1) { dimnames(fitting) <- list(1:(nrow( fitting)), c("0/1", "size", "RSS", "T.S.M.C.")) } else { dimnames(fitting) <- list(1:nrow( fitting), c("0/1", "size", paste("RSS", 1:nresponses), "T.S.M.C.")) } } } # if their are factors present in the model the factors must be stored for use during plotting if(factor1 == TRUE) { model2 <- model[-1, ] factors.in.model <- unique(model2[knots[model2[, 1]] < 0, 1]) maxfactors <- 0 for(i in 1:length(factors.in.model)) { maxfactors <- max(maxfactors, length(unique( predictors[, factors.in.model[i]]))) } factor.matrix <- matrix(ncol = length(factors.in.model), nrow = maxfactors + 2, data = NA) for(i in 1:length(factors.in.model)) { factor.matrix[1, i] <- factors.in.model[i] factor.matrix[2, i] <- length(unique(predictors[ , factors.in.model[i]])) for(j in 3:(length(unique(predictors[, factors.in.model[i]])) + 2)) { factor.matrix[j, i] <- unique( predictors[, factors.in.model[ i]])[j - 2] } } } else { factor.matrix <- 0 } if(nresponses == 1) { model <- cbind(model, model[,1]) dimnames(model)[[2]][length(dimnames(model)[[2]])] <- "SE" } else { for(i in 1:nresponses) { model <- cbind(model, model[,1]) dimnames(model)[[2]][length(dimnames(model)[[ 2]])] <- paste("SE", i) } } result <- list(model = model, fitting = fitting, model.size = z$ modelsize, responses = nresponses, ranges.and.medians = ranges.and.medians, call = call, conversion = conversion, factor.matrix = factor.matrix) class(result) <- "polymars" #refit the coefficients dd <- design.polymars(result,predictors) model2 <- result$model rsquared2 <- rep(0,nresponses) for(i in 1:nresponses){ if(z$modelsize>1) mm <- summary(lm(responses[, i] ~ dd[, -1])) else mm <- summary(lm(responses[, i] ~ 1 )) rsquared2[i] <- mm$r.squared mm <- mm$coefficients model2[,i+factor1+4] <- mm[,1] model2[,i+factor1+4+nresponses] <- mm[,2] } result$model <- model2 result$Rsquared <- rsquared2 #calculates fitted values and residual of the data according to the #model returned if(z$modelsize > 1) { fitted <- predict.polymars(result, x = predictors) residuals <- responses - fitted } else { fitted <- matrix(ncol = nresponses, nrow = ncases, data = coefs[1, 1]) residuals <- matrix(ncol = nresponses, nrow = ncases, data = responses - coefs[1, 1]) } result$residuals = residuals result$fitted = fitted return(result) } } ################################################################################################ predict.polymars<-function(object,x,classify=FALSE,intercept,...) { # Produces predicted values for a polymars object # pmars.model an object returned from a call to polymars # x a matrix with number of columns equal to number of columns of predictor matrix in # original call to polymars and predictor values in the corresponding columns. Can # also be a matrix with number of column equal to the number of predictors in the # model, in the order of the original dataset. # classify If the original call to polymars was for classification setting classify=TRUE will # the new data otherwise it will return the multi-response fitted values. # intercept By default TRUE. The full intercept is included; or when FALSE the intercept is left out. # Can also be given a numerical value if(missing(intercept)) { intercept<-TRUE } if(!missing(x))x <- unstrip(x) # some error checking if(!inherits(object, "polymars")) stop("object is not a polymars object") pmars.model <- object # The x matrix number of columns can be of length equal to the number of # predictors in the original model or shorten to the number of predictors in # the model in `pmars.model' if(!(is.matrix(x))) { if(length(unique(pmars.model$model[, "pred1"]))== 1 || ncol(pmars.model$ranges.and.medians)== 1 ) { x<-matrix(data=x,ncol=1) } } if((is.matrix(x) && ncol(x) != length(unique(pmars.model$model[,"pred1"])))) { if(ncol(x) != ncol(pmars.model$ranges.and.medians)) { stop("Input should be a matrix with number of columns equal to either number of original predictors or number of predictors in model\n") } } # If the number of columns of the matrix is not length equal to number of # predictors it is expanded to that size. if(is.matrix(x) && ncol(x) == length(unique(pmars.model$model[, "pred1"])) && ncol(x) != ncol(pmars.model$ranges.and.medians)) { tempmatrix<-x x<-matrix(nrow=nrow(tempmatrix),ncol=ncol(pmars.model$ranges.and.medians),data = 0) for(i in 1:length(unique(pmars.model$model[, "pred1"]))) { for(j in 1:nrow(tempmatrix)) { x[j,sort(unique(pmars.model$model[,"pred1"]))[i]]<-x[j] } } } # If x is a vector put it into matrix form expanding it if it is of # length equal to only the number of predictors in the model in `pmars.model' if(!(is.matrix(x))) { if(!(length(x) == ncol(pmars.model$ranges.and.medians) || length(x) == unique(pmars.model$model[, "pred1"]))) { stop("The vector of values must be equal in length to either the number of original predictors or predictors in the model\n") } if(length(x) == unique(pmars.model$model[, "pred1"]) && length(x) != ncol(pmars.model$ranges.and.medians)) { x <- rep(0, ncol(pmars.model$ranges.and.medians)) for(i in 1:length(unique(pmars.model$model[, "pred1"]))) { x[sort(unique(pmars.model$model[, "pred1"]))[i]]<-x[i] } } x <- t(as.matrix(x)) } # Checking to see if there are factor variables in the model if(dimnames(pmars.model$model)[[2]][3] == "level1") { level1<-TRUE pmars.model$model<-pmars.model$model[,c(1:(5+pmars.model$responses))] #if(dimnames(pmars.model$model)[[2]][6] == "level2"){level2<-TRUE}else{level2<-FALSE} } else { level1<-FALSE pmars.model$model<-pmars.model$model[,c(1:(4+pmars.model$responses))] #if(dimnames(pmars.model$model)[[2]][5] == "level2") # {level2<-TRUE}else{level2<-FALSE} } # Setting up the fitted responses matrix responses<-pmars.model$responses Y <- matrix(ncol = responses, nrow = nrow(x), data = rep(0, nrow(x))) Y1 <- matrix(ncol = 1, nrow = nrow(x), data = rep(0, nrow(x))) Y2 <- matrix(ncol = 1, nrow = nrow(x), data = rep(0, nrow(x))) if(is.logical(intercept)) { if(intercept==TRUE) { for(i in 1:responses)Y[,i] <- pmars.model$model[1,ncol(pmars.model$model)-responses+i] } else { if(intercept==FALSE) { for(i in 1:responses)Y[,i] <- 0.0 } } } else { if(is.numeric(intercept)) { if(length(intercept)==responses) { for(i in 1:responses)Y[,i] <- intercept[i] } else { if(length(intercept) != 1) { stop("Intercept arguement mispecified \n") } for(i in 1:responses)Y[,i] <- intercept } } } # Computing fitted values if(pmars.model$model.size>1) { for(i in 2:pmars.model$model.size) { Y2[] <- 1 Y1[] <- x[,pmars.model$model[i, "pred1"]] if(!is.na(pmars.model$model[i, "knot1"])) { Y1 <- Y1 - pmars.model$model[i,"knot1"] Y1[Y1 < 0,] <- 0 } if(level1) { if(!is.na(pmars.model$model[i, "level1"])) { Y1<- (Y1 == pmars.model$model[i, "level1"]) } } if(!is.na(pmars.model$model[i, "pred2"]) & pmars.model$model[i, "pred2"] != 0) { Y2[] <- x[,pmars.model$model[i,"pred2"]] if(!is.na(pmars.model$model[i,"knot2" ])) { Y2 <- Y2 - pmars.model$model[i,"knot2"] Y2[Y2 < 0,] <- 0 } #if(level2) #{ # if(!is.na(pmars.model$model[i, "level2"])) # { # Y2<- (Y2 == pmars.model$model[i, "level2"]) # } #} } for(j in 1:responses){Y[,j]<-Y[,j]+(Y1 * Y2 * pmars.model$model[i,ncol(pmars.model$model)-responses+j])} } } # If classification is to be used the original polymars fitting expanded the # response into a vector of indicator variables. The largest of the responses # correspondes to the fitted class for each case. if(classify == TRUE) { for(i in 1:nrow(Y)) { Y[i,]<-Y[i,]==max(Y[i,]) } if(is.matrix(pmars.model$conversion)) Z<-Y Y<-matrix(ncol=1,nrow=nrow(Z)) for(i in 1:nrow(Y)) { for(j in 1:ncol(Z)) { if(Z[i,j] == 1) Y[i,] <- pmars.model$conversion[j] } } } # else # { # if classification was used but the full multiple response fitted response # matrix is requested the response names (corresponding to the classes) are # added. # if(is.matrix(pmars.model$conversion)) # { # dimnames(Y)[[2]]<-list(pmars.model$conversion[,1]) # # } # } return(Y) } ################################################################################################ print.polymars<-function(x,...) { summary.polymars(x) } ################################################################################################ summary.polymars<-function(object,...) { if(!inherits(object, "polymars")) stop("object is not a polymars object") pmars.model <- object cat("Call:\n") print(pmars.model$call) cat("\nModel fitting\n\n") print(pmars.model$fitting) cat("\n\nModel produced\n\n") print(pmars.model$model) if(pmars.model$responses != 1) cat("\nRESPONSES :", pmars.model$responses, "\n") if(!is.null(pmars.model$Rsquared)) cat("\nRsquared :",round(pmars.model$Rsquared,3),"\n") invisible() } plot.polymars<-function(x,predictor1,response,predictor2,xx,add=FALSE,n,xyz=FALSE,contour.polymars=FALSE,xlim,ylim,intercept,...) { # pmars.model a polymars object # predictor1 the column number in the original predictor matrix of the predictor of interest # response with multi-response polymars the column number in the original response matrix. # Default is 1 # predictor2 the second predictor for a contour or persp plot. For single response data # plot(pmars1,2,6) is understood as 3-d plot of predictors 2 and 6. # xx Values for the other predictors can be given, using the same format as for the # predict fuhnction. By default median values are used. # add should the plot be added to another. (for 2-d plots only) # n For 2-d plot the number of points the function is interploted over. For 3-d plots # the a n*n mesh is interploted over. Default 2-d: 100, 3-d 33. # xyz sometimes a call can be ambiguous: plot(pmars1,6,2) a 2-d plot with 2nd response # or a 3-d plot. Use xyz=TRUE for 3-d. #contour.polymars By default a 3-d if a `persp' plot. contour.polymars=TRUE asks for a `contour' plot. #intercept same as for predict function. =TRUE intercepr is included =FALSE it is left out, or can # be given a numerical value. if(!inherits(x, "polymars")) stop("x is not a polymars object") pmars.model <- x if(missing(xx))xx<-pmars.model$ranges.and.medians[3,] if(length(xx) != ncol(pmars.model$ranges.and.medians)) { stop("xx should be of length equal to the number of predictors in original data\n") } x <- xx if(!missing(predictor2))xyz <- TRUE if(missing(predictor2) && (!missing(response)) && pmars.model$responses == 1) { if(missing(predictor1) && xyz == TRUE) { stop("You must specify 2 predictor numbers") } xyz<-TRUE predictor2<-response response<-1 } if(contour.polymars == TRUE) { xyz<-TRUE } if(missing(intercept)) { intercept<-TRUE } if(xyz==TRUE) { if(missing(n))n<-33 if(missing(response)) { if(missing(xlim)) { persp.polymars(pmars.model, predictor1, predictor2, n=n, contour.polymars=contour.polymars, intercept=intercept, ...) } else { persp.polymars(pmars.model, predictor1, predictor2, n=n, xlim=xlim, contour.polymars=contour.polymars, intercept=intercept, ...) } } else { if(missing(xlim)) { persp.polymars(pmars.model, predictor1, predictor2, response, n=n, contour.polymars=contour.polymars, intercept=intercept, ...) } else { persp.polymars(pmars.model, predictor1, predictor2, response, n=n, xlim=xlim, contour.polymars=contour.polymars, intercept=intercept, ...) } } invisible(return()) } else { if(missing(predictor1)) { cat("predictor should be specified \n") } if(pmars.model$responses != 1 && missing(response)&& missing(predictor2)) { cat("Response should be specified (default: response =1)\n") } #check to see that the predictor is in the model inmodel<-FALSE for(i in 2:pmars.model$model.size) { if(pmars.model$model[i,"pred1"] == predictor1)inmodel<-TRUE } #check to see if the predictor is a factor if(is.matrix(pmars.model$factor.matrix)) { if(length(pmars.model$factor.matrix[1,pmars.model$factor.matrix[1,]== predictor1]) != 0) { isfactor<-TRUE } else { isfactor<-FALSE } } else { isfactor<-FALSE } if(isfactor == TRUE) { pred.values <- matrix(nrow = pmars.model$factor.matrix[2,pmars.model$factor.matrix[1,]==predictor1], ncol = ncol(pmars.model$ranges.and.medians),data = x, byrow = TRUE) factors<-pmars.model$factor.matrix[-c(1,2),pmars.model$factor.matrix[1,]==predictor1] pred.values[,predictor1]<- factors[!is.na(factors)] mesh<-factors[!is.na(factors)] } else { if(missing(n))n<-100 if(missing(xlim))xlim<-c(pmars.model$ranges.and.medians[1,predictor1],pmars.model$ranges.and.medians[2,predictor1]) pred.values <- matrix(nrow = n, ncol = ncol(pmars.model$ranges.and.medians), data = x, byrow = TRUE) mesh <- matrix(seq(xlim[1],xlim[2],(xlim[2]-xlim[1])/(n-1)),nrow=1) pred.values[,predictor1]<-mesh } if(missing(response) && missing(predictor2))response<-1 if(missing(response))response <- 1 if(response > pmars.model$responses || response < 0) { stop("response arguement = ",response,"is out of range\n") } model<-pmars.model$model Y<-predict.polymars(pmars.model,pred.values,intercept=intercept) if(isfactor == FALSE) { if(add == FALSE) { if(pmars.model$responses == 1) { plot(mesh,Y,...,type="l",xlab=paste("Predictor ",predictor1),ylab="Response") } else { plot(mesh, Y[,response], type="l", xlab=paste("Predictor ",predictor1), ylab=paste("Response ",response), ...) } } else { points(mesh, Y, type="l") } } if(isfactor == TRUE) { if(add == FALSE) { if(pmars.model$responses == 1) { plot(mesh,Y,...,xlab=paste("Predictor ",predictor1),ylab="Response") } else { plot(mesh, Y[,response], type="l", xlab=paste("Predictor ",predictor1), ylab=paste("Response ",response), ...) } } else { points(mesh, Y, type="l") } } invisible() } } ################################################################################################ persp.polymars<-function(x, predictor1, predictor2, response, n= 33,xlim,ylim,xx,contour.polymars,main,intercept,...) { if(!inherits(x, "polymars")) stop("x is not a polymars object") pmars.model <- x # used by the plot.polymars function # not designed for stand alone use. if(missing(xx))xx<-pmars.model$ranges.and.medians[3,] if(missing(xlim))xlim<-c(pmars.model$ranges.and.medians[1,predictor1],pmars.model$ranges.and.medians[2,predictor1]) if(missing(ylim))ylim<-c(pmars.model$ranges.and.medians[1,predictor2],pmars.model$ranges.and.medians[2,predictor2]) if(missing(predictor1) || missing(predictor2)) { stop("You must specify 2 predictor numbers\n") } if(pmars.model$responses != 1 && missing(response)) { cat("Response should be specified (default: response =1)\n") } if(missing(response))response <- 1 if(response > pmars.model$responses || response < 0) { stop("response arguement = ",response,"is out of range\n") } if(sum(as.integer(predictor1==pmars.model$model[,1])) == 0) { stop("Predictor 1 not in model\n") } if(sum(as.integer(predictor2==pmars.model$model[,1])) == 0) { stop("Predictor 2 not in model\n") } X <- seq(xlim[1],xlim[2],(xlim[2] - xlim[1])/(n-1)) y <- seq(ylim[1],ylim[2],(ylim[2] - ylim[1])/(n-1)) meshX <- rep(X, n) meshY <- rep(y, n) meshY <- sort(meshY) pred.values <- matrix(nrow = n^2, ncol = ncol(pmars.model$ranges.and.medians), data = xx, byrow = TRUE) for(i in 1:(n^2))pred.values[i, predictor1] <- meshX[i] for(i in 1:(n^2))pred.values[i, predictor2] <- meshY[i] Z <- predict.polymars(pmars.model, pred.values,intercept=intercept)[,response] Z <- matrix(Z, ncol = n, byrow = FALSE) xtitle<-paste("Predictor", predictor1) ytitle<-paste("Predictor", predictor2) if(pmars.model$responses > 1) { if(missing(main) && (!contour.polymars)) { ztitle <- paste("Response", response) } if(missing(main) && (contour.polymars)) { ztitle <- paste("Contour of response",response) } } else { if(missing(main) && (!contour.polymars))ztitle <- "Response" if(missing(main) && contour.polymars)ztitle <- paste("Contour of response") } if(!contour.polymars) { persp(X, y, Z, xlab = xtitle, ylab= ytitle, zlab = ztitle, ...) } else { contour(X, y, Z, xlab = xtitle, ylab = ytitle , main = ztitle, ...) } invisible() } ################################################################################################ design.polymars<-function(object,x) { # Produces predicted values for a polymars object # pmars.model an object returned from a call to polymars # x a matrix with number of columns equal to number of columns of predictor matrix in # original call to polymars and predictor values in the corresponding columns. Can # also be a matrix with number of column equal to the number of predictors in the # model, in the order of the original dataset. if(!missing(x))x <- unstrip(x) # some error checking if(!inherits(object, "polymars")) stop("object is not a polymars object") pmars.model <- object # The x matrix number of columns can be of length equal to the number of # predictors in the original model or shorten to the number of predictors in # the model in `pmars.model' if(!(is.matrix(x))) { if(length(unique(pmars.model$model[, "pred1"]))== 1 || ncol(pmars.model$ranges.and.medians)== 1 ) { x<-matrix(data=x,ncol=1) } } if((is.matrix(x) && ncol(x) != length(unique(pmars.model$model[,"pred1"])))) { if(ncol(x) != ncol(pmars.model$ranges.and.medians)) { stop("Input should be a matrix with number of columns equal to either number of original predictors or number of predictors in model\n") } } # If the number of columns of the matrix is not length equal to number of # predictors it is expanded to that size. if(is.matrix(x) && ncol(x) == length(unique(pmars.model$model[, "pred1"])) && ncol(x) != ncol(pmars.model$ranges.and.medians)) { tempmatrix<-x x<-matrix(nrow=nrow(tempmatrix),ncol=ncol(pmars.model$ranges.and.medians),data = 0) for(i in 1:length(unique(pmars.model$model[, "pred1"]))) { for(j in 1:nrow(tempmatrix)) { x[j,sort(unique(pmars.model$model[,"pred1"]))[i]]<-x[j] } } } # If x is a vector put it into matrix form expanding it if it is of # length equal to only the number of predictors in the model in `pmars.model' if(!(is.matrix(x))) { if(!(length(x) == ncol(pmars.model$ranges.and.medians) || length(x) == unique(pmars.model$model[, "pred1"]))) { stop("The vector of values must be equal in length to either the number of original predictors or predictors in the model\n") } if(length(x) == unique(pmars.model$model[, "pred1"]) && length(x) != ncol(pmars.model$ranges.and.medians)) { x <- rep(0, ncol(pmars.model$ranges.and.medians)) for(i in 1:length(unique(pmars.model$model[, "pred1"]))) { x[sort(unique(pmars.model$model[, "pred1"]))[i]]<-x[i] } } x <- t(as.matrix(x)) } # Checking to see if there are factor variables in the model if(dimnames(pmars.model$model)[[2]][3] == "level1") { level1<-TRUE pmars.model$model<-pmars.model$model[,c(1:(5+pmars.model$responses))] #if(dimnames(pmars.model$model)[[2]][6] == "level2"){level2<-TRUE}else{level2<-FALSE} } else { level1<-FALSE pmars.model$model<-pmars.model$model[,c(1:(4+pmars.model$responses))] #if(dimnames(pmars.model$model)[[2]][5] == "level2") # {level2<-TRUE}else{level2<-FALSE} } # Setting up the fitted responses matrix responses<-pmars.model$responses Y <- matrix(ncol = 1, nrow = nrow(x), data = rep(1, nrow(x))) Y1 <- matrix(ncol = 1, nrow = nrow(x), data = rep(0, nrow(x))) Y2 <- matrix(ncol = 1, nrow = nrow(x), data = rep(0, nrow(x))) # Computing fitted values if(pmars.model$model.size>1) { for(i in 2:pmars.model$model.size) { Y2[] <- 1 Y1[] <- x[,pmars.model$model[i, "pred1"]] if(!is.na(pmars.model$model[i, "knot1"])) { Y1 <- Y1 - pmars.model$model[i,"knot1"] Y1[Y1 < 0,] <- 0 } if(level1) { if(!is.na(pmars.model$model[i, "level1"])) { Y1<- (Y1 == pmars.model$model[i, "level1"]) } } if(!is.na(pmars.model$model[i, "pred2"]) & pmars.model$model[i, "pred2"] != 0) { Y2[] <- x[,pmars.model$model[i,"pred2"]] if(!is.na(pmars.model$model[i,"knot2" ])) { Y2 <- Y2 - pmars.model$model[i,"knot2"] Y2[Y2 < 0,] <- 0 } #if(level2) #{ # if(!is.na(pmars.model$model[i, "level2"])) # { # Y2<- (Y2 == pmars.model$model[i, "level2"]) # } #} } Y<-cbind(Y,Y1 * Y2) } } return(Y) } ################################################################################################ logspline <- function(x, lbound, ubound, maxknots=0, knots, nknots=0, penalty= -1, silent = TRUE,mind= -1, error.action=2) { call <- match.call() if(!missing(x))x <- unstrip(x) data <- x if(length(table(data))<3)stop("Not enough unique values") ilx <- 0; iux <- 0 if(!missing(lbound)){ilx <- 1;jlx <- lbound} if(!missing(ubound)){iux <- 1;jux <- ubound} u2 <- length(data) data <- data[!is.na(data)] nsample <- length(data) if(nsample<10)stop("not enough data") if(u2 !=nsample) print(paste("***", u2-nsample, " NAs ignored in data")) data <- sort(data) # data can not be beyond the boundaries of the density if(!missing(lbound)) if(data[1] < lbound) stop("data below lbound") if(!missing(ubound)) if(data[nsample] > ubound) stop("data above ubound") mm <- range(data) if(!missing(lbound)) mm <- range(c(mm, lbound)) if(!missing(ubound)) mm <- range(c(mm, ubound)) # boundaries ilow <- (!missing(lbound)) * 1 iupp <- (!missing(ubound)) * 1 low <- 0 upp <- 0 if(ilow == 1) low <- lbound if(iupp == 1) upp <- ubound # get the maximal dimension intpars <- c(-100, rep(0, 9)) z <- .C("nlogcensorx", z = as.integer(intpars), PACKAGE = "polspline") maxp <- z$z[1] # organize knots kts <- vector(mode = "double", length = max(maxp)) if(maxknots > maxp - 5) warning(paste("maxknots reduced to", maxp)) nknots <- -nknots if(!missing(knots)) { nknots <- length(knots) knots <- sort(knots) if(!missing(lbound)) if(min(knots) < lbound) stop("data (knots) below lbound") if(!missing(ubound)) if(max(knots) > ubound) stop("data (knots) above ubound") if(nknots < 3) stop("need at least three starting knots") if(nknots > maxp - 5) stop(paste("at most", maxp - 5, "knots possible")) kts[1:nknots] <- knots } silent <- (silent == FALSE) # group parameters intpars <- c(nsample, maxknots, nknots, silent, 1-ilow, 1-iupp,mind) dpars <- c(penalty, low, upp) data <- c(data, rep(0, maxp)) # do it z <- .C("nlogcensor", ip = as.integer(intpars), coef = as.double(data), dp = as.double(dpars), logl = as.double(rep(0, maxp)), ad = as.integer(rep(0, maxp)), kts = as.double(kts), PACKAGE = "polspline") # error messages if(z$ip[1] != 0 && z$ip[1]<100) { if(z$ip[1] == 17) warning("too many knots beyond data") if(z$ip[1] == 18) warning("too many knots before data") if(z$ip[1] == 39) warning("too much data close together") if(z$ip[1] == 40) warning("no model could be fitted") if(z$ip[1] == 2) warning("error while solving system") if(z$ip[1] == 8) warning("too much step-halving") if(z$ip[1] == 5) warning("too much step-halving") if(z$ip[1] == 7) warning("numerical problems, likely tail related. Try lbound/ubound") if(z$ip[1] == 1) warning("no convergence") i <- 0 if(missing(knots))i<- 1 if(z$ip[1] == 3 && i==1) warning("right tail extremely heavy, try running with ubound") if(z$ip[1] == 4 && i==1) warning("left tail extremely heavy, try running with lbound") if(z$ip[1] == 6 && i==1) warning("both tails extremely heavy, try running with lbound and ubound") if(z$ip[1] == 3 && i==0) warning("right tail too heavy or not enough knots in right tail") if(z$ip[1] == 4 && i==0) warning("left tail too heavy or not enough knots in left tail") if(z$ip[1] == 6 && i==0) warning("both tails too heavy or not enough knots in both tail") if(error.action==0) stop("fatal error") if(error.action==1) { print("no object returned") invisible() } if(error.action==2) { if(ilx==0 && iux==0)z <- oldlogspline(x) if(ilx==0 && iux==1)z <- oldlogspline(x,ubound=jux) if(ilx==1 && iux==0)z <- oldlogspline(x,lbound=jlx) if(ilx==1 && iux==1)z <- oldlogspline(x,lbound=jlx,ubound=jux) z <- oldlogspline.to.logspline(z,x) z$call <- call warning("re-ran with oldlogspline") z } } else{ if(z$ip[1]>100) { warning(" Not all models could be fitted") } # organize logl logl <- cbind(z$ad, z$logl) logl <- cbind(2+(1:z$ip[3]),logl[1+(1:z$ip[3]), ]) kk <- (1:length(logl[,1])) kk <- kk[logl[, 2] == 0 ] if(length(kk)>0)logl <- logl[-kk,] # bye bye fit <- list(call = call, nknots = z$ip[2], coef.pol = z$coef[1:2], coef.kts = z$coef[2 + (1:z$ip[2])], knots = z$kts[1:z$ip[2]], maxknots = z$ip[3]+2, penalty = z$dp[1], bound = c(ilow, low, iupp, upp), samples = nsample, logl = logl, range = mm, mind = z$ip[7]) class(fit) <- "logspline" fit} } plogspline <- function(q, fit) { if(!inherits(fit, "logspline")) stop("fit is not a logspline object") if(!missing(q))q <- unstrip(q) sq <- rank(q) q <- sort(q) z <- .C("rpqlsd", as.double(c(fit$coef.pol, fit$coef.kts)), as.double(fit$knots), as.double(fit$bound), as.integer(1), pp = as.double(q), as.integer(length(fit$knots)), as.integer(length(q)), PACKAGE = "polspline") zz <- z$pp[sq] if(fit$bound[1] > 0) zz[q 0) zz[q>fit$bound[4]] <- 1 zz } qlogspline <- function(p, fit) { if(!inherits(fit, "logspline")) stop("fit is not a logspline object") if(!missing(p))p <- unstrip(p) sp <- rank(p) p <- sort(p) z <- .C("rpqlsd", as.double(c(fit$coef.pol, fit$coef.kts)), as.double(fit$knots), as.double(fit$bound), as.integer(0), qq = as.double(p), as.integer(length(fit$knots)), as.integer(length(p)), PACKAGE = "polspline") zz <- z$qq[sp] zz[p<0] <- NA zz[p>1] <- NA zz } rlogspline <- function(n, fit) { if(!inherits(fit, "logspline")) stop("fit is not a logspline object") pp <- runif(n) qlogspline(pp, fit) } dlogspline <- function(q, fit, log = FALSE) { if(!inherits(fit, "logspline")) stop("fit is not a logspline object") if(!missing(q))q <- unstrip(q) x <- q y <- fit$coef.pol[1] + x * fit$coef.pol[2] for(i in 1:length(fit$knots)) y <- y + fit$coef.kts[i] * ((abs(x - fit$knots[i]) +x- fit$knots[i])/2)^3 if(fit$bound[1] > 0) y[x < fit$bound[2]] <- -Inf if(fit$bound[3] > 0) y[x > fit$bound[4]] <- -Inf if (!log) y <- exp(y) y } plot.logspline <-function(x, n = 100, what = "d", add = FALSE, xlim, xlab = "", ylab = "", type = "l", ...) { fit <- x if(!inherits(fit, "logspline")) stop("fit is not a logspline object") if(add){ plim <- (par()$usr)[1:2] u4 <- plim[1] u3 <- plim[2] if(!missing(xlim)) { u4 <- max(xlim[1], plim[1]) u3 <- min(xlim[2], plim[2]) } } else{ if(missing(xlim)) { u1 <- qlogspline(0.01, fit) u2 <- qlogspline(0.99, fit) u3 <- 1.1 * u1 - 0.1 * u2 u4 <- 1.1 * u2 - 0.1 * u1 } else { u3 <- xlim[1] u4 <- xlim[2] }} xx <- (0:(n - 1))/(n - 1) * (u4 - u3) + u3 if(what == "d" || what == "D") yy <- dlogspline(xx, fit) if(what == "f" || what == "F" || what == "p" || what == "P") yy <- plogspline(xx, fit) if(what == "s" || what == "S") yy <- 1 - plogspline(xx, fit) if(what == "h" || what == "H") yy <- dlogspline(xx, fit)/(1 - plogspline(xx, fit)) if(missing(xlab)) xlab <- "" if(missing(ylab)) ylab <- "" if(missing(type)) type <- "l" if(add)lines(xx,yy, ...) else plot(xx, yy, xlab = xlab, ylab = ylab, type = type, ...) invisible() } print.logspline <- function(x,...) { summary.logspline(x) } summary.logspline <- function(object,...) { fit <- object if(!inherits(fit, "logspline")) stop("fit is not a logspline object") ul <- fit$penalty um <- fit$samples[1] if(length(fit$samples)>1) um <- fit$samples[1]+ fit$samples[4] else um <- fit$samples kk <- fit$logl[fit$logl[,2] != 0,1] ad <- fit$logl[fit$logl[,2] != 0,2] ll <- fit$logl[fit$logl[,2] != 0,3] bb <- -2 * ll + ul * (kk-1) cc1 <- bb cc2 <- bb cc2[1] <- Inf cc1[length(bb)] <- 0 if(length(bb) > 1) { for(i in 1:(length(bb) - 1)) { cc1[i] <- max((ll[(i + 1):(length(bb))] - ll[i])/(kk[(i + 1): (length(bb))] - kk[i])) cc2[i + 1] <- min((ll[1:i] - ll[i + 1])/(kk[1:i] - kk[i + 1])) } } c3 <- cc2 - cc1 cc1[c3 < 0] <- NA cc2[c3 < 0] <- NA uu <- cbind(kk, ad, ll, bb, 2 * cc1, 2 * cc2) ww <- rep("", length(bb)) dimnames(uu) <- list(ww, c("knots", "A(1)/D(2)", "loglik", "AIC", "minimum penalty", "maximum penalty")) print(round(uu, 2)) cat(paste("the present optimal number of knots is ",kk[bb== min(bb)],"\n")) if(ul == log(um)) cat(paste("penalty(AIC) was the default: BIC=log(samplesize): log(", um, ")=", round(ul, 2), "\n")) else cat(paste("penalty(AIC) was ", round(ul, 2), ", the default (BIC) ", "would have been", round(log(um), 2), "\n")) invisible() } polyclass <- function(data, cov, weight, penalty, maxdim, exclude, include, additive = FALSE, linear, delete=2, fit, silent = TRUE, normweight = TRUE, tdata, tcov, tweight, cv, select=0, loss, seed) { call <- match.call() if(!missing(cov))cov <- unstrip(cov) if(!missing(exclude))exclude <- unstrip(exclude) if(!missing(include))include <- unstrip(include) if(!missing(data))data <- unstrip(data) if(!missing(weight))weight <- unstrip(weight) if(!missing(tdata))tdata <- unstrip(tdata) if(!missing(tweight))tweight <- unstrip(tweight) if(!missing(tcov))tcov <- unstrip(tcov) it <- 0 ntdata <- 0 if(!missing(cv)) it <- 2 if(!missing(tdata))it <- 1 if(!missing(tdata))if(is.factor(tdata)) tdata <- as.integer(tdata) if(missing(cv)) cv <- 0 if(it==1||it==0) cv <- 0 if(it==2){ if(!missing(seed)){ if(sum(seed)!=0){ if(length(seed)>11) assign(".Random.seed", seed[1:12], envir=.GlobalEnv) else set.seed(seed[1]) seed <- get(".Random.seed", envir=.GlobalEnv, inherits = FALSE) } } else{ if(!missing(fit)){ if(fit$method==2) assign(".Random.seed", fit$seef, envir=.GlobalEnv) } seed <- get(".Random.seed", envir=.GlobalEnv, inherits = FALSE) } } z <- .C("spolyx", mk = as.integer(rep(-3,13)), PACKAGE = "polspline") MAXKNOTS <- z$mk[1] MAXSPACE <- z$mk[2] if(missing(data)) stop("there has to be data") if(length(data) < 25) stop("not enough data") if(is.factor(data)) data <- as.integer(data) if(is.integer(data) == FALSE){ if(max(abs(as.integer(data) - data)) < 0.001) data <- as.integer(data) else stop("not-integer data") } if(it == 1) { if(is.integer(tdata) == FALSE){ if(max(abs(as.integer(tdata) - tdata)) < 0.001) tdata <- as.integer(tdata) else stop("not-integer test data") } alldata <- c(data,tdata) if(min(alldata)<0) stop("negative data") clss <- min(alldata):max(alldata) if(min(alldata) == 1){ data <- data - 1 tdata <- tdata - 1 } ntdata <- length(tdata) if(missing(tweight)) tweight <- rep(1,ntdata) if(length(tweight)!=ntdata)stop("length tweight is incorrect") if(normweight == TRUE)tweight <- tweight*ntdata/sum(tweight) } else{ if(min(data)<0) stop("negative data") clss <- min(data):max(data) if(min(data) == 1) data <- data - 1 } nclass <- length(clss) ndata <- length(data) nu <- exists(".Random.seed", envir=.GlobalEnv, inherits = FALSE) if(nu) xx <- get(".Random.seed", envir=.GlobalEnv, inherits = FALSE) yy <- sample(ndata) if(nu)assign(".Random.seed", xx, envir=.GlobalEnv) if(missing(weight)) weight <- rep(1,ndata) if(it==2){ if(sum(abs(seed[1]))==0) myord <- 1:ndata else myord <- sample(ndata) data <- data[myord] weight <- weight[myord] } if(length(weight)!=ndata)stop("length weight is incorrect") if(normweight == TRUE)weight <- weight*ndata/sum(weight) if(missing(cov)) { stop("covariates required") } else { if(length(cov) == ndata) cov <- matrix(cov, ncol = 1, nrow = ndata) if(length(cov[, 1]) != ndata) stop("covariates not ndata * ncov matrix") if(it==2)cov <- cov[myord,] ncov <- length(cov[1, ]) nms <- 1:ncov if(is.matrix(cov)) nms <- dimnames(cov)[[2]] if(length(nms) != ncov) nms <- 1:ncov } if(missing(penalty) && it ==0) penalty <- log(ndata) if(missing(penalty) && it >0) penalty <- 0 il <- 1 if(select==1) il <- 0 if(select==2) il <- 2 if(delete!=0 && delete !=1) delete <- 2 iml <- missing(loss) if(iml) loss <- 1 - diag(rep(1,nclass)) if(il!=1 && !iml) stop("if loss is specified, select has to be 0") if((it == 0) && !iml) warning("loss only has effect when there is a test-set or CV is used") if(it == 1){ if(missing(tcov)) { if(ncov!=0)stop("missing tcov") tcov <- 0 } else { if(length(tcov) == ntdata) tcov <- matrix(tcov, ncol = 1, nrow = ntdata) if(length(tcov[, 1]) != ntdata) stop("test-covariates not ntdata * ncov matrix") ntcov <- length(cov[1, ]) if(ntcov!=ncov) stop("wrong number of test-covariates") } } naction <- nclass if(it>0){ if(is.matrix(loss)==FALSE)stop("loss is not a matrix") if(length(loss[1,])!=nclass)stop("loss has not nclass columns") naction <- length(loss[,1]) } if(additive) { if(!missing(exclude)) stop("cannot have exclude and additive") if(!missing(include)) stop("cannot have include and additive") include <- c(0, 0) } if(missing(exclude) + missing(include) == 0) stop("only 1 from exclude and include allowed") vexclude <- 0 if(missing(exclude) == FALSE) { if(length(exclude) == 2) exclude <- matrix(exclude, ncol = 2, nrow = 1) if(length(exclude[1, ]) != 2) stop("exclude has wrong shape") if(min(exclude) < 0 || max(exclude) > ncov) stop("exclude has wrong values") vexclude <- as.vector(t(exclude)) vexclude <- c(length(vexclude)/2, vexclude) } if(missing(include) == FALSE || additive) { if(length(include) == 2) include <- matrix(include, ncol = 2, nrow = 1) if(length(include[1, ]) != 2) stop("include has wrong shape") if(min(include) < 0 || max(include) > ncov) stop("include has wrong values") include <- t(apply(include, 1, sort)) if(length(include) == 2) include <- matrix(include, ncol = 2, nrow = 1) vexclude <- as.vector(t(include)) vexclude <- c( - length(vexclude)/2, vexclude) } if(missing(maxdim)) { maxdim <- floor(4 * (ndata)^(1/3))+1 maxdim <- min(ndata/2, MAXSPACE-1, (nclass-1)*maxdim) maxdim <- - maxdim } if(maxdim > MAXSPACE - 1) { maxdim <- MAXSPACE - 1 print(paste("maximum dimension reduced to", maxdim)) } lins <- rep(0, MAXSPACE) if(!missing(linear)) { linear[linear <= 0] <- ncov + 1 linear[linear > ncov + 1] <- ncov + 1 lins[linear] <- 1 } if(additive) vexclude <- c(-1, 0, 0) # do it fitter <- 0 bbtt <- matrix(0, ncol = 4 + max(data), nrow = abs(maxdim)) cckk <- matrix(0, ncol = (MAXKNOTS + 1), nrow = ncov+1) if(!missing(fit)) { if(!inherits(fit, "polyclass"))stop("fit is not a polyclass object") fitter <- (fit$nclass-1)*(fit$nbas) if(fit$ncov != ncov) stop("ncov and fit's ncov are different") if(fit$nclass != nclass) stop("nclass and fit's nclass are different") a1 <- length(fit$fcts[1,]) bbtt[1:fit$nbas, ] <- fit$fcts[,-a1] bbtt <- as.vector(t(bbtt)) bbtt[is.na(bbtt)] <- -1 a1 <- length(fit$knots[1, ]) a2 <- as.vector(t(fit$knots)) cckk <- as.vector(cckk) cckk <- c(a1,a2,cckk) cckk[is.na(cckk)] <- -1 } mindist <- 3*nclass if(missing(tdata)){ tdata<-0 tcov <-0 tweight <- 0 } ranges <- NA if(ncov == 1) ranges <- matrix(range(cov), ncol = 1, nrow = 2) if(ncov > 1) ranges <- apply(cov, 2, range) # done cov <- as.single(t(cov)) aicx <- as.single(rep(0,1000)) intpars <-c(ndata,nclass,ncov,mindist,maxdim,silent,fitter,cv,it,ntdata, naction,il,delete) anova <- loss if(length(anova) 0) dimnames(z$cckk) <- list(nms, c("K", 1:l1)) if(l1 == 0) dimnames(z$cckk) <- list(nms, "K") z$bbtt <- matrix(z$bbtt, ncol = 3 + nclass) z$bbtt <- cbind(z$bbtt, 0) dimnames(z$bbtt) <- list(1:nbas, c("dim1", "knot1", "dim2", "knot2", as.character(clss))) z$bbtt[z$bbtt[, 3] == -1, 3:4] <- NA z$bbtt[z$bbtt[, 4] == 0, 4] <- NA z$bbtt[1,1] <- NA i <- z$logl[1] z$logl <- matrix(z$logl[2:(11*i+1)],ncol=11,byrow=TRUE) z$logl[z$logl[,10]<0,10] <- NA z$logl[z$logl[,11]<0,11] <- NA z$logl[1,11] <- Inf dimnames(z$logl) <- list(NULL, c("dim","loss","l-lik-trn","loss-trn", "sq-err-trn","l-lik-test","loss-tst","sq-err-tst" , "A/D","pen-min","pen-max")) if(it!=1){ dimnames(z$logl)[[2]][2] <- "AIC" z$logl <- z$logl[,-(6:8)] } anova <- z$anova[2:(1+z$anova[1])] anova[anova<0] <- NA anova <- matrix(anova,ncol=3,byrow=TRUE) dimnames(ranges) <- list(c("min", "max"), nms) z$bbtt[0, 0] <- NA z$bbtt[z$bbtt[, 2] == 0, 2] <- NA z$bbtt[z$bbtt[, 2] == 0, 4] <- NA if(nclass==naction) yyy <- clss else yyy <- 1:naction if(it!=0)dimnames(loss) <- list(as.character(yyy),clss) if(il!=1)loss <- -1 bbb <- z$bbb bbb <- bbb[1:(nbas*nclass)] bbb <- matrix(bbb,nrow=nbas,byrow=TRUE) if(it==0){ nfit <- list(call = call, ncov = ncov, ndim = ndim, nclass = nclass, nbas = nbas, fcts = z$bbtt, knots = z$cckk, penalty = penalty, method = it, ranges = ranges, logl= z$logl, sample = ndata, wgtsum = sum(weight), covnames = nms, classnames = clss, beta = bbb, delete = delete, anova = anova) } else{ if(it==1) nfit <- list(call = call, ncov = ncov, ndim = ndim, nclass = nclass, nbas = nbas, naction = naction, fcts = z$bbtt, knots = z$cckk, loss = loss, penalty = penalty, method = it, ranges = ranges, logl= z$logl, sample = ndata, tsample = ntdata, wgtsum = sum(weight), covnames = nms, classnames = clss, beta = bbb, delete = delete, anova = anova, select = select, twgtsum = sum(tweight)) else nfit <- list(call = call, ncov = ncov, ndim = ndim, nclass = nclass, nbas = nbas, naction = naction, fcts = z$bbtt, knots = z$cckk, cv = cv, loss = loss, penalty = penalty, method = it, ranges = ranges, logl= z$logl, sample = ndata, wgtsum = sum(weight), covnames = nms, classnames = clss, cv.aic = aicx, cv.tab = aicy, seed = seed, beta = bbb, delete = delete, anova = anova, select = select) } class(nfit) <- "polyclass" nfit } cpolyclass <- function(cov, fit) { if(!inherits(fit, "polyclass"))stop("fit is not a polyclass object") if(!missing(cov))cov <- unstrip(cov) xxx <- ppolyclass(cov, fit) yyy <- fit$classnames if(fit$method!=0){ if(length(fit$loss)==1) fit$loss <- 1 - diag(rep(1,fit$nclass)) xxx <- t(-fit$loss%*%t(xxx)) if(fit$nclass==fit$naction) yyy <- fit$classnames else yyy <- 1:fit$naction } zzz <- xxx[, 1] www <- rep(yyy[1], length(zzz)) for(i in 2:length(yyy)) { www[zzz < xxx[, i]] <- yyy[i] zzz[zzz < xxx[, i]] <- xxx[zzz < xxx[, i], i] } www } ppolyclass <- function(data, cov, fit) { imf <- missing(fit) if(imf) { fit <- cov cov <- data } if(!missing(cov))cov <- unstrip(cov) if(!missing(data))data <- unstrip(data) if(!missing(data) && is.factor(data)) data <- as.integer(data) if(!inherits(fit, "polyclass"))stop("fit is not a polyclass object") if(is.matrix(cov) == FALSE) cov <- matrix(cov, ncol = 1) if(length(cov[1, ]) != fit$ncov) { if(length(cov[1, ]) == 1 && length(cov[, 1]) == fit$ncov) cov <- t(cov) else stop("incorrect number of covariates") } ncase <- length(cov[, 1]) nclass <- fit$nclass nbas <- length(fit$fcts[, 1]) if(imf || missing(data)) data <- rep(-1, ncase) if(length(data) == 1) data <- rep(data, ncase) if(is.integer(data) == FALSE) if(max(abs(as.integer(data) - data)) < 0.001) data <- as.integer(data) else stop("not-integer data") w2 <- fit$classnames if(data[1] != -1 && (min(w2) > min(data) || max(w2) < max(data))) stop("data has wrong range") if(min(data) == 0) data <- data + 1 ppp <- matrix(0, ncol = nclass, nrow = ncase) for(i in 1:(nclass - 1)) ppp[, i] <- (fit$fcts[1, (4 + i)]) if(nbas > 1) for(j in 2:nbas) { uuu <- cov[, fit$fcts[j, 1]] if(is.na(fit$fcts[j, 2]) == FALSE) { uuu <- uuu - fit$knots[fit$fcts[j, 1], fit$fcts[ j, 2] + 1] uuu[uuu < 0] <- 0 } vvv <- rep(1, ncase) if(is.na(fit$fcts[j, 3]) == FALSE) { vvv <- cov[, fit$fcts[j, 3]] if(is.na(fit$fcts[j, 4]) == FALSE) { vvv <- vvv - fit$knots[fit$fcts[j, 3], fit$ fcts[j, 4] + 1] vvv[vvv < 0] <- 0 } } uuu <- uuu * vvv for(i in 1:(nclass - 1)) ppp[, i] <- ppp[, i] + uuu * fit$fcts[j, (4 + i )] } ppp <- ppp-apply(ppp,1,max) ppp <- exp(ppp) zzz <- ppp[, nclass] for(i in 1:(nclass - 1)) zzz <- zzz + ppp[, i] for(i in 1:nclass) ppp[, i] <- ppp[, i]/zzz if(data[1] == -1) dimnames(ppp) <- list(NULL, fit$classnames) else ppp <- ppp[cbind(1:ncase, data)] ppp } plot.polyclass <- function(x,cov, which, lims, what, data, n, xlab, ylab, zlab, ...) { if(!inherits(x, "polyclass"))stop("x is not a polyclass object") if(!missing(cov))cov <- unstrip(cov) fit <- x here <- c(-1, -1) if(length(which) == 1 || length(which) == 2) here[1] <- length(which) here[2] <- as.integer(what) if(here[2]< 1||here[2]>8) stop("what is wrong") if(min(here) < 0) stop("which is wrong") if(here[2] < 5.5 && here[1] == 1) stop("which and what contradict") if(here[2] > 5.5 && here[1] == 2) stop("which and what contradict") if(length(cov) != fit$ncov) stop("length of cov is wrong") clbs <- fit$covnames ww <- fit$classnames w1 <- (1:fit$ncov) if(missing(lims)) lims <- NULL if(length(lims) != 0 && length(lims) != (here[1] * 2)) stop("lims is wrong") wa <- 0 for(i in 1:length(which)){ if(is.numeric(which) == FALSE) wa <- c(wa,w1[which[i] == clbs]) else wa <- c(wa,w1[w1 == which[i]]) } wa <- wa[-1] if(length(wa) != here[1]) stop("which is wrong") wb <- clbs[wa] if(here[2] < 3.5 || here[2] > 7.5) { if(missing(data)) stop("data is missing") if(length(data) > 1) stop("only one class (data) allowed") } if(length(lims) == 0) { if(here[1] == 1) lims <- fit$ranges[, wa] else lims <- c(fit$ranges[, wa[1]], fit$ranges[, wa[2]]) } if(missing(xlab)) xlab <- as.character(wb[1]) if(missing(ylab)) { if(here[1] == 2) ylab <- as.character(wb[2]) if(here[2] > 6.5) ylab <- "probability" if(here[2] == 6) ylab <- "class" } if(missing(zlab) && here[2] == 2) zlab <- "probability" if(missing(n) && here[1] == 1) n <- 250 if(missing(n) && here[1] == 2) n <- 50 if(here[1] == 1) { cov <- matrix(cov, byrow = TRUE, nrow = n, ncol = fit$ncov) c1 <- lims[1] + ((lims[2] - lims[1]) * (0:(n - 1)))/(n - 1) cov[, wa] <- c1 } if(here[1] == 2) { cov <- matrix(cov, byrow = TRUE, nrow = n * n, ncol = fit$ncov) c1 <- lims[1] + ((lims[2] - lims[1]) * (0:(n - 1)))/(n - 1) c11 <- (rep(c1, n)) cov[, wa[1]] <- c11 c2 <- lims[3] + ((lims[4] - lims[3]) * (0:(n - 1)))/(n - 1) c22 <- sort(rep(c2, n)) cov[, wa[2]] <- c22 } if(here[2] <= 3) { v1 <- ppolyclass(data, cov, fit) v1 <- matrix(v1, n, n) if(here[2] == 1) contour(c1, c2, v1, xlab = xlab, ylab = ylab, ...) if(here[2] == 2) persp(c1, c2, v1, xlab = xlab, ylab = ylab, zlab = zlab, ...) if(here[2] == 3) image(c1, c2, v1, xlab = xlab, ylab = ylab, ...) } if(here[2] == 6) { v1 <- cpolyclass(cov, fit) plot(c1, v1, type = "l", ylim = range(ww), xlab = xlab, ylab = ylab, ...) } if(here[2] == 8) { v1 <- ppolyclass(data, cov, fit) plot(c1, v1, type = "l", xlab = xlab, ylab = ylab, ...) } if(here[2] == 4 || here[2] == 5) { v1 <- cpolyclass(cov, fit) v1 <- matrix(v1, n, n) if(here[2] == 5) image(c1, c2, v1, xlab = xlab, ylab = ylab, ...) } if(here[2] == 4) { zz <- range(v1) z1 <- 1 * (v1 < zz[1] + 0.5) contour(c1, c2, z1, xlab = xlab, ylab = ylab, levels = 0.5, labex = 0, ...) if(zz[2] - zz[1] > 1) for(i in (zz[1] + 1):(zz[2] - 1)) { z1 <- 1 * (v1 < i + 0.5) contour(c1, c2, z1, labex = 0, levels = 0.5, add = TRUE, ...) } } if(here[2] == 7) { v1 <- ppolyclass(cov, fit) plot(c1, v1[, 1], type = "l", xlab = xlab, ylab = ylab, ylim = c(0, 1), ...) abline(h = c(0, 1)) zz <- length(v1[1, ]) if(zz > 2) for(i in 2:zz) { v1[, 1] <- v1[, 1] + v1[, i] lines(c1, v1[, 1]) } } invisible() } rpolyclass <- function(n, cov, fit) { if(!inherits(fit, "polyclass"))stop("fit is not a polyclass object") if(!missing(cov))cov <- unstrip(cov) if(n < 1) stop("n is wrong") if(is.matrix(cov) == FALSE) cov <- matrix(cov, nrow = 1) if(length(cov[1, ]) != fit$ncov) stop("wrong number of covariates") if(n > 1 && length(cov[, 1]) == 1) cov <- matrix(cov, nrow = n, ncol = fit$ncov, byrow = TRUE) if(n != length(cov[, 1])) stop("cov has wrong number of rows") vv <- ppolyclass(cov, fit) ww <- runif(n) zz <- rep(fit$nclass, n) for(i in 2:fit$nclass) vv[, i] <- vv[, i] + vv[, (i - 1)] for(i in fit$nclass:1) zz[ww < vv[, i]] <- i if(min(fit$classnames) == 0) zz <- zz - 1 zz } print.polyclass <- function(x,...) { summary.polyclass(x) } summary.polyclass <- function(object,...) { if(!inherits(object, "polyclass"))stop("object is not a polyclass object") fit <- object it <- fit$method cat("========================POLYCLASS summary=======================\n") cat(paste("The fit was obtained with\n ")) cat("\b\b") print(fit$call) cat(paste("There were",fit$nclass,"classes and", fit$ncov,"covariates.\n")) if(it == 1) cat(paste("There were", fit$sample, "trial cases and", fit$tsample, "test cases.\n\n")) else cat(paste("There were",fit$sample,"cases.\n\n")) if(it == 0) { cat("The model selection was carried out using AIC.\n") if(0.99 < fit$penalty/log(fit$wgtsum)&&fit$penalty/log(fit$wgtsum) <1.01){ cat(paste("The penalty was the default, log(")) cat(paste(round(fit$wgtsum), "\b)=")) cat(paste(round(log(fit$wgtsum), 2), "\b.\n")) } else{ cat(paste("The penalty was", round(fit$penalty, 2), "\b, the default would have been log(")) cat(paste("\b",round(fit$wgtsum), "\b)=")) cat(paste(round(log(fit$wgtsum), 2), "\b.\n")) } } if(it == 1) cat("The model selection was carried out using a test set.\n") if(it == 2) cat(paste("The model selection was carried out using", fit$cv, "\b-fold cross-validation.\n")) if((it == 1 || it == 2) && fit$select==0) { a2 <- range(fit$loss + diag(rep(1, fit$nclass))) if(a2[2] == 1 && a2[1] == 1) cat("The standard loss-matrix was used.\n") else cat("A loss matrix was provided.\n") } if((it == 1 || it == 2) && fit$select ==2) { cat("The sum of squared probabilities was used for the loss.\n") } if((it == 1 || it == 2) && fit$select ==1) { cat("Minus the test set log likelihood was used for the loss.\n") } if(length(fit$logl)<12)fit$logl<-t(as.matrix(fit$logl)) a2 <- fit$logl[fit$logl[,1]==fit$ndim, ] cat(paste("The model had dimension", fit$ndim, "\b, log-likelihood",round(a2[3], 2))) if(it == 0) cat(paste(" and AIC", round( a2[2], 2), "\b.\n\n")) if(it == 1) cat(paste(" and loss", round( a2[2], 2), "\b.\n\n")) if(it == 2) cat(paste(" and AIC", round( a2[2], 2), "\b.\n\n")) if(it == 2){ cat(paste("The penalty was cross-validated between", round(fit$cv.aic[1],2))) if(fit$cv.aic[2]<0) cat(paste(" and Inf to",round(fit$cv.aic[4],2))) else cat(paste(" and",round(fit$cv.aic[2],2),"to", round(fit$cv.aic[4],2))) cat(paste(" (loss",round(fit$cv.aic[3],2),"\b).\n")) cat(paste("The default penalty would have been log(", round(fit$wgtsum), "\b)=", round(log(fit$wgtsum), 2), "\b.\n")) } cat("The locations of the knots:\n") dimnames(fit$knots)[[2]][1] <- "Number" print(round(fit$knots, 3)) cat(paste("\n There are", fit$nbas, "basis functions, summarized below:\n")) a3 <- length(dimnames(fit$fcts)[[2]]) for(i in 5:a3) dimnames(fit$fcts)[[2]][i] <- paste("Class",dimnames(fit$fcts)[[2]][i]) print(round(fit$fcts, 3)) cat("The first basis function is the constant function. For all others,\n") cat("the first column and the third column indicate on which covariates\n") cat("that basis function depends. If the third column is NA, the basis\n") cat("function depends on only one covariate.\n") cat("For the nonconstant basis functions the second and the fourth column\n") cat("indicate on which knot the function depend. If these columns are NA,\n") cat("the basis function is linear in this covariate.\n") cat("The remaining columns give the coefficients.\n") cat("\n") cat("================================================================\n") if(fit$method==0) cat("The influence of the penalty parameter is summarized below:\n") if(fit$method==1) cat("The effect of the penalty in the final run is summarized below:\n") if(fit$method==2) cat("The equivalence of the penalty parameter is summarized below:\n") dimnames(fit$logl)[[1]] <- rep("",length(fit$logl[,1])) fit$logl[,3:5] <- fit$logl[,3:5]/fit$wgtsum if(fit$method==1)fit$logl[,6:8] <- fit$logl[,6:8]/fit$twgtsum fit$logl[,"AIC"] <- (-fit$logl[,"AIC"]) print(round(fit$logl, 3)) fit$logl[,"AIC"] <- (-fit$logl[,"AIC"]) if(fit$method==2){ cat("The relation between the CV-loss and the penalty is summarized below:\n") dimnames(fit$cv.tab)[[1]] <- rep("",length(fit$cv.tab[,1])) print(round(fit$cv.tab, 3))} cat("================================================================\n") cat("The importance-anova decomposition is:\n") anova <- fit$anova anova[,3] <- anova[,3]*100 dimnames(anova) <- list(rep("",length(anova[,1])), c("Cov-1","Cov-2","Percentage")) print(round(anova,2)) cat("================================================================\n") invisible() } beta.polyclass <- function(fit, which, xsp = 0.4, cex) { if(!inherits(fit, "polyclass"))stop("fit is not a polyclass object") plot(c(0, 1), c(0, 1), axes = FALSE, xlab = "", xlim = c(0.1, 0.9), ylim = c(0.1, 0.9), ylab = "", type = "n") lines(c(0, 1, 1, 0, 0), c(1, 1, 0, 0, 1)) xsp <- xsp/4 if(missing(which)) which <- fit$classnames if(fit$classnames[1] == 0) which <- which + 1 if(missing(cex)) cex <- par()$cex nb <- fit$nbas lines( c(4 * xsp,4*xsp),c(0,1)) b11 <- fit$beta for(i in 1:nb) { b1 <- fit$fcts[i, ] y1 <- 1 - (i - 0.5)/nb y0 <- 1 - (i - 1)/nb y2 <- 1 - (i - 0)/nb lines(c(0, 4 * xsp), c(y0, y0)) lines(c(2 * xsp, 2 * xsp), c(y0, y2)) aa <- fit$covnames[b1[1]] if(is.na(b1[2])) aa <- paste(aa, "linear") else aa <- paste(aa, "at", signif(fit$knots[b1[1], b1[2] + 1], 2)) if(i==1)aa <- "constant" text(xsp, y1, aa, cex = cex) if(is.na(b1[3]) == FALSE) { aa <- fit$covnames[b1[3]] if(is.na(b1[4])) aa <- paste(aa, "linear") else aa <- paste(aa, "at", signif(fit$knots[b1[3], b1[4] + 1], 2)) text(xsp * 3, y1, aa, cex = cex) } lines(c(4 * xsp + 0.03, 0.97), c(1 - (i - 0.1)/nb, 1 - (i - 0.1)/nb)) } b2 <- range(b11) for(i in 1:nb) { b1 <- round(((0.92-4*xsp)*(b11[i,]-b2[1]))/(b2[2]-b2[1])+4*xsp+0.04,2) aa <- rep(1, length(b1)) for(j in 1:length(b1)) aa[j] <- sum(abs(b1[1:j] - b1[j]) < 0.01) bb <- max(aa) if(bb > 1) bb <- 0.7/(nb * bb) for(j in which) text(b1[j], 1 - (i - 0.2)/nb + bb * (aa[j] - 1), as.character(fit$classnames[j])) } invisible() } testhare <- c(4.974595958,0,1,2.456985,8,38,5.229125,1,3.422498434,0,0,2.177377,7,49,5.277500,0 ,4.290693972,1,0,4.381446,20,54,5.485566,0,11.301950208,0,0,3.526174,10,65,4.621450,0 ,10.683645663,0,1,1.150400,5,34,4.766442,1,3.741203855,1,0,5.087841,13,52,6.405083,0 ,7.141522554,0,1,1.056958,8,46,4.682535,1,2.563535609,1,1,1.278860,6,25,4.556451,1 ,3.701746380,0,1,3.999343,10,54,6.084539,0,6.395697579,0,1,1.336799,7,59,4.631800,0 ,0.275924575,1,0,4.426891,10,45,5.141796,1,7.993160854,0,0,1.512389,8,53,4.976703,0 ,10.650698724,0,1,2.227674,3,56,4.770898,0,1.015110143,1,0,5.693455,13,71,4.648958,0 ,3.805403838,1,0,2.315779,5,45,4.921255,1,8.068892808,1,1,3.921555,14,29,4.820110,1 ,0.944656017,1,0,6.564750,10,46,4.194352,1,1.320377850,1,1,2.505369,30,53,5.652503,0 ,4.858707158,0,1,3.818449,8,24,5.283514,1,12.207398556,0,1,3.033311,3,50,4.506939,0 ,10.981959783,0,0,2.896733,17,62,4.637291,0,3.407096607,0,1,1.175291,13,58,5.060192,0 ,7.508765234,0,0,3.347511,9,44,5.096031,1,5.665519855,0,1,1.961776,3,30,5.067910,1 ,11.655373133,0,0,3.555977,3,44,4.810457,0,1.961668982,1,1,7.169299,5,28,5.025885,1 ,9.198057574,1,1,2.027242,7,40,5.077524,1,8.781112429,0,0,3.017898,19,61,4.660392,0 ,1.093624486,1,1,6.143122,8,39,4.956558,1,2.924913855,1,1,4.724365,13,67,4.627196,0 ,10.315301712,0,0,3.139070,15,70,6.654374,0,3.512635454,0,1,1.635826,3,50,6.034860,0 ,1.883750176,1,1,2.651898,7,51,5.034317,1,4.690818787,1,1,5.931697,13,29,5.220239,0 ,4.525531470,0,1,1.882305,4,48,6.011017,0,1.643812226,1,1,4.041397,17,39,5.052686,1 ,4.777447362,0,1,1.906920,5,34,5.695211,1,2.127848760,0,0,2.436000,7,42,4.745345,1 ,8.193705169,0,0,5.602968,15,39,5.161291,1,10.871217535,0,1,3.307412,3,50,4.506939,0 ,3.646383136,0,1,3.742517,4,42,5.357143,1,1.809633167,1,1,3.949245,5,28,5.015292,1 ,9.403031955,0,1,1.650917,9,66,4.374088,0,2.598629459,0,0,5.005954,20,54,5.270361,0 ,0.716941135,0,0,2.367035,15,29,5.151093,1,1.149237689,1,0,3.917028,3,66,5.229125,0 ,6.634921268,1,0,3.619424,2,39,4.753973,1,6.677475551,0,0,2.680901,3,59,4.619330,0 ,1.853423959,1,0,7.280685,13,39,5.374839,1,1.977927943,1,1,1.479475,5,40,5.329045,1 ,3.071427712,1,1,6.376802,17,61,4.761905,0,5.729473555,0,1,2.209530,4,70,5.251685,0 ,12.999040825,0,1,3.899504,7,45,4.800717,1,4.059714382,0,1,3.377176,5,32,4.535342,1 ,0.744850674,1,0,4.984910,20,55,6.196016,0,0.855878893,1,0,7.315716,7,47,5.851493,1 ,9.801334057,0,0,1.829557,5,54,5.921052,1,8.941585984,0,0,3.592722,4,33,4.594660,1 ,2.148160196,1,0,2.452756,7,41,4.230605,1,3.481338340,1,1,4.809930,7,34,5.247021,1 ,6.696794779,0,1,5.234634,17,46,4.693797,0,3.835564836,1,0,4.091902,13,32,5.455447,1 ,1.005947051,1,0,8.155644,17,56,5.352583,0,3.254906373,0,0,2.894001,13,38,4.860499,1 ,3.673054257,0,1,3.269990,8,56,6.070261,0,6.852679664,0,0,2.728159,3,27,4.902511,1 ,3.766346315,0,0,1.107997,6,52,4.599488,0,0.722085805,1,1,2.561833,13,31,4.705882,1 ,5.808865352,0,1,4.302919,12,48,4.778376,0,0.758610999,1,1,4.873266,13,68,4.781478,0 ,8.604434532,0,0,3.738226,10,50,4.980119,0,0.649993805,1,0,1.755723,5,62,5.077524,0 ,8.846562896,0,0,2.704749,7,33,5.344762,1,8.872918703,0,1,1.049267,13,57,4.848485,0 ,4.903475126,0,0,4.319373,3,52,5.294117,0,11.336698376,0,0,2.686271,4,60,4.475359,0 ,3.752937025,0,1,6.675384,8,52,5.418258,1,1.177802659,1,1,1.113398,12,35,5.425139,1 ,8.781171469,0,1,1.224230,8,43,5.010377,1,9.027689550,0,1,2.545398,6,23,5.728220,1 ,3.495951230,0,1,4.830449,13,23,4.115462,1,3.514034237,0,1,4.004309,17,54,4.984073,0 ,9.832671190,0,0,2.545287,5,22,3.697551,1,4.314590803,1,0,3.193582,10,49,4.848485,1 ,1.502567605,1,0,4.507756,6,41,5.131558,1,5.588331033,0,1,4.173111,8,38,4.328138,1 ,4.473941263,1,1,3.461476,17,51,5.038911,0,3.918024806,1,0,2.239662,3,43,4.666667,1 ,9.091762674,0,1,1.049056,5,48,4.836185,0,1.080213129,1,1,4.159584,30,43,5.518136,1 ,7.434034034,0,1,3.408190,5,43,4.984073,1,4.965729778,0,1,3.387252,8,32,5.659616,1 ,4.086529910,0,1,2.015208,5,52,4.860499,0,2.178294984,1,1,4.064211,5,39,5.221878,1 ,3.600221681,0,1,1.750524,10,50,4.355976,1,0.633003287,1,0,4.965685,17,22,4.923234,1 ,6.274058768,0,1,1.757575,7,28,4.841229,1,0.808337851,1,1,1.089425,7,39,5.014839,1 ,8.438751752,0,1,1.066097,3,53,5.454607,0,8.904313667,1,1,3.176962,13,43,5.180603,1 ,5.557537136,1,1,2.930177,10,29,5.474375,1,5.199344839,0,1,1.768274,10,29,5.959141,1 ,3.468550196,0,1,3.505014,5,32,4.535342,1,6.120901706,0,1,1.958902,8,46,4.682535,1 ,2.638955051,1,0,5.593618,10,46,5.555451,1,5.793515954,0,1,3.807752,7,49,4.944132,1 ,0.002876836,0,1,2.647479,7,22,4.960784,1,5.017167941,0,1,3.003154,7,37,4.974027,1 ,3.084513249,0,1,1.570307,13,45,4.847189,1,10.665055115,0,1,3.320491,8,41,6.014000,1 ,10.370884446,0,0,1.159649,5,50,5.252364,0,3.721920684,0,1,3.817728,4,42,5.357143,1 ,3.608864926,1,0,2.325495,10,44,4.724556,1,4.270983923,1,1,2.324736,7,53,4.250432,0 ,3.312833467,1,0,3.841955,8,58,4.827945,0,4.252580879,1,1,1.212867,8,32,5.516086,1 ,1.926961555,1,1,4.700265,12,68,5.286123,0,2.337763801,1,0,3.896992,3,55,5.374839,0 ,3.856019937,0,0,2.141238,8,52,4.819277,0,7.267598202,0,1,2.835711,6,33,4.508021,1 ,2.815494852,1,0,3.391577,5,34,5.421687,1,6.646758005,0,1,7.461381,7,44,5.115846,1 ,5.757489061,0,1,1.978295,27,67,4.908459,0,7.072637549,0,0,1.542867,7,55,4.781461,1 ,0.242647827,0,1,4.614868,8,24,5.329045,1,5.721986249,0,0,3.803286,27,53,4.607373,0 ,1.869202546,1,1,1.941625,9,44,5.059026,1,7.093576279,0,0,1.198225,5,43,4.660392,1 ,4.924369386,1,0,7.218409,10,56,4.414404,0,5.541972634,0,1,2.106218,15,48,5.223193,1 ,4.777928196,1,1,3.838427,10,34,4.902511,1,2.288150712,1,1,4.782008,11,52,5.386785,0 ,3.875663734,0,1,3.145217,5,40,5.038871,1,6.435290254,0,0,1.437421,11,43,4.915615,1 ,3.651424411,0,0,4.634806,3,57,5.128117,0,3.437407842,1,1,3.025336,10,53,5.583828,1 ,5.942381638,0,1,1.767708,7,45,5.386785,1,1.844332249,1,1,1.122816,7,48,5.038911,1 ,6.159103114,0,0,1.327351,13,64,5.153882,0,0.864839180,0,0,3.753201,8,73,4.666667,0 ,4.012976033,0,0,3.832005,10,43,5.257000,1,1.308869072,1,0,2.659949,16,56,4.921529,0 ,4.437839179,0,1,4.888316,10,45,4.615931,1,5.572560916,0,1,3.144377,3,44,5.951397,1 ,2.299757972,1,1,4.471766,13,36,4.850811,1,1.677105018,1,1,4.428328,8,29,5.453168,1 ,6.498067211,0,0,2.614110,5,53,4.861484,0,4.267064982,1,0,3.097657,3,55,5.052686,0 ,1.625555118,1,1,1.600333,7,30,4.548680,1,8.675170724,0,0,2.526882,8,35,5.315730,1 ,2.231627990,1,1,3.222574,15,47,5.000000,1,4.314665431,0,1,4.291517,10,59,4.652018,0 ,4.281169110,0,1,4.733467,10,51,4.913402,0,3.290729834,0,1,2.427684,9,60,4.493949,0 ,2.659039388,1,1,2.069452,9,47,4.276304,1,4.318971205,0,0,4.470250,8,25,4.694526,1 ,5.860576271,0,0,2.539947,17,52,4.668973,0,2.315594708,1,1,4.020647,23,29,5.115846,1 ,2.804584226,1,1,5.534834,7,36,5.553775,1,7.975260185,0,0,3.792803,5,62,4.660265,0 ,1.106782961,1,1,9.358279,28,37,5.333333,1,2.501710933,1,0,2.566242,10,58,5.552011,0 ,7.529826116,1,1,1.469639,17,51,4.672253,0,7.114662981,0,0,3.256092,10,60,5.295317,0 ,4.663097138,1,1,3.591701,7,48,5.770498,0,2.589886223,1,1,3.334416,10,76,4.668973,0 ,4.424446586,0,0,1.197006,8,49,4.948717,1,0.602173486,1,0,5.747700,9,37,5.517594,1 ,2.288680116,0,1,6.681697,15,25,5.313040,1,4.138863511,0,0,1.686351,10,28,6.073310,1 ,0.143355979,0,1,4.700276,17,67,4.686909,0,1.620006848,1,1,3.728193,13,66,4.550068,0 ,4.152298128,1,1,5.478927,7,23,4.908459,1,6.251817060,0,1,4.321571,13,61,4.886249,0 ,9.441347218,0,1,1.159361,27,53,4.478945,0,4.664831930,0,1,1.100395,4,33,4.594265,1 ,7.672083922,0,1,3.318092,15,65,5.225269,0,2.932772797,1,0,4.330532,5,45,4.753750,1 ,3.730763147,1,0,1.196599,9,75,4.292613,0,8.669274496,0,1,4.078849,10,54,4.733728,0 ,3.210499902,1,0,4.826839,10,57,4.997703,0,5.740347834,0,1,3.048919,11,58,4.652018,0 ,1.818485626,1,1,4.413885,22,61,6.091449,0,6.508071678,1,1,3.734937,10,55,4.892449,0 ,8.548549536,0,1,1.650514,5,30,4.886216,1,4.437758745,0,0,6.218407,10,63,4.491464,0 ,2.424876189,1,0,3.361363,3,55,5.374839,0,1.102067806,1,1,4.190865,7,46,6.214974,1 ,4.385735762,1,1,4.993822,3,30,4.607373,1,2.014738577,1,1,6.646280,15,72,4.615620,0 ,6.180637882,0,1,3.544051,10,62,5.223193,0,4.254613903,0,1,2.863435,7,50,4.503865,0 ,8.403602001,0,1,3.592442,14,36,5.345836,1,4.647634726,0,1,2.318024,4,31,4.966996,1 ,5.131910086,0,1,2.351699,11,40,5.277500,1,1.344906684,1,0,1.606278,8,46,5.404638,1 ,1.532573575,1,0,6.670015,19,68,5.116169,0,1.232745480,0,1,5.068406,13,51,4.965363,0 ,1.037380417,1,0,6.248003,8,49,4.891389,0,8.589759928,0,1,1.391212,7,62,4.145781,0 ,1.790415350,1,1,2.591412,8,46,4.952207,1,8.620250368,0,0,2.692689,10,39,5.423261,1 ,0.767846852,1,0,8.315848,10,43,5.219121,1,9.112477010,0,0,2.741637,8,35,5.315730,1 ,0.931669122,1,1,2.236075,13,42,4.789794,1,12.337309722,0,0,1.643076,13,44,4.923659,1 ,5.651648457,0,1,2.655148,7,67,5.625326,0,9.887523533,0,1,3.089551,17,51,5.336655,0 ,0.527471159,1,0,5.521132,9,37,5.517594,1,2.635730106,1,1,2.267928,10,64,4.408289,0 ,0.684619288,1,1,1.799920,12,30,4.272742,1,3.696458325,0,0,1.079333,6,30,5.070603,1 ,1.492219376,0,1,2.218436,10,31,5.324759,1,6.978924470,0,1,1.167364,13,53,5.045599,0 ,4.287556533,0,1,3.195852,20,61,4.694526,0,9.563446520,0,1,1.345802,7,53,4.789546,0 ,6.543785368,1,1,3.793917,12,36,5.006571,1,2.673429072,0,0,6.431115,3,31,4.652324,1 ,3.497507432,1,1,3.026543,14,37,6.250000,1,7.274422542,0,1,1.216880,5,63,4.731417,0 ,11.423145428,0,1,3.599164,10,55,4.921529,0,9.941126805,0,1,3.158260,3,48,4.649801,0 ,5.630463122,0,1,4.641624,10,54,4.535342,0,4.441394618,0,1,1.021535,5,53,4.521807,0 ,6.712453194,0,1,1.310118,13,44,5.340002,1,0.220304507,0,0,1.260606,10,62,5.526557,0 ,6.194856035,1,1,3.475943,7,39,4.075414,1,6.909127758,0,1,7.057882,7,65,4.798963,0 ,6.178783402,0,1,4.908034,8,33,5.257357,0,3.377913012,0,1,6.624742,13,53,4.633481,0 ,7.414119272,0,0,5.547483,13,33,4.953681,1,6.751937838,0,1,2.774286,8,39,5.521156,1 ,5.701612672,0,0,7.545380,11,34,5.052686,1,2.066030486,1,1,3.576639,8,55,5.370431,0 ,9.254740104,0,1,1.728768,5,22,4.881406,1,9.515433653,0,1,3.845054,17,51,5.336655,0 ,4.151351126,1,0,4.953528,7,49,5.263158,1,4.188501767,1,1,4.221468,15,45,4.741448,0 ,3.896630265,1,1,4.916828,8,44,5.235233,1,1.822954456,1,0,1.203984,12,49,4.864693,1 ,3.568449743,0,0,5.435036,15,41,5.120809,1,1.912548820,1,1,7.668028,13,41,4.704970,1 ,11.219042551,0,0,2.074424,2,61,4.635125,0,11.056621394,0,0,2.503133,17,65,6.250000,0 ,7.418174278,0,1,3.182933,5,46,6.531973,1,3.800188802,0,1,6.740669,4,53,5.155131,0 ,5.602112811,0,0,1.622664,13,58,4.535342,0,6.257003117,0,1,3.171081,13,42,4.430379,1 ,0.518431071,1,1,5.500709,23,24,5.401257,1,4.727847199,0,1,4.545202,10,59,4.652018,0 ,0.724555281,1,1,4.653086,10,49,4.991069,1,1.903682072,1,1,3.880554,10,30,4.759858,1 ,2.109078189,1,1,4.012484,12,68,5.286123,0,4.259027131,1,1,3.932303,7,48,5.770498,0 ,2.744858570,1,1,4.085707,10,33,4.850712,1,2.220550942,1,1,4.523721,11,52,5.386785,0 ,7.380341967,1,0,1.163121,13,53,5.154913,0,1.774944681,1,1,3.547665,5,28,5.015292,1 ,3.751020721,0,1,2.283102,3,33,4.419417,1,6.856077620,0,1,7.096555,7,65,4.798963,0 ,1.547230496,1,0,3.234160,4,48,4.991342,0,11.157422549,0,1,5.202307,18,52,4.991342,0 ,11.707553546,0,0,3.998700,7,57,4.980119,0,7.696203645,1,0,2.601323,5,54,5.247021,0 ,5.096846550,1,0,1.701784,6,46,5.869379,1,0.723263842,1,1,3.526346,7,53,4.808812,0 ,5.397526946,0,0,1.536233,4,56,4.631800,0,6.440626935,0,1,2.975475,6,45,4.570437,1 ,1.409737724,0,0,7.226188,13,55,4.761905,0,6.641189913,0,1,4.236774,10,64,5.952871,0 ,6.508748090,0,1,3.301017,12,38,6.141898,1,4.921195146,0,0,1.177132,9,33,5.142595,1 ,0.664008194,1,1,3.267832,12,56,5.796012,0,2.199608074,1,0,3.221255,7,46,5.229125,1 ,7.090401998,1,1,1.632593,8,50,5.270361,0,1.412069554,1,1,4.108582,13,50,4.778376,1 ,7.200055097,0,0,1.507909,6,58,4.453618,0,4.685260559,0,1,8.766184,9,59,4.642308,0 ,4.333250147,1,1,4.984817,13,28,5.241720,1,7.054771580,0,1,2.586440,8,31,5.624463,1 ,2.085870276,1,1,1.130246,20,33,4.176713,1,2.760954702,1,1,2.942864,7,21,5.052686,0 ,8.557328138,0,1,5.510820,10,52,4.466325,0,4.062899508,1,1,1.980304,23,51,5.439283,1 ,4.257764630,0,1,3.032253,2,29,5.006571,1,6.023658070,0,1,3.500897,5,44,6.110101,1 ,1.665516820,1,0,5.236119,10,49,5.370431,1,4.713091096,1,1,3.199575,10,49,4.784644,0 ,1.136867995,1,0,6.025526,17,70,5.580490,0,1.489985563,1,1,3.291423,33,56,5.514099,0 ,3.156369948,1,0,2.237694,10,44,4.724556,1,4.897130273,0,1,3.183937,5,71,4.439968,0 ,2.909972143,1,1,3.821681,10,76,4.668973,0,0.473195174,1,1,4.441651,20,39,5.015292,1 ,1.846312487,1,1,3.836800,8,32,5.168114,1,5.763980772,0,1,5.612299,17,33,5.014839,1 ,5.833846860,1,0,1.199922,13,54,4.870861,0,1.191873836,1,1,3.212073,8,44,5.355851,1 ,3.438199779,1,1,2.004780,12,67,6.013071,0,4.176913133,1,0,3.683610,17,51,5.038911,0 ,3.245481586,1,0,4.344132,13,39,5.504342,1,6.260273716,0,1,2.581937,5,55,4.631800,0 ,9.268476483,0,1,3.358700,7,51,4.887685,0,10.335815530,0,1,7.678052,14,52,4.701095,0 ,2.965332277,1,1,5.646492,11,69,5.112992,0,2.341294041,1,1,5.263336,10,38,5.376453,1 ,6.822608427,0,1,2.639990,7,28,4.808812,1,2.250602160,1,1,2.721885,5,69,5.138322,0 ,6.300978500,0,0,2.470716,3,59,4.619330,0,2.465998212,0,0,6.831051,3,31,4.652324,1 ,1.066376267,1,1,4.962165,17,49,4.718646,0,4.101858701,0,1,1.495405,7,57,6.959705,0 ,1.693029265,0,1,3.683914,5,29,5.407597,1,1.007218322,1,0,6.338842,12,45,5.142595,1 ,8.734197112,0,0,2.838642,17,68,5.090253,0,4.708322109,0,0,5.810662,12,50,5.094267,0 ,5.008139408,1,1,1.529218,25,66,5.656162,0,7.197577796,0,0,3.648851,8,34,5.040121,1 ,8.259847282,0,1,3.615229,4,33,5.120764,1,5.956809496,0,1,2.401528,18,57,4.960819,0 ,0.135921434,1,1,4.131625,17,41,5.661268,1,4.811381111,0,1,4.171850,12,32,5.661270,1 ,11.183490087,0,0,2.992922,12,63,5.554637,0,7.198701062,0,0,5.353519,17,46,4.693797,0 ,6.782307836,1,1,3.679246,2,39,4.753973,1,5.698595772,0,0,7.207650,11,34,5.052686,1 ,3.805061920,0,1,4.685538,16,54,4.572111,0,8.245176787,0,1,2.535451,8,53,5.549887,0 ,2.845214672,0,1,3.296065,3,64,5.185781,0,9.193522879,0,0,3.012419,18,56,4.577911,0 ,6.649138882,0,1,3.782074,5,31,5.303301,1,6.293812206,1,0,2.499770,6,43,4.508264,1 ,1.355687434,1,0,4.915542,12,58,5.221878,0,2.837860446,1,0,1.412286,8,37,5.720019,1 ,9.479260786,0,0,2.993065,5,62,4.567398,0,7.091882950,0,1,2.566071,17,56,4.860499,1 ,2.213798429,1,1,3.622597,3,62,5.023578,0,4.572762277,0,0,2.816184,12,40,5.115846,1 ,7.170860199,0,0,3.612320,3,55,5.796012,0,4.790314174,0,1,2.316505,7,49,4.516129,0 ,1.607172815,1,0,4.952683,12,36,5.366974,1,0.896199928,1,0,5.897702,17,30,5.043083,1 ,3.449437714,1,1,3.232331,28,65,4.362469,0,9.753663756,0,1,7.526090,7,53,5.416025,1 ,6.601340091,0,1,1.681674,17,39,5.500175,1,6.854971010,0,0,3.997224,13,40,5.169417,1 ,1.568935028,1,1,7.717937,9,33,4.575657,1,2.867387874,1,0,4.569772,13,39,5.504342,1 ,2.090968802,1,0,3.980132,10,69,6.748466,0,9.157326991,0,1,3.296270,7,58,4.736275,0 ,9.830822584,0,1,1.160683,5,22,4.881406,1,4.054926218,0,1,3.163021,20,61,4.694526,0 ,1.440696348,1,0,3.394164,13,60,4.533199,0,8.996651002,0,1,3.415186,7,42,4.362469,1 ,1.297020996,1,0,3.878364,8,54,5.120809,0,1.378073953,1,1,3.211672,13,75,5.229125,0 ,2.098558667,1,1,5.720832,6,66,5.111615,0,3.759938275,0,1,4.306056,11,50,6.312191,1 ,4.893984218,0,0,3.603907,7,61,5.063291,0,7.869546174,0,0,1.644335,3,42,4.322629,1 ,2.344838072,1,1,4.683118,12,53,5.078968,1,4.960971610,0,1,1.089539,5,41,4.694526,1 ,9.330519779,0,0,1.536900,7,53,4.536092,0,1.105600935,1,0,4.549566,7,37,5.220239,0 ,0.560492445,0,0,3.006726,18,50,4.766442,1,3.049369954,1,1,1.514977,4,48,5.318160,1 ,4.341731608,0,1,4.888017,7,40,5.488113,1,5.456516720,0,0,5.344640,7,50,4.529359,0 ,5.750005841,0,1,1.312609,3,30,5.067910,1,1.564712708,1,0,5.955641,20,57,5.544314,0 ,5.426550372,0,1,2.767213,8,49,4.603557,1,2.779461860,1,1,6.596323,12,53,5.261336,1 ,7.205733380,0,0,5.545706,5,38,5.697535,1,5.048819190,1,0,1.322403,13,23,4.203487,1 ,0.545143450,1,0,4.658551,20,53,4.655240,0,5.995114114,0,1,2.703438,6,45,4.570437,1 ,1.765002397,0,1,6.481649,8,33,4.577839,1,3.507343644,1,1,1.281901,8,61,5.733408,0 ,0.532532162,1,0,1.495249,15,55,5.248639,0,5.797894983,0,0,5.659140,13,50,4.810457,0 ,6.604511283,1,1,3.800932,8,29,5.164568,1,7.346587367,0,1,4.530767,20,55,5.481173,0 ,5.069804537,0,1,4.181787,12,44,5.488113,1,0.339388948,0,0,9.448597,4,42,4.698308,1 ,8.358854636,0,1,2.142333,10,62,5.352583,0,6.467726356,0,1,1.634026,10,53,5.015566,0 ,6.643724944,1,1,8.089670,17,41,4.733485,1,6.919238833,0,1,2.022032,7,32,4.549815,1 ,1.939941117,1,1,2.050028,10,52,4.655240,0,2.982583506,1,0,5.139349,12,28,4.741448,1 ,1.810415111,0,1,3.409266,5,29,5.407597,1,8.570213281,0,1,4.862987,23,36,4.930935,1 ,1.855761762,1,1,3.593343,7,38,5.733508,1,0.301597154,1,0,5.599797,8,45,5.832464,1 ,0.231423197,0,0,1.062920,10,62,5.526557,0,0.345455383,1,0,7.131616,3,45,5.174546,1 ,4.800155273,1,1,3.416740,11,55,4.980119,0,8.094522422,0,0,3.268683,7,27,6.061189,1 ,4.578820375,0,1,2.946149,3,46,5.328577,1,4.411192012,1,0,2.870890,7,43,5.075993,1 ,1.998407097,1,0,1.101122,7,48,5.038911,1,1.920281072,1,0,4.796375,15,44,4.624277,1 ,6.057648934,0,0,1.113554,8,64,4.374088,0,6.048239898,0,0,5.933510,5,58,4.302066,1 ,7.355324373,0,0,1.706783,9,58,4.706487,0,4.214826654,0,1,1.175137,7,57,6.959705,0 ,6.013621460,1,1,2.599346,17,38,4.466325,1,2.043685884,1,1,4.903934,10,61,4.631770,0 ,5.407607486,0,1,4.750799,12,44,5.488113,1,4.125843671,1,1,4.593218,7,45,4.814913,1 ,10.592281430,0,1,1.023707,17,64,4.533199,1,8.030761938,0,0,5.385319,13,72,4.879078,0 ,0.430427654,1,1,5.721438,20,40,4.650769,1,9.111283940,1,1,2.968081,7,40,5.077524,1 ,7.515296381,1,0,2.305218,4,49,5.474375,0,3.820811482,0,0,5.717769,10,50,4.893999,1 ,6.483626840,0,0,1.974287,6,58,4.453618,0,4.508714258,1,1,6.328627,17,50,5.390110,1 ,2.375836544,1,1,1.053986,17,31,4.885980,1,1.999463538,1,0,4.978882,13,52,4.839637,0 ,3.040389022,0,1,2.748946,13,55,4.166667,0,7.211924252,0,1,1.815023,8,46,4.682535,1 ,4.881413052,1,0,2.811838,5,57,4.327874,0,2.005410373,1,0,3.951752,10,53,5.685352,0 ,4.609222177,1,1,5.766891,3,33,5.161291,1,6.752495877,0,1,1.183893,4,37,4.784644,1 ,0.208722173,0,1,6.427892,8,30,5.055576,1,2.176248739,1,1,4.656861,22,47,5.376453,1 ,3.760232022,0,0,5.711707,15,55,4.701095,0,3.925154710,1,1,1.224083,18,42,5.096089,1 ,5.312882297,0,1,2.241892,4,38,5.241315,1,10.110561068,0,1,2.274060,10,56,4.706487,0 ,3.453600597,1,1,3.411477,5,36,4.696845,1,5.103860480,0,1,1.733784,3,37,5.504342,1 ,1.394725925,1,1,4.341496,10,27,5.015566,1,4.579546124,1,1,5.020559,18,49,5.370431,0 ,1.792864341,1,0,3.038276,10,36,4.080358,1,9.071814150,0,1,2.779851,3,33,5.185781,1 ,6.091612196,0,1,3.155432,12,40,4.558028,1,8.145444102,0,0,3.384657,12,42,4.960784,1 ,4.180701950,0,1,2.975262,3,33,4.419417,1,11.523924806,0,1,1.243254,13,58,4.672253,0 ,12.248223385,0,1,3.902886,8,45,5.164568,1,4.068336384,0,0,3.626877,6,53,5.326697,0 ,3.242764985,1,0,1.518876,9,75,4.292613,0,6.572059410,0,1,1.648025,12,56,4.938272,0 ,1.561962705,1,0,3.583774,4,48,4.991342,0,3.597322147,1,1,3.786477,10,33,5.299465,1 ,8.625950781,1,1,1.283505,13,58,5.006571,0,1.107881892,1,1,5.897928,8,39,4.272742,1 ,6.834428988,1,1,3.316387,8,29,5.164568,1,1.457088764,1,0,3.600972,15,62,4.793944,0 ,9.031411884,0,1,1.342553,8,34,5.832464,1,6.058416348,0,0,3.868683,3,56,4.109609,0 ,6.172218574,1,1,3.529930,13,45,4.766596,1,7.229191107,0,0,1.194385,9,58,4.706487,0 ,1.655939195,1,1,2.396522,10,46,4.535342,0,4.750297681,0,0,2.868717,4,70,5.251685,0 ,6.528564183,1,1,3.688580,10,44,4.800717,1,1.669746362,0,0,4.164697,17,64,5.237828,0 ,3.979072929,0,0,3.743189,3,66,4.723693,0,1.083100761,1,1,5.689226,12,44,5.904718,1 ,7.408603030,0,1,2.350274,8,34,5.941006,1,1.797228265,1,0,6.354184,7,46,4.827945,1 ,8.524258140,0,1,1.573125,8,66,4.637013,0,2.638208892,1,1,2.877399,9,35,4.493895,1 ,0.800734659,1,0,6.762334,13,65,4.921255,0,2.972883404,1,1,4.039496,5,65,4.593059,0 ,3.090467846,1,1,3.326468,4,50,5.318160,0,10.907723850,0,0,7.988268,7,53,5.416025,1 ,7.952081973,0,1,5.389587,13,33,4.953681,1,9.147780870,1,1,3.650056,13,43,5.180603,1 ,8.456363376,0,1,3.100534,7,50,5.000000,0,1.751124609,1,1,5.671827,13,23,4.705882,1 ,0.778723502,1,1,4.347169,8,51,5.153882,0,0.432523381,1,0,4.831612,3,60,5.561514,0 ,2.802435199,1,1,5.764255,16,31,5.391265,1,9.200843995,0,1,1.090543,7,46,4.778846,0 ,0.989988651,0,1,3.249323,10,35,4.683626,1,8.125830337,0,1,1.916480,7,52,5.201327,0 ,3.900602465,0,1,2.245333,8,60,5.207717,0,6.148142134,1,1,4.151725,10,49,4.766442,1 ,3.924550284,0,1,1.006315,6,62,5.669801,0,3.992218117,0,1,3.059786,10,45,5.024872,1 ,9.364093883,0,0,3.155882,10,50,5.132883,0,2.041921540,1,0,6.337418,7,46,4.827945,1 ,1.058448307,1,0,1.079272,12,35,5.425139,1,2.561950667,1,0,3.701132,16,60,5.242941,0 ,2.891827123,1,0,4.975455,10,34,5.554567,1,1.065517223,1,0,4.755102,28,68,6.280743,0 ,2.235826966,1,1,2.710385,10,30,4.561979,1,4.603598643,0,0,1.202609,5,70,4.921255,0 ,3.359902494,0,0,1.549379,8,60,5.094267,0,6.284424408,0,0,4.048934,7,28,4.563989,1 ,6.993184066,0,1,4.821479,13,25,5.363205,1,7.456607707,0,1,4.032171,10,54,4.733728,0 ,0.323357455,1,0,5.590777,16,52,4.648111,0,10.908473437,0,0,4.361976,17,53,5.115846,0 ,4.245837517,0,1,1.965004,5,32,4.750900,1,6.287846860,0,1,3.153801,10,36,5.624385,1 ,0.919237043,1,0,1.130161,10,68,4.548680,0,6.168837323,0,1,1.878300,6,39,5.784654,1 ,8.086577793,0,0,5.794484,12,44,5.929093,1,6.249093265,0,0,1.603284,13,37,5.359112,1 ,8.853233659,0,1,4.791674,12,57,5.000000,0,0.808009138,1,0,1.653349,9,48,6.154446,1 ,2.050633455,1,1,7.609329,13,41,4.704970,1,11.241442774,0,0,3.096521,15,35,5.094267,1 ,7.042880279,0,1,4.289976,8,31,5.164568,1,8.608023099,0,1,4.688038,10,54,4.733728,0 ,6.093956216,0,1,3.094646,5,50,4.960819,1,2.201470875,1,1,5.949804,15,39,5.687042,1 ,3.846729506,0,1,3.157237,5,32,4.535342,1,10.008533299,0,1,1.044579,5,59,4.562997,0 ,1.394567123,1,0,1.831151,7,55,4.624277,0,5.958579279,0,1,9.670487,10,60,5.182124,0 ,7.237163870,0,0,3.682433,10,50,4.798963,1,7.344749431,0,1,3.719710,13,28,5.386379,1 ,4.124655849,0,1,1.828047,14,35,5.370431,1,6.491587475,0,1,4.974500,13,61,4.886249,0 ,3.461048257,1,0,3.288262,3,56,4.680553,0,6.569245920,0,1,1.003871,12,56,4.938272,0 ,5.387570287,0,1,3.880464,3,62,4.364066,0,1.864536497,1,0,5.825757,13,66,4.800717,0 ,5.276904936,1,1,2.449857,28,38,5.580232,1,0.180977227,0,0,6.761964,8,30,5.055576,1 ,0.002821072,0,1,3.259859,6,37,4.976703,1,6.273446445,0,1,2.089837,7,28,4.808812,1 ,5.248314074,1,0,4.016090,15,54,5.326697,0,4.074713586,0,1,1.614378,3,37,4.766442,1 ,6.782409465,0,1,1.454855,6,33,5.474375,1,3.537634320,0,1,2.668229,7,37,6.389871,0 ,4.227414512,0,0,1.983044,8,41,5.266344,1,0.306393552,1,0,4.095328,15,64,5.033223,0 ,5.763045197,0,1,1.500819,6,47,6.994941,1,1.378936682,1,0,3.451202,13,51,4.771733,0 ,3.336393456,0,1,1.219664,3,50,6.034860,0,2.636784901,1,1,1.505303,7,39,5.219121,1 ,6.289302730,0,1,1.367362,8,50,5.270361,0,1.525525784,1,1,7.044859,13,59,4.904786,0 ,1.034546670,1,1,5.103517,13,41,5.732484,1,3.084538560,1,1,3.894454,7,42,5.295317,1 ,1.680179850,1,0,4.599548,10,56,4.614682,0,7.051316381,0,1,3.207134,13,38,5.178184,1 ,5.178364865,0,0,2.461112,10,49,4.741448,1,10.209324904,0,1,1.720407,13,58,4.672253,0 ,3.462754478,0,0,4.651890,13,30,5.474375,1,1.943983868,1,1,1.979412,9,44,5.059026,1 ,0.333382673,0,1,1.829802,7,39,6.185896,1,7.365314347,0,1,3.992740,3,35,4.835737,1 ,6.456711297,0,0,1.955456,10,48,5.391265,1,5.352734390,0,1,1.381658,12,60,4.603557,0 ,3.117490032,1,1,4.862531,8,39,4.827945,1,10.464199781,0,1,2.654715,3,56,4.770898,0 ,6.648622390,0,0,1.418481,6,58,4.453618,0,0.504983812,1,1,2.871429,10,33,4.681194,1 ,1.132197103,1,1,5.547047,20,68,4.619330,0,8.204686747,0,0,2.118565,7,33,5.344762,1 ,0.548629641,1,0,8.382483,12,47,6.641995,1,6.545835318,0,1,2.851951,16,61,4.830680,0 ,1.614850887,1,0,5.732372,20,41,4.907975,1,4.326508009,1,1,1.128477,10,51,5.877699,1 ,9.631693548,0,1,1.589332,7,53,4.987757,0,3.743417556,0,0,4.826593,10,41,5.021689,1 ,0.711919688,1,0,5.311243,8,34,6.344507,1,1.406760777,1,0,7.458299,8,67,4.723693,0 ,5.347828937,0,1,1.984332,12,60,4.603557,0,4.511347593,0,1,4.925597,3,45,5.590170,1 ,5.807706633,0,1,3.428959,8,34,5.422386,1,4.077919875,0,1,6.562409,30,55,4.556451,0 ,6.051981912,0,1,1.919870,8,58,5.257000,0,5.732195844,0,1,4.652636,8,65,4.467590,0 ,6.597855218,0,1,1.732938,13,44,5.340002,1,10.118567072,0,1,3.887820,4,45,6.558120,1 ,6.110741125,0,0,2.134272,5,53,4.861484,0,0.231828608,0,0,4.035851,17,60,5.882353,0 ,0.777022351,1,0,3.151760,7,30,5.295317,1,2.341648323,0,0,2.016336,4,40,5.103104,1 ,6.279425508,0,0,1.674932,17,39,5.555556,1,10.721694673,0,1,2.376518,6,53,4.899540,0 ,9.511700864,0,1,4.601852,15,51,5.106757,0,6.266444418,0,0,2.530300,18,57,4.960819,0 ,7.547995835,0,1,4.582309,5,32,5.625000,1,1.458256258,1,1,4.566258,25,31,6.240738,1 ,1.733922908,1,1,4.160118,7,26,5.763505,1,10.296185095,0,0,6.443537,5,62,5.588507,1 ,0.616789585,1,0,6.848180,33,51,4.901409,0,0.190548415,0,1,1.433576,3,36,5.096031,1 ,4.597437441,0,1,4.877607,7,37,5.624713,0,0.487907532,0,0,2.016946,8,37,5.237828,1 ,4.573749060,1,1,4.648474,13,28,5.241720,0,6.351624030,1,1,1.223701,7,48,5.416645,0 ,5.444808172,0,1,5.103662,18,37,4.252083,1,1.510551130,1,1,1.072253,2,47,4.330127,1 ,1.584217669,1,1,7.082270,13,59,4.904786,0,7.480105808,0,1,4.115575,17,45,4.933737,1 ,0.264522374,0,1,3.556272,17,31,6.419274,1,2.422858835,1,1,3.409903,5,32,4.760953,1 ,5.450188944,1,0,1.790452,6,46,5.869379,1,6.809018450,0,1,2.416089,6,43,4.508264,1 ,2.337273737,1,1,4.383944,8,48,4.841229,1,2.079221042,1,1,5.173593,15,68,5.039189,0 ,8.267420054,0,0,1.442905,3,42,4.322629,0,6.906518314,0,1,4.727592,8,31,5.164568,1 ,6.078153858,1,1,4.333743,6,51,5.767761,0,7.729096555,0,1,3.453160,13,54,5.266344,0 ,6.317741962,0,0,1.894594,17,36,4.713139,1,3.696723353,0,0,2.437806,5,59,5.142595,0 ,9.527512819,0,1,3.724191,8,55,5.015292,0,5.980060589,0,1,3.536102,5,50,4.960819,1 ,5.877707151,0,0,2.010150,10,49,4.741448,1,7.932894615,0,1,3.430362,4,33,5.120764,1 ,2.042875027,1,1,4.943407,12,68,5.286123,0,6.313682701,0,1,3.987807,27,38,5.095541,1 ,3.943776047,0,0,4.250438,11,48,4.869480,0,4.190370232,0,1,3.602082,10,42,6.369427,0 ,0.713752810,1,0,4.484808,5,59,5.642155,0,2.061156533,1,0,6.993872,10,58,4.997703,0 ,7.265972062,0,1,2.504398,8,34,5.941006,1,5.897122381,0,1,5.522065,14,54,4.563989,0 ,1.117037792,1,1,2.476285,15,37,5.296764,1,2.519232332,1,1,3.615621,13,40,4.956558,1 ,6.722139594,1,1,2.970835,5,46,5.735394,1,2.939263624,1,0,4.783918,9,44,5.553775,1 ,1.263742230,1,0,5.732667,2,41,5.327739,1,3.554809385,0,0,2.372134,8,52,4.819277,0 ,2.005697320,1,0,3.737095,10,69,6.748466,0,9.113218144,0,0,1.729485,3,54,4.810457,0 ,1.903591075,1,0,3.448379,8,66,4.916011,1,6.852265320,0,1,3.989755,10,50,5.811836,0 ,1.148551185,1,0,7.176261,30,50,5.486694,1,11.838745909,0,0,2.502532,4,60,4.475359,0 ,9.465308131,0,1,3.676296,8,55,5.015292,0,3.652735761,1,0,3.855869,4,59,5.521156,0 ,7.709119867,0,1,5.872373,8,37,4.879415,1,11.227722208,0,1,1.768116,3,35,5.304117,1 ,4.514278936,0,1,3.831382,3,43,5.050762,1,8.168211337,0,1,3.540189,14,36,5.345836,1 ,2.110967002,1,1,4.250007,10,61,4.631770,0,0.170603433,0,1,2.554719,11,55,5.151093,0 ,6.142549669,0,0,4.511429,12,37,4.976703,1,7.829874802,0,0,1.761346,10,27,5.290843,1 ,4.041970755,0,0,3.166400,7,56,4.615620,0,0.881428488,1,0,4.963674,15,38,7.096774,1 ,3.895394592,0,1,2.966590,7,50,4.503865,0,4.734134560,0,1,1.159845,8,42,4.921529,1 ,5.549556897,0,1,2.515525,12,42,6.321264,1,5.957744865,1,1,4.282083,10,29,5.096089,1 ,2.612217756,1,1,3.283575,5,32,4.760953,1,2.351318893,1,0,9.433906,7,38,5.474375,1 ,3.929335919,0,1,1.969351,3,52,4.938272,0,6.057858733,0,1,3.963494,5,50,4.960819,1 ,11.505287025,0,1,2.650312,9,45,4.705882,1,2.425573164,1,1,3.449912,12,40,4.870861,1 ,8.537079653,0,0,1.919414,10,66,4.686909,0,10.535590867,0,0,5.666118,7,69,4.506939,0 ,2.136745227,1,1,6.834885,15,25,5.313040,1,1.926380538,1,1,3.226138,7,38,5.733508,1 ,8.115219096,0,0,1.465175,17,54,4.364066,0,5.472815064,0,1,1.782311,8,37,5.856070,1 ,1.130849975,1,0,4.216702,28,68,6.280743,0,1.163170736,1,0,7.256262,30,50,5.486694,1 ,3.365204161,0,1,4.654139,33,56,4.904786,0,1.162584948,1,1,3.640609,10,36,5.333006,1 ,5.522293804,0,1,3.506413,10,34,4.881406,1,4.280830294,0,1,2.784282,6,56,4.540842,1 ,0.536465463,1,1,6.009152,8,23,5.519851,1,5.372209310,0,1,4.339617,3,23,4.655240,1 ,8.092996790,0,0,4.227226,10,44,5.476925,1,1.660042695,1,1,4.237032,10,43,4.773922,1 ,5.046438225,0,1,1.891330,27,67,4.908459,0,0.558458981,1,1,2.598031,4,32,5.487283,1 ,2.431132009,1,0,4.795160,12,42,4.423004,1,3.911608432,0,1,3.265681,7,56,4.615620,0 ,1.728596360,1,0,5.031483,27,70,4.604683,0,6.485542586,0,1,2.892669,18,57,4.960819,0 ,4.455368793,1,0,1.558971,25,66,5.656162,0,3.356534447,0,0,3.694339,15,69,4.902490,0 ,3.764739669,1,1,3.220591,12,32,5.806452,1,8.603190010,1,0,3.052693,21,67,4.610694,0 ,11.808447247,0,1,2.969251,17,54,4.851086,0,0.937717720,0,1,3.799739,10,35,4.683626,1 ,0.356154239,0,0,1.705729,10,41,4.631800,1,7.749694261,0,0,1.176630,8,60,4.778846,0 ,0.377782457,1,1,3.880753,3,33,4.944419,1,1.442296832,1,0,3.641154,13,60,4.533199,0 ,2.966253607,1,1,1.941936,7,38,4.672253,1,4.243549545,0,0,4.388806,17,51,4.668973,0 ,5.085674026,0,1,4.854721,8,65,4.467590,0,6.941571441,0,0,3.838433,12,45,4.422167,1 ,1.894093992,1,1,3.204225,3,45,5.520686,1,1.899673674,0,0,4.416458,3,53,4.835737,0 ,3.350516263,1,1,3.591717,4,59,5.521156,0,0.412278028,1,0,5.988977,18,51,5.081007,0 ,2.308422808,1,1,4.487907,17,42,4.800717,1,4.680489773,1,0,2.724866,3,64,5.201457,0 ,2.165319102,1,0,4.384848,13,52,4.839637,0,11.550136209,0,1,1.629800,7,50,4.860499,1 ,7.761382067,0,0,1.970176,8,66,4.686909,0,2.709093688,1,1,3.535508,13,63,5.252364,0 ,2.795778440,1,1,4.713039,10,33,4.850712,1,3.655220622,0,1,2.232516,7,50,4.503865,0 ,5.131761460,0,0,3.191143,10,41,5.096031,1,1.933563557,1,1,1.074989,8,44,5.247021,1 ,2.386244466,1,0,3.105901,12,57,5.652957,0,6.579558296,1,1,4.911388,10,52,4.686909,0 ,1.653981343,1,1,3.754309,7,49,4.693797,0,3.616694513,0,0,3.340925,3,52,4.590991,0 ,3.348087451,1,1,3.596255,7,31,6.202187,1,3.937152011,0,1,7.048824,11,26,4.871677,1 ,4.448652618,0,0,1.899213,5,25,5.007613,1,3.314438255,1,0,3.568579,10,47,4.921255,0 ,4.378647088,0,1,3.082401,8,32,5.659616,1,2.894753047,1,1,4.472487,10,27,5.454546,1 ,1.143836483,1,0,4.906165,20,59,4.583412,0,2.078924038,1,1,5.038161,8,41,4.759858,1 ,7.632391183,1,1,3.766607,8,29,5.164568,1,2.532663288,1,0,2.514690,27,65,5.000000,0 ,7.292980488,0,1,3.598738,13,38,5.178184,1,7.161655578,0,1,3.531391,13,38,5.178184,1 ,7.995158576,0,1,1.195915,27,61,4.631800,0,5.356725785,0,1,2.807563,3,66,4.983549,0 ,5.864581357,0,1,1.653911,7,59,4.631800,0,3.815578056,0,1,3.490062,4,42,5.357143,1 ,2.088531185,1,1,4.074264,15,58,5.646925,0,5.654649446,0,1,2.197629,4,70,5.251685,0 ,8.609041606,1,0,4.729127,12,50,5.163978,0,2.017008686,1,0,1.169704,10,51,5.929271,0 ,1.592183384,1,1,2.791577,5,53,5.521473,0,11.340743492,0,1,3.460046,8,45,5.164568,1 ,2.497296371,1,0,3.562934,10,69,4.637013,0,0.924902449,1,0,5.116869,17,40,5.094267,1 ,0.877101983,1,0,6.776094,13,65,4.921255,0,2.914522704,1,1,3.430647,7,48,5.266344,1 ,7.691193425,0,0,1.529326,6,51,5.516086,0,3.500237395,1,1,1.383206,5,43,5.420771,1 ,6.667544048,0,1,3.596455,8,42,5.120432,1,5.717699502,0,1,3.406005,5,44,5.070667,1 ,1.343640841,1,1,6.402983,5,46,4.819277,1,5.281411490,0,0,3.603305,9,52,4.923659,0 ,8.514367758,0,0,2.699022,5,62,4.567398,0,0.345293636,1,0,7.424966,3,45,5.174546,1 ,3.256129004,1,1,4.639832,13,66,3.875617,0,3.943650016,0,0,1.172036,10,28,6.073310,1 ,5.750799191,0,1,3.048840,7,38,5.242941,1,0.837870163,1,1,4.224013,13,50,6.273158,0 ,1.888124836,1,1,4.047443,8,29,5.453168,1,5.908433161,0,0,1.920029,20,41,4.454354,1 ,1.049472063,1,0,5.003171,12,44,5.904718,1,3.586541725,0,0,3.288140,7,34,5.095541,1 ,6.635303664,0,0,5.943127,14,54,4.563989,0,5.947873756,1,1,1.189624,6,39,5.784654,1 ,7.800592523,0,1,5.629727,14,52,5.514311,0,1.939952102,1,1,3.039541,15,43,6.136303,1 ,1.348567277,1,0,3.943967,15,61,5.455447,0,3.894577310,1,1,2.075025,7,48,4.843221,0 ,3.193398435,1,1,3.658782,28,65,4.362469,0,4.817679250,0,0,1.025435,9,33,5.142595,0 ,2.860194480,1,1,1.165846,23,45,4.733485,1,1.352776048,1,1,1.676759,27,30,5.454546,1 ,4.912300494,1,1,3.153114,7,32,5.381357,1,4.890521981,0,1,2.582964,13,57,4.463000,0 ,5.764706540,0,1,2.609888,5,30,4.907975,1,2.767113746,1,0,2.928604,7,57,4.798963,0 ,4.431233163,0,0,1.345869,10,41,5.454546,1,1.623662089,1,1,3.463678,27,45,4.827945,1 ,2.181049038,1,1,3.567826,3,62,5.023578,0,5.721996131,0,1,3.195724,6,42,5.452375,1 ,1.627023852,1,1,5.494793,12,51,5.421687,1,2.751551764,1,1,1.687466,5,41,6.545970,1 ,7.271223955,0,1,1.774302,10,25,4.980119,1,5.997232191,1,0,4.188447,7,57,5.617264,0 ,2.815038151,1,1,4.098625,8,39,4.827945,1,6.538407808,0,1,3.898660,20,39,4.493895,1 ,3.586533365,1,1,2.288991,13,31,5.397807,1,1.168339111,1,1,3.037992,4,59,5.014839,0 ,1.131764089,1,0,6.213348,5,42,4.535342,1,5.773740162,1,1,5.733903,10,32,4.886216,0 ,5.724049911,0,1,3.742550,6,46,5.034317,1,8.209486959,0,1,1.318034,7,43,4.960819,0 ,5.905065192,0,0,1.436360,4,39,5.034317,0,1.312351945,0,1,2.809238,7,44,6.481796,1 ,5.327245863,0,0,1.840784,20,41,4.454354,1,2.016230894,1,0,2.050312,10,43,5.386785,1 ,7.273675921,0,1,3.319160,8,33,5.303301,1,0.679058643,1,1,4.789431,10,49,4.991069,1 ,6.208641571,0,1,1.570053,7,28,4.841229,0,10.193101052,0,1,2.174288,10,49,5.081007,0 ,7.983991138,0,1,1.496593,7,23,5.228350,1,2.707835686,0,0,1.239440,12,65,5.219121,0 ,1.505188818,1,1,7.607318,13,59,4.904786,0,0.849979285,1,0,5.965647,8,50,5.625326,0 ,2.102019053,1,1,4.984487,13,39,4.567398,1,3.535572626,0,1,3.852810,13,50,5.059026,0 ,2.768660076,0,1,3.661696,18,44,5.257000,1,10.673161184,1,0,3.207696,8,42,5.589223,1 ,4.175695912,0,1,1.367948,7,53,4.960819,0,1.419040855,0,0,1.312853,10,48,4.311626,0 ,1.093027247,1,1,3.994409,5,53,5.359112,1,1.966217633,1,0,5.150978,9,51,4.593059,0 ,2.128991491,1,0,3.787845,10,53,5.685352,0,8.002784875,0,1,1.808558,5,27,4.950651,1 ,6.583644943,0,0,1.654456,17,39,5.555556,1,1.113495390,1,1,4.798297,8,49,4.652018,1 ,0.550321056,1,1,6.502562,8,23,5.519851,1,0.723488188,1,1,2.155395,13,31,4.705882,1 ,0.954077783,1,0,3.535933,3,66,4.525292,0,4.975119414,1,0,1.484172,7,43,4.733485,1 ,6.969411931,0,0,1.264260,6,58,4.453618,0,6.712535366,0,0,2.394560,12,75,4.742505,0 ,2.433923883,1,0,2.138953,4,59,5.576548,0,10.577546171,0,0,2.936957,17,65,6.250000,0 ,4.503652270,0,1,1.208192,23,54,4.712121,1,2.298074342,0,0,1.138595,7,43,5.104738,1 ,3.400328945,0,1,1.293391,13,32,4.694526,1,1.984224372,1,0,2.070662,7,42,4.745345,1 ,5.792484433,0,0,1.958561,10,46,5.940885,1,5.048172060,0,1,4.938344,10,53,5.009940,0 ,3.724314833,0,1,4.003840,10,60,5.359738,0,0.703710942,1,1,1.118981,7,39,5.014839,1 ,3.068358640,1,0,4.306813,12,59,6.130060,0,2.793717710,1,1,1.469506,10,41,4.800717,1 ,0.924667925,1,0,4.032832,7,37,5.220239,1,6.724213596,0,0,7.648622,33,59,6.595520,0 ,5.042581582,1,1,3.873687,17,45,5.423261,1,6.244645554,0,1,1.163991,13,40,5.484352,1 ,1.069207876,1,0,5.898909,12,44,5.904718,0,9.685962357,0,1,7.351507,7,53,5.416025,1 ,0.602467925,1,1,4.164720,17,61,4.385608,0,6.735501806,0,1,3.681254,12,40,4.558028,1 ,2.416085327,1,1,2.998528,13,41,4.991342,1,0.883339159,1,0,4.666377,22,25,4.960784,1 ,1.029780683,1,1,7.469264,30,50,5.486694,1,2.678863910,1,1,6.210031,12,53,5.261336,1 ,0.218703943,0,0,5.567017,5,52,5.920780,0,1.135487874,1,1,4.155227,20,49,4.923659,0 ,9.563382952,0,1,3.367165,6,35,5.514311,1,9.073131862,0,0,2.514044,8,47,5.217020,1 ,4.171939803,0,0,3.681111,7,56,4.615620,0,1.519229517,1,1,3.118656,29,67,4.563989,0 ,10.778655855,0,1,4.842721,5,45,5.329681,0,4.337965989,0,1,3.301727,10,57,4.985775,0 ,7.280470398,0,1,4.031752,17,51,4.841229,0,1.007990146,1,0,5.502734,15,45,4.988877,1 ,2.495596502,1,1,3.492195,11,44,5.163978,1,7.608110567,0,1,1.963279,12,65,4.590991,0 ,2.118993806,1,1,3.483719,10,68,4.472136,0,3.558037083,1,1,1.582273,5,55,4.519892,0 ,6.017214503,0,1,7.847679,17,60,5.052686,0,11.540110101,0,0,1.896460,12,52,5.416025,0 ,1.668611958,1,1,3.480821,10,63,4.499433,0,3.584244189,1,1,4.929268,7,34,5.247021,1 ,2.127077850,1,1,2.093565,7,64,5.488114,0,9.608429844,0,1,3.034624,8,55,5.015292,0 ,3.864569215,0,0,5.000620,10,50,4.893999,1,12.183432204,0,1,1.583632,12,44,4.830909,1 ,1.336573082,1,1,3.780255,8,54,5.120809,0,2.681474118,1,1,2.129729,14,36,5.863020,0 ,3.537433598,1,1,3.872712,12,32,5.806452,1,0.588255172,1,0,8.332843,12,47,6.641995,1 ,0.454187936,0,1,3.252996,3,39,4.758241,1,6.768400653,0,0,1.001791,11,43,4.915615,1 ,1.388905490,1,0,3.142672,17,63,4.328138,0,7.651766392,1,1,6.356338,2,33,5.962848,1 ,3.187847518,0,1,3.994416,8,27,5.583828,1,3.393697460,0,1,3.739596,3,53,5.115846,0 ,9.269941007,0,1,3.593269,8,50,4.632703,0,1.861529935,1,0,4.709698,22,47,5.376453,1 ,8.697841282,0,0,4.726717,8,55,4.385608,0,5.412574003,0,1,3.330418,10,57,5.153882,0 ,6.995501779,0,0,2.478400,3,59,4.619330,0,4.330310494,0,0,3.917717,3,66,4.723693,0 ,2.576165090,1,1,6.066838,18,54,5.661270,1,1.145485281,1,0,5.285216,2,41,5.327739,1 ,5.329422753,1,1,3.671430,7,62,4.766442,0,3.614254190,1,0,2.784692,7,54,5.677647,0 ,4.165876197,1,1,6.332982,5,41,4.944419,1,4.256215571,1,0,3.280260,8,58,4.550068,1 ,5.088455679,0,1,4.052454,13,39,6.069946,1,6.116862102,0,1,3.977267,12,38,6.141898,1 ,12.683461723,0,0,1.517336,5,70,5.043558,0,4.453783981,1,0,3.871339,10,49,4.848485,1 ,8.785755092,1,1,1.782309,12,56,4.752127,0,4.130454944,1,1,6.445827,17,50,5.390110,1 ,0.404675946,1,0,3.814497,11,53,5.064476,0,4.072113862,0,0,5.897269,9,29,4.561979,1 ,0.740543355,1,0,6.359513,8,51,4.902490,0,3.758998262,1,0,4.317449,17,40,5.201327,1 ,6.319724316,1,1,5.784411,5,54,4.899540,1,3.303044922,1,1,7.979470,13,48,5.404638,1 ,7.902598376,0,1,1.160953,10,59,4.682826,1,1.647431277,1,0,3.702247,13,57,5.096031,0 ,5.017489872,0,1,3.201001,3,42,4.781478,1,9.130907734,0,1,4.749968,7,42,5.421048,1 ,2.178538364,1,0,2.171074,17,59,4.796997,0,11.721630968,0,0,1.572511,12,52,5.416025,0 ,4.982466788,0,1,1.210030,7,51,4.503865,0,0.989578057,0,0,7.625260,20,62,4.660392,0 ,0.198328257,0,1,3.333207,5,52,5.318160,0,1.195690138,1,0,2.651865,17,52,5.229125,0 ,1.917606493,1,1,2.632788,9,48,4.704970,0,3.186227065,1,1,1.684827,7,38,4.672253,1 ,3.760231427,1,1,1.262469,10,51,5.877699,1,0.371193691,1,0,6.507787,17,52,6.180629,0 ,6.708271608,0,1,2.340167,8,34,5.941006,1,3.092500668,1,0,4.816183,22,64,4.801516,0 ,8.129999085,0,0,3.453010,15,49,4.520859,0,5.612371164,1,0,1.525717,10,44,5.160907,1 ,11.718612459,0,1,3.267709,17,46,4.704970,0,1.803107106,1,0,1.905088,27,67,4.742505,0 ,7.042425661,0,0,4.871394,10,54,5.229125,0,4.486400924,0,1,2.693333,7,60,4.991342,0 ,2.458152764,1,1,4.166088,8,45,4.724556,1,5.081226855,1,1,3.079174,7,56,4.991069,0 ,4.851088949,0,0,1.655767,5,70,4.921255,0,7.004463844,0,0,1.899629,8,32,4.412188,1 ,8.060202675,0,1,2.705815,10,34,5.033223,1,1.011714856,1,1,3.617589,21,45,5.993707,1 ,0.694334841,1,0,2.869502,12,52,4.933737,0,4.379653798,0,1,1.582491,5,33,5.115846,1 ,1.992834936,1,0,3.526825,3,25,5.451704,1,1.692036651,1,0,4.520205,17,44,5.333006,1 ,4.328743730,0,1,1.668471,7,47,4.594265,0,5.694383361,0,1,1.481445,3,30,5.067910,1 ,1.597763919,1,1,5.364744,20,41,4.907975,1,3.566550944,1,1,2.005828,7,48,4.843221,0 ,5.294380126,0,0,5.128683,7,50,4.529359,0,1.312443267,1,1,4.076913,15,72,4.896896,0 ,2.146343958,1,1,3.147547,12,41,4.983549,1,0.499759341,1,0,2.347291,18,36,4.506939,1 ,0.377100646,0,1,4.048678,7,46,5.412659,1,5.598202728,1,1,2.681853,20,35,5.842951,1 ,11.677910276,0,0,4.933050,22,66,4.810457,0,1.700213530,1,0,4.104284,12,53,4.516129,0 ,9.020224218,0,1,1.600587,5,43,4.902490,1,6.147254227,0,1,2.120357,8,49,4.603557,1 ,7.100147957,0,1,1.412633,17,39,5.500175,1,3.997298399,1,1,5.518855,6,43,6.373774,1 ,3.041361978,1,0,4.398945,8,46,5.128117,1,8.169657531,0,1,1.744003,7,23,5.228350,1 ,6.510418634,0,1,1.718795,10,53,5.015566,0,6.828632147,1,1,2.016646,12,48,5.709323,0 ,0.861517178,1,1,5.276851,8,40,4.902511,1,4.886619000,1,0,6.515116,17,45,4.648958,1 ,9.676396170,0,1,3.117316,11,52,5.201327,0,3.716733232,0,1,2.108093,13,67,4.444445,0 ,1.115358443,1,1,5.601878,20,68,4.619330,0,1.303703540,1,1,3.507072,12,42,5.685352,1 ,0.196904947,0,1,3.018814,10,26,4.643764,1,1.976208169,1,1,3.824025,27,42,5.509923,1 ,0.531891014,1,1,3.220245,20,48,6.090869,1,3.118361672,1,0,5.715606,17,45,4.413292,1 ,9.422584610,1,0,2.823839,12,24,4.830680,1,0.002647261,0,1,2.844084,7,22,4.960784,1 ,1.108267800,1,0,6.904618,8,49,4.891389,1,2.908533443,1,1,2.273455,14,36,5.863020,1 ,6.778521025,1,1,2.785345,8,37,5.554637,1,6.173335308,0,1,3.364887,8,60,4.913402,0 ,6.935856038,0,0,3.818273,6,62,5.615465,0,0.166028795,0,0,5.748957,15,38,6.033400,1 ,2.725026051,1,0,4.288533,8,46,5.128117,1,4.612444617,1,1,3.030475,8,40,5.657501,1 ,1.281861622,1,1,5.674807,2,41,5.327739,1,9.339026857,1,1,3.871680,13,43,5.180603,1 ,10.735606323,0,1,3.281375,8,55,5.015292,1,2.365873897,1,0,2.535791,27,65,5.000000,0 ,11.766978135,0,0,2.478327,18,57,5.420771,0,4.271065215,0,1,1.213050,11,41,5.412659,1 ,0.616397869,1,1,4.264361,17,22,4.923234,1,4.027677286,0,0,1.190329,10,28,6.073310,0 ,8.809499703,1,1,3.195532,7,56,4.242424,0,0.945373395,1,1,1.512612,5,55,4.933303,0 ,4.457597521,0,1,4.558692,17,51,4.668973,0,10.968263637,0,0,1.326111,5,70,5.043558,0 ,1.893454171,1,1,5.306797,7,32,4.839637,1,3.071826066,1,0,1.022251,10,34,5.266344,1 ,3.332564283,0,1,4.634036,7,34,5.247021,1,5.498649241,0,0,1.586036,6,46,5.096031,1 ,0.983960569,1,1,3.265702,8,46,4.830680,1,0.002802357,0,1,2.041719,7,22,4.960784,1 ,0.146355799,0,1,3.405241,5,35,5.520686,1,10.276878528,0,1,1.884935,5,22,4.881406,1 ,5.476632789,0,0,4.334094,17,69,5.071590,0,2.890838924,0,1,5.516277,16,31,5.391265,1 ,0.740958745,1,0,8.021389,10,43,5.219121,1,5.918680277,0,0,2.598374,13,46,5.080005,1 ,6.252165398,0,1,3.278764,7,63,4.374999,0,8.144544727,0,1,5.920142,14,52,5.514311,0 ,7.272492165,0,1,3.646474,10,50,5.811836,0,6.113740440,0,1,1.835806,7,44,4.984073,1 ,0.240082926,0,1,3.061189,17,31,6.419274,1,2.826153656,0,1,3.521198,18,44,5.257000,1 ,6.600704658,0,1,1.072442,4,37,4.784644,1,0.589988940,1,0,1.087028,15,55,5.248639,0 ,3.565092881,0,1,4.115564,11,50,6.312191,1,2.239053344,1,1,3.994855,12,40,4.870861,1 ,3.933021427,0,1,1.398644,4,48,6.011017,0,6.621891045,0,1,2.730461,12,26,4.247670,1 ,10.185764983,0,0,6.359992,5,62,5.588507,0,0.895861781,1,1,5.710522,8,40,4.902511,1 ,5.411703008,0,1,1.056656,5,43,4.864693,1,8.565351894,0,1,3.348079,8,54,4.451705,0 ,6.421887837,0,1,9.766629,10,60,5.182124,0,6.298610506,0,0,1.253611,8,47,4.191617,1 ,0.296036847,0,1,4.810572,17,55,4.791564,0,10.851082559,0,1,3.814584,12,48,4.861484,0 ,7.980208024,0,1,5.487632,10,52,4.466325,0,3.638660988,0,0,2.472651,8,40,5.326697,1 ,7.442259017,0,1,3.339889,3,61,4.619330,0,7.968494005,0,1,2.078416,8,31,5.624463,1 ,5.638054393,1,1,2.112804,10,29,5.474375,1,2.274404360,1,1,3.887508,11,44,5.163978,1 ,2.806913498,1,1,3.938302,20,64,4.650930,0,4.014024757,0,1,4.271452,10,51,4.913402,0 ,4.495647291,0,1,1.342853,17,29,4.752127,1,8.205679002,0,1,1.964848,7,52,5.201327,0 ,10.934958368,0,1,3.501997,28,68,6.308775,0,1.075246807,1,0,3.377548,17,58,6.343058,0 ,10.341693264,0,0,1.863250,12,44,4.830909,1,7.693085207,0,0,3.165204,7,54,5.481173,0 ,5.395744543,0,1,4.457089,12,48,4.778376,0,5.382884698,0,1,3.773782,6,42,5.452375,1 ,6.508818756,0,1,2.879026,7,35,5.219121,1,2.990790446,1,1,2.670362,10,61,4.677072,0 ,2.069391739,1,1,3.632507,3,67,4.224999,0,1.827157268,0,1,3.541418,5,29,5.407597,1 ,1.100326438,1,0,3.830103,33,30,5.132883,1,1.041723950,1,0,5.027721,10,42,5.174546,1 ,4.441376641,0,1,2.877808,8,41,5.219121,1,3.330571019,1,1,5.685433,10,39,4.650930,1 ,2.516389054,1,0,2.964775,4,54,4.549815,0,6.898805381,0,1,1.874730,4,37,4.784644,1 ,11.377748124,0,1,4.265396,3,58,5.652957,0,5.471347402,0,1,5.358442,13,50,4.810457,0 ,9.166552745,0,1,3.909758,7,64,4.820110,0,5.878316974,0,0,5.537839,4,24,4.572111,1 ,0.786873728,0,1,4.422472,8,69,4.519892,0,4.164596816,0,1,1.600253,3,43,5.237828,1 ,11.542036207,0,0,4.889596,6,53,4.952207,0,6.423826599,1,1,3.495273,10,67,4.419417,0 ,3.506319462,0,0,1.130150,8,60,5.094267,0,9.498279253,1,1,3.506834,5,62,4.839637,0 ,12.609272471,0,1,5.727082,13,36,5.344762,1,4.777893721,0,0,4.754430,4,52,4.829433,0 ,2.623103825,1,1,4.749771,10,33,4.850712,1,2.883005385,1,0,2.714045,7,57,4.798963,0 ,5.539691312,0,1,2.584135,3,43,4.984073,1,9.465759539,0,1,2.798065,10,62,5.352583,0 ,4.067581461,1,1,3.001352,9,32,5.290592,1,3.096699745,0,1,3.091198,8,27,5.583828,1 ,4.130818534,0,1,3.075352,10,42,6.369427,1,2.200995115,1,1,2.587967,8,43,5.194805,1 ,0.844702499,0,0,3.591533,8,73,4.666667,0,2.302195126,1,0,5.316506,7,41,4.784644,1 ,7.954934108,0,1,5.940959,17,25,5.132883,1,1.886116862,1,1,3.103121,12,45,4.983549,1 ,4.210835201,0,0,1.733284,10,54,5.717564,0,2.131763536,0,1,4.552194,12,31,5.333333,1 ,2.606818892,1,1,4.143072,13,53,4.983549,0,0.967519928,0,1,3.333475,20,30,4.631800,1 ,1.577373909,1,0,6.969599,11,44,4.744147,1,0.928473702,1,0,5.932476,13,71,4.648958,0 ,3.928922370,1,0,3.830729,7,35,4.771733,1,8.851494640,1,0,1.376508,17,59,5.419018,0 ,11.587160723,0,1,2.125626,13,44,4.606335,1,9.169098320,0,1,3.465583,14,44,5.085716,1 ,5.396104741,0,1,3.956372,8,28,5.770498,1,1.627566038,1,0,4.930407,20,69,4.319955,1 ,2.878920068,1,0,2.669477,4,59,5.576548,0,8.402053876,0,0,1.943587,7,57,4.250432,0 ,6.477433818,0,1,3.327807,15,60,5.254470,0,2.249856597,1,1,1.139254,8,49,5.303301,1 ,6.756788662,0,1,3.181352,10,46,5.447472,1,4.565235126,0,1,3.432877,15,41,5.153882,1 ,1.107124452,1,0,4.116839,7,54,4.841229,0,5.829129699,0,1,1.574529,4,37,4.784644,1 ,3.344702727,1,1,3.640927,4,40,5.327739,1,4.106279312,0,0,1.307658,3,43,5.237828,1 ,5.597583817,0,1,1.789552,5,33,5.063291,1,4.889016791,0,0,5.076378,22,62,5.309829,0 ,1.614847931,1,0,1.776776,12,39,5.697535,1,5.700602099,1,1,3.228300,7,33,5.180268,1 ,4.154081131,1,1,5.970791,8,64,5.303301,1,3.498311267,0,1,4.873115,16,54,4.572111,0 ,1.725516742,1,1,3.473946,12,45,4.983549,1,3.088626334,0,1,1.506025,8,27,5.787719,1 ,1.813557055,1,1,2.023611,5,41,4.886249,1,6.473210783,0,1,3.951521,5,45,5.585256,1 ,11.904159777,0,1,3.296605,13,51,4.621678,0,4.618503669,1,1,4.554781,13,28,5.241720,1 ,2.148192411,1,0,1.794118,12,46,5.109458,0,1.399641222,1,1,3.882329,5,46,6.495191,1 ,6.524877740,0,1,4.092007,8,58,4.980119,0,4.257113222,0,1,2.469730,12,61,5.106757,0 ,8.075994008,0,0,3.373190,7,53,4.521553,0,3.195923170,0,0,3.511813,17,54,5.196646,0 ,2.868072448,1,0,3.325605,7,69,5.717564,0,0.134297954,1,0,4.100890,5,21,4.593059,1 ,10.994402054,0,1,3.463139,10,52,4.650930,1,2.920086105,1,1,3.686064,10,76,4.668973,0 ,7.114572805,0,1,2.859050,8,34,5.941006,1,6.318422168,0,0,3.211131,7,44,5.080005,1 ,4.261228357,1,1,5.402267,17,43,5.416025,1,0.771896875,0,1,1.980577,7,43,5.966562,1 ,5.793255777,0,0,7.124845,6,36,4.997398,1,1.139539301,1,1,2.473024,15,37,5.296764,1 ,2.413839400,1,0,3.237792,20,64,4.650930,0,8.958817363,0,1,1.670993,10,59,4.682826,0 ,2.822138019,1,0,2.963084,15,61,4.687360,0,3.422131727,0,1,3.251236,7,46,5.206833,1 ,7.993613717,0,0,2.485564,6,69,4.621613,0,8.782852576,0,0,2.436971,8,35,5.315730,1 ,5.397216464,0,1,3.467820,12,26,5.660932,1,2.223455060,1,0,3.055016,15,43,6.136303,1 ,6.027392173,0,1,3.852236,10,34,4.881406,1,1.084586392,1,1,9.265588,28,37,5.333333,1 ,1.243429923,1,1,4.679064,4,41,5.488114,1,5.668138399,0,1,1.388813,5,42,5.257000,1 ,9.413060378,0,1,3.270537,11,52,5.201327,0,1.342867651,0,0,5.186753,2,41,5.327739,1 ,6.845927230,0,1,1.199097,4,21,4.731417,1,0.002594154,0,1,2.510500,7,22,4.960784,1 ,3.591301516,1,0,3.714610,3,43,5.735394,1,8.740492055,0,1,1.320928,5,48,4.836185,0 ,4.955223384,0,1,3.600015,2,29,5.006571,1,6.020906848,0,1,3.806682,4,41,4.847189,1 ,6.102748685,0,1,1.163931,3,61,5.229125,0,1.794673196,1,0,4.604695,13,36,5.077524,1 ,0.961791287,1,0,1.897478,8,45,5.135196,1,4.509406570,0,1,4.138604,10,53,4.759858,0 ,12.773241666,0,1,3.246316,8,46,4.459131,1,5.380294851,0,1,3.815470,5,44,5.070667,1 ,2.745994109,1,1,1.887257,7,22,4.613830,1,1.070126274,1,0,4.309045,7,37,5.220239,1 ,4.643592929,1,0,2.261823,5,57,4.327874,0,6.427625098,0,1,3.039427,7,39,4.605263,1 ,4.353008821,0,1,2.223608,12,61,5.106757,0,9.791228457,0,1,3.375487,7,58,4.736275,0 ,0.958278043,1,1,5.988311,17,46,6.027281,1,2.460672056,1,1,1.545435,8,49,5.303301,1 ,3.814724112,1,1,4.389676,8,65,4.850712,0,6.472706164,1,1,4.784875,17,64,5.970874,0 ,7.701176767,1,1,4.943282,8,56,4.587815,0,7.717132494,1,1,1.110856,5,34,5.350588,1 ,5.253226996,1,1,7.734394,15,45,5.315730,1,2.861673863,0,1,3.736011,10,42,5.829612,1 ,5.639338624,0,0,2.882569,9,50,5.423261,0,1.139180586,1,1,4.084861,10,23,4.850811,1 ,1.520258869,1,1,4.470049,3,41,5.096031,1,2.082513273,1,1,4.215316,8,48,4.841229,1 ,0.451145072,1,0,5.746813,23,45,4.408289,1,5.234386256,0,1,1.974097,4,53,5.359112,0 ,1.842741723,1,1,3.575789,5,28,5.015292,1,2.634777668,1,0,1.380876,13,58,4.781478,0 ,3.054968894,1,0,4.879149,13,32,5.344762,1,7.791163189,0,0,3.961538,13,60,4.494666,0 ,7.626997128,1,1,2.394343,5,54,5.247021,0,5.744454066,0,0,3.634870,13,67,6.004324,0 ,0.944391903,1,0,6.257458,13,65,4.921255,0,5.512751067,1,1,7.889996,7,55,5.698029,1 ,1.473004997,1,0,3.968566,8,51,4.381244,0,3.695483268,1,1,3.887463,5,32,4.535342,1 ,2.256091719,1,0,3.728736,7,56,5.366974,1,7.127344269,0,1,3.892185,4,54,4.408289,1 ,5.495598537,0,1,3.465119,12,36,5.488114,1,2.024487003,1,0,3.465722,8,66,4.916011,0 ,0.432877386,1,0,4.224798,2,43,5.810369,1,8.950332014,0,1,5.615929,17,54,4.577900,1 ,3.217240913,0,1,3.111013,2,51,5.412659,0,7.391514326,0,0,2.190754,10,61,4.921529,0 ,3.679468099,0,1,7.903886,11,26,4.871677,1,3.752650627,0,1,4.828012,13,50,5.416760,1 ,1.359926640,1,1,5.950181,17,60,5.205962,0,1.779742809,1,1,2.673481,5,41,4.886249,1 ,0.240097132,0,1,3.313608,17,31,6.419274,1,7.041773733,0,1,5.807772,12,56,4.984073,0 ,5.274468466,0,0,4.617729,7,25,4.563989,1,8.570785937,1,1,4.003927,9,43,5.323971,1 ,0.869031974,1,0,4.322735,20,53,4.843404,0,3.080014795,1,1,1.763183,8,30,6.171599,1 ,3.117189568,1,1,5.752226,16,31,5.391265,1,2.512258594,1,0,4.975315,5,47,5.248639,1 ,0.393262367,1,1,4.707015,20,45,5.584316,1,0.029258002,1,1,1.660248,19,22,4.983549,1 ,10.925533555,0,1,1.099849,27,53,4.478945,0,11.226861385,0,0,2.292972,5,55,5.170100,0 ,10.520582169,0,1,1.818042,12,44,4.830909,1,2.969630861,1,1,3.246843,4,40,5.327739,0 ,5.093499793,1,1,3.942309,17,65,5.269940,0,7.722979982,0,1,2.268929,8,53,5.549887,0 ,1.736996954,1,1,3.268263,27,42,5.509923,1,1.649247269,1,1,3.067915,7,49,4.693797,0 ,2.631835290,1,1,4.405991,10,33,4.850712,1,11.325181177,0,1,4.104817,12,43,4.408289,1 ,2.499554846,1,1,5.046849,10,39,4.641669,1,1.753958309,1,0,1.852803,13,55,4.766442,0 ,10.798710395,0,1,1.132757,6,50,4.850811,0,5.488611585,0,0,7.169972,10,53,5.352583,0 ,0.404717449,1,0,7.609000,3,45,5.174546,1,6.785996019,0,0,1.977703,9,58,4.706487,0 ,5.457547924,1,0,2.626157,5,50,4.736275,1,6.090189523,1,1,4.484178,18,26,5.439283,1 ,4.043925973,0,1,3.879262,10,57,4.985775,0,5.207490385,0,0,2.532634,3,40,4.701095,1 ,6.700785566,0,0,1.046443,9,58,4.706487,0,8.063779312,0,0,3.863380,12,42,4.960784,1 ,3.443084267,0,0,4.055330,13,55,6.196016,0,3.742564597,1,1,1.921520,30,43,5.659616,1 ,7.347604840,0,1,2.289630,7,53,5.764246,0,4.522371497,0,0,1.743172,10,54,5.717564,0 ,3.141453858,0,0,4.195614,12,59,6.130060,0,2.610096567,1,0,4.644975,10,63,5.178184,0 ,5.676462759,0,1,3.145090,10,47,4.974681,0,0.823474027,0,1,1.847302,7,43,5.966562,1 ,5.064240342,1,0,4.547300,20,47,5.318160,0,3.814753975,1,1,7.130591,13,48,5.404638,1 ,1.948065239,1,1,2.895129,10,30,4.561979,1,0.307495726,0,1,1.999431,10,25,4.796997,1 ,1.087432697,1,0,6.069058,8,39,4.956558,1,11.623339762,0,0,3.126116,16,47,4.983549,1 ,5.289909514,0,1,1.343425,3,53,4.921255,0,11.200088930,0,0,1.754649,6,65,5.038911,0 ,3.818835120,1,1,7.430773,18,34,6.383217,1,3.581836528,0,1,3.594143,7,57,5.625326,0 ,3.978130150,0,0,4.689308,25,34,4.976703,1,3.966332634,0,0,3.086715,23,61,5.420771,0 ,5.853514645,0,0,3.617398,7,44,5.080005,1,5.024868105,0,1,4.186934,13,54,4.516129,0 ,5.014721549,0,1,6.599893,18,51,5.025885,0,6.123538776,0,1,9.218273,10,60,5.182124,0 ,0.250535083,1,0,4.255883,17,60,5.882353,0,5.315638988,0,1,3.552472,9,39,6.211300,1 ,8.943173794,0,0,2.027613,6,69,4.621613,0,0.643938181,1,1,2.772486,12,52,4.933737,0 ,11.665038561,0,0,2.688076,18,57,5.420771,0,6.386061328,0,1,3.495028,13,38,5.178184,1 ,3.754429619,0,1,1.990836,10,64,5.102694,0,1.803470788,1,0,3.253845,8,62,5.516086,0 ,4.626745340,1,1,2.398580,13,31,5.486540,1,4.498457366,0,1,3.056049,5,56,5.943168,0 ,11.781940349,0,1,4.172124,3,43,6.165568,1,0.636151513,1,0,4.104137,27,64,4.985775,0 ,7.071992117,0,0,7.530330,23,31,4.819277,1,2.054706340,1,1,4.429761,12,43,5.359078,1 ,4.081329354,0,0,4.672746,13,30,5.474375,1,4.410354002,0,1,1.943130,20,47,4.821142,0 ,10.830422327,0,0,1.406592,6,65,5.038911,0,2.021974852,0,1,4.598517,17,30,4.839637,1 ,0.984429151,0,1,3.572986,10,35,4.683626,1,2.791930722,1,1,6.938314,13,51,4.778846,0 ,1.319126947,1,0,6.658133,13,47,5.487805,1,3.403215755,0,1,2.820119,10,66,4.724556,0 ,1.114048386,1,1,7.170733,33,40,5.796012,1,1.726013194,1,1,1.201856,13,52,5.957490,0 ,4.236758247,0,0,1.039859,7,50,5.940885,0,2.399982465,1,0,1.548747,17,60,4.980119,0 ,10.192507553,0,1,2.264828,6,53,4.899540,0,4.533598947,0,1,6.302760,25,43,5.699880,1 ,12.328957704,0,1,2.500607,17,65,6.250000,0,5.429531916,0,1,2.670772,5,30,4.907975,1 ,1.984378344,1,0,3.649803,3,44,4.984073,1,1.674410282,1,1,8.669409,8,56,5.178184,0 ,7.865770458,0,1,1.528876,5,34,4.921255,1,1.729541664,1,1,3.158925,7,55,4.967597,0 ,6.968346506,0,0,3.422479,9,44,5.773003,1,8.564097952,0,1,3.386506,10,54,5.510658,0 ,1.338175242,1,1,6.946359,17,27,5.624977,1,1.230913660,1,0,3.834779,12,59,4.672253,0 ,10.367612136,0,0,3.435516,5,61,5.352583,0,1.067652497,1,1,2.511027,14,67,5.642155,0 ,0.620071897,0,0,1.027446,13,35,5.772393,1,0.911272438,1,1,5.543977,8,40,4.902511,1 ,1.303407766,1,1,4.257949,8,49,4.652018,1,5.699432411,1,1,4.889994,10,52,4.686909,0 ,1.547658188,1,1,1.968839,8,55,4.930935,0,7.358874620,0,1,4.041300,20,55,5.481173,0 ,5.571559299,0,1,4.007010,10,53,5.009940,0,3.676279729,0,1,1.946200,5,68,4.550068,0 ,6.684024578,1,1,3.979688,17,56,4.615620,0,1.379151664,1,0,3.149651,15,61,5.455447,0 ,0.629674483,1,0,2.702666,5,48,4.980119,1,4.742057996,0,0,4.425371,3,52,5.294117,0 ,2.015700490,1,1,1.872647,8,48,5.590170,1,3.043686427,1,0,1.679111,7,65,5.007613,0 ,6.327232707,0,0,1.423567,8,65,4.607373,0,2.035903059,1,1,3.731202,16,47,5.404638,1 ,9.197425396,0,1,3.015058,7,53,4.498833,0,7.587141539,0,0,1.617228,11,34,5.381357,0 ,10.418610171,0,1,2.941383,13,44,4.606335,1,7.188468185,0,0,2.067625,3,59,4.619330,0 ,5.295264044,1,0,1.067770,7,43,4.733485,1,2.325087890,1,0,3.215898,13,51,5.070603,0 ,6.965401833,0,0,1.519877,13,52,4.881905,0,1.138303286,1,1,1.082815,5,63,4.786756,0 ,3.677413744,1,1,5.675761,17,64,4.606335,0,5.864792939,1,1,3.875541,8,42,4.423004,1 ,0.760840306,1,1,3.999757,7,53,4.808812,0,3.656370708,1,0,5.468261,8,46,4.427997,1 ,7.977481081,0,1,2.167356,10,53,5.555122,0,3.666981993,1,1,6.772681,12,49,4.419417,0 ,8.704343821,0,0,4.100223,15,40,5.115846,1,5.110168507,0,0,1.458944,4,43,4.302066,1 ,1.647651386,0,1,6.557593,5,56,4.465782,0,1.090246173,1,0,1.680488,6,42,4.899540,1 ,2.257441262,1,1,3.015033,3,42,4.843404,1,1.953757578,1,1,3.024511,12,45,4.983549,1 ,5.885632485,0,1,2.956574,13,43,5.479188,1,8.194390338,0,1,7.579026,13,35,5.359112,1 ,10.215228869,0,0,3.524750,17,41,4.841229,1,4.927100198,0,1,2.800356,7,33,4.802921,1 ,2.083129417,1,0,2.583179,7,41,4.230605,1,8.860463429,0,1,2.872429,9,57,4.811160,0 ,1.122232053,1,0,3.870709,33,30,5.132883,1,5.192371923,1,1,1.290323,5,33,5.063291,1 ,3.076037616,1,0,5.099107,12,28,4.741448,1,2.968698078,1,0,3.007386,12,63,5.313040,0 ,6.855113339,1,1,2.081363,4,40,4.946170,1,9.073883685,0,1,1.796952,5,62,5.796012,0 ,4.529704834,0,0,2.538278,9,38,4.974681,1,8.954766884,1,1,1.717818,12,30,5.174546,1 ,4.204872587,1,0,5.798053,30,71,4.536092,0,0.143972740,1,0,4.512659,17,41,5.661268,1 ,4.089147902,0,1,3.590890,10,54,6.084539,0,0.914337276,0,0,4.581733,10,35,4.682535,1 ,1.338854033,1,1,1.164560,7,51,5.146990,0,1.504048270,1,1,4.605996,4,25,5.055576,1 ,4.054685644,0,0,1.846526,8,41,5.266344,1,8.813238157,0,1,3.038083,8,59,4.680553,0 ,4.712040939,0,1,2.912451,12,69,4.759858,0,1.047072230,1,0,3.203211,7,45,4.753973,1 ,3.748215334,0,1,4.663353,17,46,5.115846,0,3.691430329,0,1,2.328387,13,67,4.444445,0 ,1.622962498,1,1,3.417064,17,49,6.172840,0,1.703839499,1,1,3.225836,7,38,5.021689,1 ,3.692680160,0,1,6.947422,8,52,5.418258,1,8.236347756,0,1,3.231294,6,35,5.514311,1 ,5.493944034,0,0,1.195176,10,48,5.391265,1,1.740439738,1,0,7.561386,12,68,5.422877,0 ,9.467880878,0,0,4.429035,13,47,4.811160,0,5.534484262,1,1,4.177471,8,25,4.901409,1 ,3.263101583,0,1,3.750295,8,56,4.689338,1,11.031644791,0,1,3.568039,4,45,6.558120,1 ,3.631417685,0,1,1.254824,12,62,5.587602,1,0.664138551,1,1,4.826736,17,22,4.923234,1 ,0.551372078,1,0,2.199468,13,47,4.798963,1,1.280112444,1,1,6.409967,5,46,4.819277,1 ,3.409553875,1,1,3.845603,7,38,5.454546,1,6.523484412,0,1,6.081367,7,60,4.466325,0 ,12.469131390,0,1,3.269804,5,51,4.028379,0,5.796893424,1,0,2.936419,12,57,4.910347,0 ,4.892863138,0,0,3.538422,13,31,4.908459,1,9.756522156,0,0,4.437509,17,61,5.994789,0 ,5.956365864,0,1,3.241240,12,48,5.077524,0,4.273672079,0,1,1.138052,13,35,6.052149,1 ,1.283302727,0,0,1.568443,10,75,4.771733,0,2.593753193,1,1,4.576124,12,56,4.561979,0 ,11.022361688,0,1,2.562302,7,46,4.723693,1,4.341809339,0,1,1.490054,8,34,5.070667,1 ,1.740294068,1,0,3.022582,4,48,4.991342,1,1.207288043,1,0,5.583565,2,41,5.327739,0 ,6.801260934,0,1,1.536236,17,50,6.431975,0,1.239098875,1,1,4.007751,17,40,6.295086,1 ,1.923827177,1,0,4.302293,3,53,4.835737,0,0.242325526,1,0,7.432516,17,39,5.169417,1 ,1.962638927,1,0,5.646618,9,51,4.593059,0,4.765866071,1,0,3.637664,10,49,4.848485,1 ,7.497251748,1,1,4.630456,20,58,4.856782,0,9.718406642,0,0,3.369178,7,58,5.153882,0 ,6.159691103,1,1,4.243608,6,51,5.767761,0,8.714778531,1,1,2.099445,13,61,4.899540,0 ,1.347854222,0,1,1.391289,7,35,4.977315,1,5.704179743,0,0,2.328115,5,53,4.861484,0 ,6.091363504,0,1,1.109748,6,39,5.784654,1,1.326709378,1,0,3.207921,8,30,5.148021,1 ,3.637595079,1,1,5.518120,13,42,5.084070,1,0.493235736,1,1,2.206559,10,33,4.681194,1 ,6.604112747,0,1,3.543386,5,30,4.381244,1,0.704454326,1,0,5.358995,8,34,6.344507,1 ,6.813956765,1,0,2.938351,5,54,5.247021,0,7.243775093,0,1,1.665633,12,65,4.590991,0 ,6.249772609,0,0,1.794299,10,48,5.391265,1,9.608482597,0,1,1.714089,27,53,4.478945,0 ,0.500085713,1,0,4.301557,15,65,6.157191,0,5.480820839,0,1,3.189965,8,54,4.850712,0 ,12.710331207,0,1,5.678058,18,52,4.991342,0,2.313843835,1,1,1.115404,8,48,5.590170,1 ,0.056334345,0,1,3.687239,10,70,5.263158,0,6.024738466,0,1,3.098768,10,47,4.974681,1 ,1.745185673,1,0,3.256935,7,38,5.021689,1,3.839304875,0,1,3.408107,10,57,4.985775,0 ,4.140271763,1,0,4.057547,13,63,4.419417,0,1.711032155,0,1,5.459517,13,61,4.374088,0 ,2.945441471,0,0,1.405297,4,61,4.695976,0,3.901363912,0,1,2.377022,8,60,5.207717,0 ,6.368603051,0,0,3.065122,15,63,4.943196,0,11.082273203,0,1,3.236662,8,55,5.015292,0 ,6.616702935,0,0,4.697332,15,48,5.120432,0,8.089383595,0,1,2.602792,8,31,5.624463,1 ,4.535427619,1,1,2.685595,6,33,5.096031,1,0.341383471,1,1,4.014767,20,45,5.584316,1 ,4.216489097,0,0,1.873561,10,64,5.645998,0,10.816620562,0,1,5.293613,3,44,4.869480,1 ,2.918432540,1,1,1.946789,13,45,4.847189,1,5.836709913,0,1,2.577243,9,36,5.385101,1 ,2.466280534,1,0,3.519277,11,57,4.479032,0,1.710999982,1,1,2.286678,13,47,5.217020,1 ,0.454346596,1,1,5.080456,23,24,5.401257,1,1.411485907,1,0,4.108376,10,45,4.921529,1 ,5.112801510,0,1,1.299017,4,53,5.359112,0,2.124665475,0,1,1.207315,12,25,5.714959,1 ,4.209002507,0,1,2.060803,6,56,4.540842,1,2.920484931,0,1,4.500004,33,56,4.904786,0 ,4.774739271,1,0,1.534296,3,40,4.631800,1,2.784954072,1,1,4.319636,23,29,5.115846,0 ,2.501403175,0,0,3.549613,10,69,4.637013,0,4.784769985,1,0,4.576474,20,42,6.797196,0 ,3.484472023,1,1,2.526027,10,19,5.109458,1,0.938932350,1,0,5.619398,17,40,5.094267,1 ,0.159616361,0,0,5.332134,15,38,6.033400,1,9.910881360,0,1,1.597291,7,31,5.029849,1 ,3.745673862,1,1,3.402812,8,46,5.206833,0,5.694807992,1,0,1.506099,3,69,5.391265,0 ,7.085666266,0,1,3.803988,15,65,5.225269,0,7.315893747,0,1,1.828972,12,65,4.590991,0 ,0.359526952,1,0,7.432276,12,37,4.762347,1,3.824774877,1,0,5.918078,13,43,4.988877,1 ,0.982772838,0,0,3.579282,8,73,4.666667,0,2.296799624,1,0,3.528680,7,56,5.366974,1 ,1.171713557,1,1,3.774755,5,21,4.599488,1,0.403966122,0,1,5.021954,18,68,4.713064,0 ,8.476544176,0,1,2.615981,6,33,4.508021,1,9.171684436,0,0,3.688894,10,50,5.132883,0 ,4.501429805,0,1,3.868264,5,40,4.997703,1,7.027335286,0,1,1.930436,13,37,5.359112,1 ,8.157290614,1,0,4.747985,12,50,5.163978,0,4.795064767,0,1,4.249273,10,44,4.635125,1 ,0.150124681,0,0,5.595037,15,38,6.033400,1,1.685459787,1,1,5.868948,13,66,4.800717,0 ,5.789678885,0,0,2.262091,5,39,4.834520,1,1.807590302,1,1,4.509097,15,42,4.879078,1 ,5.849247382,1,0,4.852739,5,37,5.174506,1,6.505686522,0,0,4.137111,22,49,4.402515,1 ,5.965507461,0,1,1.939071,6,39,5.784654,1,4.745028981,1,1,1.053258,18,42,5.096089,1 ,7.397726906,0,1,2.246315,12,38,5.659616,1,2.582139688,1,1,6.767324,13,26,5.555122,1 ,11.620713389,0,0,2.144898,11,43,5.224291,1,2.354342799,1,0,2.147087,5,38,5.151093,1 ,5.919569252,0,1,5.462591,12,56,4.984073,0,2.982479436,1,0,4.404439,13,39,5.504342,1 ,2.043911104,1,1,4.789044,12,68,5.286123,0,6.471085244,0,0,3.951506,21,49,5.303301,0 ,0.399796909,1,1,5.164287,20,40,4.650769,1,10.989655194,0,0,3.660749,8,56,4.508264,0 ,5.618858888,1,0,2.844965,5,50,4.736275,1,8.903061433,0,1,2.530546,15,61,4.723693,0 ,5.849367329,1,1,5.745089,15,53,4.800717,0,3.330087391,1,1,5.408377,13,42,5.084070,1 ,2.450236703,1,1,4.486764,10,42,5.766097,1,9.622271528,1,1,2.089677,7,40,5.077524,1 ,7.346688972,1,1,3.503054,7,65,4.423004,0,2.478651273,1,1,4.371018,10,33,4.850712,1 ,3.895491310,0,1,4.428101,7,64,4.550068,0,0.353398250,1,0,2.659858,20,46,5.386311,1 ,6.413721112,0,1,5.275857,17,33,5.014839,1,11.180874380,0,1,2.211318,7,29,4.952207,1 ,8.942891953,0,0,1.842506,7,53,4.536092,0,3.260151861,1,1,4.456568,8,45,5.620375,1 ,0.290494463,1,0,5.976378,12,47,4.677072,0,3.055727764,0,1,6.463273,10,59,4.953681,0 ,0.766194332,1,0,7.256844,4,58,4.550068,0,1.521106293,1,0,8.229116,15,50,5.385101,0 ,3.305986019,1,0,4.139014,9,44,5.553775,1,6.471743709,0,1,2.100047,8,49,4.603557,1 ,3.950150655,0,0,3.332262,6,53,5.326697,0,0.990544543,1,1,3.381248,8,46,4.830680,1 ,3.924687900,0,0,3.280216,7,56,4.615620,0,7.015305440,0,0,3.387375,6,62,5.615465,0 ,1.417217070,1,1,3.455838,13,75,5.229125,0,10.686381647,0,1,4.642725,5,62,4.231886,0 ,7.922455770,0,1,2.804753,8,53,5.549887,0,6.190366155,0,0,7.111154,23,31,4.819277,1 ,5.878891469,0,1,2.374204,9,38,5.137896,1,1.770688727,1,1,4.540284,17,39,5.052686,1 ,2.177196351,1,0,1.940813,10,64,4.850811,0,3.530529798,0,1,6.152448,10,46,5.410267,1 ,5.916002765,1,1,4.911436,10,49,4.766442,1,7.569615889,0,1,3.472873,12,61,5.182124,0 ,5.298762161,0,0,1.040475,9,33,5.142595,1,1.420976909,0,1,2.265722,10,31,5.324759,1 ,5.471085865,0,0,3.298073,9,52,4.923659,0,8.747444579,0,0,1.321746,3,42,4.322629,1 ,1.065527489,1,0,5.262461,15,45,4.988877,1,3.061506056,1,1,2.738867,17,44,5.483719,1 ,3.101768774,1,1,4.103467,5,65,4.593059,0,3.487619817,0,0,2.029529,2,41,4.245699,1 ,6.933932250,0,1,3.596082,5,45,5.585256,1,1.627501819,1,1,3.103932,17,52,4.820110,0 ,0.459899324,1,0,3.436148,11,53,5.064476,0,1.196476922,1,0,2.791036,16,56,4.921529,0 ,11.015911395,0,1,3.866773,10,52,4.650930,1,6.493480081,0,1,1.706045,5,47,6.004324,0 ,4.323063906,1,1,3.060590,7,32,5.381357,0,5.687045109,0,1,1.883918,6,47,6.994941,1 ,8.029955685,0,1,1.344839,7,30,5.055576,1,4.521019032,0,1,3.643624,20,50,4.960819,0 ,8.275488496,0,0,4.024176,10,44,5.476925,1,0.978927475,0,1,3.900913,10,35,4.683626,1 ,4.191739835,0,0,1.734116,5,70,4.921255,0,4.186580516,1,0,1.027840,18,54,5.588332,1 ,3.085856359,0,0,3.336492,10,33,5.154913,1,0.536928066,0,1,2.596819,4,32,5.487283,1 ,0.194680564,0,1,6.918101,8,30,5.055576,1,3.133393842,0,1,1.236199,5,35,4.615620,1 ,1.455958072,1,1,4.255443,15,72,4.896896,0,5.071150410,0,1,4.203627,10,46,5.047441,1 ,5.197252612,0,1,1.523496,12,58,4.759858,0,1.686088255,1,0,6.768106,10,48,4.881406,1 ,7.146015864,0,1,3.070468,8,33,5.303301,1,3.140740703,1,1,5.457124,16,31,5.391265,1 ,2.995375995,0,1,2.412651,10,66,4.724556,0,5.847248092,0,1,6.272926,8,58,5.552737,0 ,7.864718976,1,1,6.764246,2,33,5.962848,1,6.584225602,0,1,5.211285,13,39,4.881905,1 ,0.754393587,1,0,5.989793,8,50,5.625326,0,2.387815383,1,1,4.734830,12,56,4.561979,0 ,1.461969210,1,0,6.026673,7,38,4.850712,1,2.690545692,1,1,4.465125,12,55,5.000000,0 ,9.542404099,0,1,1.977479,7,55,4.273348,0,6.744635861,0,1,4.647560,7,60,4.351666,0 ,3.172623868,1,1,1.919412,9,37,5.423261,1,9.720524347,0,1,3.777607,5,32,5.055576,1 ,3.337827875,1,0,3.729475,3,56,4.680553,0,8.633958091,1,1,2.907124,8,42,4.718646,1 ,4.773444195,0,1,3.721566,13,57,4.762347,0,8.238257041,0,1,3.775267,5,63,4.518320,0 ,3.198572387,0,1,4.746129,33,56,4.904786,0,3.267366762,1,1,4.905366,12,47,5.813129,1 ,0.931400313,1,0,3.859220,13,32,5.659425,1,8.459602638,1,0,4.539977,12,40,4.469809,1 ,10.128541824,0,1,3.368283,8,50,4.632703,0,5.195980381,0,1,1.910538,10,36,5.642155,1 ,5.852506169,0,1,3.876700,7,34,5.090253,1,6.510188589,0,1,3.003975,7,57,5.063291,0 ,3.872470390,0,1,4.161128,10,51,4.913402,0,7.483627495,0,0,1.357098,2,61,4.908459,0 ,4.131692208,1,1,5.209945,5,54,4.561979,0,2.694968577,1,1,1.119132,7,39,5.219121,1 ,3.787812692,0,1,1.064101,3,50,6.034860,0,1.253495932,1,1,3.296340,7,24,5.180798,1 ,1.165154219,1,1,5.900348,17,41,5.090253,1,4.895568901,0,1,7.015869,7,33,5.352583,1 ,2.806630443,0,1,2.610060,5,37,5.094267,1,1.191073802,1,0,7.813818,30,50,5.486694,1 ,9.939381623,1,1,3.169415,7,56,4.242424,0,3.225863512,1,1,2.121407,10,41,5.197775,1 ,0.344448391,1,1,3.092457,3,33,4.944419,1,3.726565385,0,1,2.963556,7,37,6.389871,1 ,0.826608778,0,0,6.412055,13,65,4.921255,0,2.980067010,1,0,2.558614,7,49,4.252083,1 ,1.236738356,1,0,7.448885,29,39,4.705882,1,3.880393843,0,1,3.072832,7,32,5.837676,1 ,3.729013091,0,0,4.712902,23,66,5.153882,0,4.170337678,0,1,3.894594,7,41,5.379040,1 ,9.514441755,0,1,3.584329,8,50,4.632703,0,8.285041461,0,0,4.233252,10,54,5.229125,0 ,5.500631989,0,0,2.195442,7,38,4.869480,1,3.914963804,0,1,3.152215,7,64,5.135196,0 ,2.088464898,1,0,4.029423,15,37,5.087983,1,4.695915733,1,0,3.674853,8,58,4.550068,0 ,0.508263771,0,1,1.563390,13,62,5.781450,0,6.423408436,0,1,2.161117,12,26,4.247670,1 ,3.814645745,0,0,3.108560,3,66,4.723693,0,5.121649589,1,1,5.113745,14,23,5.261336,1 ,6.925514557,0,0,2.878833,5,59,4.870607,0,11.682487699,0,1,1.528803,10,52,5.357143,0 ,1.416111472,1,1,4.456550,5,37,4.937851,1,3.878054673,0,1,2.235307,14,41,5.752427,1 ,2.087212526,1,0,4.277159,3,63,4.549815,0,11.490053811,0,1,4.920517,22,55,4.577900,0 ,1.256101345,1,1,2.184008,5,46,4.841229,1,0.994297127,0,1,3.027359,10,35,4.683626,1 ,5.419649140,0,1,7.539007,15,51,5.045987,0,3.663966622,0,1,6.360583,13,53,4.633481,0 ,8.512175783,0,0,4.602498,15,56,6.017664,0,2.665814427,1,1,3.777707,17,68,5.045599,0 ,8.666369135,0,1,3.935311,7,50,5.000000,0,9.608806822,0,1,8.645478,10,52,4.821142,0 ,12.072595912,0,1,5.177734,3,44,4.869480,1,2.886999926,1,1,5.462131,17,23,4.753973,1 ,0.803767962,1,1,2.498672,13,42,4.789794,1,10.416958992,0,1,2.119693,14,66,4.364066,0 ,1.026551632,1,0,3.098744,21,45,5.993707,0,7.667335959,0,1,3.372685,15,65,5.225269,0 ,7.624852608,0,1,3.687177,14,36,5.345836,1,4.142351924,0,1,1.987480,6,36,4.463393,1 ,3.429760437,1,1,3.259736,6,29,5.800728,1,7.490867481,0,1,1.704233,4,21,4.731417,1 ,3.869903494,0,1,4.590009,10,51,4.913402,0,4.281969914,0,0,3.971873,17,36,4.761905,1 ,3.944002883,0,0,3.128415,7,34,5.095541,1,10.968094598,0,0,1.468032,13,63,4.535342,0 ,5.212150599,0,1,3.214282,7,46,5.512261,1,3.622001163,0,1,2.950828,7,37,6.389871,1 ,0.385548345,1,1,1.019563,12,42,5.732484,1,1.914268609,1,0,4.715359,3,53,4.835737,0 ,0.588104360,1,1,9.685002,10,38,4.781461,1,5.557568658,0,1,2.078265,6,37,4.923234,1 ,3.822249042,0,1,1.666467,3,37,4.766442,1,10.318248702,0,1,4.334759,5,62,4.231886,0 ,2.823237952,1,0,2.649425,3,49,5.624385,0,2.492673108,0,0,3.377316,20,64,4.650930,0 ,1.269897482,1,1,4.920774,13,33,5.045987,1,9.357387723,0,1,1.830246,7,31,5.029849,1 ,1.645688168,1,1,3.882723,13,66,4.550068,0,4.903651221,0,1,4.779042,8,49,4.503865,0 ,4.510936888,1,1,2.734384,13,33,5.145105,1,0.956381372,1,0,6.548832,7,54,5.517594,1 ,1.914477820,1,1,3.041214,18,50,5.257000,0,4.989703569,0,1,4.949574,3,23,4.655240,1 ,8.088284030,0,1,1.665561,2,61,4.908459,0,5.214449620,0,1,1.544228,7,59,4.801516,0 ,0.561215906,1,1,6.643541,8,23,5.519851,1,7.285200687,0,1,2.316143,12,51,5.257000,0 ,1.658712539,1,1,2.431853,10,46,4.535342,0,8.969450859,0,1,7.833928,14,52,4.701095,0 ,1.862072924,0,1,3.555554,12,66,4.759858,0,0.624934128,0,1,1.302327,8,26,4.827945,1 ,1.355911583,1,1,4.869751,10,23,4.850811,1,8.520290436,0,1,3.430283,14,44,5.085716,1 ,9.497624757,0,1,2.607802,8,67,4.815713,0,0.984252049,1,1,4.560475,15,44,5.948074,1 ,6.512466904,0,1,3.379775,3,51,4.772126,0,9.250421339,0,1,1.691052,15,33,5.401378,1 ,3.061095497,1,0,3.273423,10,64,5.357143,0,8.622636667,0,1,1.536653,7,52,5.201327,0 ,6.451470142,0,1,3.627664,12,34,5.249339,1,10.723622760,0,1,2.081499,17,61,4.714770,0 ,4.626932916,0,1,3.223785,3,37,5.263158,1,1.174603368,1,0,3.604351,7,39,5.823232,1 ,3.277367725,0,0,4.956886,15,40,5.209758,1,4.576979733,1,1,3.188168,14,47,5.550788,1 ,1.751395382,1,1,6.483675,18,68,4.672253,0,3.228455601,1,1,4.016816,10,66,4.350764,0 ,8.824059396,1,1,1.913446,17,64,4.533199,0,6.269713275,0,0,6.857850,10,67,5.624713,0 ,6.376485793,0,0,3.339430,15,40,4.719673,1,3.583907430,1,0,3.372652,20,60,5.611407,0 ,1.034547914,1,1,4.694744,30,43,5.518136,1,5.683106629,0,1,1.782150,5,34,5.695211,1 ,9.372136899,0,0,4.141078,15,51,5.106757,0,8.749752051,0,1,2.565810,7,52,5.095541,0 ,2.875352299,1,0,5.988152,10,46,5.555451,1,1.999597713,1,0,7.011769,5,28,5.025885,1 ,3.684788517,1,0,4.480205,13,32,5.455447,1,11.260781370,0,0,1.302029,7,46,4.933737,1 ,2.667858936,1,1,7.545183,5,36,4.577911,1,0.165100834,0,1,5.976905,15,38,6.033400,1 ,3.677171814,1,1,4.256848,13,66,3.875617,0,7.959013539,0,0,1.518858,10,66,4.686909,0 ,0.453267962,0,1,1.311068,13,62,5.781450,0,7.981381743,0,0,3.079583,1,48,4.952456,1 ,1.091764040,1,0,6.968320,12,45,5.142595,1,2.530478925,1,0,3.404665,22,68,5.164568,0 ,7.857383113,0,1,1.535848,11,55,5.334129,0,6.030819284,1,1,4.804286,8,25,4.901409,1 ,3.541964972,0,1,1.563701,11,41,5.412659,1,8.166674885,0,1,1.516168,8,45,5.488113,1 ,1.452840143,1,1,3.202186,8,33,4.770898,1,0.627102346,1,0,1.644970,5,62,5.077524,0 ,2.017670790,1,1,2.584701,7,51,5.034317,1,3.913311846,0,0,1.630889,15,29,5.161291,1 ,12.363519356,0,1,4.134158,8,43,4.575657,1,2.280510671,1,0,2.942188,17,59,4.796997,0 ,4.341179063,1,0,5.692550,9,29,4.561979,1,0.543884458,1,0,5.872703,9,37,5.517594,1 ,5.384412364,0,0,7.086228,10,53,5.352583,0,0.357926877,0,0,1.233673,10,41,4.631800,1 ,7.515937889,0,1,3.709324,7,57,4.841229,1,6.610268430,1,1,2.985425,12,26,4.247670,1 ,0.767447666,1,0,3.118447,7,30,5.295317,1,2.430434981,1,0,2.116950,13,40,5.014839,1 ,8.792517293,0,0,1.345875,10,52,4.454354,0,3.013777351,1,1,3.569921,13,36,4.532735,1 ,2.163265932,1,0,4.411266,7,59,5.229125,0,7.968264872,0,0,3.003258,12,42,4.960784,1 ,0.844040503,1,1,8.385769,7,42,6.516221,1,2.132462188,1,1,2.068871,10,30,4.561979,1 ,10.138973269,0,0,1.010718,7,52,4.798963,0,3.056468891,1,1,1.038576,7,58,5.389681,0 ,2.560767053,1,1,6.056348,5,52,4.976703,0,3.663193185,1,0,3.686986,7,31,6.202187,1 ,2.291634648,1,1,4.039808,13,41,4.991342,1,8.643643262,1,0,2.566005,4,49,5.474375,0 ,9.164207891,1,1,3.264355,14,29,4.820110,1,4.102095343,0,1,1.825318,3,47,6.041007,1 ,7.108724919,0,0,1.307443,8,50,5.270361,0,4.659110887,0,0,2.996149,5,63,4.375697,0 ,3.004592075,1,0,2.455574,10,44,4.724556,1,8.739417505,0,1,1.396395,7,23,5.228350,1 ,7.454305665,0,1,4.503241,8,31,5.164568,1,4.439855779,0,0,1.313272,8,41,4.635125,0 ,7.439941799,0,1,3.301486,17,56,4.615620,0,4.982958377,1,0,5.707454,13,29,5.220239,1 ,8.799376889,0,0,1.639104,3,54,4.810457,0,1.478564699,1,1,3.254479,5,46,6.495191,1 ,8.231881752,0,0,4.892462,13,59,5.576314,0,1.370228371,1,1,5.351432,17,41,5.090253,1 ,7.847733076,0,1,1.340585,11,55,5.334129,0,9.260718383,0,0,2.958745,8,67,5.078968,0 ,0.713335555,1,0,7.859836,11,44,4.311743,1,1.908614536,1,1,2.698272,9,48,4.704970,0 ,0.947645353,1,1,4.364577,9,37,4.276668,1,7.067428947,0,1,3.923005,12,44,5.497474,1 ,8.226063233,0,0,4.746083,15,56,6.017664,0,2.140435100,1,1,6.296405,15,72,4.615620,0 ,8.220473873,0,1,3.105577,12,61,5.182124,0,3.949257197,1,1,6.190143,20,33,5.429166,1 ,7.047474298,1,1,1.336732,7,48,5.416645,0,7.598319805,0,1,3.714017,7,54,5.481173,0 ,10.267383089,0,1,1.222931,15,33,5.401378,1,4.023251093,0,0,1.371423,6,52,4.599488,0 ,8.131350075,0,0,2.936749,7,76,4.621450,0,4.243175326,0,1,5.441902,11,40,4.923659,1 ,1.052185439,1,1,2.927342,15,37,5.296764,1,11.637009767,0,1,4.994733,22,55,4.577900,0 ,1.843750316,1,1,5.343756,12,51,5.421687,1,3.217178057,0,1,2.654884,13,55,4.166667,0 ,0.050499688,0,1,3.330976,10,70,5.263158,0,2.150433838,1,1,4.745550,12,43,5.359078,1 ,4.119472797,0,1,3.218857,14,41,5.357143,1,5.816827159,0,1,1.338042,17,29,5.386785,1 ,1.235188234,0,1,5.678901,13,51,4.965363,0,1.902475299,1,1,8.224553,21,44,6.073310,1 ,3.472140973,0,1,4.710552,6,39,5.299210,1,2.225435008,0,1,3.108445,3,67,4.224999,0 ,3.769734310,1,1,3.474964,14,64,5.295317,0,10.907262619,0,1,8.869520,17,33,4.933737,1 ,9.280621948,0,1,3.066142,8,50,4.632703,0,5.440011473,0,1,3.309324,10,55,4.892449,0 ,0.720430845,0,1,1.952454,10,35,5.661270,1,9.275824202,0,1,1.432103,7,46,4.821142,1 ,6.171754285,0,1,2.782620,5,30,4.907975,1,0.851761242,0,1,4.480100,9,37,4.276668,1 ,3.991479129,0,1,2.788143,8,60,5.207717,0,4.027130766,0,1,2.712152,6,56,4.540842,1 ,2.150557449,1,1,4.657102,12,31,5.333333,1,8.876155198,0,1,1.333591,7,55,4.273348,0 ,2.709879382,1,1,7.772380,5,36,4.577911,1,3.509888648,1,1,4.911962,8,65,4.850712,0 ,1.438177766,0,1,6.566161,3,40,5.164568,1,3.654998218,0,1,1.397364,6,50,4.718646,0 ,0.491549121,1,1,7.104059,22,57,4.821142,0,0.643228080,1,0,3.836880,7,64,5.028178,0 ,5.935350567,1,1,1.242361,8,26,4.960784,1,3.294179628,1,1,6.106902,3,66,4.398887,1 ,3.222286648,1,1,1.672454,8,43,4.899540,1,3.880637595,1,1,1.478945,20,37,5.153882,1 ,5.916463291,1,1,1.418330,9,53,5.182124,1,8.895888735,0,0,4.131253,23,36,4.930935,1 ,7.569828171,0,0,4.078775,15,56,6.017664,0,0.190022413,0,1,3.969467,5,52,5.318160,0 ,6.571915947,1,1,3.711871,20,55,5.167555,0,5.651828974,1,0,2.605541,8,68,4.466325,0 ,2.792770935,1,0,3.232202,7,61,5.376453,0,2.112533086,1,1,4.284349,13,36,5.077524,1 ,6.417937165,0,0,3.174980,7,36,5.159393,1,10.506763444,0,0,3.720029,7,58,5.153882,0 ,6.441015197,1,0,1.387931,7,46,5.153882,0,0.416201286,1,0,7.575703,3,45,5.174546,1 ,3.400599978,0,1,4.229721,13,53,4.516129,0,2.257456296,1,0,4.318870,13,52,4.839637,0 ,1.980817692,1,0,3.172698,7,46,5.229125,1,0.409135638,0,1,1.124168,9,39,5.767761,1 ,9.626953711,0,1,4.196797,5,62,4.231886,0,8.873726753,1,1,4.295763,5,29,5.907148,1 ,6.526882130,0,0,1.103429,4,62,5.323971,0,2.033732309,1,1,4.651381,17,42,4.800717,1 ,3.246602258,1,1,3.451903,15,40,4.891389,1,3.362305370,0,1,4.253282,7,48,5.911692,0 ,5.530887640,0,1,1.786893,3,53,4.921255,0,6.631603905,0,1,7.327827,7,44,5.115846,1 ,7.165996683,0,1,4.614974,12,42,6.059600,1,8.063983602,0,1,4.630703,13,25,5.363205,1 ,5.704537372,0,1,4.382012,20,54,5.291503,0,4.686644559,0,1,2.653673,5,63,4.781461,0 ,6.049204838,0,1,2.788475,16,61,4.830680,0,1.036582874,1,0,6.220311,10,46,4.194352,1 ,11.037226142,0,1,1.951964,17,56,4.705882,0,5.994978555,0,1,2.766535,6,37,4.923234,1 ,4.072662914,1,1,2.209646,6,33,5.096031,1,1.261901212,1,1,4.632160,17,40,6.295086,1 ,6.329080725,0,1,4.307175,12,34,5.590170,1,0.657757057,0,0,2.297450,17,66,5.714959,0 ,10.014428743,0,1,4.216938,5,62,4.231886,0,9.308329221,0,1,3.008391,14,44,5.085716,1 ,2.229046193,1,1,7.814473,5,28,5.025885,1,11.016614279,0,1,2.086410,3,56,4.902511,0 ,12.453829413,0,1,4.405956,22,55,4.577900,0,1.480791978,1,0,4.422947,10,51,4.374088,0 ,6.073305339,1,1,3.013016,8,42,4.423004,1,10.721930187,0,1,2.417753,10,59,4.921255,0 ,2.466598504,1,0,4.432532,7,41,6.171599,1,3.503739686,0,1,1.275846,8,40,5.068487,1 ,11.649848491,0,1,4.518982,7,52,5.062724,1,0.582062522,1,0,4.834595,15,65,6.157191,0 ,3.602467462,0,0,3.425201,17,54,5.196646,0,9.249038990,0,0,1.177843,5,22,4.881406,1 ,3.963687505,0,1,3.850679,17,40,4.860499,1,4.304977773,1,1,6.796459,20,33,5.429166,0 ,6.082609915,1,1,1.356877,9,53,5.182124,1,3.009463902,0,1,1.670912,6,50,4.718646,0 ,4.757404046,1,0,2.645656,5,57,4.327874,0,3.951021254,0,1,3.233695,17,40,4.860499,1 ,6.717183333,0,1,1.588997,7,30,5.055576,1,5.538491000,0,1,3.475693,8,56,4.231886,0 ,0.329599467,1,0,6.217489,8,67,4.841229,0,3.427751670,1,1,3.416616,12,59,4.333398,0 ,5.739149143,0,0,2.804315,20,59,5.656854,0,4.977774590,0,0,3.624645,3,62,4.631770,0 ,5.445877095,0,1,3.540264,13,31,4.908459,1,10.177229403,0,1,3.953893,8,50,4.632703,0 ,2.568706762,1,0,3.587995,20,64,4.650930,0,4.019721608,0,1,3.651225,25,52,6.521562,0 ,8.533050785,0,1,1.084226,17,73,4.878049,0,1.025160758,0,1,3.647254,10,35,4.683626,1 ,4.303917603,0,1,2.133479,3,31,4.594660,1,12.999218050,0,0,1.566818,5,70,5.043558,0 ,9.677741577,0,0,1.778715,9,69,5.790636,0,3.838812548,0,1,4.145922,17,46,5.115846,0 ,6.949571727,0,0,1.948355,20,34,5.397807,1,9.783264891,0,1,3.596454,8,41,6.014000,1 ,4.379084150,0,1,2.724802,6,56,4.540842,1,3.014898616,1,1,3.189670,5,34,5.421687,1 ,1.772994029,1,1,3.198882,7,55,4.967597,0,6.667516183,0,1,5.050620,13,33,4.953681,1 ,7.165767668,0,0,2.239096,10,61,4.921529,0,2.833907426,1,0,2.945502,15,61,4.687360,0 ,7.983392664,0,1,1.161906,8,45,5.488113,1,6.245410346,0,1,1.657422,8,49,4.977630,0 ,6.186331715,0,1,1.869346,5,65,5.045987,0,3.357774321,1,0,1.963942,12,68,4.480820,0 ,1.383746243,1,0,1.952852,7,55,4.624277,0,1.362630493,1,1,4.468038,10,27,5.015566,1 ,6.927369494,0,1,1.243462,12,56,5.154913,0,2.503036259,1,1,1.514198,6,25,4.556451,1 ,7.275876713,0,1,1.252355,7,43,4.562997,1,11.576856547,0,0,1.411803,6,65,5.038911,0 ,6.818662056,0,1,3.567689,10,60,5.295317,0,3.423068071,0,1,1.089534,6,50,4.718646,0 ,1.953605140,1,1,2.907695,18,50,4.535342,0,5.727678074,1,1,3.232356,7,38,5.138322,1 ,12.132741075,0,1,3.095812,13,47,5.957490,1,6.053348652,0,1,1.128622,8,49,4.977630,0 ,3.694768409,0,1,4.871262,16,54,4.572111,0,6.253365566,0,1,1.742508,17,39,5.500175,1 ,3.705009777,0,1,3.267305,10,66,4.622501,0,2.938119453,1,1,5.360723,17,23,4.753973,1 ,2.135541826,1,1,3.526161,8,55,5.370431,0,5.668259481,1,0,2.574615,10,29,5.474375,1 ,7.080065233,0,1,1.692322,5,34,4.921255,1,8.544738114,0,0,2.767920,10,39,5.423261,1 ,7.045502733,0,1,1.396488,5,39,5.696002,1,0.002559307,0,1,3.064055,6,37,4.976703,1 ,6.617804649,0,0,3.760495,20,39,4.493895,1,9.681871105,0,1,4.324311,4,45,4.851086,1 ,6.044649776,0,1,3.856579,7,63,4.374999,0,6.420862876,1,1,4.622526,10,49,4.766442,1 ,1.874660804,1,1,1.159535,9,44,5.059026,1,1.235709549,1,0,5.039398,12,44,5.904718,1 ,3.258418523,0,0,5.037710,8,28,4.893999,1,4.830709502,1,0,4.918688,15,54,5.326697,0 ,2.922021965,1,0,1.920790,10,34,5.266344,1,3.906092804,0,0,4.699752,11,48,4.869480,0 ,0.697623587,1,0,4.116854,5,59,5.642155,0,9.941569914,0,1,8.289183,10,52,4.821142,0 ,10.350027004,0,1,3.366197,8,55,5.015292,1,5.527569011,1,1,4.051165,18,26,5.439283,1 ,2.606175378,1,1,6.641173,13,26,5.555122,1,2.026639052,1,1,1.038067,10,54,5.294117,1 ,7.008150992,0,0,4.232506,12,42,6.059600,1,2.646393091,1,1,6.246285,18,54,5.661270,1 ,0.173419837,0,1,4.740231,15,49,4.967444,0,1.716937293,1,0,3.299435,3,25,5.451704,1 ,2.830695509,1,0,2.794498,8,68,5.121871,0,3.569302815,1,1,3.840850,7,54,5.294117,0 ,4.225227549,0,0,4.298415,10,41,5.021689,1,10.123232628,1,1,3.056420,21,67,4.610694,0 ,4.584152274,1,1,3.654068,7,48,5.770498,0,6.633500108,0,0,6.271458,7,60,4.466325,0 ,1.716644522,1,0,2.746618,9,43,5.484352,1,2.479548329,1,1,4.672449,10,33,4.850712,1 ,1.574094294,0,1,3.839817,5,29,5.407597,1,4.376846888,0,0,1.434719,8,49,4.948717,1 ,2.838176338,1,0,5.180557,10,49,5.497474,0,1.597733354,1,0,4.702143,20,69,4.319955,0 ,7.761047735,0,1,3.263322,8,33,5.295317,1,2.303782009,1,1,4.107277,12,53,5.078968,0 ,8.779316914,1,0,2.786833,4,49,5.474375,0,0.707945846,1,0,6.989046,15,30,5.187748,1 ,2.771433325,1,1,5.418486,17,52,5.141796,0,0.576891829,0,1,3.060024,7,60,4.841229,0 ,3.349106529,0,0,1.849925,8,60,5.094267,0,1.159469227,1,1,5.524873,8,43,5.063291,1 ,1.322922594,1,0,2.465975,8,41,4.718646,1,0.517570282,1,0,3.848236,7,36,5.447472,1 ,8.030447971,0,1,1.702648,12,65,4.590991,0,0.213668209,0,1,4.255354,13,61,6.373774,0 ,3.283146825,1,0,2.082126,7,54,5.677647,0,1.271388416,1,1,3.141950,10,36,5.333006,1 ,7.194447942,0,0,3.324746,1,48,4.952456,1,8.775137830,1,1,3.302513,7,56,4.242424,0 ,11.477803069,0,0,4.508761,6,53,4.952207,0,4.495830518,0,1,4.465289,3,45,5.590170,1 ,0.842441077,1,0,5.454550,8,50,5.625326,0,10.128304282,0,0,2.302096,11,43,5.224291,1 ,5.414548830,1,1,5.351232,10,23,5.132883,1,1.672620775,1,0,1.674226,3,62,4.997703,0 ,1.865278895,1,1,5.616745,6,66,5.111615,0,10.968824176,0,1,1.261960,13,57,4.154942,0 ,4.239609137,0,1,1.289914,9,58,5.060192,0,6.409953923,1,1,3.524953,10,67,4.419417,0 ,1.703956304,1,1,2.970582,5,53,5.521473,0,6.551169501,0,1,1.707130,4,47,5.552737,1 ,10.016568240,1,1,2.170398,8,52,5.007613,0,4.105695818,0,0,1.727860,6,52,4.599488,0 ,11.702959931,0,1,1.333864,15,41,5.090253,1,0.082156753,1,1,3.966131,23,62,4.635125,0 ,2.228627842,1,0,3.881510,7,56,5.366974,1,0.994236710,1,1,6.727516,7,54,5.517594,1 ,1.967989864,1,1,3.760652,3,67,4.224999,0,6.943112649,0,0,5.903703,15,39,5.161291,1 ,5.752026284,1,1,3.380272,8,42,4.423004,1,3.066375134,0,1,1.500041,5,55,4.668973,0 ,5.137912317,0,1,1.842717,9,33,5.219121,1,0.188009532,0,1,6.516876,8,30,5.055576,1 ,8.457299556,0,1,4.308274,5,32,5.625000,1,5.110364498,0,1,6.847764,20,51,4.913402,1 ,0.432127170,0,0,1.126517,10,41,4.631800,0,5.879574224,0,1,1.449354,5,43,4.864693,1 ,4.086557800,0,1,3.752157,23,61,5.420771,0,6.479730458,0,1,1.541884,6,33,5.474375,1 ,2.096060458,1,1,4.820653,13,42,6.016540,1,8.740526201,0,1,2.848737,4,54,4.960819,0 ,0.987269106,1,1,1.953991,5,55,4.933303,0,3.784784833,0,1,1.146611,13,48,4.960784,0 ,7.895338056,0,0,3.431830,10,39,4.519892,1,0.153081605,0,1,5.174208,10,21,5.420764,1 ,3.612458119,1,1,3.034005,6,31,5.128117,1,1.204751877,1,0,4.917909,25,53,4.631800,0 ,4.797438903,0,1,3.149489,3,43,5.050762,1,3.653500320,1,0,3.462682,3,43,5.735394,1 ,4.572908745,0,1,1.790413,5,33,5.115846,1,8.925976739,0,1,1.753543,8,43,5.010377,1 ,9.424089447,0,1,3.067573,7,48,4.808812,0,2.721229521,1,0,3.269509,22,68,5.164568,0 ,0.617500623,1,0,2.210704,13,47,4.798963,1,0.733668341,1,1,3.274835,10,30,4.998959,1 ,1.777653448,1,0,1.163099,13,55,4.766442,0,8.045365441,0,0,4.279056,10,63,5.621055,0 ,0.895810048,1,1,6.392544,23,70,4.983549,0,5.886969043,0,0,3.685820,7,40,4.960784,1 ,7.924019439,0,0,5.793592,5,38,5.697535,1,11.543164037,0,1,4.212662,5,45,5.329681,0 ,2.092920364,1,0,4.339656,13,52,4.839637,0,5.835997393,0,0,5.470233,5,58,4.302066,1 ,7.597981449,0,1,3.128263,12,34,4.966996,1,7.735710616,1,0,2.544029,4,49,5.474375,0 ,7.710111583,0,1,2.007118,7,48,4.366659,1,3.082220332,1,1,5.178506,11,69,5.112992,0 ,6.819277120,0,0,5.871234,15,44,5.025885,1,6.581073376,1,0,3.642454,13,59,4.923659,0 ,1.263674974,1,0,6.885249,5,42,4.535342,1,9.058271228,1,1,1.749957,13,34,4.465782,1 ,1.561582213,1,0,3.557060,4,48,4.991342,0,5.342270791,0,1,7.101077,15,51,5.045987,0 ,7.713528057,0,1,3.927043,7,55,5.062724,0,5.871852210,1,1,3.520430,10,44,4.800717,1 ,9.344645272,0,1,1.791652,13,56,5.993707,0,4.890129012,0,1,2.478405,8,38,5.229125,1 ,1.194444507,1,0,3.177897,8,54,5.120809,0,10.277324399,0,0,1.573010,13,59,5.809277,0 ,2.300039799,1,1,4.265143,8,45,4.724556,1,6.997014031,0,1,2.162587,7,53,5.764246,0 ,3.270359373,0,1,6.658219,13,53,4.633481,0,0.593110196,1,0,4.767141,15,65,6.157191,0 ,4.606589056,1,0,2.608047,5,57,4.327874,0,3.920409560,0,0,4.776128,23,66,5.153882,0 ,4.651463728,0,0,1.835911,5,70,4.921255,0,3.133126574,1,0,5.083054,12,28,4.741448,1 ,0.169656895,1,1,4.315575,8,53,5.201327,1,6.501047844,0,1,3.243885,5,43,4.984073,1 ,8.068813673,0,1,3.223044,7,58,4.736275,0,7.840334027,0,0,3.619049,17,41,4.376881,1 ,3.098918700,0,1,6.186871,10,59,4.953681,0,1.928365503,1,0,3.344411,8,66,4.916011,1 ,0.764759076,1,0,7.455564,11,44,4.311743,1,1.757825223,1,0,4.464654,20,69,4.319955,1 ,7.459053005,1,0,3.732241,21,49,5.070667,0,5.689613634,0,0,3.397186,9,52,4.923659,0) testhare <- matrix(testhare,ncol=8,byrow=TRUE) ################################################################################ polspline/MD50000644000176200001440000000475414516541355012612 0ustar liggesusers9abd56b415f15b28c46d9b4aee42a92b *DESCRIPTION 3f4f90b44a765116f3e2844a961d7f17 *NAMESPACE a64f01f04a4ed97f18a0a35938cf76b1 *R/polspline.R 16a930fc75b5d7ed229609efae3ccbf9 *man/beta.polyclass.Rd 54e6d03497918fa20145ae82a0fcce5f *man/clspec.Rd 1cebcd38e7d6c94230242cbc027d92a5 *man/cpolyclass.Rd 6a3557b2f3fef3a5d5cc2f4d3a3ab290 *man/design.polymars.Rd 948a25be763cab4e0f93a50870c0f891 *man/dhare.Rd 81b02b7e678c82332c52d18a6cf31d81 *man/dheft.Rd b061f6d635b03d0e0cbec32904767529 *man/dlogspline.Rd 5e3e90bc87cc9871a2627c47da038a68 *man/doldlogspline.Rd a86be24c8ec507bf8ca3548002f7491f *man/hare.Rd d29fae8a413ecffd313626e9fb5a1a83 *man/heft.Rd db3179386110da74cc6ae1c8f30cd190 *man/logspline.Rd c2291e12d61b4648458ce307930c2add *man/lspec.Rd 0096fc6f3ee08934ae46d6de01ef4fce *man/oldlogspline.Rd 4b3debd92d182dd9e7e35faca81d90b8 *man/oldlogspline.to.logspline.Rd d2edb410639d8b815b947658e38313b2 *man/persp.polymars.Rd 9e1e0c9e65f2c32f534b897b9420a93e *man/plot.hare.Rd 8dd5355728c4d89406c60e43bd80145c *man/plot.heft.Rd b163a5b1a6c457d3e12ba94babe9eb7f *man/plot.logspline.Rd 68533f150dae726bb0c709661f878aa5 *man/plot.lspec.Rd 7448be99f9e876ac907fa0f1e3d3874b *man/plot.oldlogspline.Rd 464b7038ec02ca6a88f1bf1f7f5284ca *man/plot.polyclass.Rd cec526bbb9acdac99a84e7c5b768f45f *man/plot.polymars.Rd e2dc94eb58fa5a95cf4a82c141f450a8 *man/polyclass.Rd 49bb51b5244b9d6226bdc379894aa661 *man/polymars.Rd cedf0c0bf315c13128697695ebc7a7d2 *man/predict.polymars.Rd 34e3ba5d6426afdd35593542f88485d4 *man/summary.hare.Rd 5f131a59314c1975e9be561cb6743a08 *man/summary.heft.Rd 1bebbf6d49d580a65db906ca79342217 *man/summary.logspline.Rd a8e06750d307c1242f3fe22183c2ebe8 *man/summary.lspec.Rd 8c5b7163662fdd3d7bba1e211b2c19df *man/summary.oldlogspline.Rd 12b0b994485166bf1e6953725b54830b *man/summary.polyclass.Rd 1dd9095ad66d2940b679f3bcff0b6359 *man/summary.polymars.Rd 92f335a9c57f21eba7398538f8c9b9ef *man/testhare.Rd c5099be9838f431d7dfb5d8e894f28b6 *man/unstrip.Rd 3b5e962e50e4f213d31670522834d250 *man/xhare.Rd 8290d2e9740414e315237f0d5d4024bb *src/Makevars 5e5873b500e169a013fdd11dfd92ae97 *src/allpack.f 13edd720cc09461e0064645a2456038d *src/hareall.c 5a6a88ad102db0082dcbcb1ec2c6d617 *src/heftall.c e2b523fee3d37720e8273827811768a1 *src/lsdall.c 5785f10f21a99e977e76b2b7e3a08e41 *src/lspecall.c 77a4338784577cbe2db469dd3986e9b6 *src/nlsd.c eb0c9c7ac3201497dd07b3ac5bf57202 *src/polyall.c 36c20e130cb68d38fb2ef7e1d10b940e *src/polymars.c 7d6ff3472ebb89f7e61564f626dbaaee *src/registerDynamicSymbol.c b6249e3e2db646c905f4a4d7b41a1ff6 *src/x2c.h