fRegression/0000755000176200001440000000000014275147203012545 5ustar liggesusersfRegression/NAMESPACE0000644000176200001440000000155414273153361013771 0ustar liggesusers################################################################################ ## Exports ################################################################################ exportPattern("^[^\\.]") S3method("termPlot", "fREG") ############################################################################### ## Imports ################################################################################ import(timeDate) import(timeSeries) import(fBasics) importFrom("methods", new, slot) importFrom("stats", as.formula, delete.response, gaussian, model.frame, model.matrix, model.response, pf, printCoefmat, rnorm, runif, sd, symnum, termplot, var) importFrom("utils", menu) ############################################################################### ## useDynLib ############################################################################### # useDynLib("fRegression") fRegression/ChangeLog0000644000176200001440000000350614273153361014323 0ustar liggesusers2014-09-16 setz * ChangeLog, DESCRIPTION: Updated ChangeLog and DESCRIPTION files after submission to CRAN * NAMESPACE: Updated NAMESPACE; functions with a dot in front are no longer exported. * R/regFit.R: No execution in parent frame anymore * Unit Tests: Functions with a dot in front are called using fRegression:::.f * src moved to inst/obsolete/src 2013-12-10 chalabi * ChangeLog, DESCRIPTION: 2013-06-23 chalabi * DESCRIPTION, R/zzz.R, src/Makevars: updated Fortran flags, version number and removed .First.lib() 2012-12-10 chalabi * ChangeLog, DESCRIPTION: Updated ChangeLog and DESCRIPTION files after submission to CRAN * DESCRIPTION: Updated 'Author' and added 'Imports' fields to reflect third-party functions used in fRegression * NAMESPACE: Updated NAMESPACE * R/summary-methods.R: Fixed partial argument match * R/lmTest.R: Replaced built-in functions by calls to original functions in lmtest package. * NAMESPACE: Added NAMESPACE * DESCRIPTION: Updated version number, maintainer field and 'Note' fields 2011-09-23 mmaechler * DESCRIPTION: remove deprecated "LazyLoad" entry 2010-07-23 chalabi * inst/DocCopying.pdf: removed DocCopying.pdf license is already specified in DESCRIPTION file 2009-09-30 chalabi * DESCRIPTION: updated version number 2009-09-29 chalabi * ChangeLog, DESCRIPTION: updated DESC and ChangeLog 2009-07-14 chalabi * man/RegressionTestsInterface.Rd: fixed equation in Rd 2009-04-02 chalabi * DESCRIPTION: more explicit depends and suggests field in DESC file. 2009-04-01 chalabi * R/regFit.R: regFit data arg is coerced to a data.frame when calling underlying method * DESCRIPTION: updated DESC file 2009-01-28 chalabi * man/fREG-class.Rd, man/plot-methods.Rd, man/regFit.Rd, man/regSim.Rd: updated manual pages to new Rd parser fRegression/README.md0000644000176200001440000001107314273546760014037 0ustar liggesusers # fRegression [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/paulnorthrop/fRegression?branch=main&svg=true)](https://ci.appveyor.com/project/paulnorthrop/fRegression) [![R-CMD-check](https://github.com/paulnorthrop/fRegression/workflows/R-CMD-check/badge.svg)](https://github.com/paulnorthrop/fRegression/actions) [![Coverage Status](https://codecov.io/github/paulnorthrop/fRegression/coverage.svg?branch=main)](https://codecov.io/github/paulnorthrop/fRegression?branch=main) [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/fRegression)](https://cran.r-project.org/package=fRegression) [![Downloads (monthly)](https://cranlogs.r-pkg.org/badges/fRegression?color=brightgreen)](https://cran.r-project.org/package=fRegression) [![Downloads (total)](https://cranlogs.r-pkg.org/badges/grand-total/fRegression?color=brightgreen)](https://cran.r-project.org/package=fRegression) ## Rmetrics - Modelling Extreme Events in Finance The **fRegression** package is a collection of functions for linear and non-linear regression modelling. It implements a wrapper for several regression models available in the base and contributed packages of R. ### An example The following code simulates some regression data and fits various models to these data. ``` r library(fRegression) # Simulate data: the response is linearly related to 3 explanatory variables x <- regSim(model = "LM3", n = 100) # Linear modelling regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") #> #> Title: #> Linear Regression Modeling #> #> Formula: #> Y ~ X1 + X2 + X3 #> #> Family: #> gaussian identity #> #> Model Parameters: #> (Intercept) X1 X2 X3 #> 0.01578 0.73967 0.25128 -0.50611 # Robust linear modelling regFit(Y ~ X1 + X2 + X3, data = x, use = "rlm") #> #> Title: #> Robust Linear Regression Modeling #> #> Formula: #> Y ~ X1 + X2 + X3 #> #> Family: #> gaussian identity #> #> Model Parameters: #> (Intercept) X1 X2 X3 #> 0.01968 0.74264 0.24736 -0.50123 # Generalised additive modelling regFit(Y ~ X1 + X2 + X3, data = x, use = "gam") #> #> Title: #> Generalized Additive Modeling #> #> Formula: #> Y ~ X1 + X2 + X3 #> #> Family: #> gaussian identity #> #> Model Parameters: #> (Intercept) X1 X2 X3 #> 0.01578 0.73967 0.25128 -0.50611 # Projection pursuit modelling regFit(Y ~ X1 + X2 + X3, data = x, use = "ppr") #> #> Title: #> Projection Pursuit Regression #> #> Formula: #> Y ~ X1 + X2 + X3 #> #> Family: #> gaussian identity #> #> Model Parameters: #> -- Projection Direction Vectors -- #> term 1 term 2 #> X1 0.7950116 -0.4422500 #> X2 0.2733278 -0.4863312 #> X3 -0.5415242 -0.7535894 #> -- Coefficients of Ridge Terms -- #> term 1 term 2 #> 0.9163087 0.0439332 # Feed-forward neural network modelling regFit(Y ~ X1 + X2 + X3, data = x, use = "nnet") #> #> Title: #> Feedforward Neural Network Modeling #> #> Formula: #> Y ~ X1 + X2 + X3 #> #> Family: #> gaussian identity #> #> Model Parameters: #> a 3-2-1 network with 11 weights #> options were - linear output units #> [1] 3.3664690 0.5597762 0.2646774 -0.5300914 0.8276914 -0.4493467 #> [7] -0.1400424 0.2787105 -0.5420174 5.4429808 -6.7838054 # Polychotonous Multivariate Adaptive Regression Splines regFit(Y ~ X1 + X2 + X3, data = x, use = "polymars") #> 1 2 3 4 5 6 #> 0.9145273 1.1607611 1.0482997 -0.5673597 -0.4692621 -1.3336450 #> X1 X2 X3 #> 1 1.8197351 -0.39077723 0.24075985 #> 2 1.3704395 0.39665330 -0.02049151 #> 3 1.1963182 0.78156956 0.29685497 #> 4 -0.4068792 -0.01912605 0.55061347 #> 5 -0.6109788 -1.94431293 -0.71396821 #> 6 -1.5089120 -0.24550669 0.38003407 #> #> Title: #> Polytochomous MARS Modeling #> #> Formula: #> Y ~ X1 + X2 + X3 #> #> Family: #> gaussian identity #> #> Model Parameters: #> pred1 knot1 pred2 knot2 coefs SE #> 1 0 NA 0 NA 0.01577838 0.009803798 #> 2 1 NA 0 NA 0.73967249 0.009930477 #> 3 3 NA 0 NA -0.50611270 0.010729997 #> 4 2 NA 0 NA 0.25127670 0.010419817 ``` ### Installation To get the current released version from CRAN: ``` r install.packages("fRegression") ``` fRegression/man/0000755000176200001440000000000014273153361013320 5ustar liggesusersfRegression/man/RegressionTestsInterface.Rd0000644000176200001440000004467114273250037020605 0ustar liggesusers\name{RegressionTestsInterface} \alias{RegressionTestsInterface} \alias{lmTest} \alias{bgTest} \alias{bpTest} \alias{dwTest} \alias{gqTest} \alias{harvTest} \alias{hmcTest} \alias{rainTest} \alias{resetTest} \title{Regression Tests} \description{ A collection and description of functions to test linear regression models, including tests for higher serial correlations, for heteroskedasticity, for autocorrelations of disturbances, for linearity, and functional relations. \cr The methods are: \tabular{ll}{ \code{"bg"} \tab Breusch--Godfrey test for higher order serial correlation, \cr \code{"bp"} \tab Breusch--Pagan test for heteroskedasticity, \cr \code{"dw"} \tab Durbin--Watson test for autocorrelation of disturbances, \cr \code{"gq"} \tab Goldfeld--Quandt test for heteroskedasticity, \cr \code{"harv"} \tab Harvey--Collier test for linearity, \cr \code{"hmc"} \tab Harrison--McCabe test for heteroskedasticity, \cr \code{"rain"} \tab Rainbow test for linearity, and \cr \code{"reset"} \tab Ramsey's RESET test for functional relation. } There is nothing new, it's just a wrapper to the underlying test functions from R's contributed package \code{lmtest}. The functions are available as "Builtin" functions. Nevertheless, the user can still install and use the original functions from \R's \code{lmtest} package. } \usage{ lmTest(formula, method = c("bg", "bp", "dw", "gq", "harv", "hmc", "rain", "reset"), data = list(), \dots) bgTest(formula, order = 1, type = c("Chisq", "F"), data = list()) bpTest(formula, varformula = NULL, studentize = TRUE, data = list()) dwTest(formula, alternative = c("greater", "two.sided", "less"), iterations = 15, exact = NULL, tol = 1e-10, data = list()) gqTest(formula, point=0.5, order.by = NULL, data = list()) harvTest(formula, order.by = NULL, data = list()) hmcTest(formula, point = 0.5, order.by = NULL, simulate.p = TRUE, nsim = 1000, plot = FALSE, data = list()) rainTest(formula, fraction = 0.5, order.by = NULL, center = NULL, data = list()) resetTest(formula, power = 2:3, type = c("fitted", "regressor", "princomp"), data = list()) } \arguments{ \item{alternative}{ [dwTest] - \cr a character string specifying the alternative hypothesis, either \code{"greater"}, \code{"two.sided"}, or \code{"less"}. } \item{center}{ [rainTest] - \cr a numeric value. If center is smaller than \code{1} it is interpreted as percentages of data, i.e. the subset is chosen that \code{n*fraction} observations are around observation number \code{n*center}. If \code{center} is greater than \code{1} it is interpreted to be the index of the center of the subset. By default center is \code{0.5}. If the Mahalanobis distance is chosen center is taken to be the mean regressor, but can be specified to be a k-dimensional vector if k is the number of regressors and should be in the range of the respective regressors. } \item{data}{ an optional data frame containing the variables in the model. By default the variables are taken from the environment which \code{lmTest} and the other tests are called from. } \item{exact}{ [dwTest] - \cr a logical flag. If set to \code{FALSE} a normal approximation will be used to compute the p value, if \code{TRUE} the "pan" algorithm is used. The default is to use "pan" if the sample size is \code{< 100}. } \item{formula}{ a symbolic description for the linear model to be tested. } \item{fraction}{ [rainTest] - \cr a numeric value, by default 0.5. The percentage of observations in the subset is determined by \code{fraction*n} if \code{n} is the number of observations in the model. } \item{iterations}{ [dwTest] - \cr an integer specifying the number of iterations when calculating the p-value with the "pan" algorithm. By default 15. } \item{method}{ the test method which should be applied. } \item{nsim}{ [hmcTest] - \cr an integer value. Determines how many runs are used to simulate the p value, by default 1000. } \item{order}{ [bgTest] - \cr an integer. The maximal order of serial correlation to be tested. By default 1. } \item{order.by}{ [gqTest][harvTest] - \cr a formula. A formula with a single explanatory variable like \code{~ x}. Then the observations in the model are ordered by the size of \code{x}. If set to \code{NULL}, the default, the observations are assumed to be ordered (e.g. a time series). \cr [rainTest] - \cr either a formula or a string. A formula with a single explanatory variable like \code{~ x}. The observations in the model are ordered by the size of \code{x}. If set to \code{NULL}, the default, the observations are assumed to be ordered (e.g. a time series). If set to \code{"mahalanobis"} then the observations are ordered by their Mahalanobis distance of the data. } \item{plot}{ [hmcTest] - \cr a logical flag. If \code{TRUE} the test statistic for all possible breakpoints is plotted, the default is \code{FALSE}. } \item{point}{ [gqTest][hmcTest] - \cr a numeric value. If point is smaller than \code{1} it is interpreted as percentages of data, i.e. \code{n*point} is taken to be the (potential) breakpoint in the variances, if \code{n} is the number of observations in the model. If \code{point} is greater than \code{1} it is interpreted to be the index of the breakpoint. By default \code{0.5}. } \item{power}{ [resetTest] - \cr integers, by default \code{2:3}. A vector of positive integers indicating the powers of the variables that should be included. By default it is tested for a quadratic or cubic influence of the fitted response. } \item{simulate.p}{ [hmcTest] - \cr a logical. If \code{TRUE}, the default, a p-value will be assessed by simulation, otherwise the p-value is \code{NA}. } \item{studentize}{ [bpTest] - \cr a logical value. If set to \code{TRUE} Koenker's studentized version of the test statistic will be used. By default set to \code{TRUE}. } \item{tol}{ [dwTest] - \cr the tolerance value. Eigenvalues computed have to be greater than \code{tol=1e-10} to be treated as non-zero. } \item{type}{ [bgTest] - \cr the type of test statistic to be returned. Either \code{"Chisq"} for the Chi-squared test statistic or \code{"F"} for the F test statistic. \cr [resetTest] - \cr a string indicating whether powers of the \code{"fitted"} response, the \code{"regressor"} variables (factors are left out) or the first principal component, \code{"princomp"}, of the regressor matrix should be included in the extended model. } \item{varformula}{ [bpTest] - \cr a formula describing only the potential explanatory variables for the variance, no dependent variable needed. By default the same explanatory variables are taken as in the main regression model. } \item{\dots}{ [regTest] - \cr additional arguments passed to the underlying lm test. Some of the tests can specify additional optional arguments like for alternative hypothesis, the type of test statistic to be returned, or others. All the optional arguments have default settings. } } \details{ \bold{bg -- Breusch Godfrey Test:} \cr\cr Under \eqn{H_0} the test statistic is asymptotically Chi-squared with degrees of freedom as given in \code{parameter}. If \code{type} is set to \code{"F"} the function returns the exact F statistic which, under \eqn{H_0}, follows an \eqn{F} distribution with degrees of freedom as given in \code{parameter}. The starting values for the lagged residuals in the supplementary regression are chosen to be 0.\cr \code{[lmtest:bgtest]} \cr \bold{bp -- Breusch Pagan Test:} \cr\cr The Breusch--Pagan test fits a linear regression model to the residuals of a linear regression model (by default the same explanatory variables are taken as in the main regression model) and rejects if too much of the variance is explained by the additional explanatory variables. Under \eqn{H_0} the test statistic of the Breusch-Pagan test follows a chi-squared distribution with \code{parameter} (the number of regressors without the constant in the model) degrees of freedom.\cr \code{[lmtest:bptest]} \cr \bold{dw -- Durbin Watson Test:} \cr\cr The Durbin--Watson test has the null hypothesis that the autocorrelation of the disturbances is 0; it can be tested against the alternative that it is greater than, not equal to, or less than 0 respectively. This can be specified by the \code{alternative} argument. The null distribution of the Durbin-Watson test statistic is a linear combination of chi-squared distributions. The p value is computed using a Fortran version of the Applied Statistics Algorithm AS 153 by Farebrother (1980, 1984). This algorithm is called "pan" or "gradsol". For large sample sizes the algorithm might fail to compute the p value; in that case a warning is printed and an approximate p value will be given; this p value is computed using a normal approximation with mean and variance of the Durbin-Watson test statistic.\cr \code{[lmtest:dwtest]} \cr \bold{gq -- Goldfeld Quandt Test:} \cr\cr The Goldfeld--Quandt test compares the variances of two submodels divided by a specified breakpoint and rejects if the variances differ. Under \eqn{H_0} the test statistic of the Goldfeld-Quandt test follows an F distribution with the degrees of freedom as given in \code{parameter}.\cr \code{[lmtest:gqtest]} \cr \bold{harv - Harvey Collier Test:} \cr\cr The Harvey-Collier test performs a t-test (with \code{parameter} degrees of freedom) on the recursive residuals. If the true relationship is not linear but convex or concave the mean of the recursive residuals should differ from 0 significantly.\cr \code{[lmtest:harvtest]} \cr \bold{hmc -- Harrison McCabe Test:} \cr\cr The Harrison--McCabe test statistic is the fraction of the residual sum of squares that relates to the fraction of the data before the breakpoint. Under \eqn{H_0} the test statistic should be close to the size of this fraction, e.g. in the default case close to 0.5. The null hypothesis is reject if the statistic is too small.\cr \code{[lmtest:hmctest]} \cr \bold{rain -- Rainbow Test:} \cr\cr The basic idea of the Rainbow test is that even if the true relationship is non-linear, a good linear fit can be achieved on a subsample in the "middle" of the data. The null hypothesis is rejected whenever the overall fit is significantly inferior to the fit of the subsample. The test statistic under \eqn{H_0} follows an F distribution with \code{parameter} degrees of freedom.\cr \code{[lmtest:raintest]} \cr \bold{reset -- Ramsey's RESET Test} \cr\cr RESET test is popular means of diagnostic for correctness of functional form. The basic assumption is that under the alternative, the model can be written by the regression \eqn{ y = X\beta + Z\gamma + u}{y=X * beta + Z * gamma}. \code{Z} is generated by taking powers either of the fitted response, the regressor variables or the first principal component of \code{X}. A standard F-Test is then applied to determine whether these additional variables have significant influence. The test statistic under \eqn{H_0} follows an F distribution with \code{parameter} degrees of freedom.\cr \code{[lmtest:reset]} } \value{ A list with class \code{"htest"} containing the following components: \item{statistic}{ the value of the test statistic. } \item{parameter}{ the lag order. } \item{p.value}{ the p-value of the test. } \item{method}{ a character string indicating what type of test was performed. } \item{data.name}{ a character string giving the name of the data. } \item{alternative}{ a character string describing the alternative hypothesis. } } \note{ The underlying \code{lmtest} package comes wit a lot of helpful examples. We highly recommend to install the \code{lmtest} package and to study the examples given therein. } \references{ Breusch, T.S. (1979); \emph{Testing for Autocorrelation in Dynamic Linear Models}, Australian Economic Papers 17, 334--355. Breusch T.S. and Pagan A.R. (1979); \emph{A Simple Test for Heteroscedasticity and Random Coefficient Variation}, Econometrica 47, 1287--1294 Durbin J. and Watson G.S. (1950); \emph{Testing for Serial Correlation in Least Squares Regression I}, Biometrika 37, 409--428. Durbin J. and Watson G.S. (1951); \emph{Testing for Serial Correlation in Least Squares Regression II}, Biometrika 38, 159--178. Durbin J. and Watson G.S. (1971); \emph{Testing for Serial Correlation in Least Squares Regression III}, Biometrika 58, 1--19. Farebrother R.W. (1980); \emph{Pan's Procedure for the Tail Probabilities of the Durbin-Watson Statistic}, Applied Statistics 29, 224--227. Farebrother R.W. (1984); \emph{The Distribution of a Linear Combination of \eqn{\chi^2}{chi^2} Random Variables}, Applied Statistics 33, 366--369. Godfrey, L.G. (1978); \emph{Testing Against General Autoregressive and Moving Average Error Models when the Regressors Include Lagged Dependent Variables}, Econometrica 46, 1293--1302. Goldfeld S.M. and Quandt R.E. (1965); \emph{Some Tests for Homoskedasticity} Journal of the American Statistical Association 60, 539--547. Harrison M.J. and McCabe B.P.M. (1979); \emph{A Test for Heteroscedasticity based on Ordinary Least Squares Residuals} Journal of the American Statistical Association 74, 494--499. Harvey A. and Collier P. (1977); \emph{Testing for Functional Misspecification in Regression Analysis}, Journal of Econometrics 6, 103--119. Johnston, J. (1984); \emph{Econometric Methods}, Third Edition, McGraw Hill Inc. Kraemer W. and Sonnberger H. (1986); \emph{The Linear Regression Model under Test}, Heidelberg: Physica. Racine J. and Hyndman R. (2002); \emph{Using R To Teach Econometrics}, Journal of Applied Econometrics 17, 175--189. Ramsey J.B. (1969); \emph{Tests for Specification Error in Classical Linear Least Squares Regression Analysis}, Journal of the Royal Statistical Society, Series B 31, 350--371. Utts J.M. (1982); \emph{The Rainbow Test for Lack of Fit in Regression}, Communications in Statistics - Theory and Methods 11, 1801--1815. } \author{ Achim Zeileis and Torsten Hothorn for the \code{lmtest} package, \cr Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## bg | dw - # Generate a Stationary and an AR(1) Series: x = rep(c(1, -1), 50) y1 = 1 + x + rnorm(100) # Perform Breusch-Godfrey Test for 1st order serial correlation: lmTest(y1 ~ x, "bg") # ... or for fourth order serial correlation: lmTest(y1 ~ x, "bg", order = 4) # Compare with Durbin-Watson Test Results: lmTest(y1 ~ x, "dw") y2 = filter(y1, 0.5, method = "recursive") lmTest(y2 ~ x, "bg") ## bp - # Generate a Regressor: x = rep(c(-1, 1), 50) # Generate heteroskedastic and homoskedastic Disturbances err1 = rnorm(100, sd = rep(c(1, 2), 50)) err2 = rnorm(100) # Generate a Linear Relationship: y1 = 1 + x + err1 y2 = 1 + x + err2 # Perform Breusch-Pagan Test bp = lmTest(y1 ~ x, "bp") bp # Calculate Critical Value for 0.05 Level qchisq(0.95, bp$parameter) lmTest(y2 ~ x, "bp") ## dw - # Generate two AR(1) Error Terms # with parameter rho = 0 (white noise) # and rho = 0.9 respectively err1 = rnorm(100) # Generate Regressor and Dependent Variable x = rep(c(-1,1), 50) y1 = 1 + x + err1 # Perform Durbin-Watson Test: lmTest(y1 ~ x, "dw") err2 = filter(err1, 0.9, method = "recursive") y2 = 1 + x + err2 lmTest(y2 ~ x, "dw") ## gq - # Generate a Regressor: x = rep(c(-1, 1), 50) # Generate Heteroskedastic and Homoskedastic Disturbances: err1 = c(rnorm(50, sd = 1), rnorm(50, sd = 2)) err2 = rnorm(100) # Generate a Linear Relationship: y1 = 1 + x + err1 y2 = 1 + x + err2 # Perform Goldfeld-Quandt Test: lmTest(y1 ~ x, "gq") lmTest(y2 ~ x, "gq") ## harv - # Generate a Regressor and Dependent Variable: x = 1:50 y1 = 1 + x + rnorm(50) y2 = y1 + 0.3*x^2 # Perform Harvey-Collier Test: harv = lmTest(y1 ~ x, "harv") harv # Calculate Critical Value vor 0.05 level: qt(0.95, harv$parameter) lmTest(y2 ~ x, "harv") ## hmc - # Generate a Regressor: x = rep(c(-1, 1), 50) # Generate Heteroskedastic and Homoskedastic Disturbances: err1 = c(rnorm(50, sd = 1), rnorm(50, sd = 2)) err2 = rnorm(100) # Generate a Linear Relationship: y1 = 1 + x + err1 y2 = 1 + x + err2 # Perform Harrison-McCabe Test: lmTest(y1 ~ x, "hmc") lmTest(y2 ~ x, "hmc") ## rain - # Generate Series: x = c(1:30) y = x^2 + rnorm(30, 0, 2) # Perform rainbow Test rain = lmTest(y ~ x, "rain") rain # Compute Critical Value: qf(0.95, rain$parameter[1], rain$parameter[2]) ## reset - # Generate Series: x = c(1:30) y1 = 1 + x + x^2 + rnorm(30) y2 = 1 + x + rnorm(30) # Perform RESET Test: lmTest(y1 ~ x , "reset", power = 2, type = "regressor") lmTest(y2 ~ x , "reset", power = 2, type = "regressor") } \keyword{htest} fRegression/man/methods-fitted.Rd0000644000176200001440000000277514273542216016543 0ustar liggesusers\name{fitted-methods} \docType{methods} \alias{fitted-methods} \alias{fitted,ANY-method} \alias{fitted,fREG-method} \title{Extract Regression Model Fitted Values} \description{ Extracts fitted values from a fitted regression model. } \section{Methods}{ \describe{ \item{object = "ANY"}{ Generic function } \item{object = "fREG"}{ Extractor function for fitted values. } } } \note{ \code{fitted} is a generic function which extracts fitted values from objects returned by modeling functions, here the \code{regFit} and \code{gregFit} parameter estimation functions. The class of the fitted values is the same as the class of the data input to the function \code{regFit} or \code{gregFit}. In contrast the slot \code{fitted} returns a numeric vector. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x.df = regSim(model = "LM3", n = 50) ## regFit - # Use data.frame input: fit = regFit(Y ~ X1 + X2 + X3, data = x.df, use = "lm") ## fitted - val = slot(fit, "fitted") head(val) class(val) val = fitted(fit) head(val) class(val) ## regFit - # Convert to dummy timeSeries Object: library(timeSeries) x.tS = as.timeSeries(x.df) fit = regFit(Y ~ X1 + X2 + X3, data = x.tS, use = "lm") ## fitted - val = slot(fit, "fitted") head(val) class(val) val = fitted(fit) head(val) class(val) } \keyword{models} fRegression/man/regFit.Rd0000644000176200001440000003211214273546176015040 0ustar liggesusers\name{regFit} \alias{regFit} \alias{gregFit} \title{Regression Modelling} \description{ Estimates the parameters of a regression model. } \usage{ regFit(formula, data, family = gaussian, use = c("lm", "rlm", "glm", "gam", "ppr", "nnet", "polymars"), title = NULL, description = NULL, \dots) } \arguments{ \item{data}{ \code{data} is the data frame containing the variables in the model. By default the variables are taken from \code{environment(formula)}, typically the environment from which \code{lm} is called. } \item{description}{ a brief description of the project of type character. } \item{family}{ a description of the error distribution and link function to be used in \code{glm} and \code{gam} models. See \code{\link{glm}} and \code{\link{family}} for more details. } \item{formula}{ a symbolic description of the model to be fit. \cr A typical \code{glm} predictor has the form \code{response ~ terms} where \code{response} is the (numeric) response vector and \code{terms} is a series of terms which specifies a (linear) predictor for \code{response}. For \code{binomial} models the response can also be specified as a \code{factor}. \cr A \code{gam} formula, see also \code{gam.models}, allows that smooth terms can be added to the right hand side of the formula. See \code{gam.side.conditions} for details and examples. } \item{use}{ denotes the regression method by a character string used to fit the model. \code{method} must be one of the strings in the default argument.\cr \code{"lm"}, for linear regression models, \cr \code{"rlm"}, for robust linear regression models, \cr \code{"glm"} for generalized linear modelling, \cr \code{"gam"} for generalized additive modelling, \cr \code{"ppr"} for projection pursuit regression, \cr \code{"nnet"} for feedforward neural network modelling, and \cr \code{"polymars"} for polychotomous MARS. } \item{title}{ a character string which allows for a project title. } \item{\dots}{ additional optional arguments to be passed to the underlying functions. For details we refer to inspect the following help pages: \code{\link{lm}}, \code{\link{glm}}, \code{gam}, \code{\link{ppr}}, \code{polymars}, or \code{nnet}. } } \value{ returns an S4 object of class \code{"fREG"}. } \details{ The function \code{regFit} was created to provide a selection of regression models working together with Rmetrics' \code{"timeSeries"} objects and providing a common S4 object as the returned value. These models include linear modeling, robust linear modeling, generalized linear modeling, generalized additive modelling, projection pursuit regression, neural networks, and polychotomous MARS models.\cr % ----------------------------------------------- \bold{LM -- Linear Modelling:} \cr\cr Univariate linear regression analysis is a statistical methodology that assumes a linear relationship between some predictor variables and a response variable. The goal is to estimate the coefficients and to predict new data from the estimated linear relationship. R's base function \code{lm(formula, data, subset, weights, na.action, method = "qr", }\cr \code{ model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE, }\cr \code{ contrasts = NULL, offset, ...) }\cr is used to fit linear models. It can be used to carry out regression, single stratum analysis of variance and analysis of covariance, although \code{aov} may provide a more convenient interface for these. Rmetrics' function \code{regFit(formula, data, use = "lm", ...) }\cr calls R's base function \code{lm} but with the difference that the \code{data} argument, may be any rectangular object which can be transferred by the function \code{as.data.frame} into a data frame with named columns, e.g. an object of class \code{"timeSeries"}. The function \code{regFit} returns an S4 object of class \code{"fREG"} whose slot \code{@fit} is the object as returned by the function \code{"lm"}. In addition we have S4 methods \code{fitted} and \code{residuals} which allow to retrieve the fitted values and the residuals as objects of same class as defined by the argument \code{data}. The function \code{plot.lm} provides four plots: a plot of residuals against fitted values, a Scale-Location plot of sqrt(| residuals |) against fitted values, a normal QQ plot, and a plot of Cook's distances versus row labels.\cr \code{[stats:lm]} \cr % ----------------------------------------------- \bold{LM -- Robust Linear Modelling:} \cr\cr To fit a linear model by robust regression using an M estimator R offers the function \code{rlm(formula, data, weights, ..., subset, na.action, }\cr \code{ method = c("M", "MM", "model.frame"), }\cr \code{ wt.method = c("inv.var", "case"), }\cr \code{ model = TRUE, x.ret = TRUE, y.ret = FALSE, contrasts = NULL) }\cr from package \code{MASS}. Again we can use the Rmetrics' wrapper \code{regFit(formula, data, use = "rlm", ...) }\cr which allows us to use for example S4 \code{timeSeries} objects as input and to get the output as an S4 object with the known slots.\cr \code{[MASS::rlm]} \cr % ----------------------------------------------- \bold{GLM -- Generalized Linear Models:} \cr\cr Generalized linear modelling extends the linear model in two directions. (i) with a monotonic differentiable link function describing how the expected values are related to the linear predictor, and (ii) with response variables having a probability distribution from an exponential family.\cr R's base function from package \code{stats} comes with the function \code{glm(formula, family = gaussian, data, weights, subset, }\cr \code{ na.action, start = NULL, etastart, mustart, offset, }\cr \code{ control = glm.control(...), model = TRUE, method = "glm.fit", }\cr \code{ x = FALSE, y = TRUE, contrasts = NULL, ...) }\cr Again we can use the Rmetrics' wrapper \code{regFit(formula, data, use = "gam", ...) }\cr \code{[stats::glm]} \cr % ----------------------------------------------- \bold{GAM -- Generalized Additive Models:} \cr\cr An additive model generalizes a linear model by smoothing individually each predictor term. A generalized additive model extends the additive model in the same spirit as the generalized linear model extends the linear model, namely for allowing a link function and for allowing non-normal distributions from the exponential family.\cr \code{[mgcv:gam]} \cr % ----------------------------------------------- \bold{PPR -- Projection Pursuit Regression:} \cr\cr The basic method is given by Friedman (1984), and is essentially the same code used by S-PLUS's \code{ppreg}. It is observed that this code is extremely sensitive to the compiler used. The algorithm first adds up to \code{max.terms}, by default \code{ppr.nterms}, ridge terms one at a time; it will use less if it is unable to find a term to add that makes sufficient difference. The levels of optimization, argument \code{optlevel}, by default 2, differ in how thoroughly the models are refitted during this process. At level 0 the existing ridge terms are not refitted. At level 1 the projection directions are not refitted, but the ridge functions and the regression coefficients are. Levels 2 and 3 refit all the terms; level 3 is more careful to re-balance the contributions from each regressor at each step and so is a little less likely to converge to a saddle point of the sum of squares criterion. The \code{plot} method plots Ridge functions for the projection pursuit regression fit.\cr \code{[stats:ppr]} \cr % ----------------------------------------------- \bold{POLYMARS -- Polychotomous MARS:} \cr\cr The algorithm employed by \code{polymars} is different from the MARS(tm) algorithm of Friedman (1991), though it has many similarities. Also the name \code{polymars} has been used for this algorithm well before MARS was trademarked.\cr \code{[polyclass:polymars]} \cr % ----------------------------------------------- \bold{NNET -- Feedforward Neural Network Regression:} \cr\cr If the response in \code{formula} is a factor, an appropriate classification network is constructed; this has one output and entropy fit if the number of levels is two, and a number of outputs equal to the number of classes and a softmax output stage for more levels. If the response is not a factor, it is passed on unchanged to \code{nnet.default}. A quasi-Newton optimizer is used, written in \code{C}. \cr \code{[nnet:nnet]} } \references{ Belsley D.A., Kuh E., Welsch R.E. (1980); \emph{Regression Diagnostics}; Wiley, New York. Dobson, A.J. (1990); \emph{An Introduction to Generalized Linear Models}; Chapman and Hall, London. Draper N.R., Smith H. (1981); \emph{Applied Regression Analysis}; Wiley, New York. Friedman, J.H. (1991); \emph{Multivariate Adaptive Regression Splines (with discussion)}, The Annals of Statistics 19, 1--141. Friedman J.H., and Stuetzle W. (1981); \emph{Projection Pursuit Regression}; Journal of the American Statistical Association 76, 817-823. Friedman J.H. (1984); \emph{SMART User's Guide}; Laboratory for Computational Statistics, Stanford University Technical Report No. 1. Green, Silverman (1994); \emph{Nonparametric Regression and Generalized Linear Models}; Chapman and Hall. Gu, Wahba (1991); \emph{Minimizing GCV/GML Scores with Multiple Smoothing Parameters via the Newton Method}; SIAM J. Sci. Statist. Comput. 12, 383-398. Hastie T., Tibshirani R. (1990); \emph{Generalized Additive Models}; Chapman and Hall, London. Kooperberg Ch., Bose S., and Stone C.J. (1997); \emph{Polychotomous Regression}, Journal of the American Statistical Association 92, 117--127. McCullagh P., Nelder, J.A. (1989); \emph{Generalized Linear Models}; Chapman and Hall, London. Myers R.H. (1986); \emph{Classical and Modern Regression with Applications}; Duxbury, Boston. Rousseeuw P.J., Leroy, A. (1987); \emph{Robust Regression and Outlier Detection}; Wiley, New York. Seber G.A.F. (1977); \emph{Linear Regression Analysis}; Wiley, New York. Stone C.J., Hansen M., Kooperberg Ch., and Truong Y.K. (1997); \emph{The use of polynomial splines and their tensor products in extended linear modeling (with discussion)}. Venables, W.N., Ripley, B.D. (1999); \emph{Modern Applied Statistics with S-PLUS}; Springer, New York. Wahba (1990); \emph{Spline Models of Observational Data}; SIAM. Weisberg S. (1985); \emph{Applied Linear Regression}; Wiley, New York. Wood (2000); \emph{Modelling and Smoothing Parameter Estimation with Multiple Quadratic Penalties}; JRSSB 62, 413-428. Wood (2001); \emph{mgcv: GAMs and Generalized Ridge Regression for \R}. R News 1, 20-25. Wood (2001); \emph{Thin Plate Regression Splines}. There exists a vast literature on regression. The references listed above are just a small sample of what is available. The book by Myers' is an introductory text book that covers discussions of much of the recent advances in regression technology. Seber's book is at a higher mathematical level and covers much of the classical theory of least squares. } \author{ The R core team for the \code{lm} functions from R's \code{base} package, \cr B.R. Ripley for the \code{glm} functions from R's \code{base} package, \cr S.N. Wood for the \code{gam} functions from R's \code{mgcv} package, \cr N.N. for the \code{ppr} functions from R's \code{modreg} package, \cr M. O' Connors for the \code{polymars} functions from R's \code{?} package, \cr The R core team for the \code{nnet} functions from R's \code{nnet} package, \cr Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x <- regSim(model = "LM3", n = 100) # LM regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") # RLM regFit(Y ~ X1 + X2 + X3, data = x, use = "rlm") # AM regFit(Y ~ X1 + X2 + X3, data = x, use = "gam") # PPR regFit(Y ~ X1 + X2 + X3, data = x, use = "ppr") # NNET regFit(Y ~ X1 + X2 + X3, data = x, use = "nnet") # POLYMARS regFit(Y ~ X1 + X2 + X3, data = x, use = "polymars") } \keyword{models} fRegression/man/class-fREG.Rd0000644000176200001440000000654514273153361015507 0ustar liggesusers\name{fREG-class} \docType{class} \alias{fREG-class} \title{Class "fREG"} \description{ The class 'fREG' represents a fitted model of an heteroskedastic time series process. } \section{Objects from the Class}{ Objects can be created by calls of the function \code{regFit}. The returned object represents parameter estimates of linear and generalized linear models. } \section{Slots}{ \describe{ \item{\code{call}:}{Object of class \code{"call"}: the call of the \code{garch} function. } \item{\code{formula}:}{Object of class \code{"formula"}: the formula used in parameter estimation. } \item{\code{family}:}{Object of class \code{"character"}: the family objects provide a convenient way to specify the details of the models used by function \code{grefFit} For details we refer to the documentation for the function \code{glm} in R's base package on how such model fitting takes place. } \item{\code{method}:}{Object of class \code{"character"}: a string denoting the regression model in use, i.e. one of those listed in the \code{use} argument of the function \code{regFit} or \code{gregFit}. } \item{\code{data}:}{Object of class \code{"list"}: a list with at least two entries named \code{x} containing the data frame used for the estimation, and \code{data} with the object of the rectangular input data. } \item{\code{fit}:}{Object of class \code{"list"}: a list with the results from the parameter estimation. The entries of the list depend on the selected algorithm, see below. } \item{\code{residuals}:}{Object of class \code{"numeric"}: a numeric vector with the residual values. } \item{\code{fitted}:}{Object of class \code{"numeric"}: a numeric vector with the fitted values. } \item{\code{title}:}{Object of class \code{"character"}: a title string. } \item{\code{description}:}{Object of class \code{"character"}: a string with a brief description. } } } \section{Methods}{ \describe{ \item{show}{\code{signature(object = "fREG")}: prints an object of class 'fREG'. } \item{plot}{\code{signature(x = "fREG", y = "missing")}: plots an object of class 'fREG'. } \item{summary}{\code{signature(object = "fREG")}: summarizes results and diagnostic analysis of an object of class 'fREG'. } \item{predict}{\code{signature(object = "fREG")}: forecasts mean and volatility from an object of class 'fREG'. } \item{fitted}{\code{signature(object = "fREG")}: extracts fitted values from an object of class 'fREG'. } \item{residuals}{\code{signature(object = "fREG")}: extracts fresiduals from an object of class 'fREG'. } \item{coef}{\code{signature(object = "fREG")}: extracts fitted coefficients from an object of class 'fREG'. } \item{formula}{\code{signature(x = "fREG")}: extracts formula expression from an object of class 'fREG'. } } } \author{ Diethelm Wuertz and Rmetrics Core Team. } \keyword{programming} fRegression/man/methods-plot.Rd0000644000176200001440000000353514273247507016242 0ustar liggesusers\name{plot-methods} \docType{methods} \alias{plot-methods} \alias{plot,ANY,ANY-method} \alias{plot,fREG,missing-method} \title{Regression Model Plot Methods} \description{ Plots results obtained from a fitted regression model. } \usage{ \S4method{plot}{fREG,missing}(x, which = "ask", \dots) } \arguments{ \item{x}{ an object of class 'fREG'. } \item{which}{ a character string selecting which plot should be displayed. By default \code{which="ask"} which allows to generate plots interactively. } \item{\dots}{ additional arguments to be passed to the underlying plot functions. } } \section{Methods}{ \describe{ \item{x = "ANY", y = "ANY"}{ Generic function. } \item{x = "fREG", y = "missing"}{ Plot function to display results obtained from a fitted regression model. } } } \details{ The plots are a set of graphs which are common to the regression models implemented in the function \code{regFit}. This includes linear regression models \code{use="lm"}, robust linear regression models \code{use="rlm"}, generalized linear regression models \code{use = "glm"}, generalized additive regression models \code{use = "gam"}, projection pursuit regression models \code{use = "ppr"}, neural network regression models \code{use = "nnet"}, and polychotomous MARS models \code{use = "polymars"}. In addition one can also use the original plot functions of the original models, .e.g. \code{plot(slot(object, "fit")}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x = regSim(model = "LM3", n = 50) ## regFit - fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") ## plot - } \keyword{models} fRegression/man/methods-coef.Rd0000644000176200001440000000156314273153361016171 0ustar liggesusers\name{coef-methods} \docType{methods} \alias{coef-methods} \alias{coef,ANY-method} \alias{coef,fREG-method} \title{REG coefficients Methods} \description{ Extracts coefficients from a fitted regression model. } \section{Methods}{ \describe{ \item{object = "ANY"}{ Generic function. } \item{object = "fREG"}{ Extractor function for coefficients. } } } \note{ \code{coef} is a generic function which extracts the coefficients from objects returned by modeling functions, here the \code{regFit} and \code{gregFit} parameter estimation functions. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x = regSim(model = "LM3", n = 50) ## regFit - fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") ## coef - coef(fit) } \keyword{models} fRegression/man/methods-vcov.Rd0000644000176200001440000000156014273153361016227 0ustar liggesusers\name{vcov-methods} \docType{methods} \alias{vcov-methods} \alias{vcov,ANY-method} \alias{vcov,fREG-method} \title{Extract Regression Model vcov} \description{ Extracts vcov from a fitted regression model. } \section{Methods}{ \describe{ \item{object = "ANY"}{ Generic function } \item{object = "fREG"}{ Extractor function for vcov. } } } \note{ \code{vcov} is a generic function which extracts fitted values from objects returned by modeling functions, here the \code{regFit} and \code{gregFit} parameter estimation functions. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x <- regSim(model = "LM3", n = 50) ## regFit - fit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") ## vcov - vcov(fit) } \keyword{models} fRegression/man/methods-summary.Rd0000644000176200001440000000126314273153361016747 0ustar liggesusers\name{summary-methods} \docType{methods} \alias{summary-methods} \alias{summary,ANY-method} \alias{summary,fREG-method} \title{Regression Summary Methods} \description{ Summary methods for regressing modelling. } \section{Methods}{ \describe{ \item{object = "ANY"}{ Generic function } \item{object = "fREG"}{ Summary method for objects of class 'fREG'. } } } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x <- regSim(model = "LM3", n = 50) ## regFit - fit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") ## summary summary(fit) } \keyword{models} fRegression/man/methods-terms.Rd0000644000176200001440000000154614273153361016410 0ustar liggesusers\name{terms-methods} \docType{methods} \alias{terms-methods} \alias{terms,ANY-method} \alias{terms,fREG-method} \title{Regression Model Plot Methods} \description{ Plots results obtained from a fitted regression model. } \usage{ \S4method{terms}{fREG}(x, \dots) } \arguments{ \item{x}{ an object of class 'fREG'. } \item{\dots}{ additional arguments to be passed to the underlying functions. } } \section{Methods}{ \describe{ \item{x = "ANY"}{ Generic function. } \item{x = "fREG"}{ Terms extractor function. } } } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x <- regSim(model = "LM3", n = 50) ## regFit - fit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") } \keyword{models} fRegression/man/methods-residuals.Rd0000644000176200001440000000200714273153361017242 0ustar liggesusers\name{residuals-methods} \docType{methods} \alias{residuals-methods} \alias{residuals,ANY-method} \alias{residuals,fREG-method} \title{Extract Regression Model Residuals} \description{ Extracts residuals from a fitted regression object. } \usage{ \S4method{residuals}{fREG}(object) } \arguments{ \item{object}{ an object of class \code{fREG} as returned from the function \code{regFit()} or \code{gregFit()}. } } \section{Methods}{ \describe{ \item{object = "ANY"}{ Generic function } \item{object = "fREG"}{ Residuals } } } \note{ \code{residuals} is a generic function which extracts residual values from objects returned by modeling functions. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x = regSim(model = "LM3", n = 50) ## regFit - fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") ## residuals - residuals(fit) } \keyword{models} fRegression/man/methods-show.Rd0000644000176200001440000000167714273153361016243 0ustar liggesusers\name{show-methods} \docType{methods} \alias{show-methods} \alias{show,ANY-method} \alias{show,fREG-method} \title{Regression Modelling Show Methods} \description{ Show methods for regression modelling. } \section{Methods}{ \describe{ \item{object = "ANY"}{ Generic function. } \item{object = "fREG"}{ Print method for objects of class 'fREG'. } } } \details{ The show or print method returns the same information for all supported regression models through the \code{use} argument in the function \code{regFit}. These are the 'title', the 'formula', the 'family' and the 'model parameters'. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x <- regSim(model = "LM3", n = 50) ## regFit - fit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") ## print - print(fit) } \keyword{models} fRegression/man/methods-formula.Rd0000644000176200001440000000157714273247230016726 0ustar liggesusers\name{formula-methods} \docType{methods} \alias{formula-methods} \alias{formula,ANY-method} \alias{formula,fREG-method} \title{Extract Regression Model formula} \description{ Extracts formula from a fitted regression model. } \section{Methods}{ \describe{ \item{object = "ANY"}{ Generic function } \item{object = "fGARCH"}{ Formula } } } \note{ \code{formula} is a generic function which extracts the formula expression from objects returned by modeling functions, here the \code{regFit} and \code{gregFit} parameter estimation function. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x = regSim(model = "LM3", n = 50) ## regFit - fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") ## formula - formula(fit) } \keyword{models} fRegression/man/regSim.Rd0000644000176200001440000000556514273153361015050 0ustar liggesusers\name{regSim} \alias{regSim} \alias{LM3} \alias{LOGIT3} \alias{GAM3} \title{Regression Model Simulation} \description{ Simulates regression models. } \usage{ regSim(model = "LM3", n = 100, ...) LM3(n = 100, seed = 4711) LOGIT3(n = 100, seed = 4711) GAM3(n = 100, seed = 4711) } \arguments{ \item{model}{ a character string defining the function name from which the regression model will be simulated. } \item{n}{ an integer value setting the length, i.e. the number of records of the output series, an integer value. By default \code{n=100}. } \item{seed}{ an integer value, the recommended way to specify seeds for random number generation. } \item{\dots}{ arguments to be passed to the underlying function specified by the \code{model} argument. } } \details{ The function \code{regSim} allows to simulate from various regression models defined by one of the three example functions \code{LM3}, \code{LOGIT3}, \code{GAM3} or by a user specified function. The examples are defined in the following way: \code{# LM3:}\cr \code{> y = 0.75 * x1 + 0.25 * x2 - 0.5 * x3 + 0.1 * eps }\cr \code{# LOGIT3:}\cr \code{> y = 1 / (1 + exp(- 0.75 * x1 + 0.25 * x2 - 0.5 * x3 + eps)) }\cr \code{# GAM3:}\cr \code{> y = scale(scale(sin(2 * pi * x1)) + scale(exp(x2)) + scale(x3)) }\cr \code{> y = y + 0.1 * rnorm(n, sd = sd(y))}\cr \code{"LM3"} models a liner regression model, \code{"LOGIT3"} a generalized linear regression model expressed by a logit model, and \code{"GAM"} an additive model. \code{x1}, \code{x2}, \code{x3}, and \code{eps} are random normal deviates of length \code{n}. The \code{model} function should return an rectangular series defined as an object of class \code{data.frame}, \code{timeSeries} or \code{mts} which can be accepted from the parameter estimation functions \code{regFit} and \code{gregFit}. } \value{ The function \code{garchSim} returns an object of the same class as returned by the underlying function \code{match.fun(model)}. These may be objects of class \code{data.frame}, \code{timeSeries} or \code{mts}. } \note{ This function is still under development. For the future we plan, that the function \code{regSim} will be able to generate general regression models. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## LM2 - # Data for a user defined linear regression model: LM2 = function(n){ x = rnorm(n) y = rnorm(n) eps = 0.1 * rnorm(n) z = 0.5 + 0.75 * x + 0.25 * y + eps data.frame(Z = z, X = x, Y = y) } for (FUN in c("LM2", "LM3")) { cat(FUN, ":\n", sep = "") print(regSim(model = FUN, n = 10)) } } \keyword{models} fRegression/man/methods-termPlot.Rd0000644000176200001440000000155314273153361017062 0ustar liggesusers\name{termPlot} \docType{methods} % \alias{termPlot-methods} % \alias{termPlot,ANY-method} \alias{termPlot.fREG} \title{Regression Model Plot Methods} \description{ Plots results obtained from a fitted regression model. } \usage{ \method{termPlot}{fREG}(model, \dots) } \arguments{ \item{model}{ an object of class 'fREG'. } \item{\dots}{ additional arguments to be passed to the underlying functions. } } \section{Methods}{ \describe{ \item{x = "ANY"}{ Generic function. } \item{x = "fREG"}{ Term plot function. } } } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x <- regSim(model = "LM3", n = 50) ## regFit - fit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") } \keyword{models} fRegression/man/00fRegression-package.Rd0000644000176200001440000001063414273153361017632 0ustar liggesusers\name{fRegression-package} \alias{fRegression-package} \alias{fRegression} \docType{package} \title{Regression Modelling Package} \description{ The Rmetrics "fRegression" package is a collection of functions for linear and non-linear regression modelling. } \details{ \tabular{ll}{ Package: \tab fRegression\cr Type: \tab Package\cr Version: \tab R 3.0.1\cr Date: \tab 2014\cr License: \tab GPL Version 2 or later\cr Copyright: \tab (c) 1999-2014 Rmetrics Association\cr Repository: \tab R-FORGE\cr URL: \tab \url{https://www.rmetrics.org} } } \section{1 Introduction}{ Regression modelling, especially linear modelling, LM, is a widely used application in financial engineering. In finance it mostly appears in form that a variable is modelled as a linear or more complex relationship as a function of other variables. For example the decision of buying or selling in a trading model may be triggered by the outcome of a regression model, e.g. neural networks are a well known tool in this field. } \section{2 Fitting Regression Models}{ Rmetrics has build a unique interface to several regression models available in the base and contributed packages of R. The following regression models are interfaced and available through a common function \code{regFit}. The argument \code{use} allows to select the desired model: \preformatted{ regFit fits regression models - lm fits a linear model [stats] - rlm fits a LM by robust regression [MASS] - glm fits a generliazed linear model [stats] - gam fits a generlized additive model [mgcv] - ppr fits a projection pursuit regression model [stats] - nnet fits a single hidden-layer neural network model [nnet] - polymars fits an adaptive polynomial spline regression [polspline] } An advantage of the \code{regFit} function is, that all the underlying functions of its family can be called with the same list of arguments, and the value returned is always an unique object, an object of class \code{"fREG"} with the following slots: \code{@call}, \code{@formula}, \code{@method}, \code{@data}, \code{@fit}, \code{@residuals}, \code{@fitted}, \code{@title}, and \code{@description}. Furthermore, independent of the selected regression model applied we can use the same S4 methods for all types of regressions. This includes, \code{print},\code{plot}, \code{summary}, \code{predict}, \code{fitted}, \code{residuals}, \code{coef}, \code{vcov}, and \code{formula} methods. It is possible to add further regression models to this framework either his own implementations or implementations available through other contributed R packages. Suggestions include \code{biglm}, \code{earth} amongst others. } \section{2 Simulation of Regression Models}{ contains a function to simulate artificial regression models, mostly used for testing. \preformatted{ regSim simulates artificial regression model data sets } } \section{3 Extractor Functions}{ These generic functions are: \preformatted{ fitted extracts fitted values from a fitted 'fREG' object residuals extracts residuals from a fitted 'fREG' object coef extracts coefficients from a fitted 'fREG' object formula extracts formula expression from a fitted 'fREG' object vcov extracts variance-covariance matrix of fitted parameters } } \section{4 Forecasting}{ The function \code{predict} returns predicted values based on the fitted model object. \preformatted{ predict forecasts from an object of class 'fREG' } } \section{4 Reporting Functions}{ For printing and plotting use the functions: \preformatted{ print prints the results from a regression fit plot plots the results from a gression fit summary returns a summary report } } \section{About Rmetrics:}{ The \code{fRegression} Rmetrics package is written for educational support in teaching "Computational Finance and Financial Engineering" and licensed under the GPL. } \keyword{package} fRegression/man/methods-predict.Rd0000644000176200001440000000237114273153361016705 0ustar liggesusers\name{predict-methods} \docType{methods} \alias{predict-methods} \alias{predict,ANY-method} \alias{predict,fREG-method} \title{Regression Models Prediction Function} \description{ Predicts a time series from a fitted regression model. } \usage{ \S4method{predict}{fREG}(object, newdata, se.fit = FALSE, type = "response", \dots) } \arguments{ \item{newdata}{ new data. } \item{object}{ an object of class \code{fREG} as returned from the function \code{regFit()}. } \item{se.fit}{ a logical flag. Should standard errors be included? By default \code{FALSE}. } \item{type}{ a character string by default \code{"response"}. } \item{\dots}{ arguments to be passed. } } \section{Methods}{ \describe{ \item{object = "ANY"}{ Generic function } \item{object = "fREG"}{ Predict method for regression models. } } } \value{ returns ... } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## regSim - x <- regSim(model = "LM3", n = 50) ## regFit - fit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") } \keyword{models} fRegression/DESCRIPTION0000644000176200001440000000215614275147203014257 0ustar liggesusersPackage: fRegression Title: Rmetrics - Regression Based Decision and Prediction Date: 2022-08-11 Version: 4021.83 Authors@R: c(person("Diethelm", "Wuertz", role = "aut") , person("Tobias", "Setz", role = "aut") , person("Yohan", "Chalabi", role = "aut") , person(given = c("Paul", "J."), family = "Northrop", role = c("cre", "ctb"), email = "p.northrop@ucl.ac.uk") ) Description: A collection of functions for linear and non-linear regression modelling. It implements a wrapper for several regression models available in the base and contributed packages of R. Depends: R (>= 2.15.1) Imports: fBasics, lmtest, MASS, methods, mgcv, nnet, polspline, stats, timeDate, timeSeries, utils Suggests: RUnit License: GPL (>= 2) URL: https://www.rmetrics.org BugReports: https://r-forge.r-project.org/projects/rmetrics NeedsCompilation: no Packaged: 2022-08-11 09:25:20 UTC; paul Author: Diethelm Wuertz [aut], Tobias Setz [aut], Yohan Chalabi [aut], Paul J. Northrop [cre, ctb] Maintainer: Paul J. Northrop Repository: CRAN Date/Publication: 2022-08-11 09:40:19 UTC fRegression/tests/0000755000176200001440000000000014273153361013707 5ustar liggesusersfRegression/tests/doRUnit.R0000644000176200001440000000154714273541007015423 0ustar liggesusers#### doRUnit.R --- Run RUnit tests ####------------------------------------------------------------------------ ### Origianlly follows Gregor Gojanc's example in CRAN package 'gdata' ### and the corresponding section in the R Wiki: ### http://wiki.r-project.org/rwiki/doku.php?id=developers:runit ### MM: Vastly changed: This should also be "runnable" for *installed* ## package which has no ./tests/ ## ----> put the bulk of the code e.g. in ../inst/unitTests/runTests.R : if(require("RUnit", quietly = TRUE)) { ## --- Setup --- wd <- getwd() pkg <- sub("\\.Rcheck$", '', basename(dirname(wd))) library(package=pkg, character.only = TRUE) path <- system.file("unitTests", package = pkg) stopifnot(file.exists(path), file.info(path.expand(path))$isdir) library(timeSeries) source(file.path(path, "runTests.R"), echo = TRUE) } fRegression/R/0000755000176200001440000000000014273153361012746 5ustar liggesusersfRegression/R/methods-plot.R0000644000176200001440000001655614273247416015532 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # S3-METHODS: PLOT METHOD: # plot.fREG Plots fit and diagnostics for a regression model # .plot.lm Linear Regression Model internal plot # .plot.rlm Robust Linear Regression Model internal plot # .plot.glm Generalized Linear Model internal plot # .plot.gam Generalized Additive Model internal plot # .plot.nnet Feedforward Neural Network Model internal plot # .plot.ppr Projection Pursuit Regression Model internal plot # .plot.polymars Polychotomous MARS Model internal plot # PLOTS: DESCRIPTION: # .interactiveRegPlot # .multRegPlot ################################################################################ setMethod(f = "plot", signature(x = "fREG", y = "missing"), definition = function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Description: # Plot method for an object of class 'fGARCH' # Note: # This method can also be used for plotting graphs fitted by # the function 'garch' from the contributed R package 'tseries'. # FUNCTION: # Plot: .plot(x@fit, which = which, ...) # Return Value: invisible(x) }) # ------------------------------------------------------------------------------ .plot.common <- function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Notes: # 1. Responses + Fitted Values Plot: # 2. Residuals Plot: # 3. Quantile Plot: # 4. Fitted Values vs. Residuals Plot: # FUNCTION: # Plot: .interactiveRegPlot( x, choices = c( "Responses + Fitted Values", "Residuals", "Normal Q-Q", "Residuals vs Fitted", "ACF of Residuals", "PACF of Residuals", "Positive Mean Excess Plot", "Negative Mean Excess Plot"), plotFUN = paste(".plot.", 1:8, sep = ""), which = which) # Return Value: invisible(x) } # ------------------------------------------------------------------------------ .plot.1 <- function(x, ...) .responsesPlot(residuals(x)+fitted(x),fitted(x)) .plot.2 <- function(x, ...) .residualsPlot(residuals(x)) .plot.3 <- function(x, ...) qqnormPlot(residuals(x)) .plot.4 <- function(x, ...) .firePlot(fitted(x), residuals(x)) .plot.5 <- function(x, ...) .acfPlot(residuals(x)) .plot.6 <- function(x, ...) .pacfPlot(residuals(x)) .plot.7 <- function(x, ...) .mrlPlot(residuals(x)) .plot.8 <- function(x, ...) .mrlPlot(-residuals(x)) # ------------------------------------------------------------------------------ .plot.lm <- function(...) .plot.common(...) .plot.rlm <- function(...) .plot.common(...) .plot.glm <- function(...) .plot.common(...) .plot.gam <- function(...) .plot.common(...) .plot.ppr <- function(...) .plot.common(...) .plot.nnet <- function(...) .plot.common(...) .plot.polymars <- function(...) .plot.common(...) # ------------------------------------------------------------------------------ .interactiveRegPlot <- function(x, choices = paste("Plot", 1:19), plotFUN = paste("plot.", 1:19, sep = ""), which = "all", ...) { # A function implemented by Diethelm Wuertz # Description: # Interactive plot method. # Arguments: # x - an object to be plotted # choices - the character string for the choice menu # plotFUN - the names of the plot functions # which - plot selection, which graph should be # displayed. If a character string named "ask" the # user is interactively asked which to plot, if # a logical vector of length N, those plots which # are set "TRUE" are displayed, if a character string # named "all" all plots are displayed. # Note: # At maximum 19 plots are supported. # FUNCTION: # Some cecks: if (length(choices) != length(plotFUN)) stop("Arguments choices and plotFUN must be of same length.") if (length(which) > length(choices)) stop("Arguments which has incorrect length.") if (length(which) > length(plotFUN)) stop("Arguments which has incorrect length.") if (length(choices) > 19) stop("Sorry, only 19 plots at max are supported.") # Plot: if (is.numeric(which)) { Which = rep(FALSE, times = length(choices)) Which[which] = TRUE which = Which } if (which[1] == "all") { which = rep(TRUE, times = length(choices)) } if (which[1] == "ask") { .multRegPlot(x, choices, plotFUN = plotFUN, ...) } else { for ( i in 1:length(which) ) { FUN = match.fun(plotFUN[i]) if (which[i]) FUN(x) } } # Return Value: invisible(x) } # ------------------------------------------------------------------------------ .multRegPlot <- function (x, choices, plotFUN, ...) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # FUNCTION: # Match Functions, up to nine(teen) ... if (length(plotFUN) < 19) plotFUN = c(plotFUN, rep(plotFUN[1], times = 19 - length(plotFUN))) plot.1 = match.fun(plotFUN[1]); plot.2 = match.fun(plotFUN[2]) plot.3 = match.fun(plotFUN[3]); plot.4 = match.fun(plotFUN[4]) plot.5 = match.fun(plotFUN[5]); plot.6 = match.fun(plotFUN[6]) plot.7 = match.fun(plotFUN[7]); plot.8 = match.fun(plotFUN[8]) plot.9 = match.fun(plotFUN[9]); plot.10 = match.fun(plotFUN[10]) plot.11 = match.fun(plotFUN[11]); plot.12 = match.fun(plotFUN[12]) plot.13 = match.fun(plotFUN[13]); plot.14 = match.fun(plotFUN[14]) plot.15 = match.fun(plotFUN[15]); plot.16 = match.fun(plotFUN[16]) plot.17 = match.fun(plotFUN[17]); plot.18 = match.fun(plotFUN[18]) plot.19 = match.fun(plotFUN[19]) pick = 1 while (pick > 0) { pick = menu ( ### choices = paste("plot:", choices), choices = paste(" ", choices), title = "\nMake a plot selection (or 0 to exit):") # up to 19 plot functions ... switch (pick, plot.1(x), plot.2(x), plot.3(x), plot.4(x), plot.5(x), plot.6(x), plot.7(x), plot.8(x), plot.9(x), plot.10(x), plot.11(x), plot.12(x), plot.13(x), plot.14(x), plot.15(x), plot.16(x), plot.17(x), plot.18(x), plot.19(x)) } } ################################################################################ fRegression/R/methods-summary.R0000644000176200001440000002662414273153361016241 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # summary Summary method for an object of class 'fREG' ################################################################################ setMethod(f = "summary", signature(object = "fREG"), definition = function(object, ...) { # A function implemented by Diethelm Wuertz # Description: # Summary method for Regression Modelling, an object of class "fREG" # FUNCTION: # Digits: digits <- max(4, getOption("digits") - 4) # Print all from print Method: print(object) # Add Residual Variance: cat("Residual Variance:\n", var(object@fit$residuals)) cat("\n\n") # Internal Function: fResiduals fResiduals <- function(x, digits) { cat("Non-Weighted Residuals:\n") names = c("Min", "1Q", "Median", "3Q", "Max") rq = structure(quantile(x), names = names) print(rq, digits = digits) names = c("Variance", "StDev", "Skewness", "Kurtosis") skewness = sum((x - mean(x))^3/sqrt(var(x))^3)/length(x) kurtosis = sum((x - mean(x))^4/var(x)^2)/length(x) - 3 rq = structure(c(var(x), sqrt(var(x)), skewness, kurtosis), names = names) print(rq, digits = digits) print("done") cat("\n") invisible() } # Internal Function: print.summary.LM print.summary.LM <- function (x, ...) { digits = max(4, getOption("digits") - 4) symbolic.cor = x$symbolic.cor signif.stars = getOption("show.signif.stars") # cat("\nCall:\n") # cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), # "\n\n", sep = "") aliased = x$aliased resid = x$residuals df = x$df rdf = df[2] cat(if (!is.null(x$w) && diff(range(x$w))) "Weighted ", "Residuals:\n", sep = "") if (rdf > 5) { nam = c("Min", "1Q", "Median", "3Q", "Max") rq = if (length(dim(resid)) == 2) structure(apply(t(resid), 1, quantile), dimnames = list(nam, dimnames(resid)[[2]])) else structure(quantile(resid), names = nam) print(rq, digits = digits, ...) } else if (rdf > 0) { print(resid, digits = digits, ...) } else { cat("ALL", df[1], "residuals are 0: no residual ", "degrees of freedom!\n") } if (length(aliased) == 0) { cat("\nNo Coefficients\n") } else { if (nsingular<-df[3] - df[1]) { cat("\nCoefficients: (", nsingular, " not defined ", "because of singularities)\n", sep = "") } else { cat("\nCoefficients:\n") } coefs = x$coefficients if (!is.null(aliased) && any(aliased)) { cn = names(aliased) coefs = matrix(NA, length(aliased), 4, dimnames = list(cn, colnames(coefs))) coefs[!aliased, ] = x$coefficients } printCoefmat(coefs, digits = digits, signif.stars = signif.stars, na.print = "NA", ...) } cat("\nResidual standard error:", format(signif(x$sigma, digits)), "on", rdf, "degrees of freedom\n") if (!is.null(x$fstatistic)) { cat("Multiple R-Squared:", formatC(x$r.squared, digits = digits)) cat(", Adjusted R-squared:", formatC(x$adj.r.squared, digits = digits), "\nF-statistic:", formatC(x$fstatistic[1], digits = digits), "on", x$fstatistic[2], "and", x$fstatistic[3], "DF, p-value:", format.pval(pf(x$fstatistic[1], x$fstatistic[2], x$fstatistic[3], lower.tail = FALSE), digits = digits), "\n") } correl = x$correlation if (!is.null(correl)) { p = NCOL(correl) if (p > 1) { cat("\nCorrelation of Coefficients:\n") if (is.logical(symbolic.cor) && symbolic.cor) { print(symnum(correl, abbr.colnames = NULL)) } else { correl = format(round(correl, 2), nsmall = 2, digits = digits) correl[!lower.tri(correl)] = "" print(correl[-1, -p, drop = FALSE], quote = FALSE) }} } cat("\n") invisible() } # Internal Function: print.summary.GLM print.summary.GLM = function (x, ...) { digits = max(4, getOption("digits") - 4) symbolic.cor = x$symbolic.cor signif.stars = getOption("show.signif.stars") aliased = x$aliased df = x$df #cat("\nCall:\n") #cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), # "\n\n", sep = "") cat("Deviance Residuals: \n") if (x$df.residual > 5) { x$deviance.resid = quantile(x$deviance.resid, na.rm = TRUE) names(x$deviance.resid) = c("Min", "1Q", "Median", "3Q", "Max") } print.default(x$deviance.resid, digits = digits, na.print = "", print.gap = 2) if (length(aliased) == 0) { cat("\nNo Coefficients\n") } else { if (!is.null(df) && (nsingular = df[3] - df[1])) cat("\nCoefficients: (", nsingular, " not defined ", "because of singularities)\n", sep = "") else cat("\nCoefficients:\n") coefs = x$coefficients if (!is.null(aliased) && any(aliased)) { cn = names(aliased) coefs = matrix(NA, length(aliased), 4, dimnames = list(cn, colnames(coefs))) coefs[!aliased, ] = x$coefficients } printCoefmat(coefs, digits = digits, signif.stars = signif.stars, na.print = "NA", ...) } cat("\n(Dispersion parameter for ", x$family$family, " family taken to be ", format(x$dispersion), ")\n\n", apply(cbind(paste(format(c("Null", "Residual"), width = 8, flag = ""), "deviance:"), format(unlist(x[c("null.deviance", "deviance")]), digits = max(5, digits + 1)), " on", format(unlist(x[c("df.null", "df.residual")])), " degrees of freedom\n"), 1, paste, collapse = " "), "AIC: ", format(x$aic, digits = max(4, digits + 1)), "\n\n", "Number of Fisher Scoring iterations: ", x$iter, "\n", sep = "") correl = x$correlation if (!is.null(correl)) { p = NCOL(correl) if (p > 1) { cat("\nCorrelation of Coefficients:\n") if (is.logical(symbolic.cor) && symbolic.cor) { print(symnum(correl, abbr.colnames = NULL)) } else { correl = format(round(correl, 2), nsmall = 2, digits = digits) correl[!lower.tri(correl)] = "" print(correl[-1, -p, drop = FALSE], quote = FALSE) }}} cat("\n") invisible() } # Internal Function: print.summary.GAM print.summary.GAM = function(x, ...) { if (length(x$p.coeff) > 0) { cat("Parametric coefficients:\n") width = max(nchar(names(x$p.coeff))) cat(rep(" ",width), " Estimate std. err. t ratio", " Pr(>|t|)\n", sep = "") for (i in 1:length(x$p.coeff)) cat(formatC(names(x$p.coeff)[i], width = width), " ", formatC(x$p.coeff[i], width=10, digits=5), " ", formatC(x$se[i], width = 10, digits = 4), " ", formatC(x$p.t[i], width = 10, digits = 4), " ", format.pval(x$p.pv[i]), "\n", sep="") } cat("\n") if (x$m > 0) { cat("Approximate significance of smooth terms:\n") width = max(nchar(names(x$chi.sq))) cat(rep(" ",width), " edf chi.sq ", "p-value\n", sep = "") for (i in 1:x$m) cat(formatC(names(x$chi.sq)[i], width = width), " ", formatC(x$edf[i], width = 10, digits = 4), " ", formatC(x$chi.sq[i], width = 10, digits = 5), " ", format.pval(x$s.pv[i]), "\n", sep = "") } cat("\nR-sq.(adj) = ", formatC(x$r.sq, digits = 3, width = 5), " Deviance explained = ", formatC(x$dev.expl*100, digits = 3, width = 4), "%", sep = "") if (is.null(x$ubre)) { cat("\nGCV score = ", formatC(x$gcv, digits = 5), " ", sep = "") } else { cat("\nUBRE score = ", formatC(x$ubre, digits = 5), sep = "") } cat(" Scale est. = ", formatC(x$scale, digits = 5, width = 8, flag = "-"), " n = ", x$n, "\n", sep = "") invisible() } # Fit: fit <- object@fit # Regression Model: LM if (object@method == "lm") { class(fit) = "lm" ans <- stats::summary.lm(object = fit, ...) print.summary.LM(x = ans, ...) } # Regression Model: GLM if (object@method == "glm") { class(fit) = c("glm", "lm") ans <- stats::summary.glm(object = fit, ...) print.summary.GLM(x = ans, ...) } # Regression Model: GAM if (object@method == "gam") { class(fit) = "gam" ans <- mgcv::summary.gam(object = fit, ...) print.summary.GAM(x = ans, ...) } # Regression Model: PPR if (object@method == "ppr") { # This is what print.ppr produces. mu <- fit$mu; ml = fit$ml cat("Goodness of fit:\n") gof <- fit$gofn; names(gof) = paste(1:ml, "terms") print(format(gof[mu:ml], ...), quote = FALSE) # This is what summary.ppr produces. if (any(fit$edf > 0)) { cat("\nEquivalent df for ridge terms:\n") edf <- fit$edf names(edf) = paste("term", 1:fit$mu) print(round(edf, 2), ...)} } # Regression Model: POLYMARS if (object@method == "polymars") { class(fit) = "polymars" # This is what summary.polymars produces. # There is no print.summary.polymars. cat("Model Fitting:\n") print(fit$fitting) if(fit$responses != 1) cat("\nResponses:", fit$responses, "\n") if(!is.null(fit$Rsquared)) cat("\nRsquared:",round(fit$Rsquared, 4),"\n") cat("\n") } # Regression Model: NNET if (object@method == "nnet") { # Use the print Method } # Return Value: invisible() }) ################################################################################ fRegression/R/zzz.R0000644000176200001440000000315314273153361013730 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### .onAttach <- function(libname, pkgname) { # do whatever needs to be done when the package is loaded # some people use it to bombard users with # messages using # packageStartupMessage( "\n" ) # packageStartupMessage( "Rmetrics Package fRegression" ) # packageStartupMessage( "Regression Based Decision and Prediction" ) # packageStartupMessage( "Copyright (C) 2005-2014 Rmetrics Association Zurich" ) # packageStartupMessage( "Educational Software for Financial Engineering and Computational Science" ) # packageStartupMessage( "Rmetrics is free software and comes with ABSOLUTELY NO WARRANTY." ) # packageStartupMessage( "https://www.rmetrics.org --- Mail to: info@rmetrics.org" ) } ############################################################################### fRegression/R/methods-residuals.R0000644000176200001440000000350014273153361016523 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION REGRESSION METHODS: # residuals.fREG Residuals method for an object of class 'fREG' ################################################################################ setMethod(f = "residuals", signature(object = "fREG"), definition = function(object) { # A function implemented by Diethelm Wuertz # Description: # residuals values method for an object of class fREG # FUNCTION: # residuals Values: residuals <- object@residuals # Get original time series class: data <- object@data$data dataClass <- class(data)[1] # Transform: if (dataClass == "timeSeries") { ans <- data data.mat <- matrix(residuals) rownames(data.mat) <- rownames(data) colnames(data.mat) <- object@data$unit series(ans) <- data.mat colnames(ans) <- as.character(object@formula[2]) } else { ans <- data } # Return Value: ans }) ################################################################################ fRegression/R/methods-predict.R0000644000176200001440000000703714273153361016173 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION REGRESSION METHODS: # predict.fREG Predicts values from a fitted regression model ################################################################################ setMethod(f = "predict", signature(object = "fREG"), definition = function(object, newdata, se.fit = FALSE, type = "response", ...) { # A function implemented by Diethelm Wuertz # Description: # Predict method for Regression Modelling, an object of class "fREG" # FUNCTION: # Fit: fit <- object@fit # Data as data.frame: if (missing(newdata)) newdata <- object@data$data # Predict: if (object@method == "nnet" & type == "response") type = "raw" ans <- .predict(object = fit, newdata = newdata, se.fit = se.fit, type = type, ...) # Make the output from 'predict' unique: if (se.fit) { if (!is.list(ans)) { if (is.matrix(ans)) ans = as.vector(ans) names(ans) = rownames(newdata) ans = list(fit = ans, se.fit = NA*ans) } else { ans = ans[1:2] } } else { if (is.matrix(ans)) ans = as.vector(ans) names(ans) = rownames(newdata) } # Return Value: ans }) # ------------------------------------------------------------------------------ # Note, in the following "object" concerns to the slot @fit: .predict.lm <- function(...) stats::predict.lm(...) # <- function (object, newdata, se.fit = FALSE, scale = NULL, df = Inf, # interval = c("none", "confidence", "prediction"), level = 0.95, # type = c("response", "terms"), terms = NULL, na.action = na.pass, # pred.var = res.var/weights, weights = 1, ...) .predict.rlm <- function(...) stats::predict.lm(...) # .predict.glm <- function(...) stats::predict.glm(...) # <- function (object, newdata = NULL, type = c("link", "response", # "terms"), se.fit = FALSE, dispersion = NULL, terms = NULL, # na.action = na.pass, ...) .predict.gam <- function(...) mgcv::predict.gam(...) # <- function (object, newdata, type = "link", se.fit = FALSE, terms = NULL, # block.size = 1000, newdata.guaranteed = FALSE, na.action = na.pass, # ...) .predict.ppr <- function(object, ...) { stats::predict(object, ...) } # <- function(object, newdata, ...) ##.predict.nnet <- function(object, ...) { nnet::predict(object, ...) } # <- function(object, newdata, type=c("raw","class"), ...) ##.predict.polspline <- function(object, ...) { polspline::predict(object, ...) } # ---- can be found in polymars.R # <- function(object, newdata, se.fit = FALSE, type = "response", ...) ################################################################################ fRegression/R/methods-termPlot.R0000644000176200001440000000276114273153361016346 0ustar liggesusers # 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, 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. # # A copy of the GNU General Public License is available via WWW at # http://www.gnu.org/copyleft/gpl.html. You can also obtain it by # writing to the Free Software Foundation, Inc., 59 Temple Place, # Suite 330, Boston, MA 02111-1307 USA. ################################################################################ # FUNCTIONS: REGRESSION TERMS: # termPlot.fREG Displays 'fREG' Model Term Plots ################################################################################ termPlot.fREG <- ## setMethod(f = "termPlot", signature(model = "fREG"), definition = function(model, ...) { # A function implemented by Diethelm Wuertz # Description: # Displays 'fREG' Model Term Plots # Arguments: # model - an object of class fREG as returned by the function # regFit # FUNCTION: # Formula: ans <- termplot(slot(model, "fit"), ...) # Return Value: ans } #) ################################################################################ fRegression/R/regSim.R0000644000176200001440000000525114273153361014322 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUNCTION: SIMULATION: # regSim Returns a regression example data set ############################################################################### LM3 <- function(n = 100, seed = 4711) { # A function implemented by Diethelm Wuertz # FUNCTION: # LM - Example Data: set.seed(seed) x1 = rnorm(n) x2 = rnorm(n) x3 = rnorm(n) y = 0.75 * x1 + 0.25 * x2 - 0.5 * x3 eps = 0.1 * rnorm(n) y = y + eps data.frame(Y = y, X1 = x1, X2 = x2, X3 = x3) } # ------------------------------------------------------------------------------ LOGIT3 <- function(n = 100, seed = 4711) { # A function implemented by Diethelm Wuertz # FUNCTION: # GLM / BINOMIAL / LOGIT - Example Data: set.seed(seed) x1 = rnorm(n) x2 = rnorm(n) x3 = rnorm(n) eps = 0.1 * rnorm(n) y = 0.75 * x1 + 0.25 * x2 - 0.5 * x3 + eps p = 1 / ( 1 + exp(-y) ) data.frame(Y = p, X1 = x1, X2 = x2, X3 = x3) } # ------------------------------------------------------------------------------ GAM3 <- function(n = 100, seed = 4711) { # A function implemented by Diethelm Wuertz # FUNCTION: # GAM - Example Data: set.seed(seed) x1 = runif(n) x2 = runif(n) x3 = runif(n) y1 = scale(sin(2 * pi * x1)) y2 = scale(exp(x2)) y3 = scale(x3) y = scale(y1 + y2 + y3) eps = 0.1 * rnorm(n, sd = sd(y)) y = y + eps data.frame(Y = y, X1 = x1, X2 = x2, X3 = x3) } # ------------------------------------------------------------------------------ regSim <- function(model = "LM3", n = 100, ...) { # A function implemented by Diethelm Wuertz # FUNCTION: # Simulate: funSim <- match.fun(model) ans <- funSim(n = n, ...) # Return Value: ans } ############################################################################### fRegression/R/methods-terms.R0000644000176200001440000000275214273153361015672 0ustar liggesusers # 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, 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. # # A copy of the GNU General Public License is available via WWW at # http://www.gnu.org/copyleft/gpl.html. You can also obtain it by # writing to the Free Software Foundation, Inc., 59 Temple Place, # Suite 330, Boston, MA 02111-1307 USA. ################################################################################ # FUNCTIONS: REGRESSION TERMS: # terms.fREG Extracts 'fREG' Model Terms ################################################################################ setMethod(f = "terms", signature(x = "fREG"), definition = function(x, ...) { # A function implemented by Diethelm Wuertz # Description: # Extracts 'fREG' Model Terms # Arguments: # object - an object of class fREG as returned by the function # regFit # FUNCTION: # Formula: ans <- stats::terms(slot(x, "fit"), ...) # Return Value: ans }) ################################################################################ fRegression/R/wrapper-polymars.R0000644000176200001440000001412014273153361016413 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # INTERFACE: FROM POLSPLINE - POLYMARS DESCRIPTION: # .polymarsFormula Polymars regress from package polspline # .polymars.default Default wrapper for polymars() # .predict.polymars Formula wrapper for polymars() # .predict.polymars Predict from a polymars model ################################################################################ # Note: # Introduce no .polymars = function() UseMethod() # this fails regFit(..., use = "polymars) # ------------------------------------------------------------------------------ .polymarsFormula <- function(formula, data, ...) { # A function implemented by Diethelm Wuertz # FUNCTION: # Extract Model Data: mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- TRUE mf[[1L]] <- quote(stats::model.frame) mf <- eval(mf, parent.frame()) mt <- attr(mf, "terms") y <- model.response(mf, "numeric") x <- model.matrix(mt, mf) # Rempove Intercept from x if exists ... M <- which(colnames(x) == "(Intercept)") if (length(M) > 0) X <- x[ ,-M] # Fit: fit <- .polymarsDefault(responses = y, predictors = X, ...) # Add to fit: # ... '$coef' keeps model fit$model <- mf fit$terms <- mt # Class: class(fit) <- "polymars" # Return Value: fit } # ------------------------------------------------------------------------------ .polymarsDefault <- 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) { # A function implemented by Diethelm Wuertz # Arguments: # 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 Arguments: # 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 # FUNCTION: # require(polspline) print(head(responses)) print(head(predictors)) # Fit: .Call <- match.call() .Call[[1]] <- quote(polspline::polymars) ans <- eval(.Call, parent.frame()) # Add Coefficients Parameters: ans$coef <- ans$model ans$parameters <- ans$coef ans$fitted.values <- ans$fitted # Return Value: ans } # ------------------------------------------------------------------------------ .predict.polymars <- function(object, newdata, se.fit = FALSE, type = "response", ...) { # Note: # newdata is a predictor data.frame, if missing the fitted # vector will be returned. # Example: # x=LM3(); object1 = regFit(Y ~ X1+X2+X3, data = x, use = "polymars")@fit # .predict.polymars(object, newdata = x[, -1]) # FUNCTION: # Restore Object Model: object$model <- object$coef class(object) <- "polymars" # Polymars requires 1-column matrices: object$residuals <- matrix(object$residuals) object$fitted <- matrix(object$fitted) # Here, object is expected to be the slot @fit of an object of class 'fREG' if (missing(newdata)) { y <- as.vector(object$fitted) } else { tt <- object$terms Terms <- delete.response(tt) modelFrame <- model.frame(Terms, newdata) X <- model.matrix(Terms, modelFrame)[, -1] Y <- polspline::predict.polymars(object, x = X, ...) } # Add optionally standard errors - NA's not available yet ... if (se.fit) Y <- list(fit = Y, se.fit = NA*Y) # Return Value: Y } ################################################################################ fRegression/R/fittedPlot.R0000644000176200001440000001120614273153361015207 0ustar liggesusers # 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, 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. # # A copy of the GNU General Public License is available via WWW at # http://www.gnu.org/copyleft/gpl.html. You can also obtain it by # writing to the Free Software Foundation, Inc., 59 Temple Place, # Suite 330, Boston, MA 02111-1307 USA. ################################################################################ # FUNCTION: REGRESSION TERM PLOTS: # .fittedPlot Line Plot # .fittedPersp Perspective Plot # .fittedContour Contour Plot ################################################################################ .fittedPlot <- function(object, which = NULL) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # object - an object of class 'fREG' as returned by the function regFit # FUNCTION: model = object@fit$model responseName = colnames(model)[attr(terms(object), "response")] model.mat = as.matrix(object@fit$model)[,-attr(terms(object), "response")] N = NCOL(model.mat) zero = rep(0, times = N) if (is.null(which)) which = 1:N colNames = colnames(model.mat)[which] ans = NULL for (i in which) { one = zero one[i] = 1 new.model.mat = model.mat new.model.mat = 0 * model.mat x = new.model.mat[, i] = model.mat %*% one y = predict(object, newdata = as.data.frame(new.model.mat)) ans = cbind(ans, y) plot(x, y, xlab = colNames[i], ylab = paste("Fitted", colNames[i])) } colnames(ans) = paste(responseName, "(", colNames, ")", sep = "") as.data.frame(ans) } # ------------------------------------------------------------------------------ .fittedPersp <- function(object) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # object - an object of class 'fREG' as returned by the function regFit # FUNCTION: # Settings: model = object@fit$model responseName = colnames(model)[attr(terms(object), "response")] model.mat = as.matrix(object@fit$model)[,-attr(terms(object), "response")] N = NCOL(model.mat) colNames = colnames(model.mat) for (i in 1:(N-1)) { rangeX = range(model.mat[, i]) X = seq(rangeX[1], rangeX[2], length = 10) newdata = matrix(rep(0, times = N*10*10), ncol = N) newdata[ ,i] = X for (j in (i+1):N) { rangeY = range(model.mat[, j]) Y = seq(rangeY[1], rangeY[2], length = 10) XY = gridVector(X, Y) newdata[, j] = Y colnames(newdata) = colNames print(head(newdata)) Z = predict(object, as.data.frame(newdata)) Z = matrix(Z, ncol = 10) .perspPlot(X, Y, Z, xlab = colNames[i], ylab = colNames[j]) } } } # ------------------------------------------------------------------------------ .fittedContour <- function(object) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # object - an object of class 'fREG' as returned by the function regFit # FUNCTION: # Settings: model <- object@fit$model responseName = colnames(model)[attr(terms(object), "response")] model.mat = as.matrix(object@fit$model)[,-attr(terms(object), "response")] N = NCOL(model.mat) colNames = colnames(model.mat) for (i in 1:(N-1)) { rangeX = range(model.mat[, i]) X = seq(rangeX[1], rangeX[2], length = 10) newdata = matrix(rep(0, times = N*10*10), ncol = N) newdata[ ,i] = X for (j in (i+1):N) { rangeY = range(model.mat[, j]) Y = seq(rangeY[1], rangeY[2], length = 10) XY = gridVector(X, Y) newdata[, j] = Y colnames(newdata) = colNames print(head(newdata)) Z = predict(object, as.data.frame(newdata)) Z = matrix(Z, ncol = 10) .contourPlot(X, Y, Z, xlab = colNames[i], ylab = colNames[j]) } } } ################################################################################ fRegression/R/wrapper-lmTest.R0000644000176200001440000001227014273153361016021 0ustar liggesusers # 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, 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. # # A copy of the GNU General Public License is available via WWW at # http://www.gnu.org/copyleft/gpl.html. You can also obtain it by # writing to the Free Software Foundation, Inc., 59 Temple Place, # Suite 330, Boston, MA 02111-1307 USA. ################################################################################ # FUNCTION: TIME SERIES TESTS # lmTest Linear Modelling Test, select from: # bgTest Breusch-Godfrey Test # bpTest Breusch-Pagan Test # dwTest Durbin-Watson Test # gqTest Goldfeld-Quandt Test # harvTest Harvey-Collier Test # hmcTest Harrison-McCabe Test # rainTest Rainbow Test # resetTest Ramsey's RESET Test # REQUIRES: # lmtest ################################################################################ ################################################################################ # BUILTIN - PACKAGE DESCRIPTION: # Package: lmtest # Title: Testing Linear Regression Models # Version: 0.9-3 # Date: $Date: 2003/02/19 15:54:30 $ # Author: Torsten Hothorn , # Achim Zeileis , David Mitchell # Maintainer: Achim Zeileis # Description: A collection of tests, data sets and examples # for diagnostic checking in linear regression models. # Depends: R (>= 1.4.0) # License: GPL ################################################################################ lmTest <- function(formula, method = c("bg", "bp", "dw", "gq", "harv", "hmc", "rain", "reset"), data = list(), ...) { # A function implemented by Diethelm Wuertz # FUNCTION: # Load Library: # Here we use a BUILTIN ... # require(lmtest) # Settings: method <- match.arg(method) # DW: if (method == "dw") ans <- lmtest::dwtest(formula = formula, data = data, ...) # BP: if (method == "bp") ans <- lmtest::bptest(formula = formula, data = data, ...) # GQ: if (method == "gq") ans <- lmtest::gqtest(formula = formula, data = data, ...) # HMC: if (method == "hmc") ans <- lmtest::hmctest(formula = formula, data = data, ...) # HARV: if (method == "harv") ans <- lmtest::harvtest(formula = formula, data = data, ...) # RAIN: if (method == "rain") ans <- lmtest::raintest(formula = formula, data = data, ...) # RESET: if (method == "reset") ans <- lmtest::reset(formula = formula, data = data, ...) # BG: if (method == "bg") ans <- lmtest::bgtest(formula = formula, data = data, ...) # Return Result: ans } # ****************************************************************************** dwTest <- function(formula, alternative = c("greater", "two.sided", "less"), iterations = 15, exact = NULL, tol = 1.0e-10, data = list()) { lmtest::dwtest(formula, alternative, iterations, exact, tol, data) } # ------------------------------------------------------------------------------ bpTest <- function(formula, varformula = NULL, studentize = TRUE, data = list()) { lmtest::bptest(formula, varformula, studentize, data) } # ------------------------------------------------------------------------------ gqTest <- function(formula, point=0.5, order.by = NULL, data = list()) { lmtest::gqtest(formula, point, order.by, data) } # ------------------------------------------------------------------------------ hmcTest <- function(formula, point = 0.5, order.by = NULL, simulate.p = TRUE, nsim = 1000, plot = FALSE, data = list()) { lmtest::hmctest(formula, point, order.by, simulate.p, nsim, plot, data) } # ------------------------------------------------------------------------------ harvTest <- function(formula, order.by = NULL, data = list()) { lmtest::harvtest(formula, order.by, data) } # ------------------------------------------------------------------------------ rainTest = function(formula, fraction = 0.5, order.by = NULL, center = NULL, data = list()) { lmtest::raintest(formula, fraction, order.by, center, data) } # ------------------------------------------------------------------------------ resetTest <- function(formula, power = 2:3, type = c("fitted", "regressor", "princomp"), data = list()) { lmtest::reset(formula, power, type, data) } # ------------------------------------------------------------------------------ bgTest <- function(formula, order = 1, type = c("Chisq", "F"), data = list()) { lmtest::bgtest(formula, order, type, data) } ################################################################################ fRegression/R/methods-fitted.R0000644000176200001440000000346514273153361016021 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUMCTION: DESCRIPTION REGRESSION METHODS: # fitted.fREG Fitted values method for an object of class fREG ############################################################################### setMethod(f = "fitted", signature(object = "fREG"), definition = function(object) { # A function implemented by Diethelm Wuertz # Description: # Fitted values method for an object of class fREG # FUNCTION: # Fitted Values: fitted <- object@fitted # Get original time series class: data = slot(object, "data")$data dataClass = class(data)[1] # Transform: if (dataClass == "timeSeries") { ans <- data data.mat <- matrix(fitted) rownames(data.mat) <- rownames(data) colnames(data.mat) <- object@data$unit series(ans) <- data.mat colnames(ans) <- as.character(object@formula[2]) } else { ans <- data } # Return Value: ans }) ############################################################################### fRegression/R/regFit.R0000644000176200001440000001521214273545762014324 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUNCTION: PARAMETER ESTIMATION: # regFit Wrapper Function for Regression Models # .lmFit Linear Regression Model # .rlmFit Robust Linear Regression Model # .glmFit Generalized Linear Model # .gamFit Generalized Additive Model # .pprFit Projection Pursuit Regression Model # .nnetFit Feedforward Neural Network Model # .polymarsFit Polychotomous MARS Model ############################################################################### ############################################################################### # MODEL: PACKAGE print plot summary print predict # persp summary # lm stats x x x x x # rlm MASS # glm stats x - x x x # gam mgcv x x x x x # ppr stats x x x x x # nnet nnet x - x x x # polymars* polspline - xx x - x ############################################################################### regFit <- function (formula, data, family = gaussian, use = c("lm", "rlm", "glm", "gam", "ppr", "nnet", "polymars"), title = NULL, description = NULL, ...) { # A function implemented by Diethelm Wuertz # Description: # Common function call for several selected regression models. # Details: # This is a wrapper function for the following regression models: # LM Linear Regression Modelling # RLM Robust Linear Regression Modelling # GLM Generalized Linear Modelling # GAM Generalized Additive Modelling # PPR Projection Pursuit Regression # NNET Feedforward Neural Net # POLYMARS Polychotomous MARS Modeling # Notes: # Available Methods are # "print", "plot", "summary", "predict" # "coef", "formula", "residuals" "fitted", "vcov" # Example: # regFit(Y ~ X1 + X2 + X3, regSim()) # FUNCTION: # Match Arguments: use <- match.arg(use) if (missing(data)) data <- NULL # Transform data into a dataframe if (!is.null(data)) { Data <- if (inherits(data, "timeSeries")) data else as.timeSeries(data) data <- as.data.frame(data) } else { Data <- data <- NULL } # Function to be called: fun <- paste(".", match.arg(use), sep = "") # Title: if (is.null(title)) { if (use == "lm") title = "Linear Regression Modeling" if (use == "rlm") title = "Robust Linear Regression Modeling" if (use == "glm") title = "Generalized Linear Modeling" if (use == "gam") title = "Generalized Additive Modeling" if (use == "ppr") title = "Projection Pursuit Regression" if (use == "nnet") title = "Feedforward Neural Network Modeling" if (use == "polymars") title = "Polytochomous MARS Modeling" } # Description: if (is.null(description)) description = description() # Compose Command to be Called: cmd <- match.call() if (!is.null(cmd$use)) cmd = cmd[-match("use", names(cmd), 0)] cmd[[1]] <- as.name(fun) # Use this to access hidden functions in a parent frame: #cmd[[1]] <- substitute(fRegression:::f, list(f=as.name(fun))) # Ensure that data is a data.frame if (!is.null(cmd$data)) cmd$data <- as.name("data") # Use this to directly pass the argument from the parent frame: #if (!is.null(cmd$data)) cmd$data <- call("as.data.frame", cmd$data) # Fit Regression Model: fit <- eval(cmd) # Use this to evaluate in parent frame: #fit <- eval(cmd, parent.frame()) # Add "cmd" to Fit: fit$cmd <- cmd # Add "xlevels" to Fit (if missing): if (is.null(fit$xlevels)) fit$xlevels = list() # Add "residuals" and "fitted" to Fit (to be sure ...): fit$residuals <- as.vector(fit$residuals) fit$fitted.values <- as.vector(fit$fitted.values) # Add "parameters" as Alternative: fit$parameters <- fit$coef # Extend to class "list": class(fit) <- c("list", class(fit)) if (!inherits(fit, "lm")) class(fit) = c(class(fit), "lm") # Return Value: new("fREG", call = as.call(match.call()), formula = as.formula(formula), family = as.character(gaussian()), method = use, # data is as.data.frame(data), Data is as.timeSeries(data): data = list(data = data, Data = Data), fit = fit, residuals = fit$residuals, fitted = fit$fitted.values, title = as.character(title), description = as.character(description) ) } ############################################################################### .lm <- function(...) { stats::lm(...) } # ----------------------------------------------------------------------------- .rlm <- function(...) { MASS::rlm(...) } # ----------------------------------------------------------------------------- .glm <- function(...) { stats::glm(...) } # ----------------------------------------------------------------------------- .gam <- function(...) { mgcv::gam(...) } # ----------------------------------------------------------------------------- .ppr <- function(..., nterms = 2) { stats::ppr(..., nterms = nterms) } # ----------------------------------------------------------------------------- .nnet <- function(..., trace = FALSE, size = 2, linout = TRUE) { nnet::nnet(..., trace = trace, size = size, linout = linout) } # ----------------------------------------------------------------------------- .polymars <- function(...) { .polymarsFormula(...) } ############################################################################### fRegression/R/methods-formula.R0000644000176200001440000000275414273153361016207 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUNCTION: DESCRIPTION REGRESSION METHODS: # formula.fREG Returns formula from a fitted regression model ############################################################################### setMethod(f = "formula", signature(x = "fREG"), definition = function(x) { # A function implemented by Diethelm Wuertz # Description: # Extracts 'fREG' Model Formula # Arguments: # object - an object of class fREG as returned by the function # regFit # FUNCTION: # Formula: ans <- slot(x, "formula") # Return Value: ans }) ############################################################################### fRegression/R/methods-coef.R0000644000176200001440000000301614273153361015446 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUNCTION: DESCRIPTION REGRESSION METHODS: # coef.fREG Returns coefficients from a fitted regression model ############################################################################### setMethod(f = "coef", signature(object = "fREG"), definition = function(object) { # A function implemented by Diethelm Wuertz # Description: # Extracts 'fREG' Model Coefficients # Arguments: # object - an object of class fREG as returned by the function regFit # FUNCTION: # Numeric vector of fitted values: ans <- slot(object, "fit")$coef # Return Value: ans }) ############################################################################### fRegression/R/class-fREG.R0000644000176200001440000000260714273153361014764 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: DESCRIPTION: # 'fREG' fREG Class representation ############################################################################### setClass("fREG", # Class Representation representation( call = "call", formula = "formula", family = "character", method = "character", data = "list", fit = "list", residuals = "numeric", fitted = "numeric", title = "character", description = "character" ) ) ############################################################################### fRegression/R/methods-show.R0000644000176200001440000001103214273153361015507 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # S3-METHODS: PRINT METHOD: # show.fREG Prints results from a regression model fit ################################################################################ setMethod(f = "show", signature(object = "fREG"), definition = function(object) { # A function implemented by Diethelm Wuertz # Description: # Print method for Regression Modelling, an object of class "fREG" # FUNCTION: # Title: cat("\nTitle:\n ") cat(as.character(object@title), "\n") # Call: # cat("\nCall:\n") # cat(paste(deparse(object@call), sep = "\n", collapse = "\n"), # "\n", sep = "") # Formula: cat("\nFormula:\n ") # cat(as.character(object@formula), "\n") print(object@formula) # Family: if (object@family[1] != "" && object@family[2] != "") { cat("\nFamily:\n ") cat(as.character(object@family[1:2]), "\n") } # Digits: digits = max(4, getOption("digits") - 4) # Model Parameters: cat("\nModel Parameters:\n") # Regression Model LM / RLM: if (object@method == "lm" | object@method == "rlm") { print.default(format(object@fit$coef, digits = digits), print.gap = 2, quote = FALSE) } # Regression Model GLM: if (object@method == "glm") { if (length(object@fit$coef)) { # if (is.character(co = object@fit$contrasts)) co <- object@fit$contrasts if (is.character(co)) cat(" [contrasts: ", apply(cbind(names(co), co), 1, paste, collapse = "="), "]") # cat(":\n") print.default(format(object@fit$coefficients, digits = digits), print.gap = 2, quote = FALSE) } else { cat("No coefficients\n\n") } } # Regression Model GAM: if (object@method == "gam" | object@method == "am") { print.default(format(object@fit$coef, digits = digits), print.gap = 2, quote = FALSE) } # Regression Model PPR: if (object@method == "ppr") { cat("-- Projection Direction Vectors --\n") print(object@fit$alpha) cat("-- Coefficients of Ridge Terms --\n") print(object@fit$beta) } # Regression Model POLYMARS: if (object@method == "polymars") { print(object@fit$coef) } # Regression Model NNET: if (object@method == "nnet") { cat(" a ",object@fit$n[1], "-", object@fit$n[2], "-", object@fit$n[3], " network", " with ", length(object@fit$wts), " weights\n", sep="") cat(" options were -") tconn = diff(object@fit$nconn) if (tconn[length(tconn)] > object@fit$n[2]+1) cat(" skip-layer connections ") if (object@fit$nunits > object@fit$nsunits && !object@fit$softmax) cat(" linear output units ") if (object@fit$entropy) cat(" entropy fitting ") if (object@fit$softmax) cat(" softmax modelling ") if (object@fit$decay[1] > 0) cat(" decay=", object@fit$decay[1], sep="") cat("\n") Weights = object@fit$wts print(Weights) } # Residual Variance: # cat("\nResidual Variance:\n", var(object@fit$residuals)) cat("\n") # Return Value: invisible() }) ############################################################################### fRegression/R/methods-vcov.R0000644000176200001440000000301214273153361015503 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUNCTION: DESCRIPTION REGRESSION METHODS: # vcov.fREG Returns Covariance from a fitted regression model ############################################################################### setMethod(f = "vcov", signature(object = "fREG"), definition = function(object) { # A function implemented by Diethelm Wuertz # Description: # Extracts 'fREG' Model Covariance # Arguments: # object - an object of class fREG as returned by the function regFit # FUNCTION: # Numeric vector of fitted values: ans <- stats::vcov(object@fit) # Return Value: ans }) ################################################################################ fRegression/NEWS.md0000644000176200001440000000067714273550114013652 0ustar liggesusers# fRegression 4021.83 * New maintainer: Paul Northrop * Updated DESCRIPTION with links, moved timeDate, timeSeries, fBasics from Depends: to Imports: and moved MASS from Suggests to Imports. * Removed Lazydata from DESCRIPTION: there are no data. * Corrected some minor typos. # fRegression 3042.82 and older versions See file ChangeLog on [the CRAN fRegression page](https://CRAN.R-project.org/package=fRegression) for changes before 4021.83. fRegression/MD50000644000176200001440000000545514275147203013066 0ustar liggesuserscc4418312d4b2ce54cf897b82d4096f7 *ChangeLog b34214dc01d99285185d38323bc2cf08 *DESCRIPTION da6d87dfbfc9a757dbf9be8d70932cf9 *NAMESPACE 6a63aafabaf58250fed33d94bf9e7b6a *NEWS.md 7f0d16d0cd6a95d5bb7c035cbe64409a *R/class-fREG.R edc4f4f056297f1517ade97632ab55a1 *R/fittedPlot.R 98ecd4a0475893310caae84e681d73cf *R/methods-coef.R 276136dbf0043ceab0feb017bade300a *R/methods-fitted.R 9224ce2d1ec85e3652955318a42289af *R/methods-formula.R 4e36abb904b5a8365ccc799e944e0a4e *R/methods-plot.R 40e5c679b61b7834a4c79d4e9a95c0db *R/methods-predict.R 8f55a40ee059e7726fccaf84e0c350f7 *R/methods-residuals.R a1af4f78caf9c6cd5cb066bcf06c945a *R/methods-show.R 48a4add0f3762e5321e15306faab212e *R/methods-summary.R 94fd5ee3f2ea0fe0bc75845d39c2de1f *R/methods-termPlot.R c68c8046cb7d94429f074d027c926ec0 *R/methods-terms.R 0fdf7d111d6b4a769cff3dc5a37f447f *R/methods-vcov.R 9aeff6a36208a7cb2ce2c677e9485227 *R/regFit.R 07409ab1901a6ccb33292eaffdcdbc31 *R/regSim.R ff9d0b0dadeb4ce6c51b3a7c838f295a *R/wrapper-lmTest.R 2f2812f19d9138b10041e52f8132a727 *R/wrapper-polymars.R d6ecdf8b77fd765859ee52cd877cc7ec *R/zzz.R e13abde6f4a695b7c16a9d85b3ba4ad6 *README.md 7ba97abe7e0c4c5b73583d0ce48e7cbb *inst/obsolete/src/LmTests.f 3996e7c16bfb96fad295ee425815cb4d *inst/obsolete/src/Makevars b6b956f0b232f76bd8ab218e49e8a489 *inst/obsolete/src/MarsModelling.f 4e26e087259af5a81c393bb801e685be *inst/unitTests/Makefile adef1981ff382526f364675d7e8068cf *inst/unitTests/runTests.R 4b752fcbcc17ee4e790f8faed6872018 *inst/unitTests/runit.LPP2005.R 5b9714427955481bab0000fbef4d4fcf *inst/unitTests/runit.RegressionModelling.R a3958c10627a11bf2f4fb22b4001cd28 *inst/unitTests/runit.TermPlots.R 93e1032d22ba16aa4584e7a46f957a1b *inst/unitTests/runit.TimeSeries.R bed1bcaa182ba205771ae86352acc394 *inst/unitTests/runit.polymars.R b58c598e6fe33c7917a2a957ceb1186a *inst/unitTests/runit.regFit.R 2e8ba0ded0f467265478d655e455fc37 *inst/unitTests/runit.terms.R 9755eb4040d166991bdf95692c76fa5a *man/00fRegression-package.Rd 9b4fc225b8d92aeb6aaae34844cadb41 *man/RegressionTestsInterface.Rd a7856292309dba2fe30910d2195f11e6 *man/class-fREG.Rd 3532c7aca9ee6c439a7fd76a8af6056b *man/methods-coef.Rd e0837f2ad2a99b3fddc0e6d048acc7fc *man/methods-fitted.Rd a2582af5375a8e4632287548c7cdbb8c *man/methods-formula.Rd b2fe035ea3ecfb7a2e83d9e1e08ccf6b *man/methods-plot.Rd e5e730a3738a753238e603fcaa371243 *man/methods-predict.Rd 5825590f1702a4095990f13e23728c0b *man/methods-residuals.Rd c2f3386cc92fd463bc780183ad5afa6a *man/methods-show.Rd 7ba8f9cff9d0b1fdfa1505abaf54db20 *man/methods-summary.Rd b8cd43748d6c40b3931cf2012eb94ee7 *man/methods-termPlot.Rd 58f6844f42f24e9dfede1d723575ae44 *man/methods-terms.Rd 574c67ac930156b42345ca45c7e1085a *man/methods-vcov.Rd da40f7c8108a01de42dcb5791037571e *man/regFit.Rd bc9a4a4535e61789e1c6e8158e9a2531 *man/regSim.Rd dafc17353d90397a1a53a6cf3f28b934 *tests/doRUnit.R fRegression/inst/0000755000176200001440000000000014273153361013522 5ustar liggesusersfRegression/inst/obsolete/0000755000176200001440000000000014273153361015336 5ustar liggesusersfRegression/inst/obsolete/src/0000755000176200001440000000000014273153361016125 5ustar liggesusersfRegression/inst/obsolete/src/LmTests.f0000644000176200001440000001106314273153361017670 0ustar liggesusers C Regression Test: lm C Subroutine pan.f SUBROUTINE PAN(A, M, C, N, RESULT) C C TRANSLATION OF AMENDED VERSION OF APPLIED STATISTICS ALGORITHM C AS 153 (AS R52), VOL. 33, 363-366, 1984. C BY R.W. FAREBROTHER (ORIGINALLY NAMED GRADSOL OR PAN) C C GRADSOL EVALUATES THE PROBABILITY THAT A WEIGHTED SUM OF C SQUARED STANDARD NORMAL VARIATES DIVIDED BY X TIMES THE UNWEIGHTED C SUM IS LESS THAN A GIVEN CONSTANT, I.E. THAT C A1.U1**2 + A2.U2**2 + ... + AM.UM**2 < C X*(U1**2 + U2**2 + ... + UM**2) + C C WHERE THE U'S ARE STANDARD NORMAL VARIABLES. C FOR THE DURBIN-WATSON STATISTIC, X = DW, C = 0, AND C A ARE THE NON-ZERO EIGENVALUES OF THE "M*A" MATRIX. C C THE ELEMENTS A(I) MUST BE ORDERED. A(0) = X C N = THE NUMBER OF TERMS IN THE SERIES. THIS DETERMINES THE C ACCURACY AND ALSO THE SPEED. NORMALLY N SHOULD BE ABOUT 10-15. C -------------- C ORIGINALLY FROM STATLIB. REVISED 5/3/1996 BY CLINT CUMMINS: C 1. DIMENSION A STARTING FROM 0 (FORTRAN 77) C IF THE USER DOES NOT INITIALIZE A(0) = X, C THERE WOULD BE UNPREDICTABLE RESULTS, SINCE A(0) IS ACCESSED C WHEN J2=0 FOR THE FINAL DO 60 LOOP. C 2. USE X VARIABLE TO AGREE WITH PUBLISHED CODE C 3. FIX BUG 2 LINES BELOW DO 60 L2 = J2, NU, D C PROD = A(J2) --> PROD = A(L2) C (PRIOR TO THIS FIX, ONLY THE TESTS WITH M=3 WORKED CORRECTLY) C 4. TRANSLATE TO UPPERCASE AND REMOVE TABS C TESTED SUCCESSFULLY ON THE FOLLOWING BENCHMARKS: C 1. FAREBROTHER 1984 TABLE (X=0): C A C PROBABILITY C 1,3,6 1 .0542 C 1,3,6 7 .4936 C 1,3,6 20 .8760 C 1,3,5,7,9 5 .0544 C 1,3,5,7,9 20 .4853 C 1,3,5,7,9 50 .9069 C 3,4,5,6,7 5 .0405 C 3,4,5,6,7 20 .4603 C 3,4,5,6,7 50 .9200 C 2. DURBIN-WATSON 1951/71 SPIRITS DATASET, FOR X=.2,.3,...,3.8, C=0 C COMPARED WITH BETA APPROXIMATION (M=66), A SORTED IN REVERSE ORDER C 3. JUDGE, ET AL 2ND ED. P.399 DATASET, FOR X=.2,.3,...,3.8, C=0 C COMPARED WITH BETA APPROXIMATION (M=8), A SORTED IN EITHER ORDER C INTEGER M, N DOUBLE PRECISION A(0:M), C, X, RESULT C C LOCAL VARIABLES C INTEGER D, H, I, J1, J2, J3, J4, K, L1, L2, NU, N2 DOUBLE PRECISION NUM, PIN, PROD, SGN, SUM, SUM1, U, V, Y DOUBLE PRECISION ZERO, ONE, HALF, TWO DATA ZERO/0.D0/, ONE/1.D0/, HALF/0.5D0/, TWO/2.D0/ C C SET NU = INDEX OF 1ST A(I) >= X. C ALLOW FOR THE A'S BEING IN REVERSE ORDER. C IF (A(1) .GT. A(M)) THEN H = M K = -1 I = 1 ELSE H = 1 K = 1 I = M ENDIF X = A(0) DO 10 NU = H, I, K IF (A(NU) .GE. X) GO TO 20 10 CONTINUE C C IF ALL A'S ARE -VE AND C >= 0, THEN PROBABILITY = 1. C IF (C .GE. ZERO) THEN RESULT = ONE RETURN ENDIF C C SIMILARLY IF ALL THE A'S ARE +VE AND C <= 0, THEN PROBABILITY = 0. C 20 IF (NU .EQ. H .AND. C .LE. ZERO) THEN RESULT = ZERO RETURN ENDIF C IF (K .EQ. 1) NU = NU - 1 H = M - NU IF (C .EQ. ZERO) THEN Y = H - NU ELSE Y = C * (A(1) - A(M)) ENDIF C IF (Y .GE. ZERO) THEN D = 2 H = NU K = -K J1 = 0 J2 = 2 J3 = 3 J4 = 1 ELSE D = -2 NU = NU + 1 J1 = M - 2 J2 = M - 1 J3 = M + 1 J4 = M ENDIF PIN = TWO * DATAN(ONE) / N SUM = HALF * (K + 1) SGN = K / DBLE(N) N2 = N + N - 1 C C FIRST INTEGRALS C DO 70 L1 = H-2*(H/2), 0, -1 DO 60 L2 = J2, NU, D SUM1 = A(J4) C FIX BY CLINT CUMMINS 5/3/96 C PROD = A(J2) PROD = A(L2) U = HALF * (SUM1 + PROD) V = HALF * (SUM1 - PROD) SUM1 = ZERO DO 50 I = 1, N2, 2 Y = U - V * DCOS(DBLE(I)*PIN) NUM = Y - X PROD = DEXP(-C/NUM) DO 30 K = 1, J1 PROD = PROD * NUM / (Y - A(K)) 30 CONTINUE DO 40 K = J3, M PROD = PROD * NUM / (Y - A(K)) 40 CONTINUE SUM1 = SUM1 + DSQRT(DABS(PROD)) 50 CONTINUE SGN = -SGN SUM = SUM + SGN * SUM1 J1 = J1 + D J3 = J3 + D J4 = J4 + D 60 CONTINUE C C SECOND INTEGRAL. C IF (D .EQ. 2) THEN J3 = J3 - 1 ELSE J1 = J1 + 1 ENDIF J2 = 0 NU = 0 70 CONTINUE C RESULT = SUM RETURN END fRegression/inst/obsolete/src/Makevars0000644000176200001440000000005614273153361017622 0ustar liggesusersPKG_LIBS=$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) fRegression/inst/obsolete/src/MarsModelling.f0000644000176200001440000005151614273153361021041 0ustar liggesusers C ############################################################################## C MARS-dcalcvar subroutine calcvar(nx,n,px,qr,qrank,qpivot,cov,tmpcov,work) implicit double precision (a-h,o-z) integer n,px,qrank,qpivot(px) double precision qr(nx,px),cov(px,px), tmpcov(px,px),work(1) double precision dsum integer i,j,km do 23000 i=1,qrank do 23002 j=1,qrank tmpcov(i,j)=0d0 cov(i,j)=qr(i,j) 23002 continue tmpcov(i,i)=1e0 23000 continue info=0 c R version has different args c call dbksl(cov,px,qrank,tmpcov,px,info) do 20 j = 1, qrank 20 call dtrsl(cov, px, qrank, tmpcov(1,j), 01, info) do 23004 i=1,qrank do 23006 j=i,qrank dsum=0e0 km=max(i,j) k=km 23008 if(.not.(k.le.qrank))goto 23010 dsum=dsum+tmpcov(i,k)*tmpcov(j,k) k=k+1 goto 23008 23010 continue tmpcov(i,j)=dsum tmpcov(j,i)=dsum 23006 continue 23004 continue do 23011 i=1,qrank do 23013 j=1,qrank cov(i,j)=tmpcov(i,j) 23013 continue 23011 continue return end C ############################################################################## C MARS-dmarss subroutine marss(nx,n,p,nclass,y,x,w,tagx,maxorder,mmax,penalty, & thresh,forwstep,interms,prune,bx,fullin,lenb, bestgcv, bestin, & flag,cut,dir,res,alpha,beta,scrat,iscrat,trace) implicit double precision (a-h,o-z) integer nx, n,p,nclass,tagx(nx,p),maxorder,mmax,bestin(mmax), & flag(mmax,p),fullin(mmax) double precision y(n,nclass),x(nx,p),w(n),bx(nx,mmax),bestgcv, & cut(mmax,p),dir(mmax,p),res(nx,nclass),alpha(nclass), & beta(mmax,nclass) double precision scrat(*) integer iscrat(*) logical forwstep, prune, trace, tracec common tracec tracec=trace len1=n*mmax len2=mmax len3=mmax*mmax len4=mmax*nclass len5=nclass len6=mmax len7=mmax len8=nclass len9=n len10=n*mmax len11=mmax*mmax len12=mmax*nclass len13=mmax*mmax len14=mmax*mmax n1=1 n2=n1+len1 n3=n2+len2 n4=n3+len3 n5=n4+len4 n6=n5+len5 n7=n6+len6 n8=n7+len7 n9=n8+len8 n10=n9+len9 n11=n10+len10 n12=n11+len11 n13=n12+len12 n14=n13+len13 n15=n14+len14 call marsnew1(nx, n, p, nclass, y, x, w, tagx, maxorder, mmax, & bx, bestgcv, bestin, fullin, lenb, flag, cut, dir, res, & alpha, beta, penalty, thresh, forwstep, interms, prune, & scrat, scrat(n2), scrat(n3), scrat(n4), scrat(n5), scrat(n6), & scrat(n7), scrat(n8), scrat(n9), scrat(n10), scrat(n11), & scrat(n12), scrat(n13), scrat(n14), scrat(n15), iscrat, & iscrat(1+mmax), iscrat(1+2*mmax), iscrat(1+3*mmax)) return end subroutine marsnew1(nx, n, p, nclass, y, x, w, tagx, maxorder, & mmax, bx, bestgcv, bestin, fullin, lenb, flag, cut, dir, & res, alpha, beta, penalty, thresh, forwstep, interms, & prune, bxorth, bxorthm, cov, covsy, ybar, scr1, scr5, scr6, & temp, bxsc, r, betasc, varsc, var, work, termlen, in, & tempin, qpivot) implicit double precision (a-h,o-z) integer n,nterms2,p,mmax,flag(mmax,p),tagx(nx,p),termlen(mmax), & nclass,fullin(mmax) double precision cov(mmax,mmax),covsy(mmax,nclass),critmax, & x(nx,p),bx(nx,mmax),bxorth(n,mmax),bxorthm(mmax), & y(n,nclass),ybar(nclass),scr1(mmax),scr5(mmax),scr6(nclass) double precision temp(n),w(n), cut(mmax,p),dir(mmax,p), & alpha(nclass),beta(mmax,nclass), bxsc(n,mmax), r(mmax,mmax), & dofit, res(nx,nclass),betasc(mmax,nclass), varsc(mmax,mmax), & var(mmax,mmax), stopfac, work(*) integer tempin(mmax), bestin(mmax),qrank, qpivot(mmax) logical forwstep,go, prune, newform, cvar, trace common trace double precision rtemp(4) integer itemp(4) tolbx=.01 stopfac=10.0 prevcrit=10e9 if(.not.(interms.eq.1))goto 23000 dofit=0 goto 23001 23000 continue dofit=0 do 23002 j=2,lenb dofit=dofit+fullin(j) 23002 continue nterms=interms 23001 continue if(.not.(forwstep))goto 23004 fullin(1)=1 do 23006 i=2,mmax fullin(i)=0 23006 continue do 23008 i=1,n w(i)=1 23008 continue do 23010 i=1, mmax termlen(i)=0 do 23012 j=1, p flag(i,j)=0 cut(i,j)=0 23012 continue 23010 continue nterms=1 nterms2=2 do 23014 i=1,n bx(i,1)=1 bxorth(i,1)=1.0/dsqrt(dfloat(n)) 23014 continue bxorthm(1)=1/dsqrt(dfloat(n)) do 23016 i=1,n do 23018 j=1, mmax bx(i,j)=0.0 23018 continue 23016 continue do 23020 i=1,n bx(i,1)=1 23020 continue do 23022 k=1, nclass ybar(k)=0.0 do 23024 i=1,n ybar(k)=ybar(k)+y(i,k)/n 23024 continue 23022 continue if(.not.(interms.eq.1))goto 23026 rssnull=0.0 do 23028 k=1, nclass do 23030 i=1,n rssnull=rssnull+(y(i,k)-ybar(k))**2 23030 continue 23028 continue goto 23027 23026 continue rssnull=0.0 do 23032 k=1, nclass do 23034 i=1,n rssnull=rssnull+res(i,k)**2 23034 continue 23032 continue 23027 continue rss=rssnull cmm= (1+dofit) + penalty*(.5*dofit) gcvnull=(rssnull/n)/(1.0-cmm/n)**2 if(.not.(trace))goto 23036 call dblepr("initial rss=",11,rssnull,1) 23036 continue if(.not.(trace))goto 23038 call dblepr("initial gcv=",11,gcvnull,1) 23038 continue lenb=1 ii=interms-1 go=.true. 23040 if(.not.( (ii.lt.(mmax-1)).and.((rss/rssnull).gt.thresh).and.go)) & goto 23041 ii=ii+2 do 23042 i1=1, nterms do 23044 i2=1, nterms cov(i1,i2)=0 23044 continue 23042 continue do 23046 j=1, nterms cov(j,j)=0.0 do 23048 i=1,n cov(j,j) = cov(j,j) + % (bxorth(i,j)-bxorthm(j)) * (bxorth(i,j)-bxorthm(j)) 23048 continue 23046 continue do 23050 k=1,nclass do 23052 j=1, nterms covsy(j,k)=0.0 do 23054 i=1,n covsy(j,k)=covsy(j,k)+(y(i,k)-ybar(k))*bxorth(i,j) 23054 continue 23052 continue 23050 continue do 23056 ik=1,mmax tempin(ik)=fullin(ik) 23056 continue call addtrm(nx,bx,tempin,bxorth,bxorthm,p,n,nclass,rss,prevcrit, & cov,covsy,y,ybar,x,tagx,w,termlen,mmax,tolbx, nterms,flag, & maxorder,scr1,scr5,scr6,imax,jmax,kmax,critmax, newform, & bxsc, r, betasc, temp) doftemp=dofit doftemp=doftemp+1 if(.not.((imax.gt.1).and.(newform)))goto 23058 doftemp=doftemp+1 23058 continue temprss=rss-critmax cmm= (1+doftemp) + penalty*(.5*doftemp) gcv=(temprss/n)/(1.0-cmm/n)**2 go=.false. if (.not.(((critmax/rss).gt.thresh).and. & ((gcv/gcvnull).lt.stopfac))) goto 23060 go=.true. dofit=doftemp rss=rss-critmax kk=tagx(imax,jmax) 256 format(" ","adding term"," jmax=",i3, " imax=",i3 ," kmax=",i3, & " critmax= ",f8.2," cutp=", f9.5," rss=",f8.2, " gcv=",f8.2, & " dofit=",f9.3) itemp(1)=jmax itemp(2)=imax itemp(3)=kmax rtemp(1)=critmax rtemp(2)=x(kk,jmax) rtemp(3)=rss rtemp(4)=gcv if(.not.(trace))goto 23062 call intpr("adding term ",12,ii,1) 23062 continue if(.not.(trace))goto 23064 call intpr("var, sp index, parent",21,itemp,3) 23064 continue if(.not.(trace))goto 23066 call dblepr("critmax cut rss gcv",19,rtemp,4) 23066 continue prevcrit=critmax do 23068 j=1,p flag(ii,j)=flag(kmax,j) flag(ii+1,j)=flag(kmax,j) cut(ii,j)=cut(kmax,j) cut(ii+1,j)=cut(kmax,j) dir(ii,j)=dir(kmax,j) dir(ii+1,j)=dir(kmax,j) 23068 continue termlen(ii)=termlen(kmax)+1 termlen(ii+1)=termlen(kmax)+1 do 23070 i=1,n temp(i)=x(tagx(i,jmax),jmax) 23070 continue temp1=temp(imax) fullin(ii)=1 if(.not.((imax.gt.1).and.(newform)))goto 23072 fullin(ii+1)=1 23072 continue flag(ii,jmax)=1 flag(ii+1,jmax)=1 cut(ii,jmax)=temp1 cut(ii+1,jmax)=temp1 dir(ii,jmax)=1 dir(ii+1,jmax)=-1 if(.not.(fullin(ii+1).eq.0))goto 23074 termlen(ii+1)=maxorder+1 23074 continue do 23076 i=1,n if(.not.( (x(i,jmax)-temp1).gt.0))goto 23078 bx(i,ii)=bx(i,kmax)*(x(i,jmax)-temp1) 23078 continue if(.not.((temp1-x(i,jmax)).ge.0))goto 23080 bx(i,ii+1)=bx(i,kmax)*(temp1-x(i,jmax)) 23080 continue 23076 continue if(.not.(nterms.eq.1))goto 23082 temp1=0.0 do 23084 i=1,n temp1=temp1+bx(i,2)/n 23084 continue do 23086 i=1,n bxorth(i,2)=bx(i,2)-temp1 23086 continue goto 23083 23082 continue call orthreg(n,n,nterms,bxorth,fullin, bx(1,ii),bxorth(1,nterms2)) 23083 continue if(.not.(fullin(ii+1).eq.1))goto 23088 call orthreg(n,n,nterms+1,bxorth,fullin, bx(1,ii+1), & bxorth(1,nterms2+1)) goto 23089 23088 continue do 23090 i=1,n bxorth(i,nterms2+1)=0 23090 continue 23089 continue bxorthm(nterms2)=0.0 bxorthm(nterms2+1)=0.0 do 23092 i=1,n bxorthm(nterms2)=bxorthm(nterms2)+bxorth(i,nterms2)/n bxorthm(nterms2+1)=bxorthm(nterms2+1)+bxorth(i,nterms2+1)/n 23092 continue temp1=0.0 temp2=0.0 do 23094 i=1,n temp1=temp1+bxorth(i,nterms2)**2 temp2=temp2+bxorth(i,nterms2+1)**2 23094 continue if(.not.(temp1.gt.0.0))goto 23096 do 23098 i=1,n bxorth(i,nterms2) =bxorth(i,nterms2)/dsqrt(temp1) 23098 continue 23096 continue if(.not.(temp2.gt.0.0))goto 23100 do 23102 i=1,n bxorth(i,nterms2+1)=bxorth(i,nterms2+1)/dsqrt(temp2) 23102 continue 23100 continue lenb=lenb+2 nterms=nterms+2 nterms2=nterms2+2 23060 continue goto 23040 23041 continue rtemp(1)=rss/rssnull rtemp(2)=critmax/rss rtemp(3)=gcv/gcvnull if(.not.(trace))goto 23104 call dblepr("stopping forw step; rss crit and gcv ratios",43, & rtemp,3) 23104 continue if(.not.(trace))goto 23106 if(.not.((rss/rssnull).le.thresh))goto 23108 call dblepr("rss ratio=",10,rss/rssnull,1) 23108 continue if(.not.((critmax/rss).le.thresh))goto 23110 call dblepr ("crit ratio=",11,critmax/rss,1) 23110 continue call dblepr("critmax",7,critmax,1) call dblepr("rss",3,rss,1) if(.not.((gcv/gcvnull).gt.stopfac))goto 23112 call dblepr("gcv ratio=",10,gcv/gcvnull,1) 23112 continue 23106 continue 23004 continue dofit= -1 do 23114 i=1,nterms bestin(i)=fullin(i) dofit=dofit+fullin(i) 23114 continue if(.not.(trace))goto 23116 call intpr("aft forw step",13,nterms,1) 23116 continue call qrreg(nx,n,mmax,lenb,nclass,bx,bxsc,bestin,y,qpivot,qrank, & beta,res,rss,cvar,var,varsc,scr1, work) nt=dofit+1 if(.not.(qrank.lt. nt))goto 23118 do 23120 i=qrank+1,nt bestin(qpivot(i))=0 fullin(qpivot(i))=0 dofit=dofit-1 23120 continue 23118 continue cvar=.true. rssfull=rss cmm= (1+dofit) + penalty*(.5*dofit) bestgcv=(rss/n)/(1.0-cmm/n)**2 rtemp(1)=bestgcv rtemp(2)=rssfull rtemp(3)=dofit if(.not.(trace))goto 23122 call dblepr("full model: gcv rss dofit",25,rtemp,3) 23122 continue if(.not.(trace))goto 23124 call intpr("terms",5,fullin,lenb) 23124 continue if(.not.(prune))goto 23126 c Need var calculated to do drop-one calculations from t values. cvar=.true. call qrreg(nx,n,mmax,lenb,nclass,bx,bxsc,tempin,y,qpivot,qrank, & beta,res,rss,cvar,var,varsc,scr1,work) do 23128 i=1,mmax tempin(i)=bestin(i) 23128 continue 23130 if(.not.(dofit.gt.0 ))goto 23131 jo=1 rsstemp=10d99 minterm=0 do 23132 ii=2, lenb if(.not.(tempin(ii).eq.1))goto 23134 jo=jo+1 temp7=0.0 do 23136 kc=1,nclass temp7=temp7+beta(jo,kc)**2/var(jo,jo) 23136 continue if(.not.(temp7 .lt. rsstemp))goto 23138 minterm=ii rsstemp=temp7 23138 continue 23134 continue 23132 continue rss=rss+rsstemp dofit=dofit-1 cmm= (1.0+dofit) + penalty*(.5*dofit) gcv=(rss/n)/(1.0-cmm/n)**2 tempin(minterm)=0 100 format(" ","pruning, minterm= ",i4, " gcv=",f9.3,2x, " rss=",f9.3, & 2x," dof=",f9.3," model= ",60(i1,1x)) if(.not.(gcv.lt. bestgcv))goto 23140 bestgcv=gcv do 23142 i=1,mmax bestin(i)=tempin(i) 23142 continue 23140 continue if(.not.(dofit .gt. 0))goto 23144 cvar=.true. call qrreg(nx,n,mmax,lenb,nclass,bx,bxsc,tempin,y,qpivot,qrank, & beta,res,rss,cvar,var,varsc,scr1,work) 23144 continue goto 23130 23131 continue call qrreg(nx,n,mmax,lenb,nclass,bx,bxsc,bestin,y,qpivot,qrank, & beta,res,rss,cvar,var,varsc,scr1, work) 101 format(" ","best model gcv=",f9.3," rss=",f9.3,2x,"model= ", & 60(i1,1x)) if(.not.(trace))goto 23146 call intpr("best model",10,bestin,lenb) 23146 continue if(.not.(trace))goto 23148 call dblepr(" gcv=",4,bestgcv,1) 23148 continue 23126 continue return end subroutine addtrm(nx,bx,tempin,bxorth,bxorthm,p,n,nclass,rss, & prevcrit,cov,covsy,y,ybar,x,tagx,w,termlen,mmax,tolbx, & nterms,flag, maxorder,scr1,scr5,scr6,imax,jmax,kmax, & critmax, newform,bxsc,r, betasc, scrat) implicit double precision (a-h,o-z) integer n,nterms,nterms2,p,mmax,flag(mmax,p),v,tagx(nx,p), & termlen(mmax), nclass, tempin(mmax), minspan, iendspan double precision cov(mmax,mmax),covsy(mmax,nclass),critmax, & x(nx,p),bx(nx,mmax),bxorth(n,mmax),bxorthm(mmax), & y(n,nclass),ybar(nclass),scr1(mmax),scr5(mmax),scr6(nclass), & bxsc(n,mmax), r(mmax,mmax),betasc(mmax,nclass), scrat(n), & w(n) double precision temp1, temp2, scr2,sumb, sumbx, su, st, tem logical newform, tnewform, trace common trace critmax=0 jmax=0 imax=0 kmax=0 do 23150 m=1,nterms nm=0 do 23152 jjj=1,n if(.not.(bx(jjj,m).gt.0))goto 23154 nm=nm+1 23154 continue 23152 continue tem=-(1d0/(n*nm))*dlog(1d0 - 5d-2) minspan= -1d0*(dlog(tem)/dlog(2d0))/2.5 tem=(5d-2)/n iendspan=3d0-dlog(tem)/dlog(2d0) if(.not.(termlen(m).lt. maxorder))goto 23156 do 23158 v=1,p if(.not.(flag(m,v).eq.0))goto 23160 tnewform=.true. mm=1 23162 if(.not.((mm.le.nterms).and.tnewform))goto 23163 mm=mm+1 if(.not.(tempin(mm).eq.1))goto 23164 tnewform=.false. if(.not.(flag(mm,v).ne.1))goto 23166 tnewform=.true. go to 9911 23166 continue do 23168 j=1,p if(.not.(j.ne.v))goto 23170 if(.not.(flag(mm,j).ne.flag(m,j)))goto 23172 tnewform=.true. go to 9911 23172 continue 23170 continue 23168 continue 23164 continue 9911 continue goto 23162 23163 continue if(.not.(tnewform))goto 23174 nterms2=nterms+1 do 23176 i=1,n scrat(i)=x(i,v)*bx(i,m) 23176 continue if(.not.(nterms.gt.1))goto 23178 call orthreg(n,n,nterms,bxorth,tempin, scrat,bxorth(1,nterms2)) goto 23179 23178 continue tem=0 do 23180 i=1,n tem=tem+scrat(i)/n 23180 continue do 23182 i=1,n bxorth(i,2)=scrat(i)-tem 23182 continue 23179 continue bxorthm(nterms2)=0.0 do 23184 i=1,n bxorthm(nterms2)=bxorthm(nterms2)+bxorth(i,nterms2)/n 23184 continue temp1=0.0 do 23186 i=1,n temp1=temp1+bxorth(i,nterms2)**2 23186 continue if(.not.(temp1.gt.tolbx))goto 23188 do 23190 i=1,n bxorth(i,nterms2)=bxorth(i,nterms2)/dsqrt(temp1) 23190 continue goto 23189 23188 continue do 23192 i=1,n bxorth(i,nterms2)=0 23192 continue tnewform=.false. 23189 continue do 23194 i1=1, nterms2 cov(i1,nterms2)=0.0 cov(nterms2, i1)=0.0 23194 continue cov(nterms2,nterms2)=1 do 23196 kc=1,nclass covsy(nterms2,kc)=0.0 do 23198 i=1,n covsy(nterms2,kc) = covsy(nterms2,kc)+(y(i,kc)-ybar(kc)) * & bxorth(i,nterms2) 23198 continue 23196 continue critnew=0.0 do 23200 kc=1,nclass temp1=0 do 23202 i=1,n temp1=temp1+y(i,kc)*bxorth(i,nterms2) 23202 continue critnew=critnew+temp1**2 23200 continue if(.not.(critnew.gt.critmax))goto 23204 jmax=v critmax=critnew imax=1 kmax=m 23204 continue 23174 continue if(.not.(tnewform))goto 23206 nterms2=nterms+1 nterms21=nterms+2 goto 23207 23206 continue nterms2=nterms nterms21=nterms+1 critnew=0.0 23207 continue do 23208 kc=1, nclass covsy(nterms21,kc)=0 23208 continue do 23210 ii=1,nterms21 cov(ii,nterms21)=0 cov(nterms21,ii)=0 23210 continue do 23212 kc=1,nclass scr6(kc)=0 23212 continue do 23214 ii=1,nterms21 scr1(ii)=0 23214 continue scr2=0 su=0 st=0 sumbx2=0 sumb=0.0 sumbx=0.0 k=n-1 23216 if(.not.(k.gt.0))goto 23218 do 23219 i=1,nterms2 kk=tagx(k,v) kk1=tagx(k+1,v) scr1(i)=scr1(i)+(bxorth(kk1,i)-bxorthm(i))*bx(kk1,m) cov(i,nterms21)=cov(i,nterms21)+ (x(kk1,v)-x(kk,v))*scr1(i) cov(nterms21,i)=cov(i,nterms21) 23219 continue scr2=scr2+(bx(kk1,m)**2)*x(kk1,v) sumbx2=sumbx2+bx(kk1,m)**2 sumb=sumb+bx(kk1,m) sumbx=sumbx+bx(kk1,m)*x(kk1,v) su=st st=sumbx-sumb*x(kk,v) cov(nterms21,nterms21)= cov(nterms21,nterms21)+ (x(kk1,v)-x(kk,v)) & *(2*scr2-sumbx2*(x(kk,v)+x(kk1,v)))+ ( (su*su)-(st*st) )/n crittemp=critnew do 23221 kc=1, nclass scr6(kc)=scr6(kc)+(y(kk1,kc)-ybar(kc))*bx(kk1,m) covsy(nterms21,kc)=covsy(nterms21,kc )+(x(kk1,v)-x(kk,v))*scr6(kc) temp1=covsy(nterms21,kc) temp2=cov(nterms21,nterms21) do 23223 jk=1,nterms2 temp1=temp1-covsy(jk,kc)*cov(jk,nterms21) temp2=temp2-cov(jk,nterms21)*cov(jk,nterms21) 23223 continue if(.not.(cov(nterms21,nterms21).gt.0))goto 23225 if(.not.((temp2/cov(nterms21,nterms21)) .gt. tolbx))goto 23227 critadd=(temp1*temp1)/temp2 goto 23228 23227 continue critadd=0.0 23228 continue goto 23226 23225 continue critadd=0 23226 continue crittemp=crittemp+critadd if(.not.(crittemp.gt.(1.01*rss)))goto 23229 crittemp=0.0 23229 continue if(.not.(crittemp.gt.(2*prevcrit)))goto 23231 crittemp=0.0 23231 continue 23221 continue if(.not.(k.gt.1))goto 23233 k0=tagx(k-1,v) 23233 continue if(.not.((crittemp.gt.critmax) .and. & (mod(k,minspan).eq.0) .and. & (k.ge.iendspan) .and. & (k.le.(n-iendspan)) .and. & (bx(kk1,m).gt.0) .and. & (.not.( (k.gt.1) .and. (x(kk,v).eq.x(k0,v))) ))) goto 23235 jmax=v critmax=crittemp imax=k kmax=m newform=tnewform 23235 continue k=k-1 goto 23216 23218 continue 23160 continue 9999 continue 23158 continue 23156 continue 23150 continue return end C ############################################################################## C MARS-dorthreg subroutine orthreg(nx,n,p,x,in, y,res) implicit double precision (a-h,o-z) integer n,nx,p, in(p) double precision x(nx,p),y(n),res(n) do 23000 i=1,n res(i)=y(i) 23000 continue do 23002 j=1,p if(.not.(in(j).eq.1))goto 23004 temp1=0 temp2=0 do 23006 i=1,n temp1=temp1+res(i)*x(i,j) temp2=temp2+x(i,j)*x(i,j) 23006 continue beta=temp1/temp2 do 23008 i=1,n res(i)=res(i)-beta*x(i,j) 23008 continue 23004 continue 23002 continue return end C ############################################################################## C MARS-dqrreg subroutine qrreg(nx,n,px,p,nclass,x,xsc,in,y,qpivot,qrank,beta, & res,rss,cvar,var,varsc,scr1,work) implicit double precision (a-h,o-z) integer nx,n,p,px, qpivot(p),qrank,nclass,in(p) double precision x(nx,p), xsc(n,p), y(n,nclass),res(nx,nclass), & beta(px,nclass),work(*),scr1(p),var(px,p),varsc(px,p) logical cvar ii=0 do 23000 j=1,p if(.not.(in(j).eq.1))goto 23002 ii=ii+1 do 23004 i=1,n xsc(i,ii)=x(i,j) 23004 continue 23002 continue 23000 continue nt=ii ijob=101 info=1 temp3=1d-2 do 23006 i=1,p qpivot(i)=i 23006 continue call dqrdc2(xsc,n,n,nt,temp3,qrank,scr1,qpivot,work) rss=0.0 do 23008 k=1,nclass call dqrsl(xsc,n,n,qrank,scr1,y(1,k),work(1),work(1),beta(1,k), & work(1),res(1,k),ijob,info) do 23010 i=1,n res(i,k)=y(i,k)-res(i,k) rss=rss+res(i,k)*res(i,k) 23010 continue 23008 continue if(.not.(cvar))goto 23012 call calcvar(nx,n,px,xsc,qrank,qpivot,var,varsc,work) 23012 continue return end fRegression/inst/unitTests/0000755000176200001440000000000014273153361015524 5ustar liggesusersfRegression/inst/unitTests/runit.RegressionModelling.R0000644000176200001440000002571514273153361022774 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: REGRESSION MODELLING DESCRIPTION: # regSim Returns a regression example data set # regFit.dataframe # regFit.valueSlots # predict.fREG Predicts values from a fitted regression model # regFit.nonDefaults # generalizedModels ################################################################################ test.regSim <- function() { # Plot Parameters: par(ask = FALSE) par(mfrow = c(3, 1)) # Simulate Artificial LM: X = regSim(model = "LM3", n = 365) head(X) plot(X[, "Y"], type = "l", main = "LM3", xlab = "1970", ylab = "Y") # Simulate Artificial LOGIT: X = regSim(model = "LOGIT3", n = 365) head(X) plot(X[, "Y"], type = "l", main = "LOGIT3", xlab = "1970", ylab = "Y") # Simulate Artificial GAM: X = regSim(model = "GAM3", n = 365) head(X) plot(X[, "Y"], type = "l", main = "GAM3", xlab = "1970", ylab = "Y") # Return Value: return() } # ------------------------------------------------------------------------------ test.regFit.dataframe <- function() { # Working with timeSeries Objects ... DATA = regSim(model = "GAM3", n = 100) head(DATA) class(DATA) # Regression Fit: LM = regFit(Y ~ X1 + X2, data = DATA, use = "lm") RLM = regFit(Y ~ X1 + X2, data = DATA, use = "rlm") AM = regFit(Y ~ X1 + X2, data = DATA, use = "gam") PPR = regFit(Y ~ X1 + X2, data = DATA, use = "ppr") POLYMARS = regFit(Y ~ X1 + X2, data = DATA, use = "polymars") ## NNET = regFit(Y ~ X1 + X2, data = DATA, use = "nnet") # ... a note on AM the smoothing functions are added by default! # this is different to gam() # Print Method: print(LM) print(RLM) print(AM) print(PPR) print(POLYMARS) ## print(NNET) # Plot Method: par(ask = FALSE) par(mfrow = c(1, 1)) # plot(LM, which = "all") # CHECK which !!! # plot(RLM, which = "all") # plot(AM, which = "all") # plot(PPR, which = "all") # plot(POLYMARS, which = "all") # plot(NNET, which = "all") # Summary Method: summary(LM) summary(RLM) summary(AM) summary(PPR) summary(POLYMARS) ## summary(NNET) # Return Value: return() } # ------------------------------------------------------------------------------ test.regFit.valueSlots <- function() { # Working with timeSeries Objects ... DATA = regSim(model = "GAM3", n = 100) head(DATA) class(DATA) require(mgcv) # Modelling: LM = regFit(Y ~ X1 + X2, data = DATA, use = "lm") RLM = regFit(Y ~ X1 + X2, data = DATA, use = "rlm") AM = regFit(Y ~ s(X1) + s(X2), DATA, use = "gam") PPR = regFit(Y ~ X1 + X2, data = DATA, use = "ppr") POLYMARS = regFit(Y ~ X1 + X2, data = DATA, use = "polymars") NNET = regFit(Y ~ X1 + X2, data = DATA, use = "nnet") # Extract: # call = "call" # formula = "formula" # family = "character" # method = "character" # data = "data.frame" # fit = "list" # residuals = "timeSeries" # fitted.values = "timeSeries" # title = "character" # description = "character" LM@call RLM@call AM@call PPR@call POLYMARS@call NNET@call LM@formula RLM@formula AM@formula # CHECK !!! PPR@formula POLYMARS@formula NNET@formula LM@family[1:2] RLM@family[1:2] AM@family[1:2] PPR@family[1:2] POLYMARS@family[1:2] NNET@family[1:2] LM@method RLM@method AM@method PPR@method POLYMARS@method NNET@method # Note the residuals are time tmeSeries objects! print(LM@residuals[c(1,100)]) print(RLM@residuals[c(1,100)]) print(AM@residuals[c(1,100)]) print(PPR@residuals[c(1,100)]) print(POLYMARS@residuals[c(1,100)]) print(NNET@residuals[c(1,100)]) # Note the fitted values are time tmeSeries objects! print(LM@fitted[c(1,100)]) print(RLM@fitted[c(1,100)]) print(AM@fitted[c(1,100)]) print(PPR@fitted[c(1,100)]) print(POLYMARS@fitted[c(1,100)]) print(NNET@fitted[c(1,100)]) # Returns a Title, by default the name of the algorithm applied: LM@title RLM@title AM@title PPR@title POLYMARS@title NNET@title # Returns a Description, by default Date/Time and user: LM@description RLM@description AM@description PPR@description POLYMARS@description NNET@description # Return Value: return() } # ------------------------------------------------------------------------------ test.predict.fREG <- function() { # Working with timeSeries Objects ... DATA <- regSim(model = "GAM3", n = 100) head(DATA) class(DATA) require(mgcv) # Regression Fit: LM = regFit(Y ~ X1 + X2, data = DATA, use = "lm") RLM = regFit(Y ~ X1 + X2, data = DATA, use = "rlm") AM = regFit(Y ~ s(X1) + s(X2), DATA, use = "gam") PPR = regFit(Y ~ X1 + X2, data = DATA, use = "ppr") POLYMARS = regFit(Y ~ X1 + X2, data = DATA, use = "polymars") NNET = regFit(Y ~ X1 + X2, data = DATA, use = "nnet") # Just to rmember - Predict: # predict.fREG(object, newdata, se.fit = FALSE, type = "response", ...) # Selext some rows to predict: set.seed(4711) N <- round(runif(5, 1, 100), 0) # Predict Response: predict(LM, DATA[N, ]) predict(RLM, DATA[N, ]) predict(AM, DATA[N, ]) predict(PPR, DATA[N, ]) predict(POLYMARS, DATA[N, ]) ## predict(NNET, DATA[N, ]) # Predict Response: predict(LM, DATA[N, ], type = "response") predict(RLM, DATA[N, ], type = "response") predict(AM, DATA[N, ], type = "response") predict(PPR, DATA[N, ], type = "response") predict(POLYMARS, DATA[N, ], type = "response") ## predict(NNET, DATA[N, ], type = "response") # Predict Response with Standard Errors: predict(LM, DATA[N, ], se.fit = TRUE) predict(RLM, DATA[N, ], se.fit = TRUE) predict(AM, DATA[N, ], se.fit = TRUE) predict(PPR, DATA[N, ], se.fit = TRUE) predict(POLYMARS, DATA[N, ], se.fit = TRUE) ## predict(NNET, DATA[N, ], se.fit = TRUE) # Return Value: return() } # ------------------------------------------------------------------------------ test.regFit.nonDefaults <- function() { # Simulate Data - a data frame: DATA = regSim(model = "GAM3", n = 100) head(DATA) class(DATA) # Simulate Data - a timeSeries object: DATA = as.timeSeries(DATA) head(DATA) class(DATA) # LM: LM1 = regFit(Y ~ X1 + X2, DATA, use = "lm") print(LM1) LM2 = regFit(Y ~ 1 + X1 + X2, DATA) print(LM2) LM3 = regFit(Y ~ -1 + X1 + X2, DATA) print(LM3) LM4 = regFit(Y ~ X1 + log(X2), DATA) print(LM4) require(mgcv) # AM: AM1 = regFit(Y ~ s(X1) + s(X2), data = DATA, use = "gam") print(AM1) # AM2 = regFit(Y ~ s(X1) + s(X2), DATA, "gam", # method = gam.method(pearson = TRUE)) # print(AM2) # PPR: par(ask = FALSE) par(mfrow = c(1, 1)) PPR1 = regFit(Y ~ sin(X1) + exp(X2), DATA, "ppr", nterms = 4, sm.method = "supsmu", use = "ppr") PPR2 = regFit(Y ~ sin(X1) + exp(X2), DATA, "ppr", nterms = 4, sm.method = "spline", use = "ppr") PPR3 = regFit(Y ~ sin(X1) + exp(X2), DATA, "ppr", nterms = 3, sm.method = "gcvspline", use = "ppr") ## termPlot(PPR1) ## termPlot(PPR2) ## termPlot(PPR3) # POLYMARS: POLYMARS <- regFit(Y ~ X1 + X2 + X3, DATA, use = "polymars") POLYMARS <- regFit(Y ~ X1*X2 + X2*X3 + X3*X1, DATA, use = "polymars") # NNET # todo ... # Return Value: return() } # ------------------------------------------------------------------------------ test.generalizedModels <- function() { # Generalized * Models: M1 <- matrix(c( 1, 0.80, 0.83, 0.66, 1.9, 1.100, 0.996, 1, 0.90, 0.36, 0.32, 1.4, 0.740, 0.992, 0, 0.80, 0.88, 0.70, 0.8, 0.176, 0.982, 0, 1.00, 0.87, 0.87, 0.7, 1.053, 0.986, 1, 0.90, 0.75, 0.68, 1.3, 0.519, 0.980, 0, 1.00, 0.65, 0.65, 0.6, 0.519, 0.982, 1, 0.95, 0.97, 0.92, 1.0, 1.230, 0.992, 0, 0.95, 0.87, 0.83, 1.9, 1.354, 1.020, 0, 1.00, 0.45, 0.45, 0.8, 0.322, 0.999, 0, 0.95, 0.36, 0.34, 0.5, 0.000, 1.038, 0, 0.85, 0.39, 0.33, 0.7, 0.279, 0.988, 0, 0.70, 0.76, 0.53, 1.2, 0.146, 0.982, 0, 0.80, 0.46, 0.37, 0.4, 0.380, 1.006, 0, 0.20, 0.39, 0.08, 0.8, 0.114, 0.990, 0, 1.00, 0.90, 0.90, 1.1, 1.037, 0.990, 1, 1.00, 0.84, 0.84, 1.9, 2.064, 1.020, 0, 0.65, 0.42, 0.27, 0.5, 0.114, 1.014, 0, 1.00, 0.75, 0.75, 1.0, 1.322, 1.004, 0, 0.50, 0.44, 0.22, 0.6, 0.114, 0.990, 1, 1.00, 0.63, 0.63, 1.1, 1.072, 0.986, 0, 1.00, 0.33, 0.33, 0.4, 0.176, 1.010, 0, 0.90, 0.93, 0.84, 0.6, 1.591, 1.020, 1, 1.00, 0.58, 0.58, 1.0, 0.531, 1.002, 0, 0.95, 0.32, 0.30, 1.6, 0.886, 0.988, 1, 1.00, 0.60, 0.60, 1.7, 0.964, 0.990, 1, 1.00, 0.69, 0.69, 0.9, 0.398, 0.986, 0, 1.00, 0.73, 0.73, 0.7, 0.398, 0.986), byrow = TRUE, ncol = 7) colnames(M1) = c("Y", "X1", "X2", "X3", "X4", "X5", "X6") D1 = data.frame(M1) D1 # fit.glm = glm(Y ~ X1 + X2 + X3 + X4 + X5 + X6, data = D1, # family = binomial("logit")) # fit.gam = gam(Y ~ s(X1) + s(X2) + s(X3) + s(X4) + s(X5) + s(X6), # data = D1, family = binomial("logit")) M2 <- matrix(c( 0,29,62, 0,30,83, 0,31,74, 0,31,88, 0,32,68, 1,29,41, 1,30,44, 1,31,21, 1,32,50, 1,33,33), byrow = TRUE, ncol = 3) colnames(M2) = c("Y", "X1", "X2") D2 = data.frame(M2) D2 plot (D2[1:5, "X1"], D2[1:5, "X2"], xlim = range(D2[, "X1"]), ylim = range(D2[, "X2"]), pch = 19, col = "blue") points(D2[6:10,"X1"], D2[6:10,"X2"], pch = 19, col = "red") U = range(D2[, "X1"]) V = 2*U - 6 lines(U, V, lty = 3, col = "grey") fit.glm = glm(Y ~ X1 + X2, data = D2, family = binomial("logit")) print(fit.glm) # Return Value: return() } ################################################################################ fRegression/inst/unitTests/runit.regFit.R0000644000176200001440000001235014273153361020230 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: REGRESSION MODELLING DESCRIPTION: # regFit Wrapper Function for Regression Models ################################################################################ test.lmFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: lmfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") print(lmfit) summary(lmfit) # plot(lmfit) fitted(lmfit) slot(lmfit, "fitted") residuals(lmfit) slot(lmfit, "residuals") coef(lmfit) formula(lmfit) predict(lmfit) # Return Value: return() } # ------------------------------------------------------------------------------ test.rlmFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: rlmfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "rlm") print(rlmfit) summary(rlmfit) # plot(rlmfit) fitted(rlmfit) slot(rlmfit, "fitted") residuals(rlmfit) slot(rlmfit, "residuals") coef(rlmfit) formula(rlmfit) predict(rlmfit) head(rlmfit@fit$model) # Return Value: return() } # ------------------------------------------------------------------------------ test.glmFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: glmfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "glm") print(glmfit) summary(glmfit) # plot(glmfit) print(glmfit@fit) summary(glmfit@fit) fitted(glmfit) slot(glmfit, "fitted") residuals(glmfit) slot(glmfit, "residuals") coef(glmfit) formula(glmfit) predict(glmfit) # Return Value: return() } # ------------------------------------------------------------------------------ test.gamFit <- function() { # Simulate Artificial LM: x <- regSim(model = "GAM3", n = 50) # Fit Parameters: gamfit <- regFit(Y ~ s(X1) + s(X2) + X3, data = x, use = "gam") print(gamfit) summary(gamfit) # plot(gamfit) print(gamfit@fit) summary(gamfit@fit) fitted(gamfit) slot(gamfit, "fitted") residuals(gamfit) slot(gamfit, "residuals") coef(gamfit) formula(gamfit) predict(gamfit) gamfit@fit$terms # Return Value: return() } # ------------------------------------------------------------------------------ test.pprFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: pprfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "ppr") ppr <- ppr(Y ~ X1 + X2 + X3, data = x, nterms = 2) print(pprfit) summary(pprfit) # plot(pprfit) print(pprfit@fit) summary(pprfit@fit) fitted(pprfit) slot(pprfit, "fitted") residuals(pprfit) slot(pprfit, "residuals") coef(pprfit) formula(pprfit) predict(pprfit) pprfit@fit$terms # Return Value: return() } # ------------------------------------------------------------------------------ if (FALSE) { test.nnetFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: nnetfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "nnet") print(nnetfit) summary(nnetfit) # plot(nnetfit) print(nnetfit@fit) summary(nnetfit@fit) fitted(nnetfit) slot(nnetfit, "fitted") residuals(nnetfit) slot(nnetfit, "residuals") coef(nnetfit) formula(nnetfit) predict(nnetfit) nnetfit@fit$terms # Return Value: return() } } # ------------------------------------------------------------------------------ test.polymarsFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: polymarsfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "polymars") print(polymarsfit) summary(polymarsfit) fitted(polymarsfit) slot(polymarsfit, "fitted") residuals(polymarsfit) slot(polymarsfit, "residuals") coef(polymarsfit) formula(polymarsfit) predict(polymarsfit) polymarsfit@fit$terms # Return Value: return() } ################################################################################ fRegression/inst/unitTests/runit.terms.R0000644000176200001440000001025214273153361020141 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### # FUNCTION: REGRESSION MODELLING DESCRIPTION: # regFit Wrapper Function for Regression Models ############################################################################### test.lmFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: lmfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") lm <- stats::lm(Y ~ X1 + X2 + X3, data = x) # Terms: terms(lmfit@fit) terms(lm) # Return Value: return() } # ----------------------------------------------------------------------------- test.rlmFit <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Fit Parameters: rlmfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "rlm") rlm <- MASS::rlm(Y ~ X1 + X2 + X3, data = x) # Terms: terms(rlmfit@fit) terms(rlm) # Return Value: return() } # ----------------------------------------------------------------------------- test.glmFit <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Fit Parameters: glmfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "glm") glm <- stats::glm(Y ~ X1 + X2 + X3, data = x) # Terms: terms(glmfit@fit) terms(glm) # Return Value: return() } # ----------------------------------------------------------------------------- test.gamFit <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Fit Parameters: gamfit <- regFit(Y ~ s(X1) + s(X2) + X3, data = x, use = "gam") gam <- mgcv::gam(Y ~ X1 + X2 + X3, data = x) # Terms: terms(gamfit@fit) terms(gam) # Return Value: return() } # ----------------------------------------------------------------------------- test.pprFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: pprfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "ppr") ppr <- stats::ppr(Y ~ X1 + X2 + X3, data = x, nterms = 2) # Terms: terms(pprfit@fit) terms(ppr) # Return Value: return() } # ----------------------------------------------------------------------------- test.nnetFit <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Fit Parameters: nnetfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "nnet") nnet <- nnet::nnet(Y ~ X1 + X2 + X3, data = x, trace = FALSE, size = 2, linout = TRUE) # Terms: terms(nnetfit@fit) terms(nnet) # Return Value: return() } # ----------------------------------------------------------------------------- test.polymarsFit <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Fit Parameters: polymarsfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "polymars") polymars <- fRegression:::.polymars(Y ~ X1 + X2 + X3, data = x) # Terms: terms(polymarsfit@fit) terms(polymars) # Return Value: return() } ############################################################################### fRegression/inst/unitTests/runit.TimeSeries.R0000644000176200001440000001100214273153361021052 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### test.lmCoef <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Convert to a timeSeries Object with Dummy Dates x = as.timeSeries(x) # Fit Parameters: fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") fit # Extract Fitted values: head(slot(fit, "fitted")) val = fitted(fit) head(val) class(val) # Extract Residuals: head(slot(fit, "residuals")) val = residuals(fit) head(val) class(val) # Return Value: return() } # ------------------------------------------------------------------------------ test.rlmCoef <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Convert to a timeSeries Object with Dummy Dates x = as.timeSeries(x) # Fit Parameters: fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "rlm") fit # Extract Fitted values: head(slot(fit, "fitted")) val = fitted(fit) head(val) class(val) # Extract Residuals: head(slot(fit, "residuals")) val = residuals(fit) head(val) class(val) # Return Value: return() } # ------------------------------------------------------------------------------ test.amCoef <- function() { # Simulate Artificial LM: x = regSim(model = "GAM3", n = 50) # Convert to a timeSeries Object with Dummy Dates x = as.timeSeries(x) # Fit Parameters: fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "gam") fit # Extract Fitted values: head(slot(fit, "fitted")) val = fitted(fit) head(val) class(val) # Extract Residuals: head(slot(fit, "residuals")) val = residuals(fit) head(val) class(val) # Return Value: return() } # ------------------------------------------------------------------------------ test.pprCoef <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Convert to a timeSeries Object with Dummy Dates x = as.timeSeries(x) # Fit Parameters: fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "ppr") fit # Extract Fitted values: head(slot(fit, "fitted")) val = fitted(fit) head(val) class(val) # Extract Residuals: head(slot(fit, "residuals")) val = residuals(fit) head(val) class(val) # Return Value: return() } # ------------------------------------------------------------------------------ test.nnetCoef <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Convert to a timeSeries Object with Dummy Dates x = as.timeSeries(x) # Fit Parameters: fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "nnet") fit # Extract Fitted values: head(slot(fit, "fitted")) val = fitted(fit) head(val) class(val) # Extract Residuals: head(slot(fit, "residuals")) val = residuals(fit) head(val) class(val) # Return Value: return() } # ------------------------------------------------------------------------------ test.polymarsCoef <- function() { # Simulate Artificial LM: x = regSim(model = "LM3", n = 50) # Convert to a timeSeries Object with Dummy Dates x = as.timeSeries(x) # Fit Parameters: fit = regFit(Y ~ X1 + X2 + X3, data = x, use = "polymars") fit # Extract Fitted values: head(slot(fit, "fitted")) val = fitted(fit) head(val) class(val) # Extract Residuals: head(slot(fit, "residuals")) val = residuals(fit) head(val) class(val) # Return Value: return() } ################################################################################ fRegression/inst/unitTests/runTests.R0000644000176200001440000000617414273153361017506 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ############################################################################### pkg <- "fRegression" if(require("RUnit", quietly = TRUE)) { library(package=pkg, character.only = TRUE) if(!(exists("path") && file.exists(path))) path <- system.file("unitTests", package = pkg) ## --- Testing --- ## Define tests testSuite <- defineTestSuite(name = paste(pkg, "unit testing"), dirs = path) if(interactive()) { cat("Now have RUnit Test Suite 'testSuite' for package '", pkg, "' :\n", sep='') str(testSuite) cat('', "Consider doing", "\t tests <- runTestSuite(testSuite)", "\nand later", "\t printTextProtocol(tests)", '', sep = "\n") } else { ## run from shell / Rscript / R CMD Batch / ... ## Run tests <- runTestSuite(testSuite) if(file.access(path, 02) != 0) { ## cannot write to path -> use writable one tdir <- tempfile(paste(pkg, "unitTests", sep="_")) dir.create(tdir) pathReport <- file.path(tdir, "report") cat("RUnit reports are written into ", tdir, "/report.(txt|html)", sep = "") } else { pathReport <- file.path(path, "report") } ## Print Results: printTextProtocol(tests, showDetails = FALSE) printTextProtocol(tests, showDetails = FALSE, fileName = paste(pathReport, "Summary.txt", sep = "")) printTextProtocol(tests, showDetails = TRUE, fileName = paste(pathReport, ".txt", sep = "")) ## Print HTML Version to a File: ## printHTMLProtocol has problems on Mac OS X if (Sys.info()["sysname"] != "Darwin") printHTMLProtocol(tests, fileName = paste(pathReport, ".html", sep = "")) ## stop() if there are any failures i.e. FALSE to unit test. ## This will cause R CMD check to return error and stop tmp <- getErrors(tests) if(tmp$nFail > 0 | tmp$nErr > 0) { stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, ", R errors: ", tmp$nErr, ")\n\n", sep="")) } } } else { cat("R package 'RUnit' cannot be loaded -- no unit tests run\n", "for package", pkg,"\n") } ################################################################################ fRegression/inst/unitTests/runit.LPP2005.R0000644000176200001440000000223714273153361017755 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ###########################\##################################################### test.Fit <- function() { # Simulate Artificial LM: x <- as.timeSeries(data(LPP2005REC)) # Fit Parameters: lmfit <- regFit(LPP40 ~ 0 + SPI + SBI + SII + LMI + MPI + ALT, data = x, use = "lm") # print(lmfit) # Return Value: return() } ############################################################################### fRegression/inst/unitTests/runit.polymars.R0000644000176200001440000001350214273153361020656 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: REGRESSION MODELLING DESCRIPTION: # polymars Polymars Regression # .polymars Polymars regress from package polspline # .polymarsDefault Internal Function # .polymarsVormula Internal Function # .predict.polymars Internal Function ################################################################################ test.polymars <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Original Polymars: fit <- polspline::polymars(responses = x[,1], predictors = x[,2:4]) # Model Fitting: fit$fitting # Model Produced: fit$model fit$coef # Summary: # Note print.polymars = summary.polymars polspline::summary.polymars(fit) # Predict: ans <- polspline::predict.polymars(object = fit, x = x[,-1]) as.vector(ans) as.vector(fit$fitted) # Return Value: return() } # ------------------------------------------------------------------------------ test.polymarsDefault <- function() { # Simulate Artificial LM: set.seed(4711) x = regSim(model = "LM3", n = 50) # Polymars Wrapper: fit1 = fRegression:::.polymarsDefault(responses = x[,1], predictors = x[, 2:4]) class(fit1) names(fit1) # Note, this fails: # fit1 = .polymars(responses = x[,1], predictors = x[,2:4]) # Model Fitting: fit1$fitting # Model Produced: # fit1$model reserved for model series, use ... fit1$coef # Summary: print(fit1) # Print: summary(fit1) # Predict: ans <- polspline::predict.polymars(object = fit1, x = x[,-1]) as.vector(ans) as.vector(fit1$fitted) # Check: fit1$ranges.and.medians # Return Value: return() } # ----------------------------------------------------------------------------- test.polymarsFormula <- function() { # Simulate Artificial LM: set.seed(4711) x <- regSim(model = "LM3", n = 50) # Polymars Formula Wrapper: fit2 <- fRegression:::.polymarsFormula(formula = Y ~ X1 + X2 + X3, data = x) fit2 <- fRegression:::.polymars(formula = Y ~ X1 + X2 + X3, data = x) class(fit2) names(fit2) # Model Fitting: fit2$fitting # Model Produced: # fit$model reserved for model series, use ... fit2$coef # Summary: print(fit2) # Print: summary(fit2) # Predict: fit2$model <- fit2$coef ans <- polspline::predict.polymars(object = fit2, x = x[,-1]) as.vector(ans) as.vector(fit2$fitted) # Check: fit2$ranges.and.medians # Return Value: return() } # ----------------------------------------------------------------------------- test.regFit.polymars <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # Polymars Formula Wrapper: fit <- regFit(formula = Y ~ X1 + X2 + X3, data = x, use = "polymars") class(fit) # Model Fitting: fit@fit$fitting # Model Produced: # fit$model reserved for model series, use ... fit@fit$coef # Summary: print(fit) # Print: summary(fit) # Return Value: return() } # ----------------------------------------------------------------------------- test.regFit.polymars.methods <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 20) # Polymars Formula Wrapper: polymarsfit <- regFit( formula = Y ~ X1 + X2 + X3, data = x, use = "polymars") # Print: print(polymarsfit) # Summary: summary(polymarsfit) # Fitted Values: fitted(polymarsfit) slot(polymarsfit, "fitted") # Residuals: residuals(polymarsfit) slot(polymarsfit, "residuals") # Coefficients: coef(polymarsfit) # Formula formula(polymarsfit) # Return Value: return() } # ----------------------------------------------------------------------------- test.regFit.polymars.predict <- function() { # Simulate Artificial LM: x <- regSim(model = "LM3", n = 50) # regFit / Polymars Formula Wrapper: fit <- regFit(formula = Y ~ X1 + X2 + X3, data = x, use = "polymars") class(fit) fit@fit$cmd # Predict from predict.polymars: object <- fit@fit class(object) = "polymars" object object$model = object$coef ans <- polspline::predict.polymars(object = object, x = x[,-1]) as.vector(ans) as.vector(fit@fitted) # Predict from predict.fREG: ans <- predict(object = fit, newdata = x) as.vector(ans) as.vector(fit@fitted) # Return Value: return() } ############################################################################### fRegression/inst/unitTests/Makefile0000644000176200001440000000042414275145400017161 0ustar liggesusersPKG=fRegression TOP=../.. SUITE=doRUnit.R R=R all: inst test inst: # Install package -- but where ?? -- will that be in R_LIBS ? cd ${TOP}/..;\ ${R} CMD INSTALL ${PKG} test: # Run unit tests export RCMDCHECK=FALSE;\ cd ${TOP}/tests;\ ${R} --vanilla --slave < ${SUITE} fRegression/inst/unitTests/runit.TermPlots.R0000644000176200001440000001531714273153361020747 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library 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 Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA ################################################################################ # FUNCTION: REGRESSION TERM PLOTS # termPlot Line Plot # termPersp Perspective Plot # termContour Contour Plot ################################################################################ test.termPlot <- function() { x <- regSim(model = "LM3", n = 100) lmfit <- regFit(Y ~ X1 + X2 + X3, data = x, use = "lm") # Simulate Data - a data frame: DATA <- regSim(model = "GAM3", n = 100) head(DATA) class(DATA) # Convert to a timeSeries object: DATATS <- as.timeSeries(DATA) head(DATATS) class(DATATS) require(mgcv) # Fit: LM = regFit(Y ~ 1 + X1 + X2 + X3, data = DATATS, use = "lm") RLM = regFit(Y ~ 1 + X1 + X2 + X3, data = DATATS, use = "rlm") AM = regFit(Y ~ 1 + X1 + X2 + X3, DATATS, use = "gam") PPR = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "ppr") PPR4 = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "ppr", nterms = 4) POLYMARS = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "polymars") NNET = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "nnet") NNET6 = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "nnet", size = 6) ## TODO: Term Plot: ## par(ask = FALSE) ## par(mfrow = c(1, 1)) ## termPlot(LM) ## termPlot(RLM) ## termPlot(AM) ## termPlot(PPR) ## termPlot(POLYMARS) ## termPlot(NNET) ## TODO: ## par(ask = FALSE) ## par(mfrow = c(1, 1)) ## termPlot(LM, terms = "X1") ## termPlot(RLM, terms = "X1") ## termPlot(AM, terms = "X1") ## termPlot(PPR, terms = "X1") ## termPlot(PPR4, terms = "X1") ## termPlot(POLYMARS, terms = "X1") ## termPlot(NNET, terms = "X1") ## termPlot(NNET6, terms = "X1") # Return Value: return() } # ------------------------------------------------------------------------------ test.termPersp <- function() { # Simulate Data - a data frame: DATA <- regSim(model = "GAM3", n = 100) head(DATA) class(DATA) # Convert to a timeSeries object: DATATS <- as.timeSeries(DATA) head(DATATS) class(DATATS) require(mgcv) # Fit: LM = regFit(Y ~ 1 + X1 + X2 + X3, data = DATATS, use = "lm") RLM = regFit(Y ~ 1 + X1 + X2 + X3, data = DATATS, use = "rlm") AM = regFit(Y ~ 1 + s(X1)+s(X2)+s(X3), DATATS, use = "gam") PPR = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "ppr") PPR4 = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "ppr", nterms = 4) POLYMARS = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "polymars") NNET = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "nnet") NNET6 = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "nnet", size = 6) ## TODO: Bivariate Perspective Term Plot: ## par(ask = FALSE) ## par(mfrow = c(1, 1)) ## termPersp(LM, terms = c("X1", "X2")) ## termPersp(RLM, terms = c("X1", "X2")) ## termPersp(AM, terms = c("X1", "X2")) ## termPersp(PPR, terms = c("X1", "X2")) ## termPersp(PPR4, terms = c("X1", "X2")) ## termPersp(POLYMARS, terms = c("X1", "X2")) ## termPersp(NNET, terms = c("X1", "X2")) ## termPersp(NNET6, terms = c("X1", "X2")) # Return Value: return() } # ------------------------------------------------------------------------------ test.termContour <- function() { # Simulate Data - a data frame: DATA = regSim(model = "GAM3", n = 100) head(DATA) class(DATA) # Convert to a timeSeries object: DATATS = as.timeSeries(DATA) head(DATATS) class(DATATS) require(mgcv) # Fit: LM = regFit(Y ~ 1 + X1 + X2 + X3, data = DATATS, use = "lm") RLM = regFit(Y ~ 1 + X1 + X2 + X3, data = DATATS, use = "rlm") AM = regFit(Y ~ 1 + s(X1)+s(X2)+s(X3), DATATS, use = "gam") PPR = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "ppr") PPR4 = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "ppr", nterms = 4) POLYMARS = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "polymars") NNET = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "nnet") NNET6 = regFit(Y ~ X1 + X2 + X3, data = DATATS, use = "nnet", size = 6) ## TODO: Bivariate Contour Term Plot: ## par(ask = FALSE) ## par(mfrow = c(1, 1)) ## termContour(LM, terms = c("X1", "X2")) ## termContour(RLM, terms = c("X1", "X2")) ## termContour(AM, terms = c("X1", "X2")) ## termContour(PPR, terms = c("X1", "X2")) ## termContour(PPR4, terms = c("X1", "X2")) ## termContour(POLYMARS, terms = c("X1", "X2")) ## termContour(NNET, terms = c("X1", "X2")) ## termContour(NNET6, terms = c("X1", "X2")) # Return Value: return() } # ------------------------------------------------------------------------------ test.termComparison <- function() { # Simulate Data - a data frame: DATA = regSim(model = "GAM3", n = 100) head(DATA) class(DATA) # Convert to a timeSeries object: DATATS = as.timeSeries(DATA) head(DATATS) class(DATATS) require(mgcv) ## TODO: if (FALSE) { # Comparison: par(ask = FALSE) par(mfrow = c(1, 1)) LM = regFit(Y ~ 1 + X1 + X2 + X3, data = DATATS, use = "lm") termPlot(LM) AM = regFit(Y ~ 1 + s(X1)+s(X2)+s(X3), data = DATATS, use = "gam") termPlot(AM) am = gam(formula = Y ~ s(X1) + s(X2) + s(X3), data = DATA) for (s in 1:3) { plot(am, residuals = residuals(am), se = TRUE, main = "AM", cex = 0.7, select = s, pch = 19); grid() } } # Return Value: return() } ###############################################################################