├── tests ├── ex-Vinod.Rout.save ├── o-linux.Rout.save ├── o-linux.R ├── Valderio-ex.R ├── sim-ex.R ├── ex-Vinod.R ├── sim-2.R ├── Valderio-ex.Rout.save ├── ex-Vinod.Rout-32b ├── ex-Vinod.Rout-64b ├── ex.R ├── o-linux.Rout-32b ├── o-linux.Rout-64b ├── ex.Rout-32b ├── ex.Rout.save └── sim-ex.Rout.save ├── src ├── Makevars ├── gamm_comm.h ├── mach_comm.h ├── maux_comm.h ├── hess_comm.h ├── pmult.c ├── fracdiff.h ├── init.c ├── fdsim.c ├── fdhess.c ├── fdgam.c └── fdcore.c ├── .gitignore ├── .Rbuildignore ├── DESCRIPTION_Author ├── Calling ├── NAMESPACE ├── README ├── Done ├── R ├── fdGPH.R ├── fdSperio.R ├── diffseries.R ├── fd-methods.R └── fracdiff.R ├── man ├── fdGPH.Rd ├── confint.fracdiff.Rd ├── diffseries.Rd ├── fracdiff.var.Rd ├── fdSperio.Rd ├── fd-methods.Rd ├── fracdiff.sim.Rd └── fracdiff.Rd ├── DESCRIPTION ├── TODO └── ChangeLog /tests/ex-Vinod.Rout.save: -------------------------------------------------------------------------------- 1 | ex-Vinod.Rout-64b -------------------------------------------------------------------------------- /tests/o-linux.Rout.save: -------------------------------------------------------------------------------- 1 | o-linux.Rout-64b -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_LIBS = $(BLAS_LIBS) $(FLIBS) 2 | -------------------------------------------------------------------------------- /src/gamm_comm.h: -------------------------------------------------------------------------------- 1 | FD_EXTERNAL 2 | struct { int igamma, jgamma; } gammfd_; 3 | -------------------------------------------------------------------------------- /src/mach_comm.h: -------------------------------------------------------------------------------- 1 | FD_EXTERNAL 2 | struct { double fltmin, fltmax, epsmin, epsmax; } machfd_; 3 | -------------------------------------------------------------------------------- /src/maux_comm.h: -------------------------------------------------------------------------------- 1 | FD_EXTERNAL 2 | struct { double epsp25, epspt3, epspt5, epsp75, bignum; } mauxfd_; 3 | #define mauxfd_1 mauxfd_ 4 | 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Archive/ 2 | codes_for_fracdiff/ 3 | src-c/ 4 | src/00-multiple-symbols 5 | src/done-f2c 6 | tests/*.save_* 7 | tests/*.Rout_* 8 | tests/o-linux.Rout*-1 9 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | Archive 2 | Calling 3 | DESCRIPTION_ 4 | Done 5 | M1mac 6 | 00.*winb 7 | .*\.zip 8 | .*\.rar 9 | .*\.tgz 10 | .*\.mail 11 | .*-manual 12 | qed.*\.pdf 13 | codes_for_.* 14 | ^filters\.R 15 | simul-compare.* 16 | tests/.*Rout-[36][24]b 17 | tests/.*Rout.*_ 18 | tests/ex-Vinod.*Rout 19 | tests/.*linux 20 | tests/windows.* 21 | src/.*\.c\+ 22 | src/00-.* 23 | src/ftn-struc 24 | src/done-.* 25 | src-c 26 | -------------------------------------------------------------------------------- /DESCRIPTION_Author: -------------------------------------------------------------------------------- 1 | Author: Martin Maechler [aut, cre] (), 2 | Chris Fraley [ctb, cph] (S original; Fortran code), 3 | Friedrich Leisch [ctb] (R port, 4 | ), 5 | Valderio Reisen [ctb] (fdGPH() & fdSperio()), 6 | Artur Lemonte [ctb] (fdGPH() & fdSperio()), 7 | Rob Hyndman [ctb] (residuals() & fitted(), 8 | ) 9 | Maintainer: Martin Maechler 10 | -------------------------------------------------------------------------------- /src/hess_comm.h: -------------------------------------------------------------------------------- 1 | /* included only by ./fdcore.c and ./fdhess.c : */ 2 | 3 | FD_EXTERNAL 4 | struct { int n, m, p, q, pq, pq1, maxpq, maxpq1, minpq, nm; } Dims; 5 | 6 | FD_EXTERNAL 7 | struct { double hatmu, wnv, cllf; } filtfd_; 8 | FD_EXTERNAL 9 | struct { int ksvd, kcov, kcor; } hessfd_; 10 | 11 | FD_EXTERNAL 12 | struct { int ly, lamk, lak, lvk, lphi, lpi; } w_fil; 13 | 14 | FD_EXTERNAL 15 | struct { int lqp, la, lajac, ipvt, ldiag, lqtf, lwa1, lwa2, lwa3, lwa4; } w_opt; 16 | 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /Calling: -------------------------------------------------------------------------------- 1 | R Function C Functions(s) called SRC file 2 | ~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~ 3 | 4 | fracdiff() fracdf (main routine) src/fdcore.c 5 | \--> fdcom(), dopt() 6 | 7 | fdhpq ("hess") src/fdhess.c 8 | \--> hesspq() 9 | 10 | fdcov ("cov" and "cor" from hess etc) " 11 | \--> hesdpq(); dsvdc() & invsvd_() 12 | 13 | {{TODO: how exactly are hesspq() and hessdpq() related ??? }} 14 | 15 | 16 | fracdiff.var fdcom (init common blocks) src/fdhess.c 17 | fdcov " 18 | 19 | fracdiff.sim fdsim src/fdsim.c 20 | 21 | 22 | --- 23 | see also ./src/ftn-struc 24 | --- ~~~~~~~~~~~~~~~ 25 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | useDynLib(fracdiff, .registration=TRUE) 2 | 3 | importFrom("stats", 4 | AIC, arima, as.ts 5 | , fft, nextn 6 | , lm.fit 7 | , coef, logLik, resid 8 | , na.fail 9 | , printCoefmat 10 | , pnorm, qnorm, rnorm 11 | , symnum 12 | , tsp, "tsp<-" 13 | ) 14 | 15 | export("fracdiff", "fracdiff.sim", "fracdiff.var", 16 | "diffseries", 17 | "fdGPH", "fdSperio") 18 | 19 | ###---- Methods ---- all documented but not exported 20 | 21 | S3method(coef, fracdiff) 22 | S3method(confint, fracdiff) ; export("confint.fracdiff")# has been advertized 23 | S3method(fitted, fracdiff) 24 | S3method(logLik, fracdiff) 25 | S3method(print, fracdiff) 26 | S3method(residuals, fracdiff) 27 | S3method(vcov, fracdiff) 28 | S3method(summary, fracdiff) 29 | 30 | S3method(print, summary.fracdiff) 31 | 32 | -------------------------------------------------------------------------------- /src/pmult.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2004 Martin Maechler 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU General Public License as published by 6 | * the Free Software Foundation; either version 2 of the License, or 7 | * (at your option) any later version. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU General Public License for more details. 13 | * 14 | * A copy of the GNU General Public License is available via WWW at 15 | * http://www.gnu.org/copyleft/gpl.html. You can also obtain it by 16 | * writing to the Free Software Foundation, Inc., 59 Temple Place, 17 | * Suite 330, Boston, MA 02111-1307 USA. 18 | */ 19 | 20 | #include 21 | #include 22 | 23 | SEXP poly_mult(SEXP a, SEXP b) 24 | { 25 | SEXP prod; 26 | 27 | /* TODO: implement polynomial multiplication */ 28 | 29 | prod = a; /* -Wall : for now */ 30 | 31 | return prod; 32 | } 33 | -------------------------------------------------------------------------------- /tests/o-linux.R: -------------------------------------------------------------------------------- 1 | ### Very similar to ./ex.R but using *MORE* precision 2 | ### ===> non-portable but better for consistency checking (Development) 3 | library(fracdiff) 4 | 5 | .proctime00 <- proc.time() 6 | set.seed(107) 7 | options(digits = 10) 8 | 9 | ## 1) 10 | 11 | x1 <- fracdiff.sim( 5000, ar = .2, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 12 | (fd1 <- fracdiff(x1$series, nar = 1, nma = 1, dtol = 1e-10)) 13 | vcov(fd1) 14 | logLik(fd1) 15 | 16 | fdCOVcomp <- 17 | c("h", "covariance.dpq", "stderror.dpq", "correlation.dpq", "hessian.dpq") 18 | fd1. <- fracdiff.var(x1$series, fd1, h = fd1$h / 8) 19 | fd1.[fdCOVcomp] 20 | fd1u <- fracdiff.var(x1$series, fd1, h = fd1$h * 8) 21 | sapply(fd1u[fdCOVcomp], signif, digits= 8) 22 | 23 | ## 2) 24 | 25 | x2 <- fracdiff.sim( 2048, ar = .8, ma = -.4, d = .3, n.start=0, allow.0 = TRUE)# -> NA's and problems 26 | fd2 <- fracdiff(x2$series, nar = length(x2$ar), nma = length(x2$ma)) 27 | summary(fd2) 28 | 29 | (fd2. <- fracdiff.var(x2$series, fd2, h = fd2$h / 8))[fdCOVcomp] 30 | (fd2u <- fracdiff.var(x2$series, fd2, h = fd2$h * 8))[fdCOVcomp] 31 | 32 | ## Last Line: 33 | cat('Time elapsed: ', proc.time() - .proctime00,'\n') 34 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | fracdiff Maximum likelihood estimation of the parameters of a fractionally 2 | differenced ARIMA (p,d,q) model. For long-memory dependence in 3 | time series. (Haslett and Raftery, Applied Statistics 38, 1989, 1-50). 4 | 5 | See the help files for details. 6 | 7 | The original S/S-plus package by Chris Fraley, Department of Statistics, 8 | University of Washington, has been converted for usage with R; 9 | see README.orig, also for copyright. 10 | 11 | I've converted all single precision floats to double precision (both 12 | in the R file and the Fortran sources), as R didn't support single 13 | precision (in 1999). 14 | 15 | Fritz Leisch, TU Wien, Austria 16 | 17 | ------------ 18 | 19 | The package was _orphaned_ in Summer 2003, and after asking Fritz and Chris 20 | Fraley, I have become the new maintainer in December 2003. 21 | I've managed to locate and eradicate the bug leading to wrong hessian, 22 | covariance and correlation matrix estimates. 23 | 24 | Martin Maechler, ETH Zurich, Switzerland 25 | 26 | ------ 27 | 28 | See the files ./TODO and ./Done and ./ChangeLog on TODOs and ideas 29 | 30 | See the file ./Calling (and then src/ftn-struc) about code organization 31 | ~~~~~~~~~ 32 | -------------------------------------------------------------------------------- /Done: -------------------------------------------------------------------------------- 1 | 0. After F2c'ing, and declaring things, I now get the compiler warnings 2 | 3 | fdcore.c: In function `pqopt_': 4 | fdcore.c:561: warning: passing arg 18 of `lmder1_' from incompatible pointer type 5 | fdcore.c:573: warning: passing arg 18 of `lmder1_' from incompatible pointer type 6 | fdcore.c:583: warning: passing arg 18 of `lmder1_' from incompatible pointer type 7 | 8 | and indeed, the argument passed is &w[woptfd_1.ipvt] 9 | but this is internally treated as *integer* '*ipvt' 10 | 11 | ===> reason for occasional seg.faults !? 12 | 13 | fracdf() -> dopt() -> pqopt() 14 | really should pass a double w[] PLUS an int iw[] 15 | 16 | ___ DONE, 2004-10-xx (MM) ___ 17 | 18 | 1. Estimation now produces a class with print(), summary(), coef(), 19 | logLik() and vcov() methods 20 | 21 | 1b. fracdiff.sim() improved, now allowing non-Gaussian innovations. 22 | 23 | 2. Translate to C, 24 | ___ DONE, 2004-09-18 (MM) ___ 25 | 26 | 5. Jan de Leeuw cannot link things on Mac OSX using "flat namespaces" 27 | (because the Common Blocks look like having multiple definitions) 28 | --> start cleaning up common blocks in general. 2005-06-29 29 | mostly finished; at least CRAN-checks are fine now. 30 | 31 | 32 | -------------------------------------------------------------------------------- /R/fdGPH.R: -------------------------------------------------------------------------------- 1 | #### by Valderio Reisen -- Dec.2005-- 2 | #### Tweaks by MM 3 | 4 | ## MM(FIXME): This is "in parallel" to fdSperio() , see ./fdSperio.R 5 | 6 | fdGPH <- function(x, bandw.exp = 0.5) 7 | { 8 | if(NCOL(x) > 1) stop("only implemented for univariate time series") 9 | x <- as.numeric(na.fail(as.ts(x))) 10 | if (any(is.na(x))) stop("NAs in x") 11 | n <- length(x) 12 | ## Compute "smoothed" periodogram -- MM (FIXME): use spec.pgram() ! 13 | g <- trunc(n^bandw.exp) 14 | j <- 1:g 15 | kk <- 1:(n-1) 16 | w <- 2*pi*j/n 17 | x <- x - mean(x) 18 | var.x <- sum(x^2)/n # not /(n-1) 19 | cov.x <- numeric(n-1L) 20 | for (k in kk) 21 | cov.x[k] <- sum(x[1:(n-k)] * x[(1+k):n]) / n 22 | 23 | periodogram <- numeric(g) 24 | for (i in 1:g) # unscaled (will scale below) 25 | periodogram[i] <- var.x + 2*sum(cov.x * cos(w[i]*kk)) 26 | 27 | pos <- j[periodogram > 0] 28 | y.reg <- log(periodogram[pos] / (2*pi)) 29 | x.reg <- 2*log(2*sin(w[pos]/2)) ## = log( (2*sin(..)) ^ 2) 30 | fit <- lm.fit(cbind(1, x.reg), y.reg) 31 | d.GPH <- coef(fit)[["x.reg"]] 32 | x.r2 <- sum((x.reg - mean(x.reg))^2) 33 | var.d <- pi^2 / (6*x.r2) 34 | var.reg <- sum(resid(fit)^2) / ((g - 1) * x.r2) 35 | ## return 36 | list(d = -d.GPH, sd.as = sqrt(var.d), sd.reg = sqrt(var.reg)) 37 | } 38 | 39 | -------------------------------------------------------------------------------- /man/fdGPH.Rd: -------------------------------------------------------------------------------- 1 | \name{fdGPH} 2 | \alias{fdGPH} 3 | \title{Geweke and Porter-Hudak Estimator for ARFIMA(p,d,q)} 4 | 5 | \description{ 6 | Estimate the fractional (or \dQuote{memory}) parameter \eqn{d} in the 7 | ARFIMA(p,d,q) model by the method of Geweke and Porter-Hudak (GPH). 8 | The GPH estimator is based on the regression equation using the 9 | periodogram function as an estimate of the spectral density. 10 | } 11 | \usage{ 12 | fdGPH(x, bandw.exp = 0.5) 13 | } 14 | \arguments{ 15 | \item{x}{univariate time series} 16 | \item{bandw.exp}{the bandwidth used in the regression equation} 17 | } 18 | \details{ 19 | The function also provides the asymptotic standard deviation and the standard 20 | error deviation of the fractional estimator. 21 | 22 | The bandwidth is 23 | \code{bw = trunc(n ^ bandw.exp)}, where 0 < bandw.exp < 1 and n is the sample size. 24 | Default \code{bandw.exp = 0.5}. 25 | } 26 | 27 | \value{ 28 | \item{d}{GPH estimate} 29 | \item{sd.as}{asymptotic standard deviation} 30 | \item{sd.reg}{standard error deviation} 31 | } 32 | 33 | \references{see those in \code{\link{fdSperio}}. 34 | } 35 | 36 | \author{Valderio A. Reisen and Artur J. Lemonte} 37 | 38 | \seealso{\code{\link{fdSperio}}, \code{\link{fracdiff}}} 39 | 40 | \examples{ 41 | memory.long <- fracdiff.sim(1500, d = 0.3) 42 | fdGPH(memory.long$series) 43 | } 44 | \keyword{ts} 45 | -------------------------------------------------------------------------------- /tests/Valderio-ex.R: -------------------------------------------------------------------------------- 1 | library(fracdiff) 2 | 3 | set.seed(1) 4 | ## examples(fdSperio) 5 | mem.long <- fracdiff.sim(1500, d = 0.3) 6 | spm <- fdSperio(mem.long$series) 7 | str(spm, digits=6) 8 | 9 | set.seed(8) 10 | ## examples(fdGPH) 11 | mem.l2 <- fracdiff.sim(1024, d = 0.25) 12 | fdGPH(mem.l2$series) 13 | 14 | diffserie0 <- fracdiff:::diffseries0 # the old slow for()-loop one 15 | stopifnot(exprs = { 16 | all.equal(diffserie0(1:20, d = 1), c(-9.5, rep(1, 20-1)), tol = 1e-15) 17 | all.equal(diffseries(1:20, d = 1), c(-9.5, rep(1, 20-1)), tol = 1e-13) # fft 18 | all.equal(diffserie0(-10:10, d = 0), -10:10, tol = 1e-15) 19 | all.equal(diffseries(-10:10, d = 0), -10:10, tol = 1e-13) 20 | all.equal(diffserie0(-10:10, d = 1/2), 21 | diffseries(-10:10, d = 1/2), tol = 1e-13) # see 4.3e-16 on 64b-Lnx 22 | }) 23 | 24 | set.seed(123) 25 | ## example(diffseries) 26 | mem.l3 <- fracdiff.sim(80, d = 0.3) 27 | mGPH <- fdGPH(mem.l3$series) 28 | r0 <- diffserie0(mem.l3$series, d = mGPH$d) 29 | r. <- diffseries(mem.l3$series, d = mGPH$d) 30 | print(r0, digits = 4) 31 | r <- all.equal(r0, r., tol = 0, countEQ = TRUE) # average rel.error, seen ~ 3.5e-16 32 | if(is.character(r) && as.numeric(sub(".*: ", '', r)) > 4e-15) 33 | print(r) 34 | stopifnot(all.equal(r0, r., tol = 1e-13)) 35 | print(acf(r0)) # 36 | mtext("(shouldn't show structure - ideally)") 37 | 38 | cat("Time used: ", proc.time(),"\n") # for ``statistical reasons'' 39 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: fracdiff 2 | Version: 1.5-4 3 | VersionNote: Released 1.5-0 on 2019-12-09, 1.5-1 on 2020-01-20, 1.5-2 on 2022-10-31, 1.5-3 on 2024-02-01 4 | Date: 2024-03-13 5 | Title: Fractionally Differenced ARIMA aka ARFIMA(P,d,q) Models 6 | Authors@R: c(person("Martin","Maechler", role=c("aut","cre"), email="maechler@stat.math.ethz.ch", 7 | comment = c(ORCID = "0000-0002-8685-9910")) 8 | , person("Chris", "Fraley", role=c("ctb","cph"), comment = "S original; Fortran code") 9 | , person("Friedrich", "Leisch", role = "ctb", 10 | comment = c("R port", ORCID = "0000-0001-7278-1983")) 11 | , person("Valderio", "Reisen", role="ctb", comment = "fdGPH() & fdSperio()") 12 | , person("Artur", "Lemonte", role="ctb", comment = "fdGPH() & fdSperio()") 13 | , person("Rob", "Hyndman", email="Rob.Hyndman@monash.edu", role="ctb", 14 | comment = c("residuals() & fitted()", ORCID = "0000-0002-2140-5352")) 15 | ) 16 | Description: Maximum likelihood estimation of the parameters of a fractionally 17 | differenced ARIMA(p,d,q) model (Haslett and Raftery, Appl.Statistics, 1989); 18 | including inference and basic methods. Some alternative algorithms to estimate "H". 19 | Imports: stats 20 | Suggests: longmemo, forecast, urca 21 | License: GPL (>= 2) 22 | URL: https://github.com/mmaechler/fracdiff 23 | BugReports: https://github.com/mmaechler/fracdiff/issues 24 | Encoding: UTF-8 25 | NeedsCompilation: yes 26 | -------------------------------------------------------------------------------- /R/fdSperio.R: -------------------------------------------------------------------------------- 1 | #### by Valderio Reisen -- Dec.2005-- 2 | #### Tweaks by MM 3 | 4 | ## MM(FIXME): This is "in parallel" to fdGPH() , see ./fdGPH.R 5 | 6 | fdSperio <- function(x, bandw.exp = 0.5, beta = 0.9) 7 | { 8 | if(NCOL(x) > 1) stop("only implemented for univariate time series") 9 | x <- as.numeric(na.fail(as.ts(x))) 10 | if (any(is.na(x))) stop("NAs in x") 11 | n <- length(x) 12 | ## Compute "smoothed" periodogram -- MM (FIXME): use spec.pgram() ! 13 | g <- trunc(n^bandw.exp) 14 | j <- 1:g 15 | kk <- 1:(n-1) 16 | w <- 2*pi*j/n 17 | x <- x - mean(x) 18 | var.x <- sum(x^2)/n # not /(n-1) 19 | cov.x <- numeric(n-1) 20 | for (k in kk) 21 | cov.x[k] <- sum(x[1:(n-k)] * x[(1+k):n]) / n 22 | 23 | M <- trunc(n^beta) 24 | M2 <- M %/% 2 25 | pw <- numeric(n-1) 26 | for (k in kk) { 27 | A_k <- k/M 28 | pw[k] <- 29 | if (k <= M2) 1 - 6*A_k^2 *(1 - A_k) 30 | else if (k <= M) 2*(1 - A_k)^3 else 0 31 | } 32 | periodogram <- numeric(g) 33 | for (i in 1:g) # unscaled (will scale below) 34 | periodogram[i] <- var.x + 2*sum(cov.x* pw * cos(w[i]*kk)) 35 | 36 | pos <- j[periodogram > 0] 37 | y.reg <- log(periodogram[pos] / (2*pi)) 38 | x.reg <- 2*log(2*sin(w[pos]/2)) ## = log( (2*sin(..)) ^ 2) 39 | fit <- lm.fit(cbind(1, x.reg), y.reg) 40 | d.GPH <- coef(fit)[["x.reg"]] 41 | x.r2 <- sum((x.reg - mean(x.reg))^2) 42 | var.d <- (0.539285*M/n)/ x.r2 43 | var.reg <- sum(resid(fit)^2) / ((g - 1) * x.r2) 44 | list(d = -d.GPH, sd.as = sqrt(var.d), sd.reg = sqrt(var.reg)) 45 | } 46 | 47 | -------------------------------------------------------------------------------- /tests/sim-ex.R: -------------------------------------------------------------------------------- 1 | library(fracdiff) 2 | if(FALSE) # manual testing 3 | library(fracdiff, lib="/u/maechler/R/Pkgs/fracdiff.Rcheck-64b") 4 | 5 | .ptime <- proc.time() 6 | ## Test if the default 'n.start' is ok, i.e., if the 7 | ## "burn in" period is long enough : 8 | 9 | n <- 512 10 | 11 | set.seed(101) ; ok <- TRUE 12 | for(i in 1:2000) { 13 | r <- fracdiff.sim(n, ar = -0.9, ma = NULL, d = 0.3)$series 14 | if(max(abs(r)) > 10) { 15 | cat("OOps! Indices", 16 | capture.output(str(ibig <- which(big <- abs(r) > 10))), "-- are > 10\n") 17 | if(any(ibig < 200) && (length(ibig) > 5 || abs(r)[big] > 20)) { 18 | cat("Some have index < 200 --> BREAK\n") 19 | ok <- FALSE 20 | break 21 | } 22 | } 23 | if(i %% 100 == 0) { 24 | cat(i,": ACF = \n") 25 | print(acf(r, plot=FALSE)) 26 | } 27 | } 28 | if(!ok) { 29 | cat("i=",i," gave series \n") 30 | print(head(r)) ; cat(".......\n") 31 | plot(as.ts(r)) ## clearly did show problem {when we had bug} 32 | } 33 | 34 | ## Try to find an example more quickly with setting `one seed': 35 | .AR <- c(-.75, -.9) 36 | .MA <- c(0.2, 0.1) 37 | ok <- TRUE 38 | set.seed(1) 39 | r0 <- fracdiff.sim(100, d = 0.3) 40 | r1 <- fracdiff.sim(100, ar = .AR, d = 0.25) 41 | r2 <- fracdiff.sim(100, ar = .AR, ma = .MA, d = 0.2) 42 | for(i in 1:1000) { 43 | set.seed(1)# yes; identical ones 44 | r0i <- fracdiff.sim(100, d = 0.3) 45 | r1i <- fracdiff.sim(100, ar = .AR, d = 0.25) 46 | r2i <- fracdiff.sim(100, ar = .AR, ma = .MA, d = 0.2) 47 | stopifnot(identical(r0, r0i), 48 | identical(r1, r1i), 49 | identical(r2, r2i)) 50 | } 51 | 52 | ## Last Line: 53 | cat('Time elapsed: ', proc.time() - .ptime,'\n') 54 | -------------------------------------------------------------------------------- /man/confint.fracdiff.Rd: -------------------------------------------------------------------------------- 1 | \name{confint.fracdiff} 2 | \alias{confint.fracdiff} 3 | \title{Confidence Intervals for Fracdiff Model Parameters} 4 | \description{ 5 | Computes (Wald) confidence intervals for one or more parameters in a 6 | fitted fracdiff model, see \code{\link{fracdiff}}. 7 | } 8 | \usage{ 9 | \method{confint}{fracdiff}(object, parm, level = 0.95, \dots) 10 | } 11 | \section{Warning}{ 12 | As these confidence intervals use the standard errors returned by 13 | \code{\link{fracdiff}()} (which are based on finite difference 14 | approximations to the Hessian) they may end up being much too narrow, 15 | see the example in \code{\link{fracdiff.var}}. 16 | } 17 | \arguments{ 18 | \item{object}{an object of class \code{fracdiff}, typically result of 19 | \code{\link{fracdiff}(..)}.} 20 | \item{parm}{a specification of which parameters are to be given 21 | confidence intervals, either a vector of numbers or a vector of 22 | names. If missing, all parameters are considered.} 23 | \item{level}{the confidence level required.} 24 | \item{\dots}{additional argument(s) for methods.} 25 | } 26 | \value{ 27 | A matrix (or vector) with columns giving lower and upper confidence 28 | limits for each parameter. These will be labelled as (1-level)/2 and 29 | 1 - (1-level)/2 in \% (by default 2.5\% and 97.5\%). 30 | } 31 | \author{Spencer Graves posted the initial version to R-help.} 32 | \seealso{the generic \code{\link{confint}}; \code{\link{fracdiff}} model 33 | fitting, notably \code{\link{fracdiff.var}()} for re-estimating the 34 | variance-covariance matrix on which \code{confint()} builds entirely. 35 | } 36 | \examples{ 37 | set.seed(101) 38 | ts2 <- fracdiff.sim(5000, ar = .2, ma = -.4, d = .3) 39 | mFD <- fracdiff( ts2$series, nar = length(ts2$ar), nma = length(ts2$ma)) 40 | coef(mFD) 41 | confint(mFD) 42 | } 43 | \keyword{models} 44 | 45 | -------------------------------------------------------------------------------- /src/fracdiff.h: -------------------------------------------------------------------------------- 1 | 2 | // fdsim.c -------------------------------------- 3 | void fdsim(int *n, int *ip, int *iq, double *ar, double *ma, 4 | double *d__, double *mu, double *y, double *s, 5 | double *flmin, double *flmax, double *epmin, double *epmax); 6 | 7 | // fdcore.c -------------------------------------- 8 | 9 | void fracdf(double *x, int *n, int *m, int *nar, int *nma, 10 | double *dtol, double *drange, double *hood_etc, 11 | double *d__, double *ar, double *ma, double *w, 12 | int *lenw, int *iw, int *inform, // <- also use as input 13 | double *flmin, double *flmax, double *epmin, double *epmax); 14 | 15 | void fdfilt(double *x, double d, 16 | /* output : */ 17 | double *y, double *slogvk, 18 | /* using */ 19 | double *amk, double *ak, double *vk, 20 | double *phi, double *pi); 21 | 22 | void fdcom(int *n, int *m, int *nar, int *nma, 23 | double *hood, double *flmin, double *flmax, 24 | double *epmin, double *epmax); 25 | 26 | void ajqp_(double *qp, double *a, double *ajac, 27 | int lajac, int op_code, double *y); 28 | 29 | // fdhess.c -------------------------------------- 30 | 31 | void fdhpq(double *h, int *lh, double *w); 32 | 33 | void fdcov(double *x, double *d__, double *hh, 34 | double *hd, double *cov, int *lcov, double *cor, 35 | int *lcor, double *se, double *w, int *info); 36 | 37 | // fdmin.c -------------------------------------- 38 | 39 | typedef /* Subroutine */ void (*S_fp)(double *, double *, double *, int, int, double *); 40 | 41 | double lmder1(S_fp fcn, int m, int n, 42 | double *x, double *fvec, double *fjac, int ldfjac, 43 | double ftol, double xtol, double gtol, int maxfev, double *diag, 44 | int mode, double factor, 45 | int *info, int *nfev, int *njev, 46 | int *ipvt, double *qtf, 47 | double *wa1, double *wa2, double *wa3, double *wa4, double *y); 48 | 49 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "fracdiff.h" 5 | 6 | #include 7 | 8 | #define CDEF(name) {#name, (DL_FUNC) &name, sizeof(name ## _typ)/sizeof(name ## _typ[0]), name ##_typ} 9 | 10 | 11 | // -- ./fdsim.c -- 12 | static R_NativePrimitiveArgType fdsim_typ[13] = { 13 | /*n:*/ INTSXP, INTSXP, INTSXP, REALSXP, REALSXP, 14 | /*d__:*/ REALSXP, REALSXP, REALSXP, REALSXP, 15 | /*flmin__:*/ REALSXP, REALSXP, REALSXP, REALSXP 16 | }; 17 | 18 | // -- ./fdhess.c -- 19 | static R_NativePrimitiveArgType fdhpq_typ[3] = { 20 | REALSXP, INTSXP, REALSXP 21 | }; 22 | 23 | static R_NativePrimitiveArgType fdcov_typ[11] = { 24 | REALSXP, REALSXP, REALSXP, 25 | REALSXP, REALSXP, INTSXP, REALSXP, 26 | INTSXP, REALSXP, REALSXP, INTSXP 27 | }; 28 | 29 | // -- ./fdcore.c -- 30 | static R_NativePrimitiveArgType fracdf_typ[19] = { 31 | /* x */ REALSXP, INTSXP, INTSXP, INTSXP, INTSXP, 32 | /* dtol */REALSXP, REALSXP, REALSXP, 33 | /* d__*/ REALSXP, REALSXP, REALSXP, REALSXP, 34 | /* lenw */INTSXP, INTSXP, INTSXP, 35 | /* flmin*/REALSXP, REALSXP, REALSXP, REALSXP 36 | }; 37 | 38 | static R_NativePrimitiveArgType fdcom_typ[9] = { 39 | /* n */ INTSXP, INTSXP, INTSXP, INTSXP, 40 | /* hood */ REALSXP, REALSXP, REALSXP, 41 | /*epmin */ REALSXP, REALSXP 42 | }; 43 | 44 | static const R_CMethodDef CEntries[] = { 45 | CDEF(fdsim), 46 | CDEF(fdhpq), 47 | CDEF(fdcov), 48 | CDEF(fracdf), 49 | CDEF(fdcom), 50 | {NULL, NULL, 0} 51 | }; 52 | 53 | /* static R_CallMethodDef CallEntries[] = { 54 | * {NULL, NULL, 0} 55 | * }; 56 | */ 57 | 58 | /* static R_FortranMethodDef FortEntries[] = { 59 | * {NULL, NULL, 0} 60 | * }; 61 | */ 62 | 63 | void R_init_fracdiff(DllInfo *dll) 64 | { 65 | R_registerRoutines(dll, CEntries, NULL/*CallEntries*/, NULL/*FortEntries*/, NULL); 66 | R_useDynamicSymbols(dll, FALSE); 67 | } 68 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | TODO / Ideas see ---> ./Done for things finished 2 | ------------ ~~~~~~ 3 | 4 | 1. Now have class, but not yet residuals() & fitted(); predict() 5 | 1a. In any case, we want $residuals (as "arima"): ``the fitted innovations'' 6 | 7 | 1c. fracdiff.sim(): think about making it an *generalization* of arima.sim, 8 | maybe call the new function arfima.sim() and keep the old one as is. 9 | 10 | 11 | 12 | 2. call R's gammafn() and minimizers (Brent is there!), instead of "our own" 13 | 14 | 4. Consider the diverse filters, e.g. (0,d,0) --> (p,d,q) 15 | Now started implementing and testing in *R* : 16 | --> ./filters.R 17 | ~~~~~~~~~~~ 18 | 5. fracdiff() and fracdiff.var() share much code, including warning 19 | message generation. Clean up! See 'FIXME' in R/fracdiff.R ! 20 | 21 | 6. fracdiff.sim(): This really is a *filter* of the innovations. 22 | in C: 1) eps_t --> fARIMA(0, d, 0) =: Y_t 23 | 2) Y_t --> fARIMA(p, d, q) =: Z_t i.e. a simple ARMA() filter 24 | --> we should provide the "filter 1)" as a *separate* R function 25 | 26 | 27 | 8. Long-standing "Bug" / Problem: 28 | 29 | set.seed(1); (fdc <- fracdiff(X <- fracdiff.sim(n=100,d=0.25)$series))$covariance.dpq 30 | # d 31 | # d 1.901027e-12 32 | 33 | This is *clearly* too small: At least now added warning 34 | 35 | 36 | 37 | 38 | Hessian --> covariance 39 | ====================== 40 | 41 | 3. For the hessian / covariance { src/fdhess.c } : 42 | Think about trying several step-sizes and use stable ("optimal"?) one. 43 | 44 | 6. Currently C/Fortran uses old Linpack SVD and its own inverse, and 45 | just returns warnings if things "fail" there. 46 | Possibly rather do these in R, and possibly use 47 | using chol() and chol2inv() rather than svd. 48 | 49 | 7. We should return \hat{\sigma_\epsilon} or 50 | \hat{\sigma^2_\epsilon} 51 | ---> is the new "wnv" (= white noise variance) ??? 52 | -------------------------------------------------------------------------------- /man/diffseries.Rd: -------------------------------------------------------------------------------- 1 | \name{diffseries} 2 | \alias{diffseries} 3 | \title{Fractionally Differenciate Data} 4 | 5 | \description{ 6 | Differenciates the time series data using 7 | the approximated binomial expression of the long-memory filter and an estimate of 8 | the memory parameter in the ARFIMA(p,d,q) model. 9 | } 10 | \usage{ 11 | diffseries(x, d) 12 | } 13 | \arguments{ 14 | \item{x}{numeric vector or univariate time series.} 15 | \item{d}{number specifiying the fractional difference order.} 16 | } 17 | 18 | \value{the fractionally differenced series \code{x}.} 19 | \details{ 20 | Since 2018, we are using (an important correction of) the fast 21 | algorithm based on the discrete Fourier transform (\code{\link{fft}}) 22 | by Jensen and Nielsen which is significantly faster for large 23 | \code{n = length(x)}. 24 | } 25 | \references{ 26 | See those in \code{\link{fdSperio}}; additionally 27 | 28 | Reisen, V. A. and Lopes, S. (1999) 29 | Some simulations and applications 30 | of forecasting long-memory time series models; 31 | \emph{Journal of Statistical Planning and Inference} \bold{80}, 269--287. 32 | 33 | Reisen, V. A. Cribari-Neto, F. and Jensen, M.J. (2003) 34 | Long Memory Inflationary Dynamics. The case of Brazil. 35 | \emph{Studies in Nonlinear Dynamics and Econometrics} \bold{7}(3), 1--16. 36 | 37 | Jensen, Andreas Noack and Nielsen, Morten \enc{Ørregaard}{Oerregaard} (2014) 38 | A Fast Fractional Difference Algorithm. 39 | \emph{Journal of Time Series Analysis} \bold{35}(5), 428--436; 40 | \doi{10.1111/jtsa.12074}. 41 | } 42 | 43 | \author{Valderio A. Reisen \email{valderio@cce.ufes.br} and Artur 44 | J. Lemonte (first slow version), now hidden as \code{diffseries.0()}. 45 | 46 | Current version: Jensen and Nielsen (2014); tweaks by Martin Maechler, 2018. 47 | } 48 | 49 | \seealso{\code{\link{fracdiff.sim}}} 50 | 51 | \examples{ 52 | memory.long <- fracdiff.sim(80, d = 0.3) 53 | str(mGPH <- fdGPH(memory.long$series)) 54 | r <- diffseries(memory.long$series, d = mGPH$d) 55 | #acf(r) # shouldn't show structure - ideally 56 | } 57 | \keyword{ts} 58 | -------------------------------------------------------------------------------- /man/fracdiff.var.Rd: -------------------------------------------------------------------------------- 1 | \name{fracdiff.var} 2 | \alias{fracdiff.var} 3 | \title{Recompute Covariance Estimate for fracdiff} 4 | \usage{ 5 | fracdiff.var(x, fracdiff.out, h) 6 | } 7 | \arguments{ 8 | \item{x}{a univariate time series or a vector. Missing values (NAs) 9 | are not allowed.} 10 | \item{fracdiff.out}{output from \code{fracdiff} for time series \code{x}.} 11 | \item{h}{finite-difference interval length (\eqn{ > 0}) for approximating partial 12 | derivatives with respect to the \code{d} parameter. Typically smaller 13 | than the one in \code{fracdiff.out}} 14 | } 15 | \description{ 16 | Allows the finite-difference interval to be altered for recomputation of the 17 | covariance estimate for \code{fracdiff}. 18 | } 19 | \value{ 20 | an object of S3 \code{\link{class}} \code{"fracdiff"}, i.e., basically 21 | a list with the same elements as the result from 22 | \code{\link{fracdiff}}, but with possibly different values for the 23 | hessian, covariance, and correlation matrices and for standard error, 24 | as well as for \code{h}. 25 | } 26 | \seealso{ 27 | \code{fracdiff}, also for references. 28 | } 29 | \examples{ 30 | ## Generate a fractionally-differenced ARIMA(1,d,1) model : 31 | set.seed(5) # reproducibility; x86_64 Lnx: get warning 32 | tst <- fracdiff.sim(500, ar = .2, ma = .4, d = .3)$series 33 | ## estimate the parameters in an ARIMA(1,d,1) model for the simulated series 34 | fd.out <- fracdiff(tst, nar= 1, nma = 1) # warning ... maybe change 'h' 35 | summary(fd.out)## *** Warning ... {has been stored} --> h = 7.512e-6 36 | 37 | ## Modify the covariance estimate by changing the finite-difference interval 38 | (fd.o2 <- fracdiff.var(tst, fd.out, h = 1e-3)) 39 | ## looks identical as print(fd.out), 40 | ## however these (e.g.) differ : 41 | vcov(fd.out) 42 | vcov(fd.o2) 43 | 44 | ## A case, were the default variance is *clearly* way too small: 45 | set.seed(1); fdc <- fracdiff(X <- fracdiff.sim(n=100, d=0.25)$series) 46 | fdc 47 | # Confidence intervals just based on asymp.normal approx. and std.errors: 48 | confint(fdc) # ridiculously too narrow 49 | } 50 | \keyword{ts} 51 | -------------------------------------------------------------------------------- /tests/ex-Vinod.R: -------------------------------------------------------------------------------- 1 | ## From: VINOD@FORDHAM.EDU 2 | ## To: maechler@stat.math.ethz.ch 3 | ## X-Spam-Level: * 4 | ## Subject: fracdiff in R does not work for gnp series "insufficient workspace" 5 | ## Date: Sun, 15 May 2005 13:24:46 -0400 6 | 7 | ## Dear Martin Maechler 8 | 9 | ## I teach econometrics at Fordham. For some reason the fracdiff 10 | ## does not work for the basic gnp series. 11 | 12 | library(fracdiff) 13 | 14 | if(FALSE) { 15 | ##MM library(urca) 16 | ##MM data(npext) 17 | data(npext, package = "urca") # Nelson Plosser data 18 | ## "bad practice": attach(npext) 19 | realgnp2 <- npext[50:129, "realgnp"] # to exclude missing data 20 | } else { ## keep test independent: 21 | realgnp2 <- 22 | c(4.7604631, 4.7883247, 4.8138091, 4.8690717, 4.8782461, 4.8331023, 23 | 4.8243057, 4.9000761, 4.9067552, 5.0225639, 4.9863426, 4.9416424, 24 | 4.8504665, 4.9972123, 5.1113852, 5.1089712, 5.1896179, 5.2470241, 25 | 5.2459709, 5.2517497, 5.3161573, 5.2122147, 5.1316723, 4.9712012, 26 | 4.9522997, 5.0388988, 5.1328529, 5.2626902, 5.3141907, 5.2621719, 27 | 5.3442463, 5.4258307, 5.5748121, 5.6964221, 5.8203796, 5.8897086, 28 | 5.872681, 5.7449244, 5.7362497, 5.7798172, 5.7810521, 5.8729625, 29 | 5.9490788, 5.9791389, 6.0229632, 6.0088132, 6.0822189, 6.1005431, 30 | 6.1147878, 6.1032295, 6.1652077, 6.1897005, 6.2089924, 6.2724996, 31 | 6.3117348, 6.3649229, 6.4261648, 6.4893569, 6.5150089, 6.5604647, 32 | 6.5857578, 6.5792512, 6.6067, 6.6552832, 6.705961, 6.700553, 33 | 6.687906, 6.7356178, 6.781224, 6.8328012, 6.8572808, 6.8556192, 34 | 6.8747935, 6.8489768, 6.8840768, 6.9496707, 6.9826227, 7.0096668, 35 | 7.0455416, 7.0888837) 36 | } 37 | 38 | fr1 <- fracdiff(realgnp2, nar = 0, nma = 0, M = 100) 39 | 40 | ## COMPUTER SAYS 41 | ## Error in switch(result$info, stop("insufficient workspace"), stop("error in 42 | ## gamma function"), : 43 | ## insufficient workspace 44 | 45 | fr1 46 | 47 | ## ... 48 | 49 | ## Hrishikesh D. Vinod 50 | ## Professor of Economics, Fordham University 51 | ## E-Mail: Vinod@fordham.edu 52 | ## Web page: http://www.fordham.edu/economics/vinod 53 | 54 | summary(fr1) 55 | -------------------------------------------------------------------------------- /man/fdSperio.Rd: -------------------------------------------------------------------------------- 1 | \name{fdSperio} 2 | \alias{fdSperio} 3 | 4 | \title{Sperio Estimate for 'd' in ARFIMA(p,d,q)} 5 | \description{ 6 | This function makes use Reisen (1994) estimator to estimate the memory 7 | parameter d in the ARFIMA(p,d,q) model. It is based on the regression 8 | equation using the smoothed periodogram function as an estimate of the 9 | spectral density. 10 | } 11 | \usage{ 12 | fdSperio(x, bandw.exp = 0.5, beta = 0.9) 13 | } 14 | \arguments{ 15 | \item{x}{univariate time series data.} 16 | \item{bandw.exp}{numeric: exponent of the bandwidth used in the regression equation.} 17 | \item{beta}{numeric: exponent of the bandwidth used in the lag Parzen window.} 18 | } 19 | \details{ 20 | The function also provides the asymptotic standard deviation and the 21 | standard error deviation of the fractional estimator. 22 | 23 | The bandwidths are \code{bw = trunc(n ^ bandw.exp)}, where 0 < bandw.exp < 1 24 | and n is the sample size. Default \code{bandw.exp= 0.5}; 25 | \cr 26 | and \code{bw2 = trunc(n ^ beta)}, where 0 < beta < 1 and n is the 27 | sample size. Default \code{beta = 0.9}. 28 | } 29 | 30 | \value{ 31 | a list with components 32 | \item{d}{Sperio estimate} 33 | \item{sd.as}{asymptotic standard deviation} 34 | \item{sd.reg}{standard error deviation} 35 | } 36 | \references{ 37 | Geweke, J. and Porter-Hudak, S. (1983) 38 | The estimation and application of long memory time series models. 39 | \emph{Journal of Time Series Analysis} \bold{4}(4), 221--238. 40 | 41 | Reisen, V. A. (1994) 42 | Estimation of the fractional difference parameter in the ARFIMA(p,d,q) 43 | model using the smoothed periodogram. 44 | \emph{Journal Time Series Analysis}, \bold{15}(1), 335--350. 45 | 46 | Reisen, V. A., B. Abraham, and E. M. M. Toscano (2001) 47 | Parametric and semiparametric estimations of stationary univariate 48 | ARFIMA model. 49 | \emph{Brazilian Journal of Probability and Statistics} \bold{14}, 185--206. 50 | } 51 | \author{Valderio A. Reisen \email{valderio@cce.ufes.br} and Artur J. Lemonte} 52 | 53 | \seealso{\code{\link{fdGPH}}, \code{\link{fracdiff}} 54 | } 55 | 56 | \examples{ 57 | memory.long <- fracdiff.sim(1500, d = 0.3) 58 | spm <- fdSperio(memory.long$series) 59 | str(spm, digits=6) 60 | } 61 | \keyword{ts} 62 | -------------------------------------------------------------------------------- /man/fd-methods.Rd: -------------------------------------------------------------------------------- 1 | \name{fracdiff-methods} 2 | \alias{coef.fracdiff} 3 | \alias{logLik.fracdiff} 4 | \alias{print.fracdiff} 5 | \alias{fitted.fracdiff} 6 | \alias{residuals.fracdiff} 7 | \alias{vcov.fracdiff} 8 | \alias{summary.fracdiff} 9 | \alias{print.summary.fracdiff} 10 | % 11 | \title{Many Methods for "fracdiff" Objects} 12 | \description{ 13 | Many \dQuote{accessor} methods for \code{\link{fracdiff}} objects, 14 | notably \code{\link{summary}}, \code{\link{coef}}, \code{\link{vcov}}, and 15 | \code{\link{logLik}}; further \code{\link{print}()} methods were needed. 16 | } 17 | \usage{ 18 | \method{coef}{fracdiff}(object, \dots) 19 | \method{logLik}{fracdiff}(object, \dots) 20 | \method{print}{fracdiff}(x, digits = getOption("digits"), \dots) 21 | \method{summary}{fracdiff}(object, symbolic.cor = FALSE, \dots) 22 | \method{print}{summary.fracdiff}(x, digits = max(3, getOption("digits") - 3), 23 | correlation = FALSE, symbolic.cor = x$symbolic.cor, 24 | signif.stars = getOption("show.signif.stars"), \dots) 25 | \method{fitted}{fracdiff}(object, \dots) 26 | \method{residuals}{fracdiff}(object, \dots) 27 | \method{vcov}{fracdiff}(object, \dots) 28 | } 29 | \arguments{ 30 | \item{x, object}{object of class \code{fracdiff}.} 31 | \item{digits}{the number of significant digits to use when printing.} 32 | \item{\dots}{further arguments passed from and to methods.} 33 | \item{correlation}{logical; if \code{TRUE}, the correlation matrix of 34 | the estimated parameters is returned and printed.} 35 | \item{symbolic.cor}{logical. If \code{TRUE}, print the correlations in 36 | a symbolic form (see \code{\link{symnum}}) rather than as numbers.} 37 | \item{signif.stars}{logical. If \code{TRUE}, \dQuote{significance stars} 38 | are printed for each coefficient.} 39 | } 40 | \author{Martin Maechler; Rob Hyndman contributed the 41 | \code{\link{residuals}()} and \code{\link{fitted}()} methods.} 42 | \seealso{\code{\link{fracdiff}} to get \code{"fracdiff"} objects, 43 | \code{\link{confint.fracdiff}} for the \code{\link{confint}} method; 44 | further, \code{\link{fracdiff.var}}. 45 | } 46 | \examples{ 47 | set.seed(7) 48 | ts4 <- fracdiff.sim(10000, ar = c(0.6, -.05, -0.2), ma = -0.4, d = 0.2) 49 | modFD <- fracdiff( ts4$series, nar = length(ts4$ar), nma = length(ts4$ma)) 50 | ## -> warning (singular Hessian) %% FIXME ??? 51 | coef(modFD) # the estimated parameters 52 | vcov(modFD) 53 | smFD <- summary(modFD) 54 | smFD 55 | coef(smFD) # gives the whole table 56 | AIC(modFD) # AIC works because of the logLik() method 57 | stopifnot(exprs = { 58 | 59 | }) 60 | } 61 | \keyword{print} 62 | \keyword{models} 63 | -------------------------------------------------------------------------------- /R/diffseries.R: -------------------------------------------------------------------------------- 1 | #### Fractional differentiation -- the inverse of fractional integration 2 | #### -------------------------- ---------------------------------------- 3 | 4 | ## by Valderio Reisen -- Dec.2005-- 5 | ## MM: This is 'not optimal' -- and I may have better in ../filters.R ? <<< FIXME >>> 6 | diffseries0 <- function(x, d) 7 | { 8 | x <- as.data.frame(x) 9 | names(x) <- "series" 10 | x <- x$series 11 | if (NCOL(x) > 1) 12 | stop("only implemented for univariate time series") 13 | if (any(is.na(x))) 14 | stop("NAs in x") 15 | n <- length(x) 16 | stopifnot(n >= 2) 17 | x <- x - mean(x) 18 | PI <- numeric(n) 19 | PI[1] <- -d 20 | for (k in 2:n) { 21 | PI[k] <- PI[k-1]*(k - 1 - d)/k 22 | } 23 | ydiff <- x 24 | for (i in 2:n) { 25 | ydiff[i] <- x[i] + sum(PI[1:(i-1)]*x[(i-1):1]) 26 | } 27 | ## return numeric! 28 | ydiff 29 | } 30 | 31 | 32 | 33 | ## From: alexios ghalanos 34 | ## Date: Mon, 13 Jan 2014 19:58:48 +0000 35 | ## To: 36 | ## Subject: fracdiff 37 | 38 | ## Dear Martin, 39 | 40 | ## Just a quick note, should it be of interest, that a very fast algorithm 41 | ## for diffseries was recently published (1st version, 2013; 2nd: March 2014): 42 | ## http://qed.econ.queensu.ca/working_papers/papers/qed_wp_1307.pdf‎ (ok, but wget fails!) 43 | ## (MM: This is now published ===> see ../man/diffseries.Rd) 44 | 45 | ## Page 6 contains the R code and page 7 the benchmark timings. 46 | 47 | ## Quick check (win 7 x64, R 3.02) shows a large performance boost (for 'large' n): 48 | #-------------------------------------- 49 | ## library(microbenchmark) 50 | ## library(fracdiff) 51 | ## memory.long <- fracdiff.sim(8000, d = 0.3) 52 | ## mGPH <- fdGPH(memory.long$series) 53 | ## Jensen and Nielsen code: 54 | ## (slightly improved by MM) 55 | diffseries <- function(x, d) { 56 | stopifnot((iT <- length(x)) >= 2) 57 | x <- x - mean(x) ## <<-- Missing in J+N(2014) 58 | np2 <- nextn(iT+iT - 1L)# changed from J+N: also factors 3 and 5 59 | pad <- rep.int(0, np2-iT) 60 | k <- seq_len(iT - 1L) 61 | b <- c(1, cumprod((k - (d+1))/ k), pad) 62 | ## ~= convolve(x, b, type = "filter") : 63 | dx <- fft(fft(b) * fft(c(x, pad)), inverse =TRUE)[seq_len(iT)] / np2 64 | Re(dx) 65 | } 66 | ## microbenchmark(diffseries(memory.long$series, d = mGPH$d), 67 | ## diffseries2(memory.long$series, d = mGPH$d)) 68 | # Unit: milliseconds 69 | # diffseries 852.314992 (median) 70 | # diffseries2 3.181065 (median) 71 | #------------------------------------------------ 72 | 73 | 74 | ## Best Regards, 75 | ## Alexios 76 | 77 | -------------------------------------------------------------------------------- /tests/sim-2.R: -------------------------------------------------------------------------------- 1 | require(fracdiff) 2 | 3 | .ptime <- proc.time() 4 | ##>> *no* *.Rout.save here ===> can well have if(doExtras) ... 5 | (doExtras <- fracdiff:::doExtras()) 6 | 7 | ## confirm that we guessed right: 8 | ## fracdiff.sim(....., d = 0, backComp = FALSE) <===> arima.sim(....) 9 | 10 | AR <- c(0.7, -0.1, 0.2) 11 | MA <- c(-0.5, 0.4, 0.4) 12 | n <- 512 ; sd <- 0.1 13 | n.st <- 10 14 | 15 | set.seed(1) 16 | for(i in 1:200) { 17 | cat(sprintf("%3d ", i)) 18 | p <- sample(0:length(AR), 1) 19 | q <- sample(0:length(MA), 1) 20 | .ar <- AR[seq_len(p)] 21 | .ma <- MA[seq_len(q)] 22 | n.st <- p+q+ rpois(1, lambda = 2) 23 | sid <- round(runif(1)* 1000) 24 | set.seed(sid) 25 | y1 <- arima.sim(list(ar = .ar, ma = .ma), n = n, n.start = n.st, sd = sd) 26 | set.seed(sid) 27 | y2 <- fracdiff.sim(n = n, ar = .ar, ma = - .ma, d = 0, 28 | n.start = n.st, sd = sd, backComp = FALSE) 29 | if(!isTRUE(aeq <- all.equal(c(y1), y2$series, tol = 1e-15))) 30 | cat("y1 and y2 are not equal: ", aeq,"\n") 31 | if(!(i %% 10)) cat("\n") 32 | } 33 | 34 | cat('Time elapsed: ', proc.time() - .ptime,'\n'); .ptime <- proc.time() 35 | 36 | if(doExtras) withAutoprint({ 37 | isee <- 1:500 38 | do5c <- lapply(isee, function(seed) { set.seed(seed) 39 | tst <- fracdiff.sim(1000, ar = .6, ma = -.4, d = .3)$ser 40 | fracdiff(tst, nar = 1, nma = 1) 41 | }) 42 | ## There were 56 warnings (use warnings() to see them) 43 | summary(warnings()) ## 56 x { unable to compute correlation matrix; maybe change 'h' } 44 | str( msg5c <- sapply(do5c, `[[`, "msg") ) # matrix with 2 rows 45 | table(msg5c["fdcov", ]) 46 | str(which(prbl <- msg5c["fdcov", ] != "ok")) 47 | ## int [1:56] 5 22 26 29 37 39 65 66 69 71 ... 48 | 49 | ## now want to use fracdiff.var() with different 'h' to *fix* the failures 50 | ## (need to re-simulate as we did not keep 'tst's above) 51 | L <- lapply(isee[prbl], function(seed) { 52 | set.seed(seed) 53 | tst <- fracdiff.sim(1000, ar = .6, ma = -.4, d = .3)$ser # -> 56 warnings 54 | fd. <- fracdiff(tst, nar = 1, nma = 1) 55 | hs <- fd.[["h"]] / 2^(3:19) 56 | fd2L <- lapply(hs, function(h) suppressWarnings(fracdiff.var(tst, fd., h = h))) 57 | table(msgCov <- sapply(fd2L, `[[`, "msg")["fdcov",]) 58 | if(any(ok <- msgCov == "ok")) list(h.old = fd.[["h"]], fits.ok = fd2L[ok]) else list() 59 | }) 60 | cat("fracdiff.var() fixed:", sum(okL <- lengths(L) > 0), "(out of", length(L), "problem cases)\n") 61 | ## MM: see fracdiff.var() fixed: 43 (out of 56 problem cases) -- sometimes really needing h/32768 62 | invisible(lapply(L[okL], function(lst) { 63 | cat(sprintf("h.old= %12g", lst[["h.old"]])) 64 | if(FALSE) {## too much: 65 | ## cat("h.old: ", lst[["h.old"]], " summary():\n") 66 | lapply(lst[["fits.ok"]], function(fm) print(summary(fm))) 67 | } 68 | cat(" -- h ratio(s) old/new = 2 ^ ... : ") 69 | print(log2(lst[["h.old"]] / sapply(lst[["fits.ok"]], `[[`, "h"))) 70 | })) 71 | ## 72 | cat('Time elapsed: ', proc.time() - .ptime,'\n') 73 | }) 74 | -------------------------------------------------------------------------------- /tests/Valderio-ex.Rout.save: -------------------------------------------------------------------------------- 1 | 2 | R Under development (unstable) (2020-01-16 r77667) -- "Unsuffered Consequences" 3 | Copyright (C) 2020 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | R is a collaborative project with many contributors. 11 | Type 'contributors()' for more information and 12 | 'citation()' on how to cite R or R packages in publications. 13 | 14 | Type 'demo()' for some demos, 'help()' for on-line help, or 15 | 'help.start()' for an HTML browser interface to help. 16 | Type 'q()' to quit R. 17 | 18 | > library(fracdiff) 19 | > 20 | > set.seed(1) 21 | > ## examples(fdSperio) 22 | > mem.long <- fracdiff.sim(1500, d = 0.3) 23 | > spm <- fdSperio(mem.long$series) 24 | > str(spm, digits=6) 25 | List of 3 26 | $ d : num 0.189757 27 | $ sd.as : num 0.048145 28 | $ sd.reg: num 0.0319748 29 | > 30 | > set.seed(8) 31 | > ## examples(fdGPH) 32 | > mem.l2 <- fracdiff.sim(1024, d = 0.25) 33 | > fdGPH(mem.l2$series) 34 | $d 35 | [1] 0.2357737 36 | 37 | $sd.as 38 | [1] 0.1346387 39 | 40 | $sd.reg 41 | [1] 0.1209971 42 | 43 | > 44 | > diffserie0 <- fracdiff:::diffseries0 # the old slow for()-loop one 45 | > stopifnot(exprs = { 46 | + all.equal(diffserie0(1:20, d = 1), c(-9.5, rep(1, 20-1)), tol = 1e-15) 47 | + all.equal(diffseries(1:20, d = 1), c(-9.5, rep(1, 20-1)), tol = 1e-13) # fft 48 | + all.equal(diffserie0(-10:10, d = 0), -10:10, tol = 1e-15) 49 | + all.equal(diffseries(-10:10, d = 0), -10:10, tol = 1e-13) 50 | + all.equal(diffserie0(-10:10, d = 1/2), 51 | + diffseries(-10:10, d = 1/2), tol = 1e-13) # see 4.3e-16 on 64b-Lnx 52 | + }) 53 | > 54 | > set.seed(123) 55 | > ## example(diffseries) 56 | > mem.l3 <- fracdiff.sim(80, d = 0.3) 57 | > mGPH <- fdGPH(mem.l3$series) 58 | > r0 <- diffserie0(mem.l3$series, d = mGPH$d) 59 | > r. <- diffseries(mem.l3$series, d = mGPH$d) 60 | > print(r0, digits = 4) 61 | [1] -0.761863 -0.648357 1.156142 0.254446 0.205702 1.790090 1.061263 62 | [8] -0.727289 -0.711688 -0.641284 0.969069 0.581372 0.643513 0.406330 63 | [15] -0.308041 1.804514 1.121691 -1.376291 0.516945 -0.296126 -1.079355 64 | [22] -0.539937 -1.294863 -1.253349 -1.235765 -2.351131 -0.223510 -0.376664 65 | [29] -1.579870 0.473816 0.201878 -0.440213 0.602163 0.889618 1.028929 66 | [36] 1.031588 0.971153 0.386139 -0.015032 -0.256695 -0.707172 -0.421774 67 | [43] -1.471215 1.610035 1.508302 -0.597359 -0.429911 -0.591076 0.550370 68 | [50] 0.002532 0.255906 0.042294 -0.017154 1.366683 0.206105 1.723059 69 | [57] -0.901849 0.538978 0.339388 0.422938 0.616481 -0.192038 -0.254046 70 | [64] -1.031030 -1.378216 -0.226398 0.183380 -0.022056 0.848218 2.268592 71 | [71] 0.286371 -1.954859 0.551967 -0.638054 -0.878345 0.681981 -0.196609 72 | [78] -1.287879 -0.267172 -0.392858 73 | > r <- all.equal(r0, r., tol = 0, countEQ = TRUE) # average rel.error, seen ~ 3.5e-16 74 | > if(is.character(r) && as.numeric(sub(".*: ", '', r)) > 4e-15) 75 | + print(r) 76 | > stopifnot(all.equal(r0, r., tol = 1e-13)) 77 | > print(acf(r0)) # 78 | 79 | Autocorrelations of series 'r0', by lag 80 | 81 | 0 1 2 3 4 5 6 7 8 9 10 82 | 1.000 0.239 0.045 0.198 -0.051 -0.039 -0.024 -0.055 -0.093 -0.115 -0.084 83 | 11 12 13 14 15 16 17 18 19 84 | -0.067 -0.197 -0.168 0.081 -0.068 -0.016 0.098 -0.061 -0.042 85 | > mtext("(shouldn't show structure - ideally)") 86 | > 87 | > cat("Time used: ", proc.time(),"\n") # for ``statistical reasons'' 88 | Time used: 0.153 0.026 0.233 0.002 0.004 89 | > 90 | > proc.time() 91 | user system elapsed 92 | 0.155 0.030 0.233 93 | -------------------------------------------------------------------------------- /tests/ex-Vinod.Rout-32b: -------------------------------------------------------------------------------- 1 | 2 | R version 2.13.1 Patched (2011-08-08 r56671) 3 | Copyright (C) 2011 The R Foundation for Statistical Computing 4 | ISBN 3-900051-07-0 5 | Platform: i686-pc-linux-gnu (32-bit) 6 | 7 | R is free software and comes with ABSOLUTELY NO WARRANTY. 8 | You are welcome to redistribute it under certain conditions. 9 | Type 'license()' or 'licence()' for distribution details. 10 | 11 | R is a collaborative project with many contributors. 12 | Type 'contributors()' for more information and 13 | 'citation()' on how to cite R or R packages in publications. 14 | 15 | Type 'demo()' for some demos, 'help()' for on-line help, or 16 | 'help.start()' for an HTML browser interface to help. 17 | Type 'q()' to quit R. 18 | 19 | > ## From: VINOD@FORDHAM.EDU 20 | > ## To: maechler@stat.math.ethz.ch 21 | > ## X-Spam-Level: * 22 | > ## Subject: fracdiff in R does not work for gnp series "insufficient workspace" 23 | > ## Date: Sun, 15 May 2005 13:24:46 -0400 24 | > 25 | > ## Dear Martin Maechler 26 | > 27 | > ## I teach econometrics at Fordham. For some reason the fracdiff 28 | > ## does not work for the basic gnp series. 29 | > 30 | > library(fracdiff) 31 | > 32 | > if(FALSE) { 33 | + ##MM library(urca) 34 | + ##MM data(npext) 35 | + data(npext, package = "urca") # Nelson Plosser data 36 | + ## "bad practice": attach(npext) 37 | + realgnp2 <- npext[50:129, "realgnp"] # to exclude missing data 38 | + } else { ## keep test independent: 39 | + realgnp2 <- 40 | + c(4.7604631, 4.7883247, 4.8138091, 4.8690717, 4.8782461, 4.8331023, 41 | + 4.8243057, 4.9000761, 4.9067552, 5.0225639, 4.9863426, 4.9416424, 42 | + 4.8504665, 4.9972123, 5.1113852, 5.1089712, 5.1896179, 5.2470241, 43 | + 5.2459709, 5.2517497, 5.3161573, 5.2122147, 5.1316723, 4.9712012, 44 | + 4.9522997, 5.0388988, 5.1328529, 5.2626902, 5.3141907, 5.2621719, 45 | + 5.3442463, 5.4258307, 5.5748121, 5.6964221, 5.8203796, 5.8897086, 46 | + 5.872681, 5.7449244, 5.7362497, 5.7798172, 5.7810521, 5.8729625, 47 | + 5.9490788, 5.9791389, 6.0229632, 6.0088132, 6.0822189, 6.1005431, 48 | + 6.1147878, 6.1032295, 6.1652077, 6.1897005, 6.2089924, 6.2724996, 49 | + 6.3117348, 6.3649229, 6.4261648, 6.4893569, 6.5150089, 6.5604647, 50 | + 6.5857578, 6.5792512, 6.6067, 6.6552832, 6.705961, 6.700553, 51 | + 6.687906, 6.7356178, 6.781224, 6.8328012, 6.8572808, 6.8556192, 52 | + 6.8747935, 6.8489768, 6.8840768, 6.9496707, 6.9826227, 7.0096668, 53 | + 7.0455416, 7.0888837) 54 | + } 55 | > 56 | > fr1 <- fracdiff(realgnp2, nar = 0, nma = 0, M = 100) 57 | > 58 | > ## COMPUTER SAYS 59 | > ## Error in switch(result$info, stop("insufficient workspace"), stop("error in 60 | > ## gamma function"), : 61 | > ## insufficient workspace 62 | > 63 | > fr1 64 | 65 | Call: 66 | fracdiff(x = realgnp2, nar = 0, nma = 0, M = 100) 67 | 68 | Coefficients: 69 | d 70 | 0.4977438 71 | sigma[eps] = 0.185019 72 | a list with components: 73 | [1] "log.likelihood" "n" "msg" "d" 74 | [5] "ar" "ma" "covariance.dpq" "fnormMin" 75 | [9] "sigma" "stderror.dpq" "correlation.dpq" "h" 76 | [13] "d.tol" "M" "hessian.dpq" "length.w" 77 | [17] "call" 78 | > 79 | > ## ... 80 | > 81 | > ## Hrishikesh D. Vinod 82 | > ## Professor of Economics, Fordham University 83 | > ## E-Mail: Vinod@fordham.edu 84 | > ## Web page: http://www.fordham.edu/economics/vinod 85 | > 86 | > summary(fr1) 87 | 88 | Call: 89 | fracdiff(x = realgnp2, nar = 0, nma = 0, M = 100) 90 | 91 | Coefficients: 92 | Estimate Std. Error z value Pr(>|z|) 93 | d 4.977e-01 2.072e-07 2402593 <2e-16 *** 94 | --- 95 | Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 96 | sigma[eps] = 0.185019 97 | [d.tol = 0.0001221, M = 100, h = 2.078e-07] 98 | Log likelihood: 18.72 ==> AIC = -33.44708 [2 deg.freedom] 99 | > 100 | -------------------------------------------------------------------------------- /man/fracdiff.sim.Rd: -------------------------------------------------------------------------------- 1 | \name{fracdiff.sim} 2 | \alias{fracdiff.sim} 3 | \title{Simulate fractional ARIMA Time Series} 4 | \description{ 5 | Generates simulated long-memory time series data from the 6 | fractional ARIMA(p,d,q) model. This is a test problem generator for 7 | \code{\link{fracdiff}}. 8 | 9 | Note that the MA coefficients have \emph{inverted} signs 10 | compared to other parametrizations, see the details in 11 | \code{\link{fracdiff}}. 12 | } 13 | \usage{ 14 | fracdiff.sim(n, ar = NULL, ma = NULL, d, 15 | rand.gen = rnorm, innov = rand.gen(n+q, ...), 16 | n.start = NA, backComp = TRUE, allow.0.nstart = FALSE, 17 | start.innov = rand.gen(n.start, ...), 18 | ..., mu = 0) 19 | } 20 | \arguments{ 21 | \item{n}{length of the time series.} 22 | \item{ar}{vector of autoregressive parameters; empty by default.} 23 | \item{ma}{vector of moving average parameters; empty by default.} 24 | \item{d}{fractional differencing parameter.} 25 | \item{rand.gen}{a function to generate the innovations; the default, 26 | \code{\link{rnorm}} generates white N(0,1) noise.} 27 | \item{innov}{an optional times series of innovations. If not 28 | provided, \code{rand.gen()} is used.} 29 | \item{n.start}{length of \dQuote{burn-in} period. If \code{NA}, the 30 | default, the same value as in \code{\link{arima.sim}} is computed.} 31 | \item{backComp}{logical indicating if back compatibility with older 32 | versions of \code{fracdiff.sim} is desired. Otherwise, for 33 | \code{d = 0}, compatibility with \R's \code{\link{arima.sim}} is 34 | achieved.} 35 | \item{allow.0.nstart}{logical indicating if \code{n.start = 0} should 36 | be allowed even when \eqn{p + q > 0}. This not recommended unless 37 | for producing the same series as with older versions of 38 | \code{fracdiff.sim}.} 39 | \item{start.innov}{an optional vector of innovations to be used for 40 | the burn-in period. If supplied there must be at least 41 | \code{n.start} values.} 42 | \item{\dots}{additional arguments for \code{rand.gen()}. Most usefully, 43 | the standard deviation of the innovations generated by \code{rnorm} 44 | can be specified by \code{sd}.} 45 | \item{mu}{time series mean (added at the end).} 46 | } 47 | \value{ 48 | a list containing the following elements : 49 | \item{series}{time series} 50 | \item{ar, ma, d, mu, n.start}{same as input} 51 | } 52 | \seealso{ 53 | \code{\link{fracdiff}}, also for references; 54 | \code{\link[stats]{arima.sim}} 55 | } 56 | \examples{ 57 | ## Pretty (too) short to "see" the long memory 58 | fracdiff.sim(100, ar = .2, ma = .4, d = .3) 59 | 60 | ## longer with "extreme" ar: 61 | r <- fracdiff.sim(n=1500, ar=-0.9, d= 0.3) 62 | plot(as.ts(r$series)) 63 | 64 | ## Show that MA coefficients meaning is inverted 65 | ## compared to stats :: arima : 66 | 67 | AR <- 0.7 68 | MA <- -0.5 69 | n.st <- 2 70 | 71 | AR <- c(0.7, -0.1) 72 | MA <- c(-0.5, 0.4) 73 | n <- 512 ; sd <- 0.1 74 | n.st <- 10 75 | 76 | set.seed(101) 77 | Y1 <- arima.sim(list(ar = AR, ma = MA), n = n, n.start = n.st, sd = sd) 78 | plot(Y1) 79 | 80 | # For our fracdiff, reverse the MA sign: 81 | set.seed(101) 82 | Y2 <- fracdiff.sim(n = n, ar = AR, ma = - MA, d = 0, 83 | n.start = n.st, sd = sd)$series 84 | lines(Y2, col=adjustcolor("red", 0.5)) 85 | ## .. no, you don't need glasses ;-) Y2 is Y1 shifted slightly 86 | 87 | ##' rotate left by k (k < 0: rotate right) 88 | rot <- function(x, k) { 89 | stopifnot(k == round(k)) 90 | n <- length(x) 91 | if(k <- k \%\% n) x[c((k+1):n, 1:k)] else x 92 | } 93 | k <- n.st - 2 94 | Y2.s <- rot(Y2, k) 95 | head.matrix(cbind(Y1, Y2.s)) 96 | plot(Y1, Y2.s); i <- (n-k+1):n 97 | text(Y1[i], Y2.s[i], i, adj = c(0,0)-.1, col=2) 98 | 99 | ## With backComp = FALSE, get *the same* as arima.sim(): 100 | set.seed(101) 101 | Y2. <- fracdiff.sim(n = n, ar = AR, ma = - MA, d = 0, 102 | n.start = n.st, sd = sd, backComp = FALSE)$series 103 | stopifnot( all.equal( c(Y1), Y2., tolerance= 1e-15)) 104 | } 105 | \keyword{ts} 106 | -------------------------------------------------------------------------------- /tests/ex-Vinod.Rout-64b: -------------------------------------------------------------------------------- 1 | 2 | R Under development (unstable) (2020-01-16 r77667) -- "Unsuffered Consequences" 3 | Copyright (C) 2020 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | R is a collaborative project with many contributors. 11 | Type 'contributors()' for more information and 12 | 'citation()' on how to cite R or R packages in publications. 13 | 14 | Type 'demo()' for some demos, 'help()' for on-line help, or 15 | 'help.start()' for an HTML browser interface to help. 16 | Type 'q()' to quit R. 17 | 18 | > ## From: VINOD@FORDHAM.EDU 19 | > ## To: maechler@stat.math.ethz.ch 20 | > ## X-Spam-Level: * 21 | > ## Subject: fracdiff in R does not work for gnp series "insufficient workspace" 22 | > ## Date: Sun, 15 May 2005 13:24:46 -0400 23 | > 24 | > ## Dear Martin Maechler 25 | > 26 | > ## I teach econometrics at Fordham. For some reason the fracdiff 27 | > ## does not work for the basic gnp series. 28 | > 29 | > library(fracdiff) 30 | > 31 | > if(FALSE) { 32 | + ##MM library(urca) 33 | + ##MM data(npext) 34 | + data(npext, package = "urca") # Nelson Plosser data 35 | + ## "bad practice": attach(npext) 36 | + realgnp2 <- npext[50:129, "realgnp"] # to exclude missing data 37 | + } else { ## keep test independent: 38 | + realgnp2 <- 39 | + c(4.7604631, 4.7883247, 4.8138091, 4.8690717, 4.8782461, 4.8331023, 40 | + 4.8243057, 4.9000761, 4.9067552, 5.0225639, 4.9863426, 4.9416424, 41 | + 4.8504665, 4.9972123, 5.1113852, 5.1089712, 5.1896179, 5.2470241, 42 | + 5.2459709, 5.2517497, 5.3161573, 5.2122147, 5.1316723, 4.9712012, 43 | + 4.9522997, 5.0388988, 5.1328529, 5.2626902, 5.3141907, 5.2621719, 44 | + 5.3442463, 5.4258307, 5.5748121, 5.6964221, 5.8203796, 5.8897086, 45 | + 5.872681, 5.7449244, 5.7362497, 5.7798172, 5.7810521, 5.8729625, 46 | + 5.9490788, 5.9791389, 6.0229632, 6.0088132, 6.0822189, 6.1005431, 47 | + 6.1147878, 6.1032295, 6.1652077, 6.1897005, 6.2089924, 6.2724996, 48 | + 6.3117348, 6.3649229, 6.4261648, 6.4893569, 6.5150089, 6.5604647, 49 | + 6.5857578, 6.5792512, 6.6067, 6.6552832, 6.705961, 6.700553, 50 | + 6.687906, 6.7356178, 6.781224, 6.8328012, 6.8572808, 6.8556192, 51 | + 6.8747935, 6.8489768, 6.8840768, 6.9496707, 6.9826227, 7.0096668, 52 | + 7.0455416, 7.0888837) 53 | + } 54 | > 55 | > fr1 <- fracdiff(realgnp2, nar = 0, nma = 0, M = 100) 56 | > 57 | > ## COMPUTER SAYS 58 | > ## Error in switch(result$info, stop("insufficient workspace"), stop("error in 59 | > ## gamma function"), : 60 | > ## insufficient workspace 61 | > 62 | > fr1 63 | 64 | Call: 65 | fracdiff(x = realgnp2, nar = 0, nma = 0, M = 100) 66 | 67 | Coefficients: 68 | d 69 | 0.4977438 70 | sigma[eps] = 0.185019 71 | a list with components: 72 | [1] "log.likelihood" "n" "msg" "d" 73 | [5] "ar" "ma" "covariance.dpq" "fnormMin" 74 | [9] "sigma" "stderror.dpq" "correlation.dpq" "h" 75 | [13] "d.tol" "M" "hessian.dpq" "length.w" 76 | [17] "residuals" "fitted" "call" 77 | > 78 | > ## ... 79 | > 80 | > ## Hrishikesh D. Vinod 81 | > ## Professor of Economics, Fordham University 82 | > ## E-Mail: Vinod@fordham.edu 83 | > ## Web page: http://www.fordham.edu/economics/vinod 84 | > 85 | > summary(fr1) 86 | 87 | Call: 88 | fracdiff(x = realgnp2, nar = 0, nma = 0, M = 100) 89 | 90 | Coefficients: 91 | Estimate Std. Error z value Pr(>|z|) 92 | d 4.977e-01 2.072e-07 2402593 <2e-16 *** 93 | --- 94 | Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 95 | sigma[eps] = 0.185019 96 | [d.tol = 0.0001221, M = 100, h = 2.078e-07] 97 | Log likelihood: 18.72 ==> AIC = -33.44708 [2 deg.freedom] 98 | > 99 | > proc.time() 100 | user system elapsed 101 | 0.099 0.027 0.163 102 | -------------------------------------------------------------------------------- /src/fdsim.c: -------------------------------------------------------------------------------- 1 | /*-*- mode: C; kept-old-versions: 12; kept-new-versions: 20; -*- 2 | * 3 | * fdsim.f -- translated by f2c (version 20031025). 4 | * 5 | * and produced by f2c-clean,v 1.10 2002/03/28 16:37:27 maechler 6 | */ 7 | #include 8 | 9 | #include "fracdiff.h" 10 | 11 | extern double dgamr_(double *); 12 | extern double dgamma_(double *); 13 | 14 | /* Common Block Declarations --- included as "extern" */ 15 | #define FD_EXTERNAL extern 16 | 17 | #include "mach_comm.h" 18 | #include "gamm_comm.h" 19 | 20 | 21 | void fdsim(int *n, int *ip, int *iq, double *ar, double *ma, 22 | double *d__, double *mu, double *y, double *s, 23 | double *flmin, double *flmax, double *epmin, double *epmax) 24 | { 25 | /* Generates a random time series ``for use with fracdif'', 26 | * i.e., filters a white noise series y[] into an ARIMA(p,d,q) series s[] 27 | 28 | Input : 29 | 30 | n int length of the time series 31 | ip int number of autoregressive parameters 32 | iq int number of moving average parameters 33 | ar float (ip) autoregressive parameters 34 | ma float (iq) moving average parameters 35 | d float fractional differencing parameter 36 | mu float time series mean 37 | y float (n+iq) 1st n : normalized random numbers 38 | s float (n+iq) workspace 39 | 40 | Output : 41 | 42 | s float (n) the generated time series 43 | ----------------------------------------------------------------------------- 44 | 45 | Simulates a series of length n from an ARIMA (p,d,q) model 46 | with fractional d (0 < d < 0.5). 47 | 48 | ----------------------------------------------------------------------------- 49 | float ar(ip), ma(iq), d, mu 50 | float y(n+iq), s(n+iq) 51 | -------------------------------------------------------------------------- 52 | */ 53 | 54 | /* System generated locals */ 55 | double d__1; 56 | 57 | /* Local variables */ 58 | int i, j, k; 59 | double dj, vk, dk1, amk, sum, dk1d, temp; 60 | 61 | /* Parameter adjustments */ 62 | --y; 63 | --s; 64 | 65 | /* Common Block -- Initializations: Input & Output for gamma() functions */ 66 | gammfd_.igamma = 0; 67 | gammfd_.jgamma = 0; 68 | machfd_.fltmin = *flmin; 69 | machfd_.fltmax = *flmax; 70 | machfd_.epsmin = *epmin; 71 | machfd_.epsmax = *epmax; 72 | 73 | /* Calculate vk[0] = 'g0' */ 74 | d__1 = 1. - *d__; 75 | temp = dgamr_(&d__1); 76 | if (gammfd_.igamma != 0) { 77 | for (i = 1; i <= *n; ++i) 78 | s[i] = 0.; 79 | return; 80 | } 81 | /* else : */ 82 | d__1 = 1. - *d__ * 2.; 83 | vk = dgamma_(&d__1) * (temp * temp); 84 | if (gammfd_.igamma != 0) { 85 | for (i = 1; i <= *n; ++i) 86 | s[i] = 0.; 87 | return; 88 | } 89 | /* else -- Gamma values ok, compute : */ 90 | 91 | /* Generate y(1) */ 92 | 93 | y[1] *= sqrt(vk); 94 | 95 | /* Generate y(2) and initialise vk,phi(j) */ 96 | 97 | temp = *d__ / (1. - *d__); 98 | vk *= 1. - temp * temp; 99 | amk = temp * y[1]; 100 | s[1] = temp; 101 | y[2] = amk + y[2] * sqrt(vk); 102 | 103 | /* Generate y(3),...,y(n+iq) */ 104 | 105 | for (k = 3; k <= (*n + *iq); ++k) { 106 | dk1 = (double) k - 1.; 107 | dk1d = dk1 - *d__; 108 | 109 | /* Update the phi(j) using the recursion formula on W498 */ 110 | 111 | for (j = 1; j <= (k - 2); ++j) { 112 | dj = dk1 - (double) j; 113 | s[j] *= dk1 * (dj - *d__) / (dk1d * dj); 114 | } 115 | temp = *d__ / dk1d; 116 | s[k - 1] = temp; 117 | 118 | /* Update vk */ 119 | 120 | vk *= 1. - temp * temp; 121 | 122 | /* Form amk */ 123 | amk = 0.; 124 | for (j = 1; j <= (k - 1); ++j) 125 | amk += s[j] * y[k - j]; 126 | 127 | /* Generate y(k) */ 128 | 129 | y[k] = amk + y[k] * sqrt(vk); 130 | } 131 | 132 | /* We now have an ARIMA (0,d,0) realisation of length n+iq in 133 | * y[k], k=1,..,n+iq. We now run this through an inverse ARMA(p,q) 134 | filter to get the final output in s[k], k=1,..,n. */ 135 | 136 | for (k = 1; k <= *n; ++k) { 137 | sum = 0.; 138 | j = imin2(*ip, k-1); /* i < j <= k-1 ==> (k - i - 1) >= 1 */ 139 | for (i = 0; i < j; ++i) 140 | sum += ar[i] * s[k - i - 1]; 141 | for (j = 0; j < *iq; ++j) 142 | sum -= ma[j] * y[k + *iq - j - 1]; 143 | s[k] = sum + y[k + *iq]; 144 | } 145 | /* now add the global mean */ 146 | if (*mu != 0.) { 147 | for (i = 1; i <= *n; ++i) 148 | s[i] += *mu; 149 | } 150 | return; 151 | } /* fdsim */ 152 | 153 | -------------------------------------------------------------------------------- /R/fd-methods.R: -------------------------------------------------------------------------------- 1 | #### Methods for "fracdiff" objects 2 | #### ------------------------------- 3 | 4 | coef.fracdiff <- function(object, ...) unlist(object[c("d", "ar", "ma")]) 5 | 6 | vcov.fracdiff <- function(object, ...) object$covariance.dpq 7 | 8 | ## Lines added by RJH. 9 Dec 2019 9 | residuals.fracdiff <- function(object, ...) object$residuals 10 | 11 | fitted.fracdiff <- function(object, ...) object$fitted 12 | ## End of RJH addition 13 | 14 | logLik.fracdiff <- function(object, ...) 15 | { 16 | r <- object$log.likelihood 17 | attr(r, "df") <- length(coef(object)) + 1:1 # "+ 1" : sigma^2 18 | attr(r, "nobs") <- attr(r, "nall") <- object$n 19 | class(r) <- "logLik" 20 | r 21 | } 22 | ## ==> AIC(), BIC() do work; the latter as nobs(logLik(.)) works 23 | 24 | print.fracdiff <- function(x, digits = getOption("digits"), ...) 25 | { 26 | cat("\nCall:\n ", deparse(x$call), "\n") 27 | if(any(not.ok <- x$msg != "ok")) 28 | cat(sprintf("\n*** Warning during (%s) fit: %30s\n", 29 | names(x$msg)[not.ok], x$msg[not.ok])) 30 | cat("\nCoefficients:\n") 31 | print(coef(x), digits = digits, ...) 32 | ## print.default(x, digits = digits, ...)too cheap to be true 33 | cat("sigma[eps] =", format(x$sigma), "\n") 34 | cat("a list with components:\n") 35 | print(names(x), ...) 36 | invisible(x) 37 | } 38 | 39 | summary.fracdiff <- function(object, symbolic.cor = FALSE, ...) 40 | { 41 | ## add a 'coef' matrix (and not much more): 42 | cf <- coef(object) 43 | se <- object$stderror.dpq 44 | cf <- cbind("Estimate" = cf, 45 | "Std. Error"= se, "z value" = cf / se, 46 | "Pr(>|z|)" = 2 * pnorm(-abs(cf / se))) 47 | object$coefficients <- cf # 'long name' such that coef(.) works 48 | logl <- logLik(object) 49 | object$df <- attr(logl, "df") 50 | object$aic <- AIC(logl) 51 | object$symbolic.cor <- symbolic.cor 52 | ## remove those components we have in 'coef' anyway 53 | object$d <- object$ar <- object$ma <- object$stderror.dpq <- NULL 54 | class(object) <- "summary.fracdiff" 55 | object 56 | } 57 | 58 | print.summary.fracdiff <- 59 | function(x, digits = max(3, getOption("digits") - 3), 60 | correlation = FALSE, 61 | symbolic.cor = x$symbolic.cor, 62 | signif.stars = getOption("show.signif.stars"), ...) 63 | { 64 | cat("\nCall:\n ", deparse(x$call), "\n") 65 | if(any(not.ok <- x$msg != "ok")) 66 | cat(sprintf("\n*** Warning during (%s) fit: %30s\n", 67 | names(x$msg)[not.ok], x$msg[not.ok])) 68 | cat("\nCoefficients:\n") 69 | printCoefmat(x$coef, digits = digits, signif.stars = signif.stars, ...) 70 | cat("sigma[eps] =", format(x$sigma), "\n") 71 | cat("[d.tol = ", formatC(x$d.tol),", M = ", x$M,", h = ",formatC(x$h), 72 | ## really not much informative: "length.w = ", x$length.w, 73 | "]\n", sep='') 74 | cat("Log likelihood: ", formatC(x$log.likelihood, digits=digits), 75 | " ==> AIC = ", x$aic," [", x$df," deg.freedom]\n", sep='') 76 | if (correlation && !is.null(correl <- x$correlation.dpq)) { 77 | p <- NCOL(correl) 78 | if (p > 1) { 79 | cat("\nCorrelation of Coefficients:\n") 80 | if (is.logical(symbolic.cor) && symbolic.cor) { 81 | print(symnum(correl, abbr.colnames = NULL)) 82 | } 83 | else { 84 | correl <- format(round(correl, 2), nsmall = 2, digits = digits) 85 | correl[!lower.tri(correl)] <- "" 86 | print(correl[-1, -p, drop = FALSE], quote = FALSE) 87 | } 88 | } 89 | } 90 | invisible(x) 91 | } 92 | 93 | 94 | ### This and coef.fracdiff() were supplied 95 | 96 | ## From: Spencer Graves 97 | ## To: Melissa Ann Haltuch 98 | ## CC: r-help@stat.math.ethz.ch, Martin Maechler 99 | ## Subject: Re: [R] fracdiff 100 | ## Date: Sun, 23 Jul 2006 03:40:08 +0800 101 | 102 | confint.fracdiff <- function(object, parm, level = 0.95, ...) 103 | { 104 | p <- length(cf <- coef(object)) 105 | stopifnot(p >= 1, length(level) == 1, 0 < level, level < 1) 106 | se <- object$stderror.dpq 107 | pnames <- names(cf) 108 | names(se) <- pnames 109 | if (missing(parm)) 110 | parm <- 1:p 111 | else if (is.character(parm)) 112 | parm <- match(parm, pnames, nomatch = 0) 113 | cf <- cf[parm] 114 | se <- se[parm] 115 | 116 | a <- (1-level)/2 117 | a <- c(a, 1 - a) 118 | CI <- cf + outer(se, qnorm(a)) 119 | dimnames(CI)[[2]] <- paste(format(100*a), "%") 120 | CI 121 | } 122 | -------------------------------------------------------------------------------- /tests/ex.R: -------------------------------------------------------------------------------- 1 | library(fracdiff) 2 | 3 | doExtras <- fracdiff:::doExtras() 4 | .proctime00 <- proc.time() 5 | 6 | set.seed(107) 7 | options(digits = 5) 8 | 9 | ## 1) 10 | 11 | x1 <- fracdiff.sim(5000, ar = .2, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 12 | summary(fd1 <- fracdiff(x1$series, nar = 1, nma = 1, dtol = 1e-10)) 13 | vcov(fd1) 14 | logLik(fd1) 15 | stopifnot(all.equal(structure(-7051.5027, df = 4L, nall = 5000L, nobs = 5000L, class = "logLik"), 16 | logLik(fd1))) 17 | fdCOVcomp <- 18 | c("h", "covariance.dpq", "stderror.dpq", "correlation.dpq", "hessian.dpq") 19 | fd1. <- fracdiff.var(x1$series, fd1, h = fd1$h / 2) 20 | dns <- dimnames(fd1.$covariance.dpq) 21 | 22 | ## dput(sapply(fd1.[fdCOVcomp], signif, digits = 4)) # edited: 23 | fd1.L <- list( 24 | h = 3.7155e-05, 25 | covariance.dpq = matrix(c(0.0005966, -0.0008052, -0.0001897, 26 | -0.0008052, 0.001612, 0.000664, 27 | -0.0001897, 0.000664, 0.0005485), 28 | 3L, 3L, dimnames = dns), 29 | stderror.dpq = c(0.02443, 0.04015, 0.02342), 30 | correlation.dpq = matrix(c(1, -0.821, -0.3316, 31 | -0.821, 1, 0.7061, 32 | -0.3316, 0.7061, 1), 3), 33 | hessian.dpq = matrix(c(-8252, -5875, 4258, 34 | -5875, -5420, 4529, 35 | 4258, 4529, -5834), 36 | 3L, 3L, dimnames = dns)) 37 | stopifnot(all.equal(fd1.[fdCOVcomp], fd1.L, tolerance = 2e-4)) 38 | 39 | fd1u <- fracdiff.var(x1$series, fd1, h = fd1$h * 8) 40 | ## dput(sapply(fd1u[fdCOVcomp], signif, digits = 4)) : 41 | fd1uL <- list( 42 | h = 0.0005945, 43 | covariance.dpq = matrix(c(0.0005966, -0.0008052, -0.0001897, 44 | -0.0008052, 0.001612, 0.000664, 45 | -0.0001897, 0.000664, 0.0005485), 46 | 3L, 3L, dimnames = dns), 47 | stderror.dpq = c(0.02443, 0.04015, 0.02342), 48 | correlation.dpq = matrix(c(1, -0.821, -0.3316, 49 | -0.821, 1, 0.7061, 50 | -0.3316, 0.7061, 1), 3), 51 | hessian.dpq = matrix(c(-8252, -5875, 4258, 52 | -5875, -5420, 4529, 53 | 4258, 4529, -5834), 54 | 3L, 3L, dimnames = dns)) 55 | if(doExtras) 56 | print(all.equal(fd1u[fdCOVcomp], fd1uL, tolerance = 0)) 57 | stopifnot(all.equal(fd1u[fdCOVcomp], fd1uL, tolerance = 2e-4) ) 58 | 59 | ## 2) 60 | 61 | x2 <- fracdiff.sim( 2048, ar = .8, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 62 | ## -> NA's and problems 63 | fd2 <- fracdiff(x2$series, nar = length(x2$ar), nma = length(x2$ma)) 64 | sfd2 <- summary(fd2) 65 | ss2 <- lapply(sfd2[setdiff(names(sfd2), c("residuals", "fitted"))], 66 | function(.) if(is.numeric(.)) signif(., digits = 7) else .) 67 | ss2$coefficients <- ss2$coefficients[, -4] # drop p values 68 | ss2S <- list( 69 | log.likelihood = -2924.262, n = 2048, 70 | msg = c(fracdf = "ok", fdcov = "ok"), 71 | covariance.dpq = matrix(c(0.0004182859, -0.0007078449, -6.753008e-05, 72 | -0.0007078449, 0.001712827, 0.0002692938, 73 | -6.753008e-05, 0.0002692938, 0.0002572701), 3L, 74 | dimnames = dns), 75 | fnormMin = 45.62935, sigma = 1.008768, 76 | correlation.dpq = matrix(c(1, -0.8362667, -0.2058572, 77 | -0.8362667, 1, 0.405672, 78 | -0.2058572, 0.405672, 1), 3, dimnames = dns), 79 | h = 3.082264e-05, d.tol = 0.0001220703, M = 100, 80 | hessian.dpq = matrix(c(-8557.83, -3810.55, 1742.32, 81 | -3810.55, -2395.564, 1507.303, 82 | 1742.32, 1507.303, -5007.377), 3, dimnames = dns), 83 | length.w = 10254, 84 | call = quote( 85 | fracdiff(x = x2$series, nar = length(x2$ar), nma = length(x2$ma))), 86 | coefficients = matrix(c(0.3374173, 0.7709664, -0.3810478, 87 | 0.02045204, 0.04138631, 0.01603964, 88 | 16.49798, 18.62854, -23.75663), 89 | 3, 3, dimnames = dimnames(ss2$coefficients)), 90 | df = 4, aic = 5856.524, symbolic.cor = FALSE) 91 | ## 92 | if(doExtras) 93 | print(all.equal(ss2S, ss2, tol = 0)) # 0.0001273 (32b Win); TRUE (64b F30, gcc) 94 | stopifnot(all.equal(ss2S, ss2, tol = 4e-4)) 95 | 96 | fd2. <- fracdiff.var(x2$series, fd2, h = fd2$h / 2) 97 | sfd2. <- sapply(fd2.[fdCOVcomp], signif, digits = 4) 98 | sfd2S <- ## dput(sapply(fd2.[fdCOVcomp], signif, digits = 5)) 99 | list(h = 1.5411e-05, 100 | covariance.dpq = matrix(c( 5.4726e-05,-9.261e-05, -8.8353e-06, 101 | -9.261e-05, 0.0006717, 0.00016997, 102 | -8.8353e-06, 0.00016997, 0.00024779), 3, dimnames=dns), 103 | stderror.dpq = c(0.0073977, 0.025917, 0.015741), 104 | correlation.dpq = matrix(c(1, -0.48303, -0.075871, 105 | -0.48303, 1, 0.41661, 106 | -0.075871, 0.41661, 1), 3), 107 | hessian.dpq = matrix(c(-24440, -3810.6, 1742.3, 108 | -3810.6, -2395.6, 1507.3, 109 | 1742.3, 1507.3,-5007.4), 3, dimnames=dns)) 110 | ## 111 | if(doExtras) 112 | print(all.equal(sfd2S, sfd2., tol = 0 , countEQ=TRUE)) # 8.7655e-5 113 | stopifnot(all.equal(sfd2S, sfd2., tol = 2e-4, countEQ=TRUE)) 114 | 115 | fd2u <- fracdiff.var(x2$series, fd2, h = fd2$h * 8)#-> warning, unable .. corr... 116 | ##= no se.ok --> 117 | fdCOV.0 <- setdiff(fdCOVcomp, c("stderror.dpq", "correlation.dpq")) 118 | sd2u <- sapply(fd2u[fdCOV.0], signif, digits = 4) 119 | sd2uS <- list( ## dput(sapply(sd2u[fdCOVcomp], signif, digits = 5)) 120 | h = 0.0002466, 121 | covariance.dpq = matrix(c(-0.0003545, 6e-04, 5.724e-05, 122 | 6e-04, -0.0005003, 5.816e-05, 123 | 5.724e-05, 5.816e-05, 0.0002371), 3, dimnames=dns), 124 | ## stderror.dpq = c(0, 0, 0.0154), 125 | ## correlation.dpq = matrix(0, 3,3), 126 | hessian.dpq = matrix(c(-3347, -3811, 1742, 127 | -3811, -2396, 1507, 128 | 1742, 1507,-5007), 3, dimnames=dns)) 129 | ## 130 | if(doExtras) 131 | print(all.equal(sd2uS, sd2u, tol = 0 , countEQ=TRUE))# 0.000103 (32b Win); T.(64b F30) 132 | stopifnot(all.equal(sd2uS, sd2u, tol = 4e-4, countEQ=TRUE)) 133 | 134 | -------------------------------------------------------------------------------- /man/fracdiff.Rd: -------------------------------------------------------------------------------- 1 | \name{fracdiff} 2 | \alias{fracdiff} 3 | \title{ML Estimates for Fractionally-Differenced ARIMA (p,d,q) models} 4 | \description{ 5 | Calculates the maximum likelihood estimators of the parameters 6 | of a fractionally-differenced ARIMA (p,d,q) model, together (if possible) 7 | with their estimated covariance and correlation matrices and standard 8 | errors, as well as the value of the maximized likelihood. The 9 | likelihood is approximated using the fast and accurate method of 10 | Haslett and Raftery (1989). 11 | } 12 | \usage{ 13 | fracdiff(x, nar = 0, nma = 0, 14 | ar = rep(NA, max(nar, 1)), ma = rep(NA, max(nma, 1)), 15 | dtol = NULL, drange = c(0, 0.5), h, M = 100, trace = 0) 16 | } 17 | \arguments{ 18 | \item{x}{time series (numeric vector) for the ARIMA model} 19 | \item{nar}{number of autoregressive parameters \eqn{p}.} 20 | \item{nma}{number of moving average parameters \eqn{q}.} 21 | \item{ar}{initial autoregressive parameters.} 22 | \item{ma}{initial moving average parameters.} 23 | \item{dtol}{interval of uncertainty for \eqn{d}. If \code{dtol} is 24 | negative or NULL, the fourth root of machine precision will be used. 25 | \code{dtol} will be altered if necessary by the program.} 26 | \item{drange}{interval over which the likelihood function is to be 27 | maximized as a function of \eqn{d}.} 28 | \item{h}{size of finite difference interval for numerical derivatives. 29 | By default (or if negative), 30 | %% Only found the following by reading ../src/fdhess.f : 31 | \code{h = min(0.1, eps.5 * (1+ abs(cllf)))}, where 32 | \code{clff := log. max.likelihood} (as returned) and 33 | \code{eps.5 := sqrt(.Machine$double.neg.eps)} (typically 1.05e-8). 34 | 35 | This is used to compute a finite difference approximation to the 36 | Hessian, and hence only influences the cov, cor, and std.error 37 | computations; use \code{\link{fracdiff.var}()} to change this 38 | \emph{after} the estimation process. 39 | } 40 | \item{M}{number of terms in the likelihood approximation (see Haslett 41 | and Raftery 1989).} 42 | \item{trace}{optional integer, specifying a trace level. If positive, 43 | currently the \dQuote{outer loop} iterations produce one line of 44 | diagnostic output.} 45 | } 46 | \details{ 47 | The \pkg{fracdiff} package has --- for historical reason, namely, 48 | S-plus \code{arima()} compatibility --- used an unusual 49 | parametrization for the MA part, see also the \sQuote{Details} section 50 | in \code{\link[stats]{arima}} (in standard \R's \pkg{stats} package). 51 | The ARMA (i.e., \eqn{d = 0}) model in \code{fracdiff()} and 52 | \code{\link{fracdiff.sim}()} is 53 | 54 | \deqn{X_t - a_1X_{t-1} - \cdots - a_pX_{t-p} = e_t - b_1e_{t-1} - \dots - b_qe_{t-q},}{% 55 | X[t] - a[1]X[t-1] - \dots - a[p]X[t-p] = e[t] - b[1]e[t-1] - \dots - b[q]e[t-q],} 56 | 57 | where \eqn{e_i}{e[i]} are mean zero i.i.d., for \code{fracdiff()}'s 58 | estimation, \eqn{e_i \sim \mathcal{N}(0,\sigma^2)}{e[i] ~ N(0, s^2)}. 59 | This model indeed has the signs of the MA coefficients \eqn{b_j}{b[j]} 60 | \emph{inverted}, compared to other parametrizations, including 61 | Wikipedia's 62 | \url{https://en.wikipedia.org/wiki/Autoregressive_moving-average_model} 63 | and the one of \code{\link[stats]{arima}}. 64 | 65 | Note that \code{NA}'s in the initial values for \code{ar} or \code{ma} 66 | are replaced by \eqn{0}'s. 67 | } 68 | \value{ 69 | an object of S3 \code{\link{class}} \code{"fracdiff"}, which is 70 | a list with components: 71 | \item{log.likelihood}{logarithm of the maximum likelihood} 72 | \item{d}{optimal fractional-differencing parameter} 73 | \item{ar}{vector of optimal autoregressive parameters} 74 | \item{ma}{vector of optimal moving average parameters} 75 | \item{covariance.dpq}{covariance matrix of the parameter estimates 76 | (order : d, ar, ma).} 77 | \item{stderror.dpq}{standard errors of the parameter estimates 78 | \code{c(d, ar, ma)}.} 79 | \item{correlation.dpq}{correlation matrix of the parameter estimates 80 | (order : d, ar, ma).} 81 | \item{h}{interval used for numerical derivatives, see \code{h} argument.} 82 | \item{dtol}{interval of uncertainty for d; possibly altered from input 83 | \code{dtol}.} 84 | \item{M}{as input.} 85 | \item{hessian.dpq}{the approximate Hessian matrix \eqn{H} of 2nd order 86 | partial derivatives of the likelihood with respect to the 87 | parameters; this is (internally) used to compute 88 | \code{covariance.dpq}, the approximate asymptotic covariance matrix as 89 | \eqn{C = (-H)^{-1}}.} 90 | } 91 | \note{ 92 | Ordinarily, \code{nar} and \code{nma} should not be too large (say < 10) 93 | to avoid degeneracy in the model. The function 94 | \code{\link{fracdiff.sim}} is available for generating test problems. 95 | } 96 | \section{Method}{ 97 | The optimization is carried out in two levels:\cr 98 | an outer univariate unimodal 99 | optimization in d over the interval \code{drange} (typically [0,.5]), 100 | using Brent's \code{fmin} algorithm), and\cr 101 | an inner nonlinear least-squares optimization in the AR and MA parameters to 102 | minimize white noise variance (uses the MINPACK subroutine \code{lm}DER). 103 | written by Chris Fraley (March 1991). 104 | } 105 | \section{Warning}{ 106 | The variance-covariance matrix and consequently the standard errors 107 | may be quite inaccurate, see the example in \code{\link{fracdiff.var}}. 108 | } 109 | \references{ 110 | J. Haslett and A. E. Raftery (1989) 111 | Space-time Modelling with Long-memory Dependence: Assessing Ireland's 112 | Wind Power Resource (with Discussion); 113 | \emph{Applied Statistics} \bold{38}, 1--50. 114 | 115 | R. Brent (1973) 116 | \emph{Algorithms for Minimization without Derivatives}, Prentice-Hall 117 | 118 | J. J. More, B. S. Garbow, and K. E. Hillstrom (1980) 119 | \emph{Users Guide for MINPACK-1}, Technical Report ANL-80-74, 120 | Applied Mathematics Division, Argonne National Laboratory. 121 | } 122 | \seealso{ 123 | \code{\link{coef.fracdiff}} and other methods for \code{"fracdiff"} 124 | objects; 125 | \code{\link{fracdiff.var}()} for re-estimation of variances or 126 | standard errors; 127 | \code{\link{fracdiff.sim}} 128 | } 129 | \examples{ 130 | ts.test <- fracdiff.sim( 5000, ar = .2, ma = -.4, d = .3) 131 | fd. <- fracdiff( ts.test$series, 132 | nar = length(ts.test$ar), nma = length(ts.test$ma)) 133 | fd. 134 | ## Confidence intervals 135 | confint(fd.) 136 | 137 | ## with iteration output 138 | fd2 <- fracdiff(ts.test$series, nar = 1, nma = 1, trace = 1) 139 | all.equal(fd., fd2) 140 | } 141 | \keyword{ts} 142 | -------------------------------------------------------------------------------- /tests/o-linux.Rout-32b: -------------------------------------------------------------------------------- 1 | 2 | R version 2.13.1 Patched (2011-08-08 r56671) 3 | Copyright (C) 2011 The R Foundation for Statistical Computing 4 | ISBN 3-900051-07-0 5 | Platform: i686-pc-linux-gnu (32-bit) 6 | 7 | R is free software and comes with ABSOLUTELY NO WARRANTY. 8 | You are welcome to redistribute it under certain conditions. 9 | Type 'license()' or 'licence()' for distribution details. 10 | 11 | R is a collaborative project with many contributors. 12 | Type 'contributors()' for more information and 13 | 'citation()' on how to cite R or R packages in publications. 14 | 15 | Type 'demo()' for some demos, 'help()' for on-line help, or 16 | 'help.start()' for an HTML browser interface to help. 17 | Type 'q()' to quit R. 18 | 19 | > ### Very similar to ./ex.R but using *MORE* precision 20 | > ### ===> non-portable but better for consistency checking (Development) 21 | > library(fracdiff) 22 | > 23 | > .proctime00 <- proc.time() 24 | > set.seed(107) 25 | > options(digits = 10) 26 | > 27 | > ## 1) 28 | > 29 | > x1 <- fracdiff.sim( 5000, ar = .2, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 30 | > (fd1 <- fracdiff(x1$series, nar = 1, nma = 1, dtol = 1e-10)) 31 | 32 | Call: 33 | fracdiff(x = x1$series, nar = 1, nma = 1, dtol = 1e-10) 34 | 35 | Coefficients: 36 | d ar ma 37 | 0.2672118741 0.2782353323 -0.3695102431 38 | sigma[eps] = 0.9913837059 39 | a list with components: 40 | [1] "log.likelihood" "n" "msg" "d" 41 | [5] "ar" "ma" "covariance.dpq" "fnormMin" 42 | [9] "sigma" "stderror.dpq" "correlation.dpq" "h" 43 | [13] "d.tol" "M" "hessian.dpq" "length.w" 44 | [17] "call" 45 | > vcov(fd1) 46 | d ar1 ma1 47 | d 0.0005966071956 -0.0008052233293 -0.0001897086645 48 | ar1 -0.0008052233293 0.0016121920198 0.0006639892294 49 | ma1 -0.0001897086645 0.0006639892294 0.0005484879117 50 | > logLik(fd1) 51 | 'log Lik.' -7051.502651 (df=4) 52 | > 53 | > fdCOVcomp <- 54 | + c("h", "covariance.dpq", "stderror.dpq", "correlation.dpq", "hessian.dpq") 55 | > fd1. <- fracdiff.var(x1$series, fd1, h = fd1$h / 8) 56 | > fd1.[fdCOVcomp] 57 | $h 58 | [1] 9.288773777e-06 59 | 60 | $covariance.dpq 61 | d ar1 ma1 62 | d 0.0005965884542 -0.0008051980249 -0.0001897026990 63 | ar1 -0.0008051980249 0.0016121578540 0.0006639811749 64 | ma1 -0.0001897026990 0.0006639811749 0.0005484860129 65 | 66 | $stderror.dpq 67 | [1] 0.02442516027 0.04015168557 0.02341977824 68 | 69 | $correlation.dpq 70 | [,1] [,2] [,3] 71 | [1,] 1.0000000000 -0.8210346711 -0.3316296170 72 | [2,] -0.8210346711 1.0000000000 0.7061048691 73 | [3,] -0.3316296170 0.7061048691 1.0000000000 74 | 75 | $hessian.dpq 76 | d ar1 ma1 77 | d -8251.618278 -5875.111454 4258.283879 78 | ar1 -5875.111454 -5420.120471 4529.438126 79 | ma1 4258.283879 4529.438126 -5833.610390 80 | 81 | > fd1u <- fracdiff.var(x1$series, fd1, h = fd1$h * 8) 82 | > sapply(fd1u[fdCOVcomp], signif, digits= 8) 83 | $h 84 | [1] 0.00059448152 85 | 86 | $covariance.dpq 87 | d ar1 ma1 88 | d 0.00059660783 -0.00080522481 -0.00018970926 89 | ar1 -0.00080522481 0.00161219490 0.00066399023 90 | ma1 -0.00018970926 0.00066399023 0.00054848822 91 | 92 | $stderror.dpq 93 | [1] 0.024425557 0.040152146 0.023419825 94 | 95 | $correlation.dpq 96 | [,1] [,2] [,3] 97 | [1,] 1.00000000 -0.82103923 -0.33163503 98 | [2,] -0.82103923 1.00000000 0.70610497 99 | [3,] -0.33163503 0.70610497 1.00000000 100 | 101 | $hessian.dpq 102 | d ar1 ma1 103 | d -8251.5707 -5875.1142 4258.2848 104 | ar1 -5875.1142 -5420.1205 4529.4381 105 | ma1 4258.2848 4529.4381 -5833.6104 106 | 107 | > 108 | > ## 2) 109 | > 110 | > x2 <- fracdiff.sim( 2048, ar = .8, ma = -.4, d = .3, n.start=0, allow.0 = TRUE)# -> NA's and problems 111 | > fd2 <- fracdiff(x2$series, nar = length(x2$ar), nma = length(x2$ma)) 112 | > summary(fd2) 113 | 114 | Call: 115 | fracdiff(x = x2$series, nar = length(x2$ar), nma = length(x2$ma)) 116 | 117 | Coefficients: 118 | Estimate Std. Error z value Pr(>|z|) 119 | d 0.33741729 0.02045203 16.49798 < 2.22e-16 *** 120 | ar 0.77096644 0.04138630 18.62854 < 2.22e-16 *** 121 | ma -0.38104778 0.01603964 -23.75663 < 2.22e-16 *** 122 | --- 123 | Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 124 | sigma[eps] = 1.008768342 125 | [d.tol = 0.0001221, M = 100, h = 3.082e-05] 126 | Log likelihood: -2924.262 ==> AIC = 5856.524183 [4 deg.freedom] 127 | > 128 | > (fd2. <- fracdiff.var(x2$series, fd2, h = fd2$h / 8))[fdCOVcomp] 129 | $h 130 | [1] 3.85283057e-06 131 | 132 | $covariance.dpq 133 | d ar1 ma1 134 | d 2.976947870e-06 -5.037744154e-06 -4.806127321e-07 135 | ar1 -5.037744154e-06 5.235002972e-04 1.558292850e-04 136 | ma1 -4.806127321e-07 1.558292850e-04 2.464452848e-04 137 | 138 | $stderror.dpq 139 | [1] 0.001725383398 0.022880128872 0.015698575884 140 | 141 | $correlation.dpq 142 | [,1] [,2] [,3] 143 | [1,] 1.00000000000 -0.1276121502 -0.01774391303 144 | [2,] -0.12761215025 1.0000000000 0.43384076287 145 | [3,] -0.01774391303 0.4338407629 1.00000000000 146 | 147 | $hessian.dpq 148 | d ar1 ma1 149 | d -342081.635606 -3810.550345 1742.319991 150 | ar1 -3810.550345 -2395.564007 1507.302636 151 | ma1 1742.319991 1507.302636 -5007.377244 152 | 153 | > (fd2u <- fracdiff.var(x2$series, fd2, h = fd2$h * 8))[fdCOVcomp] 154 | $h 155 | [1] 0.0002465811564 156 | 157 | $covariance.dpq 158 | d ar1 ma1 159 | d -0.0003545343344 0.0005999613404 0.0000572377558 160 | ar1 0.0005999613404 -0.0005003104481 0.0000581552762 161 | ma1 0.0000572377558 0.0000581552762 0.0002371269493 162 | 163 | $stderror.dpq 164 | [1] 0.00000000000 0.00000000000 0.01539892689 165 | 166 | $correlation.dpq 167 | [,1] [,2] [,3] 168 | [1,] 0 0 0 169 | [2,] 0 0 0 170 | [3,] 0 0 0 171 | 172 | $hessian.dpq 173 | d ar1 ma1 174 | d -3346.521619 -3810.551029 1742.320036 175 | ar1 -3810.551029 -2395.564007 1507.302636 176 | ma1 1742.320036 1507.302636 -5007.377244 177 | 178 | Warning message: 179 | In fracdiff.var(x2$series, fd2, h = fd2$h * 8) : 180 | unable to compute correlation matrix 181 | > 182 | > ## Last Line: 183 | > cat('Time elapsed: ', proc.time() - .proctime00,'\n') 184 | Time elapsed: 0.287 0.006 0.294 0 0 185 | > 186 | -------------------------------------------------------------------------------- /tests/o-linux.Rout-64b: -------------------------------------------------------------------------------- 1 | 2 | R Under development (unstable) (2020-01-16 r77667) -- "Unsuffered Consequences" 3 | Copyright (C) 2020 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu (64-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | R is a collaborative project with many contributors. 11 | Type 'contributors()' for more information and 12 | 'citation()' on how to cite R or R packages in publications. 13 | 14 | Type 'demo()' for some demos, 'help()' for on-line help, or 15 | 'help.start()' for an HTML browser interface to help. 16 | Type 'q()' to quit R. 17 | 18 | > ### Very similar to ./ex.R but using *MORE* precision 19 | > ### ===> non-portable but better for consistency checking (Development) 20 | > library(fracdiff) 21 | > 22 | > .proctime00 <- proc.time() 23 | > set.seed(107) 24 | > options(digits = 10) 25 | > 26 | > ## 1) 27 | > 28 | > x1 <- fracdiff.sim( 5000, ar = .2, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 29 | > (fd1 <- fracdiff(x1$series, nar = 1, nma = 1, dtol = 1e-10)) 30 | 31 | Call: 32 | fracdiff(x = x1$series, nar = 1, nma = 1, dtol = 1e-10) 33 | 34 | Coefficients: 35 | d ar ma 36 | 0.2672118968 0.2782353076 -0.3695102490 37 | sigma[eps] = 0.9913837059 38 | a list with components: 39 | [1] "log.likelihood" "n" "msg" "d" 40 | [5] "ar" "ma" "covariance.dpq" "fnormMin" 41 | [9] "sigma" "stderror.dpq" "correlation.dpq" "h" 42 | [13] "d.tol" "M" "hessian.dpq" "length.w" 43 | [17] "residuals" "fitted" "call" 44 | > vcov(fd1) 45 | d ar1 ma1 46 | d 0.0005966058259 -0.0008052214705 -0.0001897082342 47 | ar1 -0.0008052214705 0.0016121895340 0.0006639886761 48 | ma1 -0.0001897082342 0.0006639886761 0.0005484878015 49 | > logLik(fd1) 50 | 'log Lik.' -7051.502651 (df=4) 51 | > 52 | > fdCOVcomp <- 53 | + c("h", "covariance.dpq", "stderror.dpq", "correlation.dpq", "hessian.dpq") 54 | > fd1. <- fracdiff.var(x1$series, fd1, h = fd1$h / 8) 55 | > fd1.[fdCOVcomp] 56 | $h 57 | [1] 9.288773777e-06 58 | 59 | $covariance.dpq 60 | d ar1 ma1 61 | d 0.0005965839808 -0.0008051919770 -0.0001897012819 62 | ar1 -0.0008051919770 0.0016121497143 0.0006639792896 63 | ma1 -0.0001897012819 0.0006639792896 0.0005484855888 64 | 65 | $stderror.dpq 66 | [1] 0.02442506870 0.04015158421 0.02341976919 67 | 68 | $correlation.dpq 69 | [,1] [,2] [,3] 70 | [1,] 1.0000000000 -0.8210336551 -0.3316285111 71 | [2,] -0.8210336551 1.0000000000 0.7061049197 72 | [3,] -0.3316285111 0.7061049197 1.0000000000 73 | 74 | $hessian.dpq 75 | d ar1 ma1 76 | d -8251.630384 -5875.111194 4258.283796 77 | ar1 -5875.111194 -5420.120386 4529.438165 78 | ma1 4258.283796 4529.438165 -5833.610409 79 | 80 | > fd1u <- fracdiff.var(x1$series, fd1, h = fd1$h * 8) 81 | > sapply(fd1u[fdCOVcomp], signif, digits= 8) 82 | $h 83 | [1] 0.00059448152 84 | 85 | $covariance.dpq 86 | d ar1 ma1 87 | d 0.00059660783 -0.00080522480 -0.00018970926 88 | ar1 -0.00080522480 0.00161219490 0.00066399026 89 | ma1 -0.00018970926 0.00066399026 0.00054848825 90 | 91 | $stderror.dpq 92 | [1] 0.024425557 0.040152147 0.023419826 93 | 94 | $correlation.dpq 95 | [,1] [,2] [,3] 96 | [1,] 1.00000000 -0.82103922 -0.33163503 97 | [2,] -0.82103922 1.00000000 0.70610498 98 | [3,] -0.33163503 0.70610498 1.00000000 99 | 100 | $hessian.dpq 101 | d ar1 ma1 102 | d -8251.5702 -5875.1140 4258.2847 103 | ar1 -5875.1140 -5420.1204 4529.4382 104 | ma1 4258.2847 4529.4382 -5833.6104 105 | 106 | > 107 | > ## 2) 108 | > 109 | > x2 <- fracdiff.sim( 2048, ar = .8, ma = -.4, d = .3, n.start=0, allow.0 = TRUE)# -> NA's and problems 110 | > fd2 <- fracdiff(x2$series, nar = length(x2$ar), nma = length(x2$ma)) 111 | > summary(fd2) 112 | 113 | Call: 114 | fracdiff(x = x2$series, nar = length(x2$ar), nma = length(x2$ma)) 115 | 116 | Coefficients: 117 | Estimate Std. Error z value Pr(>|z|) 118 | d 0.33741729 0.02045204 16.49798 < 2.22e-16 *** 119 | ar 0.77096644 0.04138631 18.62854 < 2.22e-16 *** 120 | ma -0.38104778 0.01603964 -23.75663 < 2.22e-16 *** 121 | --- 122 | Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 123 | sigma[eps] = 1.008768342 124 | [d.tol = 0.0001221, M = 100, h = 3.082e-05] 125 | Log likelihood: -2924.262 ==> AIC = 5856.524183 [4 deg.freedom] 126 | > 127 | > (fd2. <- fracdiff.var(x2$series, fd2, h = fd2$h / 8))[fdCOVcomp] 128 | $h 129 | [1] 3.85283057e-06 130 | 131 | $covariance.dpq 132 | d ar1 ma1 133 | d 2.976947874e-06 -5.037744161e-06 -4.806127328e-07 134 | ar1 -5.037744161e-06 5.235002972e-04 1.558292850e-04 135 | ma1 -4.806127328e-07 1.558292850e-04 2.464452848e-04 136 | 137 | $stderror.dpq 138 | [1] 0.001725383399 0.022880128872 0.015698575884 139 | 140 | $correlation.dpq 141 | [,1] [,2] [,3] 142 | [1,] 1.00000000000 -0.1276121503 -0.01774391305 143 | [2,] -0.12761215034 1.0000000000 0.43384076287 144 | [3,] -0.01774391305 0.4338407629 1.00000000000 145 | 146 | $hessian.dpq 147 | d ar1 ma1 148 | d -342081.635127 -3810.550345 1742.319991 149 | ar1 -3810.550345 -2395.564007 1507.302636 150 | ma1 1742.319991 1507.302636 -5007.377244 151 | 152 | > (fd2u <- fracdiff.var(x2$series, fd2, h = fd2$h * 8))[fdCOVcomp] 153 | $h 154 | [1] 0.0002465811564 155 | 156 | $covariance.dpq 157 | d ar1 ma1 158 | d -3.545343344e-04 5.999613405e-04 5.723775582e-05 159 | ar1 5.999613405e-04 -5.003104484e-04 5.815527618e-05 160 | ma1 5.723775582e-05 5.815527618e-05 2.371269493e-04 161 | 162 | $stderror.dpq 163 | [1] 0.00000000000 0.00000000000 0.01539892689 164 | 165 | $correlation.dpq 166 | [,1] [,2] [,3] 167 | [1,] 0 0 0 168 | [2,] 0 0 0 169 | [3,] 0 0 0 170 | 171 | $hessian.dpq 172 | d ar1 ma1 173 | d -3346.521619 -3810.551029 1742.320036 174 | ar1 -3810.551029 -2395.564007 1507.302636 175 | ma1 1742.320036 1507.302636 -5007.377244 176 | 177 | Warning message: 178 | In fracdiff.var(x2$series, fd2, h = fd2$h * 8) : 179 | unable to compute correlation matrix 180 | > 181 | > ## Last Line: 182 | > cat('Time elapsed: ', proc.time() - .proctime00,'\n') 183 | Time elapsed: 0.064 0.002 0.066 0 0 184 | > 185 | > proc.time() 186 | user system elapsed 187 | 0.160 0.024 0.227 188 | -------------------------------------------------------------------------------- /tests/ex.Rout-32b: -------------------------------------------------------------------------------- 1 | 2 | R version 3.6.2 (2019-12-12) -- "Dark and Stormy Night" 3 | Copyright (C) 2019 The R Foundation for Statistical Computing 4 | Platform: i686-pc-linux-gnu (32-bit) 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | R is a collaborative project with many contributors. 11 | Type 'contributors()' for more information and 12 | 'citation()' on how to cite R or R packages in publications. 13 | 14 | Type 'demo()' for some demos, 'help()' for on-line help, or 15 | 'help.start()' for an HTML browser interface to help. 16 | Type 'q()' to quit R. 17 | 18 | > library(fracdiff) 19 | > 20 | > doExtras <- interactive() # for now 21 | > 22 | > .proctime00 <- proc.time() 23 | > 24 | > set.seed(107) 25 | > options(digits = 5) 26 | > 27 | > ## 1) 28 | > 29 | > x1 <- fracdiff.sim(5000, ar = .2, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 30 | > (fd1 <- fracdiff(x1$series, nar = 1, nma = 1, dtol = 1e-10)) 31 | 32 | Call: 33 | fracdiff(x = x1$series, nar = 1, nma = 1, dtol = 1e-10) 34 | 35 | Coefficients: 36 | d ar ma 37 | 0.26721 0.27824 -0.36951 38 | sigma[eps] = 0.99138 39 | a list with components: 40 | [1] "log.likelihood" "n" "msg" "d" 41 | [5] "ar" "ma" "covariance.dpq" "fnormMin" 42 | [9] "sigma" "stderror.dpq" "correlation.dpq" "h" 43 | [13] "d.tol" "M" "hessian.dpq" "length.w" 44 | [17] "residuals" "fitted" "call" 45 | > vcov(fd1) 46 | d ar1 ma1 47 | d 0.00059661 -0.00080522 -0.00018971 48 | ar1 -0.00080522 0.00161219 0.00066399 49 | ma1 -0.00018971 0.00066399 0.00054849 50 | > logLik(fd1) 51 | 'log Lik.' -7051.5 (df=4) 52 | > 53 | > fdCOVcomp <- 54 | + c("h", "covariance.dpq", "stderror.dpq", "correlation.dpq", "hessian.dpq") 55 | > fd1. <- fracdiff.var(x1$series, fd1, h = fd1$h / 2) 56 | > dns <- dimnames(fd1.$covariance.dpq) 57 | > 58 | > ## dput(sapply(fd1.[fdCOVcomp], signif, digits = 4)) # edited: 59 | > fd1.L <- list( 60 | + h = 3.7155e-05, 61 | + covariance.dpq = matrix(c(0.0005966, -0.0008052, -0.0001897, 62 | + -0.0008052, 0.001612, 0.000664, 63 | + -0.0001897, 0.000664, 0.0005485), 64 | + 3L, 3L, dimnames = dns), 65 | + stderror.dpq = c(0.02443, 0.04015, 0.02342), 66 | + correlation.dpq = matrix(c(1, -0.821, -0.3316, 67 | + -0.821, 1, 0.7061, 68 | + -0.3316, 0.7061, 1), 3), 69 | + hessian.dpq = matrix(c(-8252, -5875, 4258, 70 | + -5875, -5420, 4529, 71 | + 4258, 4529, -5834), 72 | + 3L, 3L, dimnames = dns)) 73 | > stopifnot(all.equal(fd1.[fdCOVcomp], fd1.L, tolerance = 2e-4)) 74 | > 75 | > fd1u <- fracdiff.var(x1$series, fd1, h = fd1$h * 8) 76 | > ## dput(sapply(fd1u[fdCOVcomp], signif, digits = 4)) : 77 | > fd1uL <- list( 78 | + h = 0.0005945, 79 | + covariance.dpq = matrix(c(0.0005966, -0.0008052, -0.0001897, 80 | + -0.0008052, 0.001612, 0.000664, 81 | + -0.0001897, 0.000664, 0.0005485), 82 | + 3L, 3L, dimnames = dns), 83 | + stderror.dpq = c(0.02443, 0.04015, 0.02342), 84 | + correlation.dpq = matrix(c(1, -0.821, -0.3316, 85 | + -0.821, 1, 0.7061, 86 | + -0.3316, 0.7061, 1), 3), 87 | + hessian.dpq = matrix(c(-8252, -5875, 4258, 88 | + -5875, -5420, 4529, 89 | + 4258, 4529, -5834), 90 | + 3L, 3L, dimnames = dns)) 91 | > stopifnot( all.equal(fd1u[fdCOVcomp], fd1uL, tolerance = 2e-4) ) 92 | > 93 | > ## 2) 94 | > 95 | > x2 <- fracdiff.sim( 2048, ar = .8, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 96 | > ## -> NA's and problems 97 | > fd2 <- fracdiff(x2$series, nar = length(x2$ar), nma = length(x2$ma)) 98 | > sfd2 <- summary(fd2) 99 | > ss2 <- lapply(sfd2[setdiff(names(sfd2), c("residuals", "fitted"))], 100 | + function(.) if(is.numeric(.)) signif(., digits = 7) else .) 101 | > ss2$coefficients <- ss2$coefficients[, -4] # drop p values 102 | > ss2S <- list( 103 | + log.likelihood = -2924.262, n = 2048, 104 | + msg = c(fracdf = "ok", fdcov = "ok"), 105 | + covariance.dpq = matrix(c(0.0004182859, -0.0007078449, -6.753008e-05, 106 | + -0.0007078449, 0.001712827, 0.0002692938, 107 | + -6.753008e-05, 0.0002692938, 0.0002572701), 3L, 108 | + dimnames = dns), 109 | + fnormMin = 45.62935, sigma = 1.008768, 110 | + correlation.dpq = matrix(c(1, -0.8362667, -0.2058572, 111 | + -0.8362667, 1, 0.405672, 112 | + -0.2058572, 0.405672, 1), 3, dimnames = dns), 113 | + h = 3.082264e-05, d.tol = 0.0001220703, M = 100, 114 | + hessian.dpq = matrix(c(-8557.83, -3810.55, 1742.32, 115 | + -3810.55, -2395.564, 1507.303, 116 | + 1742.32, 1507.303, -5007.377), 3, dimnames = dns), 117 | + length.w = 10254, 118 | + call = quote( 119 | + fracdiff(x = x2$series, nar = length(x2$ar), nma = length(x2$ma))), 120 | + coefficients = matrix(c(0.3374173, 0.7709664, -0.3810478, 121 | + 0.02045204, 0.04138631, 0.01603964, 122 | + 16.49798, 18.62854, -23.75663), 123 | + 3, 3, dimnames = dimnames(ss2$coefficients)), 124 | + df = 4, aic = 5856.524, symbolic.cor = FALSE) 125 | > ## 126 | > if(doExtras) 127 | + print(all.equal(ss2S, ss2, tol = 0)) # 0.0001273 (32b Win); TRUE (64b F30, gcc) 128 | > stopifnot(all.equal(ss2S, ss2, tol = 4e-4)) 129 | > 130 | > fd2. <- fracdiff.var(x2$series, fd2, h = fd2$h / 2) 131 | > sfd2. <- sapply(fd2.[fdCOVcomp], signif, digits = 4) 132 | > sfd2S <- ## dput(sapply(fd2.[fdCOVcomp], signif, digits = 5)) 133 | + list(h = 1.5411e-05, 134 | + covariance.dpq = matrix(c( 5.4726e-05,-9.261e-05, -8.8353e-06, 135 | + -9.261e-05, 0.0006717, 0.00016997, 136 | + -8.8353e-06, 0.00016997, 0.00024779), 3, dimnames=dns), 137 | + stderror.dpq = c(0.0073977, 0.025917, 0.015741), 138 | + correlation.dpq = matrix(c(1, -0.48303, -0.075871, 139 | + -0.48303, 1, 0.41661, 140 | + -0.075871, 0.41661, 1), 3), 141 | + hessian.dpq = matrix(c(-24440, -3810.6, 1742.3, 142 | + -3810.6, -2395.6, 1507.3, 143 | + 1742.3, 1507.3,-5007.4), 3, dimnames=dns)) 144 | > ## 145 | > if(doExtras) 146 | + print(all.equal(sfd2S, sfd2., tol = 1e-6, countEQ=TRUE)) # 8.7655e-5 147 | > stopifnot(all.equal(sfd2S, sfd2., tol = 2e-4, countEQ=TRUE)) 148 | > 149 | > fd2u <- fracdiff.var(x2$series, fd2, h = fd2$h * 8)#-> warning, unable .. corr... 150 | Warning message: 151 | In fracdiff.var(x2$series, fd2, h = fd2$h * 8) : 152 | unable to compute correlation matrix 153 | > sd2u <- sapply(fd2u[fdCOVcomp], signif, digits = 4) 154 | > sd2uS <- list( ## dput(sapply(sd2u[fdCOVcomp], signif, digits = 5)) 155 | + h = 0.0002466, 156 | + covariance.dpq = matrix(c(-0.0003545, 6e-04, 5.724e-05, 157 | + 6e-04, -0.0005003, 5.816e-05, 158 | + 5.724e-05, 5.816e-05, 0.0002371), 3, dimnames=dns), 159 | + stderror.dpq = c(0, 0, 0.0154), 160 | + correlation.dpq = matrix(0, 3,3), 161 | + hessian.dpq = matrix(c(-3347, -3811, 1742, 162 | + -3811, -2396, 1507, 163 | + 1742, 1507,-5007), 3, dimnames=dns)) 164 | > ## 165 | > if(doExtras) 166 | + print(all.equal(sd2uS, sd2u, tol = 1e-8, countEQ=TRUE))# 0.000103 (32b Win); T.(64b F30) 167 | > stopifnot(all.equal(sd2uS, sd2u, tol = 4e-4, countEQ=TRUE)) 168 | > 169 | > 170 | > proc.time() 171 | user system elapsed 172 | 0.336 0.061 2.265 173 | -------------------------------------------------------------------------------- /tests/ex.Rout.save: -------------------------------------------------------------------------------- 1 | 2 | R Under development (unstable) (2024-03-12 r86109) -- "Unsuffered Consequences" 3 | Copyright (C) 2024 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | R is a collaborative project with many contributors. 11 | Type 'contributors()' for more information and 12 | 'citation()' on how to cite R or R packages in publications. 13 | 14 | Type 'demo()' for some demos, 'help()' for on-line help, or 15 | 'help.start()' for an HTML browser interface to help. 16 | Type 'q()' to quit R. 17 | 18 | > library(fracdiff) 19 | > 20 | > doExtras <- fracdiff:::doExtras() 21 | > .proctime00 <- proc.time() 22 | > 23 | > set.seed(107) 24 | > options(digits = 5) 25 | > 26 | > ## 1) 27 | > 28 | > x1 <- fracdiff.sim(5000, ar = .2, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 29 | > summary(fd1 <- fracdiff(x1$series, nar = 1, nma = 1, dtol = 1e-10)) 30 | 31 | Call: 32 | fracdiff(x = x1$series, nar = 1, nma = 1, dtol = 1e-10) 33 | 34 | Coefficients: 35 | Estimate Std. Error z value Pr(>|z|) 36 | d 0.2672 0.0244 10.94 < 2e-16 *** 37 | ar 0.2782 0.0402 6.93 4.2e-12 *** 38 | ma -0.3695 0.0234 -15.78 < 2e-16 *** 39 | --- 40 | Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 41 | sigma[eps] = 0.99138 42 | [d.tol = 1.054e-08, M = 100, h = 7.431e-05] 43 | Log likelihood: -7.05e+03 ==> AIC = 14111 [4 deg.freedom] 44 | > vcov(fd1) 45 | d ar1 ma1 46 | d 0.00059661 -0.00080522 -0.00018971 47 | ar1 -0.00080522 0.00161219 0.00066399 48 | ma1 -0.00018971 0.00066399 0.00054849 49 | > logLik(fd1) 50 | 'log Lik.' -7051.5 (df=4) 51 | > stopifnot(all.equal(structure(-7051.5027, df = 4L, nall = 5000L, nobs = 5000L, class = "logLik"), 52 | + logLik(fd1))) 53 | > fdCOVcomp <- 54 | + c("h", "covariance.dpq", "stderror.dpq", "correlation.dpq", "hessian.dpq") 55 | > fd1. <- fracdiff.var(x1$series, fd1, h = fd1$h / 2) 56 | > dns <- dimnames(fd1.$covariance.dpq) 57 | > 58 | > ## dput(sapply(fd1.[fdCOVcomp], signif, digits = 4)) # edited: 59 | > fd1.L <- list( 60 | + h = 3.7155e-05, 61 | + covariance.dpq = matrix(c(0.0005966, -0.0008052, -0.0001897, 62 | + -0.0008052, 0.001612, 0.000664, 63 | + -0.0001897, 0.000664, 0.0005485), 64 | + 3L, 3L, dimnames = dns), 65 | + stderror.dpq = c(0.02443, 0.04015, 0.02342), 66 | + correlation.dpq = matrix(c(1, -0.821, -0.3316, 67 | + -0.821, 1, 0.7061, 68 | + -0.3316, 0.7061, 1), 3), 69 | + hessian.dpq = matrix(c(-8252, -5875, 4258, 70 | + -5875, -5420, 4529, 71 | + 4258, 4529, -5834), 72 | + 3L, 3L, dimnames = dns)) 73 | > stopifnot(all.equal(fd1.[fdCOVcomp], fd1.L, tolerance = 2e-4)) 74 | > 75 | > fd1u <- fracdiff.var(x1$series, fd1, h = fd1$h * 8) 76 | > ## dput(sapply(fd1u[fdCOVcomp], signif, digits = 4)) : 77 | > fd1uL <- list( 78 | + h = 0.0005945, 79 | + covariance.dpq = matrix(c(0.0005966, -0.0008052, -0.0001897, 80 | + -0.0008052, 0.001612, 0.000664, 81 | + -0.0001897, 0.000664, 0.0005485), 82 | + 3L, 3L, dimnames = dns), 83 | + stderror.dpq = c(0.02443, 0.04015, 0.02342), 84 | + correlation.dpq = matrix(c(1, -0.821, -0.3316, 85 | + -0.821, 1, 0.7061, 86 | + -0.3316, 0.7061, 1), 3), 87 | + hessian.dpq = matrix(c(-8252, -5875, 4258, 88 | + -5875, -5420, 4529, 89 | + 4258, 4529, -5834), 90 | + 3L, 3L, dimnames = dns)) 91 | > if(doExtras) 92 | + print(all.equal(fd1u[fdCOVcomp], fd1uL, tolerance = 0)) 93 | > stopifnot(all.equal(fd1u[fdCOVcomp], fd1uL, tolerance = 2e-4) ) 94 | > 95 | > ## 2) 96 | > 97 | > x2 <- fracdiff.sim( 2048, ar = .8, ma = -.4, d = .3, n.start=0, allow.0 = TRUE) 98 | > ## -> NA's and problems 99 | > fd2 <- fracdiff(x2$series, nar = length(x2$ar), nma = length(x2$ma)) 100 | > sfd2 <- summary(fd2) 101 | > ss2 <- lapply(sfd2[setdiff(names(sfd2), c("residuals", "fitted"))], 102 | + function(.) if(is.numeric(.)) signif(., digits = 7) else .) 103 | > ss2$coefficients <- ss2$coefficients[, -4] # drop p values 104 | > ss2S <- list( 105 | + log.likelihood = -2924.262, n = 2048, 106 | + msg = c(fracdf = "ok", fdcov = "ok"), 107 | + covariance.dpq = matrix(c(0.0004182859, -0.0007078449, -6.753008e-05, 108 | + -0.0007078449, 0.001712827, 0.0002692938, 109 | + -6.753008e-05, 0.0002692938, 0.0002572701), 3L, 110 | + dimnames = dns), 111 | + fnormMin = 45.62935, sigma = 1.008768, 112 | + correlation.dpq = matrix(c(1, -0.8362667, -0.2058572, 113 | + -0.8362667, 1, 0.405672, 114 | + -0.2058572, 0.405672, 1), 3, dimnames = dns), 115 | + h = 3.082264e-05, d.tol = 0.0001220703, M = 100, 116 | + hessian.dpq = matrix(c(-8557.83, -3810.55, 1742.32, 117 | + -3810.55, -2395.564, 1507.303, 118 | + 1742.32, 1507.303, -5007.377), 3, dimnames = dns), 119 | + length.w = 10254, 120 | + call = quote( 121 | + fracdiff(x = x2$series, nar = length(x2$ar), nma = length(x2$ma))), 122 | + coefficients = matrix(c(0.3374173, 0.7709664, -0.3810478, 123 | + 0.02045204, 0.04138631, 0.01603964, 124 | + 16.49798, 18.62854, -23.75663), 125 | + 3, 3, dimnames = dimnames(ss2$coefficients)), 126 | + df = 4, aic = 5856.524, symbolic.cor = FALSE) 127 | > ## 128 | > if(doExtras) 129 | + print(all.equal(ss2S, ss2, tol = 0)) # 0.0001273 (32b Win); TRUE (64b F30, gcc) 130 | > stopifnot(all.equal(ss2S, ss2, tol = 4e-4)) 131 | > 132 | > fd2. <- fracdiff.var(x2$series, fd2, h = fd2$h / 2) 133 | > sfd2. <- sapply(fd2.[fdCOVcomp], signif, digits = 4) 134 | > sfd2S <- ## dput(sapply(fd2.[fdCOVcomp], signif, digits = 5)) 135 | + list(h = 1.5411e-05, 136 | + covariance.dpq = matrix(c( 5.4726e-05,-9.261e-05, -8.8353e-06, 137 | + -9.261e-05, 0.0006717, 0.00016997, 138 | + -8.8353e-06, 0.00016997, 0.00024779), 3, dimnames=dns), 139 | + stderror.dpq = c(0.0073977, 0.025917, 0.015741), 140 | + correlation.dpq = matrix(c(1, -0.48303, -0.075871, 141 | + -0.48303, 1, 0.41661, 142 | + -0.075871, 0.41661, 1), 3), 143 | + hessian.dpq = matrix(c(-24440, -3810.6, 1742.3, 144 | + -3810.6, -2395.6, 1507.3, 145 | + 1742.3, 1507.3,-5007.4), 3, dimnames=dns)) 146 | > ## 147 | > if(doExtras) 148 | + print(all.equal(sfd2S, sfd2., tol = 0 , countEQ=TRUE)) # 8.7655e-5 149 | > stopifnot(all.equal(sfd2S, sfd2., tol = 2e-4, countEQ=TRUE)) 150 | > 151 | > fd2u <- fracdiff.var(x2$series, fd2, h = fd2$h * 8)#-> warning, unable .. corr... 152 | Warning message: 153 | In fracdiff.var(x2$series, fd2, h = fd2$h * 8) : 154 | unable to compute correlation matrix 155 | > ##= no se.ok --> 156 | > fdCOV.0 <- setdiff(fdCOVcomp, c("stderror.dpq", "correlation.dpq")) 157 | > sd2u <- sapply(fd2u[fdCOV.0], signif, digits = 4) 158 | > sd2uS <- list( ## dput(sapply(sd2u[fdCOVcomp], signif, digits = 5)) 159 | + h = 0.0002466, 160 | + covariance.dpq = matrix(c(-0.0003545, 6e-04, 5.724e-05, 161 | + 6e-04, -0.0005003, 5.816e-05, 162 | + 5.724e-05, 5.816e-05, 0.0002371), 3, dimnames=dns), 163 | + ## stderror.dpq = c(0, 0, 0.0154), 164 | + ## correlation.dpq = matrix(0, 3,3), 165 | + hessian.dpq = matrix(c(-3347, -3811, 1742, 166 | + -3811, -2396, 1507, 167 | + 1742, 1507,-5007), 3, dimnames=dns)) 168 | > ## 169 | > if(doExtras) 170 | + print(all.equal(sd2uS, sd2u, tol = 0 , countEQ=TRUE))# 0.000103 (32b Win); T.(64b F30) 171 | > stopifnot(all.equal(sd2uS, sd2u, tol = 4e-4, countEQ=TRUE)) 172 | > 173 | > 174 | > proc.time() 175 | user system elapsed 176 | 0.178 0.044 0.238 177 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2024-03-13 Martin Maechler 2 | 3 | * DESCRIPTION (Version): 1.5-4: 4 | * R/fracdiff.var: finally fix 'FIXME': se.ok 5 | * tests/sim*: updates, searching for 'h' in fracdiff.var(.., h = *) 6 | 7 | 2022-10-18 Martin Maechler 8 | 9 | * DESCRIPTION (Version): 1.5-2: 10 | * src/fracdiff.h, src/fdcore.c: (S_fp) pointer *with* argument list [clang15 warnings]. 11 | 12 | 2020-01-17 Martin Maechler 13 | 14 | * DESCRIPTION (Version): 1.5-1; for CRAN 'Additional issues', fiddling w/ 15 | * tests/Valderio-ex.R: show all.equal(*, tol=0) only if "surprising" 16 | 17 | 2019-12-09 Martin Maechler 18 | 19 | * DESCRIPTION (Authors@R): using new format; ready for CRAN 20 | 21 | * R/fd-methods.R (summary.fracdiff): renamed '$ coefficients' such 22 | that 'coef()' works. 23 | 24 | 2019-12-09 Rob Hyndman 25 | 26 | * R/fracdiff.R, fd-methods.R (fracdiff): provide 'residuals()' and 27 | 'fitted'()' methods. 28 | 29 | 2018-09-10 Martin Maechler 30 | 31 | * R/diffseries.R (diffseries): Finally found bug in the fft() based 32 | version {"forgotten" centering} and fixed it. 33 | 34 | 2018-09-06 Martin Maechler 35 | 36 | * DESCRIPTION (Version): 1.5-0 (for new release with proper Imports) 37 | 38 | 2012-12-01 Martin Maechler 39 | 40 | * DESCRIPTION (Version): 1.4-2 41 | 42 | * R/fracdiff.R (fracdiff.sim): new argument 'start.innov' in order 43 | to become even closer to arima.sim(). New arg 'backComp' which 44 | should allow to get *the same* results are arima.sima(). 45 | 46 | 2011-08-09 Martin Maechler 47 | 48 | * DESCRIPTION (Version): 1.4-0 49 | 50 | * R/fd-methods.R (summary.fracdiff): fix bug that gave wrong 'df' 51 | 52 | * R/fracdiff.R (fracdiff): new 'trace' argument; 53 | further: now return estimated sigma (of white noise). 54 | * src/fdcore.c: -> verbose argument for iteration monitoring 55 | 56 | * src/init.c: add (dll symbol) "registration", for implied consistency checking 57 | * NAMESPACE: ditto 58 | 59 | * src/*.[ch]: a bit of cleanup; no longer using global fd_min_fnorm 60 | 61 | 2011-04-29 Martin Maechler 62 | 63 | * src/fdcore.c: remove set but unused variables (R 2.14.0 on CRAN now warns). 64 | 65 | 2009-06-09 Martin Maechler 66 | 67 | * DESCRIPTION (Version): 1.3-2, released to CRAN 68 | 69 | 2009-06-08 Martin Maechler 70 | 71 | * R/fracdiff.R (fracdiff): save *both* kind of warnings; 72 | 73 | * R/fd-methods.R (print.fracdiff): print them 74 | 75 | 2009-05-07 Martin Maechler 76 | src/ 77 | * NAMESPACE: add namespace, "just for fun" 78 | 79 | * R/fracdiff.R (fracdiff): first steps in *saving* 80 | warning messages (from C calls). 81 | 82 | 2006-09-08 Martin Maechler 83 | 84 | * DESCRIPTION (Enhances): longmemo 85 | 86 | 2006-09-08 Martin Maechler 87 | 88 | * released 1.3-1 to CRAN 89 | 90 | * tests/ex.R: update; use summary() 91 | * tests/ex.Rout.save: 92 | 93 | * R/fd-methods.R (summary.fracdiff): logLik + AIC (also in print). 94 | 95 | 2006-09-07 Martin Maechler 96 | 97 | * R/fd-methods.R (summary.fracdiff): also add summary(), print() 98 | vcov() and logLik() methods for that. 99 | 100 | * R/fracdiff.R (fracdiff.var): 101 | 102 | * DESCRIPTION (Version): 1.3-1 103 | 104 | * R/fracdiff.R (fracdiff): finally add *class* "fracdiff" 105 | 106 | * src/Makevars: add missing FLIBS 107 | 108 | * R/fd-methods.R (confint.fracdiff): new, based on 109 | Spencer Graves' code (R-help, 23 Jul 2006) 110 | 111 | * R/fd-methods.R: (print.fracdiff), etc; new; just a stub 112 | * man/fd-methods.Rd: new. 113 | 114 | 2006-02-06 Martin Maechler 115 | 116 | * DESCRIPTION (Version): 1.3-0 released to CRAN 117 | 118 | 2005-12-27 Martin Maechler 119 | 120 | * R/diffseries.R (diffseries): new functions from Valderio Reisen 121 | * R/Sperio.R (Sperio): 122 | 123 | 2005-07-19 Martin Maechler 124 | 125 | * DESCRIPTION (Version): 1.2-2 126 | 127 | * R/fracdiff.R (fracdiff): use .C(), no longer .Fortran() 128 | * src/fdcore.c (fracdf): dito 129 | 130 | * Calling: update 131 | 132 | * tests/sim-ex.R: if(FALSE) library(*, lib="..MM..") 133 | 134 | 2005-07-06 Martin Maechler 135 | 136 | * src/fdhess.c (hesspq_): move "inline" declarations to beginning 137 | of loop: against warning "ISO C89 forbids mixed declarations and code" 138 | 139 | 2005-07-02 Martin Maechler 140 | 141 | * DESCRIPTION (Version): 1.2-1 142 | 143 | * src/fdsim.c (fdsim): finally found "off by 1" indexing bug 144 | {introduced only in 1.1-2, two weeks ago} which accessed s[0] 145 | and hence sometimes gave huge garbage initially. 146 | 147 | * tests/sim-ex.R: new: for fracdiff.sim() bug search 148 | now also a speed test. 149 | 150 | 151 | 2005-06-30 Martin Maechler 152 | 153 | * R/fracdiff.R (fracdiff.sim): add 'n.start', 'rand.gen', etc; 154 | similar as in arima.sim. 155 | NOTA BENE: changes the default fracdiff.sim() result as soon as 156 | --------- p + q >= 1 ! 157 | 158 | 2005-06-29 Martin Maechler 159 | 160 | * DESCRIPTION (Version): 1.2-0 {never released} 161 | 162 | * src/fdcore.c: using FD_EXTERNAL and including all the 163 | ``common block'' declarations: 164 | 165 | * src/mach_comm.h: all these are new, and included by 166 | * src/maux_comm.h: the *.c files that need them. 167 | * src/tols_comm.h: 168 | * src/gamm_comm.h: 169 | * src/hess_comm.h: 170 | 171 | * README: added several general notes 172 | 173 | * R/fracdiff.R (fracdiff): .C("fdhpq"): 'x' is not neeeded 174 | 175 | * src/fdcore.c (fdcom): move fdcom() {Common Block Initialization} 176 | * src/fdhess.c (fdcom): from fdhess.c to fdcore.c 177 | 178 | 2005-06-17 Martin Maechler 179 | 180 | * src/Makevars : drop the non-portable "-O3 -Wall" flags 181 | 182 | 183 | 2005-06-17 Martin Maechler 184 | 185 | * DESCRIPTION (Version): 1.1-2 186 | * DESCRIPTION (Date): 2004-10-02 --- never released ---> now to CRAN 187 | 188 | * tests/ex-Vinod.R: add the example that failed (memory error) 189 | 190 | 2004-10-02 Martin Maechler 191 | 192 | * R/fracdiff.R (fracdiff): new integer work array passed to C. 193 | 194 | * src/fdcore.c (fracdf_): etc: new iw[] integer work array. 195 | 196 | * README: explain the "cast" bug in pqopt_()'s call to lmder1_()... 197 | 198 | * src/fracdiff.h: new for common declarations 199 | 200 | 2004-09-18 Martin Maechler 201 | 202 | * src/fdcore.c: now translated from fortran 203 | * src/fdgam.c: using f2c, my "f2c-clean" 204 | * src/fdhess.c: and lots of manual cleaning. 205 | * src/fdmin.c: 206 | * src/fdsim.c: 207 | 208 | 2004-04-29 Martin Maechler 209 | 210 | * R/fracdiff.R (fracdiff): make 'lenw' compatible to check in 211 | src/fdcore.f; {also make "info = 1" message more informative} 212 | 213 | * src/fdcore.f (fracdf): in the case of too small workspace, 214 | return the desired size to R. 215 | 216 | 2004-01-12 Martin Maechler 217 | 218 | * DESCRIPTION (Version): 1.1-1 219 | 220 | * tests/ex.R: changed version; less precision - portable? 221 | * tests/ex.Rout.save: 222 | 223 | 2004-01-07 Martin Maechler 224 | 225 | * man/fracdiff.Rd: explain `h' argument and its default; 226 | now list all components in \value{}; also 'dtol': 227 | * R/fracdiff.R: dtol < 0 now does work as the docs have always said. 228 | 229 | * src/Makevars (PKG_LIBS): new; use BLAS_LIBS. 230 | 231 | 2003-12-29 Martin Maechler 232 | 233 | * DESCRIPTION (Version): 1.1-0 -> released to CRAN 234 | 235 | * tests/ex.R: new - first regression tests 236 | 237 | * R/fracdiff.R (fracdiff): found *the* bug!! : use result$w ! 238 | 239 | * src/fdmin.f: declared all; checked with "implicit none" 240 | * src/fdhess.f: 241 | * src/fdcore.f: 242 | 243 | * src/fdgam.f (d9lgmc): fixed typo: s/d9gmlc/d9lgmc/ 244 | checked all with "implicit none" 245 | 246 | * DESCRIPTION (Maintainer): Martin Maechler (was ORPHANED) 247 | * DESCRIPTION (License): GPL 248 | 249 | -------------------------------------------------------------------------------- /tests/sim-ex.Rout.save: -------------------------------------------------------------------------------- 1 | 2 | R Under development (unstable) (2024-03-12 r86109) -- "Unsuffered Consequences" 3 | Copyright (C) 2024 The R Foundation for Statistical Computing 4 | Platform: x86_64-pc-linux-gnu 5 | 6 | R is free software and comes with ABSOLUTELY NO WARRANTY. 7 | You are welcome to redistribute it under certain conditions. 8 | Type 'license()' or 'licence()' for distribution details. 9 | 10 | R is a collaborative project with many contributors. 11 | Type 'contributors()' for more information and 12 | 'citation()' on how to cite R or R packages in publications. 13 | 14 | Type 'demo()' for some demos, 'help()' for on-line help, or 15 | 'help.start()' for an HTML browser interface to help. 16 | Type 'q()' to quit R. 17 | 18 | > library(fracdiff) 19 | > if(FALSE) # manual testing 20 | + library(fracdiff, lib="/u/maechler/R/Pkgs/fracdiff.Rcheck-64b") 21 | > 22 | > .ptime <- proc.time() 23 | > ## Test if the default 'n.start' is ok, i.e., if the 24 | > ## "burn in" period is long enough : 25 | > 26 | > n <- 512 27 | > 28 | > set.seed(101) ; ok <- TRUE 29 | > for(i in 1:2000) { 30 | + r <- fracdiff.sim(n, ar = -0.9, ma = NULL, d = 0.3)$series 31 | + if(max(abs(r)) > 10) { 32 | + cat("OOps! Indices", 33 | + capture.output(str(ibig <- which(big <- abs(r) > 10))), "-- are > 10\n") 34 | + if(any(ibig < 200) && (length(ibig) > 5 || abs(r)[big] > 20)) { 35 | + cat("Some have index < 200 --> BREAK\n") 36 | + ok <- FALSE 37 | + break 38 | + } 39 | + } 40 | + if(i %% 100 == 0) { 41 | + cat(i,": ACF = \n") 42 | + print(acf(r, plot=FALSE)) 43 | + } 44 | + } 45 | 100 : ACF = 46 | 47 | Autocorrelations of series 'r', by lag 48 | 49 | 0 1 2 3 4 5 6 7 8 9 10 50 | 1.000 -0.810 0.793 -0.668 0.635 -0.542 0.516 -0.446 0.445 -0.395 0.401 51 | 11 12 13 14 15 16 17 18 19 20 21 52 | -0.361 0.374 -0.332 0.329 -0.304 0.319 -0.312 0.319 -0.289 0.314 -0.300 53 | 22 23 24 25 26 27 54 | 0.302 -0.288 0.282 -0.256 0.235 -0.218 55 | OOps! Indices int 443 -- are > 10 56 | 200 : ACF = 57 | 58 | Autocorrelations of series 'r', by lag 59 | 60 | 0 1 2 3 4 5 6 7 8 9 10 61 | 1.000 -0.792 0.775 -0.613 0.560 -0.421 0.366 -0.267 0.228 -0.148 0.124 62 | 11 12 13 14 15 16 17 18 19 20 21 63 | -0.068 0.047 0.004 0.000 0.040 -0.027 0.041 -0.013 0.036 0.001 -0.014 64 | 22 23 24 25 26 27 65 | 0.058 -0.056 0.079 -0.068 0.085 -0.080 66 | 300 : ACF = 67 | 68 | Autocorrelations of series 'r', by lag 69 | 70 | 0 1 2 3 4 5 6 7 8 9 10 71 | 1.000 -0.842 0.817 -0.700 0.666 -0.572 0.546 -0.456 0.445 -0.385 0.386 72 | 11 12 13 14 15 16 17 18 19 20 21 73 | -0.336 0.342 -0.289 0.303 -0.261 0.266 -0.226 0.227 -0.185 0.199 -0.165 74 | 22 23 24 25 26 27 75 | 0.172 -0.136 0.135 -0.103 0.121 -0.104 76 | 400 : ACF = 77 | 78 | Autocorrelations of series 'r', by lag 79 | 80 | 0 1 2 3 4 5 6 7 8 9 10 81 | 1.000 -0.864 0.832 -0.739 0.698 -0.624 0.567 -0.498 0.443 -0.372 0.341 82 | 11 12 13 14 15 16 17 18 19 20 21 83 | -0.286 0.254 -0.212 0.157 -0.115 0.066 -0.039 0.013 0.011 -0.013 0.020 84 | 22 23 24 25 26 27 85 | -0.035 0.029 -0.032 0.026 -0.053 0.051 86 | 500 : ACF = 87 | 88 | Autocorrelations of series 'r', by lag 89 | 90 | 0 1 2 3 4 5 6 7 8 9 10 91 | 1.000 -0.766 0.729 -0.578 0.549 -0.427 0.396 -0.289 0.277 -0.196 0.189 92 | 11 12 13 14 15 16 17 18 19 20 21 93 | -0.123 0.131 -0.090 0.116 -0.084 0.103 -0.042 0.060 -0.036 0.055 -0.043 94 | 22 23 24 25 26 27 95 | 0.041 -0.032 0.033 -0.056 0.063 -0.092 96 | 600 : ACF = 97 | 98 | Autocorrelations of series 'r', by lag 99 | 100 | 0 1 2 3 4 5 6 7 8 9 10 101 | 1.000 -0.822 0.765 -0.634 0.607 -0.513 0.478 -0.384 0.357 -0.295 0.283 102 | 11 12 13 14 15 16 17 18 19 20 21 103 | -0.220 0.194 -0.153 0.136 -0.089 0.072 -0.044 0.028 0.000 -0.006 0.039 104 | 22 23 24 25 26 27 105 | -0.053 0.082 -0.098 0.110 -0.097 0.086 106 | 700 : ACF = 107 | 108 | Autocorrelations of series 'r', by lag 109 | 110 | 0 1 2 3 4 5 6 7 8 9 10 111 | 1.000 -0.855 0.824 -0.724 0.698 -0.627 0.610 -0.554 0.516 -0.466 0.441 112 | 11 12 13 14 15 16 17 18 19 20 21 113 | -0.391 0.359 -0.302 0.275 -0.234 0.233 -0.204 0.205 -0.197 0.198 -0.187 114 | 22 23 24 25 26 27 115 | 0.186 -0.181 0.169 -0.165 0.172 -0.180 116 | 800 : ACF = 117 | 118 | Autocorrelations of series 'r', by lag 119 | 120 | 0 1 2 3 4 5 6 7 8 9 10 121 | 1.000 -0.809 0.748 -0.649 0.598 -0.546 0.510 -0.450 0.414 -0.373 0.337 122 | 11 12 13 14 15 16 17 18 19 20 21 123 | -0.298 0.274 -0.249 0.238 -0.201 0.172 -0.144 0.138 -0.113 0.090 -0.061 124 | 22 23 24 25 26 27 125 | 0.043 -0.045 0.040 -0.051 0.052 -0.035 126 | 900 : ACF = 127 | 128 | Autocorrelations of series 'r', by lag 129 | 130 | 0 1 2 3 4 5 6 7 8 9 10 131 | 1.000 -0.834 0.824 -0.696 0.679 -0.572 0.562 -0.473 0.460 -0.375 0.371 132 | 11 12 13 14 15 16 17 18 19 20 21 133 | -0.307 0.318 -0.261 0.262 -0.202 0.200 -0.136 0.139 -0.086 0.097 -0.034 134 | 22 23 24 25 26 27 135 | 0.036 0.012 0.002 0.037 -0.011 0.037 136 | 1000 : ACF = 137 | 138 | Autocorrelations of series 'r', by lag 139 | 140 | 0 1 2 3 4 5 6 7 8 9 10 141 | 1.000 -0.844 0.813 -0.699 0.668 -0.594 0.565 -0.502 0.477 -0.426 0.386 142 | 11 12 13 14 15 16 17 18 19 20 21 143 | -0.343 0.319 -0.299 0.270 -0.233 0.193 -0.153 0.127 -0.104 0.093 -0.083 144 | 22 23 24 25 26 27 145 | 0.086 -0.083 0.059 -0.048 0.036 -0.035 146 | 1100 : ACF = 147 | 148 | Autocorrelations of series 'r', by lag 149 | 150 | 0 1 2 3 4 5 6 7 8 9 10 151 | 1.000 -0.713 0.713 -0.547 0.555 -0.422 0.443 -0.358 0.368 -0.297 0.289 152 | 11 12 13 14 15 16 17 18 19 20 21 153 | -0.241 0.238 -0.152 0.145 -0.092 0.124 -0.075 0.099 -0.056 0.078 -0.027 154 | 22 23 24 25 26 27 155 | 0.022 -0.013 0.045 -0.024 0.042 -0.059 156 | 1200 : ACF = 157 | 158 | Autocorrelations of series 'r', by lag 159 | 160 | 0 1 2 3 4 5 6 7 8 9 10 161 | 1.000 -0.785 0.726 -0.594 0.522 -0.445 0.402 -0.366 0.349 -0.313 0.297 162 | 11 12 13 14 15 16 17 18 19 20 21 163 | -0.231 0.204 -0.124 0.107 -0.052 0.002 0.064 -0.088 0.120 -0.106 0.128 164 | 22 23 24 25 26 27 165 | -0.150 0.166 -0.183 0.217 -0.231 0.256 166 | 1300 : ACF = 167 | 168 | Autocorrelations of series 'r', by lag 169 | 170 | 0 1 2 3 4 5 6 7 8 9 10 171 | 1.000 -0.830 0.830 -0.705 0.700 -0.593 0.575 -0.487 0.468 -0.383 0.361 172 | 11 12 13 14 15 16 17 18 19 20 21 173 | -0.287 0.289 -0.229 0.235 -0.173 0.176 -0.147 0.141 -0.094 0.077 -0.034 174 | 22 23 24 25 26 27 175 | 0.025 0.021 -0.013 0.045 -0.030 0.057 176 | 1400 : ACF = 177 | 178 | Autocorrelations of series 'r', by lag 179 | 180 | 0 1 2 3 4 5 6 7 8 9 10 181 | 1.000 -0.841 0.800 -0.702 0.662 -0.587 0.546 -0.467 0.428 -0.372 0.360 182 | 11 12 13 14 15 16 17 18 19 20 21 183 | -0.315 0.293 -0.251 0.254 -0.234 0.233 -0.220 0.222 -0.220 0.219 -0.204 184 | 22 23 24 25 26 27 185 | 0.194 -0.167 0.181 -0.157 0.162 -0.151 186 | 1500 : ACF = 187 | 188 | Autocorrelations of series 'r', by lag 189 | 190 | 0 1 2 3 4 5 6 7 8 9 10 191 | 1.000 -0.807 0.811 -0.670 0.677 -0.562 0.551 -0.442 0.421 -0.338 0.321 192 | 11 12 13 14 15 16 17 18 19 20 21 193 | -0.258 0.259 -0.224 0.225 -0.197 0.189 -0.178 0.174 -0.179 0.180 -0.191 194 | 22 23 24 25 26 27 195 | 0.179 -0.188 0.169 -0.166 0.142 -0.121 196 | 1600 : ACF = 197 | 198 | Autocorrelations of series 'r', by lag 199 | 200 | 0 1 2 3 4 5 6 7 8 9 10 201 | 1.000 -0.825 0.800 -0.662 0.629 -0.527 0.487 -0.409 0.378 -0.303 0.275 202 | 11 12 13 14 15 16 17 18 19 20 21 203 | -0.195 0.181 -0.140 0.154 -0.129 0.141 -0.110 0.108 -0.078 0.070 -0.047 204 | 22 23 24 25 26 27 205 | 0.046 -0.001 0.003 0.061 -0.042 0.084 206 | 1700 : ACF = 207 | 208 | Autocorrelations of series 'r', by lag 209 | 210 | 0 1 2 3 4 5 6 7 8 9 10 211 | 1.000 -0.830 0.798 -0.675 0.624 -0.527 0.487 -0.416 0.391 -0.325 0.297 212 | 11 12 13 14 15 16 17 18 19 20 21 213 | -0.252 0.210 -0.161 0.130 -0.108 0.093 -0.076 0.081 -0.068 0.087 -0.054 214 | 22 23 24 25 26 27 215 | 0.041 -0.025 0.017 0.007 -0.001 0.028 216 | 1800 : ACF = 217 | 218 | Autocorrelations of series 'r', by lag 219 | 220 | 0 1 2 3 4 5 6 7 8 9 10 221 | 1.000 -0.704 0.679 -0.530 0.486 -0.400 0.381 -0.307 0.314 -0.271 0.273 222 | 11 12 13 14 15 16 17 18 19 20 21 223 | -0.257 0.241 -0.230 0.223 -0.166 0.185 -0.146 0.151 -0.121 0.136 -0.120 224 | 22 23 24 25 26 27 225 | 0.154 -0.118 0.142 -0.107 0.095 -0.074 226 | 1900 : ACF = 227 | 228 | Autocorrelations of series 'r', by lag 229 | 230 | 0 1 2 3 4 5 6 7 8 9 10 231 | 1.000 -0.856 0.816 -0.685 0.630 -0.535 0.493 -0.444 0.427 -0.400 0.384 232 | 11 12 13 14 15 16 17 18 19 20 21 233 | -0.361 0.348 -0.326 0.304 -0.280 0.252 -0.203 0.172 -0.123 0.103 -0.061 234 | 22 23 24 25 26 27 235 | 0.073 -0.040 0.042 -0.005 -0.016 0.051 236 | 2000 : ACF = 237 | 238 | Autocorrelations of series 'r', by lag 239 | 240 | 0 1 2 3 4 5 6 7 8 9 10 241 | 1.000 -0.824 0.804 -0.640 0.620 -0.508 0.495 -0.390 0.380 -0.280 0.281 242 | 11 12 13 14 15 16 17 18 19 20 21 243 | -0.208 0.223 -0.160 0.173 -0.133 0.160 -0.140 0.172 -0.137 0.162 -0.112 244 | 22 23 24 25 26 27 245 | 0.140 -0.111 0.170 -0.159 0.217 -0.196 246 | > if(!ok) { 247 | + cat("i=",i," gave series \n") 248 | + print(head(r)) ; cat(".......\n") 249 | + plot(as.ts(r)) ## clearly did show problem {when we had bug} 250 | + } 251 | > 252 | > ## Try to find an example more quickly with setting `one seed': 253 | > .AR <- c(-.75, -.9) 254 | > .MA <- c(0.2, 0.1) 255 | > ok <- TRUE 256 | > set.seed(1) 257 | > r0 <- fracdiff.sim(100, d = 0.3) 258 | > r1 <- fracdiff.sim(100, ar = .AR, d = 0.25) 259 | > r2 <- fracdiff.sim(100, ar = .AR, ma = .MA, d = 0.2) 260 | > for(i in 1:1000) { 261 | + set.seed(1)# yes; identical ones 262 | + r0i <- fracdiff.sim(100, d = 0.3) 263 | + r1i <- fracdiff.sim(100, ar = .AR, d = 0.25) 264 | + r2i <- fracdiff.sim(100, ar = .AR, ma = .MA, d = 0.2) 265 | + stopifnot(identical(r0, r0i), 266 | + identical(r1, r1i), 267 | + identical(r2, r2i)) 268 | + } 269 | > 270 | > ## Last Line: 271 | > cat('Time elapsed: ', proc.time() - .ptime,'\n') 272 | Time elapsed: 0.94 0.025 0.968 0 0 273 | > 274 | > proc.time() 275 | user system elapsed 276 | 1.052 0.060 1.130 277 | -------------------------------------------------------------------------------- /R/fracdiff.R: -------------------------------------------------------------------------------- 1 | ### Patched by Friedrich.Leisch, for use with R, 22.1.1997; then 2 | ### 3 | ### Copyright 2003--2024 Martin Maechler; fixed, changed enhanced .. 4 | 5 | ### Original file: 6 | ### copyright 1991 Department of Statistics, University of Washington 7 | 8 | if(getRversion() < "2.15") 9 | paste0 <- function(...) paste(..., sep="") 10 | 11 | .fdcov <- function(x, d, h, # <- missing by default 12 | nar, nma, hess, fdf.work) 13 | { 14 | npq <- as.integer(nar + nma) 15 | npq1 <- npq + 1L # integer, too 16 | stopifnot(length(di <- dim(hess)) == 2, di == c(npq1, npq1)) 17 | fdc <- .C(fdcov, ## --> ../src/fdhess.c 18 | x, 19 | d, 20 | h = as.double(if(missing(h)) -1 else h), 21 | hd = double(npq1), 22 | cov = hess, npq1, 23 | cor = hess, npq1, 24 | se = double(npq1), 25 | fdf.work, 26 | info = integer(1))[c("h","hd", "cov","cor", "se", "info")] 27 | 28 | f.msg <- 29 | if(fdc$info) { 30 | msg <- 31 | switch(fdc$info, 32 | "fdcov problem in gamma function", # 1 33 | "singular Hessian", # 2 34 | ## FIXME improve: different reasons for info = 3 : 35 | "unable to compute correlation matrix; maybe change 'h'", 36 | # 3 37 | stop("error in gamma function")) # 4 38 | warning(msg, call. = FALSE) 39 | msg 40 | } else "ok" 41 | se.ok <- fdc$info %in% 0:2 42 | nam <- "d" 43 | if(nar) nam <- c(nam, paste0("ar", 1:nar)) 44 | if(nma) nam <- c(nam, paste0("ma", 1:nma)) 45 | 46 | dimnames(fdc$cov) <- dn <- list(nam, nam) 47 | if(se.ok) dimnames(fdc$cor) <- dn 48 | list(msg = f.msg, d = d, nam = nam, 49 | h = fdc$h, hd = fdc$hd, se.ok = se.ok, 50 | covariance.dpq = fdc$cov, 51 | stderror.dpq = if(se.ok) fdc$se, # else NULL 52 | correlation.dpq= if(se.ok) fdc$cor) 53 | }## end{.fdcov} 54 | 55 | fracdiff <- function(x, nar = 0, nma = 0, 56 | ar = rep(NA, max(nar, 1)), ma = rep(NA, max(nma, 1)), 57 | dtol = NULL, drange = c(0, 0.5), h, M = 100, trace = 0) 58 | { 59 | ## ######################################################################### 60 | ## 61 | ## x - time series for the ARIMA model 62 | ## nar - number of autoregressive parameters 63 | ## nma - number of moving average parameters 64 | ## ar - initial autoregressive parameters 65 | ## ma - initial moving average parameters 66 | ## dtol - desired accurcay for d 67 | ## by default (and if negative), (4th root of machine precision) 68 | ## is used. dtol will be changed internally if necessary 69 | ## drange - interval over which the likelihood function is to be maximized 70 | ## as a function of d 71 | ## h - finite difference interval 72 | ## M - number of terms in the likelihood approximation 73 | ## 74 | ## (see Haslett and Raftery 1989) 75 | ## 76 | ## ######################################################################## 77 | 78 | cl <- match.call() 79 | if(any(is.na(x))) 80 | stop("missing values not allowed in time series") 81 | if(is.matrix(x) && ncol(x) > 2) 82 | stop("multivariate time series not allowed") 83 | n <- length(x) 84 | if(round(nar) != nar || nar < 0 || round(nma) != nma || nma < 0) 85 | stop("'nar' and 'nma' must be non-negative integer numbers") 86 | npq <- as.integer(nar + nma) 87 | npq1 <- npq + 1L # integer, too 88 | lenw <- max(npq + 2*(n + M), 89 | 3*n + (n+6)*npq + npq %/% 2 + 1, 90 | 31 * 12, ## << added because checked in ../src/fdcore.f 91 | (3 + 2*npq1) * npq1 + 1)## << this is *not* checked (there) 92 | lenw <- as.integer(lenw) 93 | ar[is.na(ar)] <- 0 94 | ma[is.na(ma)] <- 0 95 | if(is.null(dtol)) 96 | dtol <- .Machine$double.eps^0.25 # ~ 1.22e-4 97 | ## if dtol < 0: the fortran code will choose defaults 98 | tspx <- tsp(x) # Added by RJH. 9 Dec 2019 99 | x <- as.double(x) 100 | 101 | ## this also initializes "common blocks" that are used in .C(.) calls : 102 | fdf <- .C(fracdf, 103 | x, 104 | n, 105 | as.integer(M), 106 | as.integer(nar), 107 | as.integer(nma), 108 | dtol = as.double(dtol), 109 | drange = as.double(drange), 110 | hood.etc = double(3), 111 | d = double(1), 112 | ar = as.double(ar), 113 | ma = as.double(ma), 114 | w = double(lenw), 115 | lenw = lenw, 116 | iw = integer(npq), ## <<< new int-work array 117 | info = as.integer(trace > 0),## <- "verbose" [input] 118 | .Machine$double.xmin, 119 | .Machine$double.xmax, 120 | .Machine$double.neg.eps, 121 | .Machine$double.eps)[c("dtol","drange","hood.etc", 122 | "d", "ar", "ma", "w", "lenw", "info")] 123 | 124 | fd.msg <- 125 | if(fdf$info) { 126 | msg <- 127 | switch(fdf$info, 128 | stop("insufficient workspace; need ", fdf$lenw, 129 | " instead of just ", lenw), # 1 130 | stop("error in gamma function"), # 2 131 | stop("invalid MINPACK input"), # 3 132 | "warning in gamma function", # 4 133 | "C fracdf() optimization failure", # 5 134 | "C fracdf() optimization limit reached") # 6 135 | ## otherwise 136 | ## stop("unknown .C(fracdf, *) info -- should not happen") 137 | warning(msg, call. = FALSE, immediate. = TRUE) 138 | msg 139 | } else "ok" 140 | 141 | if(nar == 0) fdf$ar <- numeric(0) 142 | if(nma == 0) fdf$ma <- numeric(0) 143 | 144 | hess <- .C(fdhpq, 145 | hess = matrix(double(1), npq1, npq1), 146 | npq1, 147 | fdf$w)$hess 148 | 149 | ## NOTA BENE: The above hess[.,.] is further "transformed", 150 | ## well, added to and inverted in fdcov : 151 | ## Cov == (-H)^{-1} == solve(-H) 152 | 153 | ## Note that the following can be "redone" using fracdiff.var() : 154 | fdc <- .fdcov(x, fdf$d, h, # <- missing by default 155 | nar=nar, nma=nma, hess=hess, fdf.work = fdf$w) 156 | ##==> "vcov" = fdc $ covariance.dpq 157 | dimnames(hess) <- dimnames(fdc$covariance.dpq) 158 | hess[1, ] <- fdc$hd 159 | hess[row(hess) > col(hess)] <- hess[row(hess) < col(hess)] 160 | 161 | hstat <- fdf[["hood.etc"]] 162 | var.WN <- hstat[3] 163 | 164 | ## Following lines added by RJH. 9 Dec 2019 165 | diffx <- diffseries(x, d = fdf$d) 166 | armafit <- arima(diffx, order = c(length(fdf$ar), 0L, length(fdf$ma)), 167 | include.mean = FALSE, fixed = c(fdf$ar, -fdf$ma)) 168 | res <- armafit$residuals 169 | tsp(res) <- tspx 170 | 171 | structure(list(log.likelihood = hstat[1], 172 | n = n, 173 | msg = c(fracdf = fd.msg, fdcov = fdc$msg), 174 | d = fdf$d, ar = fdf$ar, ma = fdf$ma, 175 | covariance.dpq = fdc$covariance.dpq, # == vcov 176 | fnormMin = hstat[2], sigma = sqrt(var.WN), 177 | stderror.dpq = if(fdc$se.ok) fdc$stderror.dpq, # else NULL 178 | correlation.dpq= if(fdc$se.ok) fdc$correlation.dpq, 179 | h = fdc$h, d.tol = fdf$dtol, M = M, hessian.dpq = hess, 180 | length.w = lenw, 181 | residuals = res, fitted = x - res, ## by RJH 182 | call = cl), 183 | class = "fracdiff") 184 | } 185 | 186 | ### FIXME [modularity]: a lot of this is "cut & paste" also in fracdiff() itself 187 | ### ----- NOTABLY, now use .fdcov() ! 188 | 189 | fracdiff.var <- function(x, fracdiff.out, h) 190 | { 191 | if(!is.numeric(h)) 192 | stop("h must be numeric") 193 | if(!is.list(fracdiff.out) || !is.numeric(M <- fracdiff.out$M)) 194 | stop("invalid ", sQuote("fracdiff.out")) 195 | p <- length(fracdiff.out$ar) 196 | q <- length(fracdiff.out$ma) 197 | n <- length(x) 198 | npq <- p + q 199 | npq1 <- npq + 1 200 | lwork <- max(npq + 2 * (n + M), 201 | 3 * n + (n + 6) * npq + npq %/% 2 + 1, 202 | (3 + 2 * npq1) * npq1 + 1) 203 | ## Initialize 204 | .C(fdcom, 205 | n, 206 | as.integer(M), 207 | (p), 208 | (q), 209 | as.double(fracdiff.out$log.likelihood), 210 | .Machine$double.xmin, 211 | .Machine$double.xmax, 212 | .Machine$double.neg.eps, 213 | .Machine$double.eps) 214 | ## Re compute Covariance Matrix: 215 | fdc <- .C(fdcov, 216 | as.double(x), 217 | as.double(fracdiff.out$d), 218 | h = as.double(h), 219 | hd = double(npq1), 220 | cov = as.double(fracdiff.out$hessian.dpq), 221 | as.integer(npq1), 222 | cor = as.double(fracdiff.out$hessian.dpq), 223 | as.integer(npq1), 224 | se = double(npq1), 225 | as.double(c(fracdiff.out$ma, 226 | fracdiff.out$ar, 227 | rep(0, lwork))), 228 | info = integer(1)) 229 | msg <- 230 | if(fdc$info) { 231 | msg <- 232 | switch(fdc$info, 233 | "warning in gamma function", 234 | "singular Hessian", 235 | "unable to compute correlation matrix", 236 | stop("error in gamma function")) 237 | warning(msg) 238 | } else "ok" 239 | se.ok <- fdc$info %in% 0:2 240 | 241 | if("fdcov" %in% names(fracdiff.out$msg)) # fracdiff(): msg = c(fracdf = fd.msg, fdcov = fdc$msg) 242 | fracdiff.out$msg[["fdcov"]] <- msg 243 | else fracdiff.out$msg <- msg 244 | nam <- c("d", 245 | if(p) paste0("ar", 1:p), 246 | if(q) paste0("ma", 1:q)) 247 | fracdiff.out$h <- fdc$h 248 | fracdiff.out$covariance.dpq <- array(fdc$cov, c(npq1,npq1), list(nam,nam)) 249 | fracdiff.out$stderror.dpq <- if(se.ok) fdc$se # else NULL 250 | fracdiff.out$correlation.dpq <- if(se.ok) array(fdc$cor, c(npq1, npq1)) 251 | fracdiff.out$hessian.dpq[1, ] <- fdc$hd 252 | fracdiff.out$hessian.dpq[, 1] <- fdc$hd 253 | fracdiff.out 254 | }## end{ fracdiff.var() } 255 | 256 | ## MM: Added things for more arima.sim() compatibility. 257 | ## really, 'mu' is nonsense since can be done separately (or via 'innov'). 258 | fracdiff.sim <- function(n, ar = NULL, ma = NULL, d, rand.gen = rnorm, 259 | innov = rand.gen(n+q, ...), n.start = NA, 260 | backComp = TRUE, allow.0.nstart = FALSE, # <- for back-compatibility 261 | start.innov = rand.gen(n.start, ...), ..., mu = 0) 262 | { 263 | p <- length(ar) 264 | q <- length(ma) 265 | if(p) { 266 | minroots <- min(Mod(polyroot(c(1, -ar)))) 267 | if(minroots <= 1) { 268 | warning("'ar' part of fracdiff model is not stationary!!") 269 | minroots <- 1.01 # -> n.start= 603 by default 270 | } 271 | } 272 | if(is.na(n.start)) 273 | n.start <- p + q + ifelse(p > 0, ceiling(6/log(minroots)), 0) 274 | if(n.start < p + q && !allow.0.nstart) 275 | stop("burn-in 'n.start' must be as long as 'ar + ma'") 276 | if(missing(start.innov)) { 277 | if(!backComp) force(start.innov) 278 | } else if(length(start.innov) < n.start) 279 | stop(gettextf("'start.innov' is too short: need %d points", 280 | n.start), domain = NA) 281 | if(length(innov) < n+q) stop("'innov' must have length >= n + q") 282 | y <- c(start.innov[seq_len(n.start)], innov[1:(n+q)]) 283 | stopifnot(is.double(y), length(y) == n + q + n.start) 284 | if(d < -1/2 || d > 1/2) 285 | stop("'d' must be in [-1/2, 1/2]. Consider using cumsum(.) or diff(.) 286 | for additional integration or differentiation") 287 | ii <- n.start - (if(backComp) 0L else q) + 1:n 288 | y <- .C(fdsim, 289 | as.integer(n + n.start), 290 | (p), 291 | (q), 292 | as.double(ar), 293 | as.double(ma), 294 | as.double(d), 295 | as.double(mu), 296 | y = y, 297 | s = double(length(y)), 298 | .Machine$double.xmin, 299 | .Machine$double.xmax, 300 | .Machine$double.neg.eps, 301 | .Machine$double.eps)[["s"]][ii] 302 | list(series = y, ar = ar, ma = ma, d = d, mu = mu, n.start = n.start) 303 | } 304 | 305 | ## Not exported; used for faster checking, e.g., on CRAN 306 | doExtras <- function() { 307 | interactive() || nzchar(Sys.getenv("R_fracdiff_check_extra")) || 308 | identical("true", unname(Sys.getenv("R_PKG_CHECKING_doExtras"))) 309 | } 310 | -------------------------------------------------------------------------------- /src/fdhess.c: -------------------------------------------------------------------------------- 1 | /*-*- mode: C; kept-old-versions: 12; kept-new-versions: 20; -*- 2 | * 3 | * fdhess.f -- translated by f2c (version 20031025). 4 | * and produced by f2c-clean,v 1.10 2002/03/28 16:37:27 maechler 5 | * 6 | * and manually pretty edited by Martin Maechler, 2004-10-01 7 | */ 8 | 9 | #include 10 | 11 | #include "fracdiff.h" 12 | 13 | /* ddot(), daxpy(), dcopy(), dscal() : */ 14 | #include 15 | 16 | /* dsvdc: */ 17 | #include 18 | 19 | /*----------------------------------------------------------- 20 | 21 | * local to this file: */ 22 | static 23 | void hesdpq(double *, double, double *, double *, double *); 24 | static 25 | void hesspq_(double *qp, double *a, double *ajac, 26 | int *lajac, double *h__, int *lh, double *aij, double *g); 27 | 28 | static 29 | void invsvd_(double *, double *, int *, 30 | double *, int *, double *, int *); 31 | 32 | static 33 | void gradpq(double *g, double a[], double ajac[], int l_ajac); 34 | 35 | 36 | /* Common Block Declarations --- included as "extern" */ 37 | #define FD_EXTERNAL extern 38 | #include "mach_comm.h" 39 | /*-> machfd_ */ 40 | #include "maux_comm.h" 41 | /*-> mauxfd_ */ 42 | #include "gamm_comm.h" 43 | /*-> gammfd_ */ 44 | #include "hess_comm.h" 45 | /*-> Dims, filtfd_, hessfd_, w_fil, w_opt */ 46 | 47 | 48 | /* Table of constant values */ 49 | static int c__0 = 0; 50 | static int c__1 = 1; 51 | 52 | static double c_0d = 0.; 53 | static double c_m1 = -1.; 54 | 55 | /******************************************************************************* 56 | *******************************************************************************/ 57 | 58 | /* Called from R: Analytic Hessian with respect to p and q variables : */ 59 | void fdhpq(double *h, int *lh, double *w) 60 | { 61 | /* double precision H(lH, pq1) 62 | 63 | copyright 1991 Department of Statistics, University of Washington 64 | written by Chris Fraley 65 | ----------------------------------------------------------------------------- 66 | Parameter adjustments */ 67 | --w; 68 | 69 | hesspq_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], &Dims.nm, 70 | h, lh, &w[w_opt.lwa4], &w[w_opt.lwa1]); 71 | /* call dcopy( pq1, zero, 0, H(1,1), lH) */ 72 | /* call dcopy( pq , zero, 0, H(2,1), 1) */ 73 | return; 74 | } /* fdhpq */ 75 | 76 | /******************************************************************************* 77 | *******************************************************************************/ 78 | 79 | /* called from R : */ 80 | void fdcov(double *x, double *d__, double *hh, double *hd, 81 | double *cov, int *lcov, 82 | double *cor, int *lcor, double *se, double *w, int *info) 83 | { 84 | /* float x(n) 85 | double precision d, hh, hd(pq1), cov(lcov,pq1), cor(lcor,pq1), 86 | se(pq1), w(*) 87 | 88 | copyright 1991 Department of Statistics, University of Washington 89 | written by Chris Fraley 90 | ----------------------------------------------------------------------------*/ 91 | 92 | const int c__11 = 11; 93 | int i, j, k, le, ls, lu, lv, lwork, pq1 = Dims.pq1; 94 | double temp; 95 | 96 | /* Parameter adjustments */ 97 | int cov_dim1, cov_offset, cor_dim1, cor_offset; 98 | cov_dim1 = *lcov; cov_offset = 1 + cov_dim1; cov -= cov_offset; 99 | cor_dim1 = *lcor; cor_offset = 1 + cor_dim1; cor -= cor_offset; 100 | --se; 101 | --w; 102 | 103 | hesdpq(x, *d__, hh, hd, &w[1]); 104 | /* ====== ^^ */ 105 | F77_CALL(dcopy)(&pq1, hd, &c__1, &cov[cov_offset], lcov); 106 | 107 | gammfd_.igamma = 0; 108 | gammfd_.jgamma = 0; 109 | /* hessfd_.ksvd = 0; */ 110 | hessfd_.kcov = 0; 111 | hessfd_.kcor = 0; 112 | *info = 0; 113 | 114 | for (i = 1; i <= pq1; ++i) { 115 | for (j = i + 1; j <= pq1; ++j) { 116 | cov[j + i * cov_dim1] = cov[i + j * cov_dim1]; 117 | } 118 | } 119 | ls = w_fil.ly; 120 | lu = ls + pq1 + 1; 121 | lv = lu + pq1 * pq1; 122 | le = lv + pq1 * pq1; 123 | lwork = le + pq1; 124 | /* lfree = lwork + pq1 */ 125 | 126 | /*Linpack: dsvdc(x, ldx, n,p, s, e,u,ldu, v,ldv, work, job,info) */ 127 | F77_CALL(dsvdc)(&cov[cov_offset], lcov, &pq1, &pq1, &w[ls], 128 | &w[le], &w[lu], &pq1, &w[lv], &pq1, &w[lwork], 129 | (int*)&c__11, info); 130 | if (*info != 0) { 131 | F77_CALL(dcopy)(&pq1, &c_0d, &c__0, &se[1], &c__1); 132 | for (j = 1; j <= pq1; ++j) { 133 | F77_CALL(dcopy)(&pq1, &c_0d, &c__0, 134 | &cov[j * cov_dim1 + 1], &c__1); 135 | } 136 | /* hessfd_.ksvd = 1; */ 137 | *info = 3; 138 | return; 139 | } 140 | invsvd_(&w[ls], &w[lu], &pq1, &w[lv], &pq1, &cov[cov_offset], lcov); 141 | for (i = 1; i <= pq1; ++i) { 142 | for (j = i + 1; j <= pq1; ++j) { 143 | cov[j + i * cov_dim1] = cov[i + j * cov_dim1]; 144 | } 145 | } 146 | temp = 1.; 147 | for (j = 1; j <= pq1; ++j) { 148 | if (cov[j + j * cov_dim1] > 0.) { 149 | se[j] = sqrt(cov[j + j * cov_dim1]); 150 | } else { 151 | temp = fmin2(temp, cov[j + j * cov_dim1]); 152 | se[j] = 0.; 153 | } 154 | } 155 | if (temp == 1.) { 156 | double d__1; 157 | for (k = 1; k <= pq1; ++k) { 158 | F77_CALL(dcopy)(&k, &cov[k * cov_dim1 + 1], &c__1, 159 | &cor[k * cor_dim1 + 1], &c__1); 160 | } 161 | for (i = 1; i <= pq1; ++i) { 162 | int i2 = pq1 - i + 1; 163 | d__1 = 1. / se[i]; 164 | F77_CALL(dscal)(&i2, &d__1, &cor[i + i * cor_dim1], lcor); 165 | } 166 | for (j = 1; j <= pq1; ++j) { 167 | d__1 = 1. / se[j]; 168 | F77_CALL(dscal)(&j, &d__1, &cor[j * cor_dim1 + 1], &c__1); 169 | } 170 | } else { /* cov() contains non-positive diagonal entry */ 171 | hessfd_.kcor = 1; 172 | for (j = 1; j <= pq1; ++j) { 173 | F77_CALL(dcopy)(&pq1, &c_0d, &c__0, 174 | &cor[j * cor_dim1 + 1], &c__1); 175 | } 176 | } 177 | for (i = 1; i <= pq1; ++i) 178 | for (j = i + 1; j <= pq1; ++j) 179 | cor[j + i * cor_dim1] = cor[i + j * cor_dim1]; 180 | if (gammfd_.igamma != 0) *info = 4; 181 | if (gammfd_.jgamma != 0) *info = 1; 182 | /* if (hessfd_.ksvd != 0) *info = 3; */ 183 | if (hessfd_.kcov != 0) *info = 2; /* error in invsvd() */ 184 | if (hessfd_.kcor != 0) *info = 3; 185 | return; 186 | } /* fdcov */ 187 | 188 | /****************************************************************************** 189 | *******************************************************************************/ 190 | static 191 | void invsvd_(double *s, double *u, int *lu, 192 | double *v, int *lv, double *cov, int *lcov) 193 | { 194 | /* double precision s(pq1), u(lu,pq1), v(lv,pq1), cov(lcov,pq1) 195 | 196 | copyright 1991 Department of Statistics, University of Washington 197 | written by Chris Fraley 198 | ---------------------------------------------------------------------------*/ 199 | 200 | /* System generated locals */ 201 | int u_dim1, u_offset, v_dim1, v_offset, cov_dim1, cov_offset; 202 | double d__1; 203 | 204 | /* Local variables */ 205 | int i__, j, k, krank, pq1 = Dims.pq1; 206 | double ss; 207 | 208 | /* Parameter adjustments */ 209 | --s; 210 | u_dim1 = *lu; u_offset = 1 + u_dim1; u -= u_offset; 211 | v_dim1 = *lv; v_offset = 1 + v_dim1; v -= v_offset; 212 | cov_dim1 = *lcov; cov_offset = 1 + cov_dim1; cov -= cov_offset; 213 | 214 | /* Function Body */ 215 | krank = pq1; 216 | for (i__ = 1; i__ <= pq1; ++i__) { 217 | ss = s[i__]; 218 | for (j = 1; j <= pq1; ++j) { 219 | if (ss < 1.) { 220 | if (fabs(u[i__ + j * u_dim1]) > ss * machfd_.fltmax) { 221 | krank = i__ - 1; 222 | hessfd_.kcov = 1; 223 | goto L100; 224 | } 225 | } 226 | } 227 | } 228 | L100: 229 | for (k = 1; k <= pq1; ++k) { 230 | F77_CALL(dcopy)(&k, &c_0d, &c__0, &cov[k * cov_dim1 + 1], &c__1); 231 | } 232 | if (krank == 0) { 233 | return; 234 | } 235 | /* do k = 1, pq1 */ 236 | /* do i = 1, pq1 */ 237 | /* do j = i, pq1 */ 238 | /* H(i,j) = H(i,j) + s(k)*u(i,k)*v(j,k) */ 239 | /* end do */ 240 | /* end do */ 241 | /* end do */ 242 | /* do k = 1, pq1 */ 243 | /* ss = s(k) */ 244 | /* do j = 1, pq1 */ 245 | /* call daxpy( j, ss*v(j,k), u(1,k), 1, H(1,j), 1) */ 246 | /* end do */ 247 | /* end do */ 248 | for (k = 1; k <= krank; ++k) { 249 | ss = -1. / s[k]; 250 | for (j = 1; j <= pq1; ++j) { 251 | d__1 = ss * u[j + k * u_dim1]; 252 | F77_CALL(daxpy)(&j, &d__1, &v[k * v_dim1 + 1], &c__1, 253 | &cov[j * cov_dim1 + 1], &c__1); 254 | } 255 | } 256 | return; 257 | } /* invsvd_ 258 | 259 | ****************************************************************************** 260 | *****************************************************************************/ 261 | 262 | /* analytic Hessian with respect to p and q variables */ 263 | void hesspq_(double *qp, double *a, double *ajac, int *lajac, 264 | /* output: h[.,.], aij[.], g[.] : */ 265 | double *h__, int *lh, double *aij, double *g) 266 | { 267 | /* double precision qp(pq), a(nm), ajac(nm,pq) 268 | double precision H(lH,pq1), aij(nm), g(pq) 269 | 270 | copyright 1991 Department of Statistics, University of Washington 271 | written by Chris Fraley 272 | ----------------------------------------------------------------------------*/ 273 | 274 | int i, j, k, l, km; 275 | double s, t, u, fac; 276 | int n = Dims.n, p = Dims.p, q = Dims.q; 277 | 278 | /* Parameter adjustments */ 279 | int ajac_dim1 = *lajac, ajac_offset; 280 | int h_dim1 = *lh; 281 | --qp; 282 | ajac_offset = 1 + ajac_dim1; ajac -= ajac_offset; 283 | --aij; 284 | --g; 285 | 286 | fac = 1. / (filtfd_.wnv * (double) (Dims.nm - 1)); 287 | if (q != 0 && p != 0) { 288 | for (k = 1; k <= Dims.pq; ++k) { 289 | g[k] = F77_CALL(ddot)(&Dims.nm, a, &c__1, 290 | &ajac[k * ajac_dim1 + 1], &c__1); 291 | } 292 | for (i = 1; i <= p; ++i) { 293 | int i_aj = (q + i)* ajac_dim1; 294 | u = g[q + i]; 295 | for (j = 1; j <= q; ++j) { 296 | u *= g[j]; 297 | for (k = Dims.maxpq1; k <= n; ++k) { 298 | km = k - Dims.maxpq; 299 | t = 0.; 300 | for (l = 1; l < km && l <= q; ++l) 301 | t += qp[l] * aij[km - l]; 302 | 303 | aij[km] = (km > j) ? ajac[km - j + i_aj] + t : t; 304 | } 305 | s = F77_CALL(ddot)(&Dims.nm, &ajac[i_aj + 1], &c__1, 306 | &ajac[j * ajac_dim1 + 1], &c__1); 307 | t = F77_CALL(ddot)(&Dims.nm, a, &c__1, &aij[1], &c__1); 308 | h__[i + (p + j) * h_dim1] = - n * (s + t - 2 * fac * u) * fac; 309 | } 310 | } 311 | } 312 | if (q != 0) { 313 | for (i = 1; i <= q; ++i) { 314 | int i_aj = i * ajac_dim1; 315 | u = g[i]; 316 | for (j = i; j <= q; ++j) { 317 | int j_aj = j * ajac_dim1; 318 | u *= g[j]; 319 | for (k = Dims.maxpq1; k <= n; ++k) { 320 | km = k - Dims.maxpq; 321 | t = 0.; 322 | for (l = 1; l < km && l <= q; ++l) 323 | t += qp[l] * aij[km - l]; 324 | 325 | s = 0.; 326 | if (km > i) s += ajac[km - i + j_aj]; 327 | if (km > j) s += ajac[km - j + i_aj]; 328 | 329 | aij[km] = s + t; 330 | } 331 | s = F77_CALL(ddot)(&Dims.nm, &ajac[i_aj + 1], &c__1, 332 | &ajac[j_aj + 1], &c__1); 333 | t = F77_CALL(ddot)(&Dims.nm, a, &c__1, &aij[1], &c__1); 334 | h__[p + i + (p + j) * h_dim1] = 335 | -n * (s + t - 2 * fac * u) * fac; 336 | } 337 | } 338 | } 339 | if (p != 0) { 340 | for (i = 1; i <= p; ++i) { 341 | u = g[q + i]; 342 | for (j = i; j <= p; ++j) { 343 | u = g[q + j] * u; 344 | /* do k = maxpq1, n */ 345 | /* km = k - maxpq */ 346 | /* t = zero */ 347 | /* if (nq .ne. 0) then */ 348 | /* do l = 1, nq */ 349 | /* if (km .le. l) goto 303 */ 350 | /* t = t + qp(l)*aij(km-l) */ 351 | /* end do */ 352 | /* end if */ 353 | /* 303 continue */ 354 | /* aij(km) = t */ 355 | /* end do */ 356 | 357 | /* t = ddot( nm, a , 1, aij , 1) */ 358 | s = F77_CALL(ddot)(&Dims.nm, 359 | &ajac[(q+ i)*ajac_dim1 + 1], &c__1, 360 | &ajac[(q+ j)*ajac_dim1 + 1], &c__1); 361 | 362 | /* H(i+1,j+1) = -dble(n)*((s + t) - two*fac*u)*fac */ 363 | h__[i + (j) * h_dim1] = - n * (s - 2 * fac * u) * fac; 364 | } 365 | } 366 | } 367 | return; 368 | } /* hesspq_ */ 369 | 370 | 371 | /****************************************************************************** 372 | *****************************************************************************/ 373 | void 374 | hesdpq(double *x, double d_, double *hh, double *hd, double *w) 375 | { 376 | /* float x(n) 377 | double precision d, hh, hd(pq1), w(*) 378 | 379 | * copyright 1991 Department of Statistics, University of Washington 380 | written by Chris Fraley 381 | ---------------------------------------------------------------------------*/ 382 | 383 | double fa, fb, slogvk, d__1; 384 | 385 | /* Parameter adjustments */ 386 | --w; 387 | 388 | /* Function Body */ 389 | if (*hh <= 0.) { // <==> missing(h) [ = default ] in R's .fdcov() 390 | *hh = (fabs(filtfd_.cllf) + 1.) * mauxfd_.epspt5; 391 | } 392 | if(*hh > 0.1) *hh = 0.1; 393 | if (d_ - *hh > 0.) { 394 | fdfilt(x, d_ - *hh, &w[w_fil.ly], &slogvk, 395 | &w[w_fil.lamk], &w[w_fil.lak], &w[w_fil.lvk], 396 | &w[w_fil.lphi], &w[w_fil.lpi]); 397 | if (Dims.pq != 0) { 398 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 399 | Dims.nm, 1, &w[w_fil.ly]); 400 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 401 | Dims.nm, 2, &w[w_fil.ly]); 402 | gradpq(&w[w_opt.lwa1], &w[w_opt.la], &w[w_opt.lajac],Dims.nm); 403 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, 404 | &w[w_opt.la], &c__1, 405 | &w[w_opt.la], &c__1); 406 | d__1 = 1. / filtfd_.wnv; 407 | F77_CALL(dscal)(&Dims.pq, &d__1, &w[w_opt.lwa1], &c__1); 408 | filtfd_.wnv /= (Dims.nm - 1); 409 | } else { 410 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, 411 | &w[w_fil.ly], &c__1, 412 | &w[w_fil.ly], &c__1) / (Dims.nm - 1); 413 | } 414 | fa = -(Dims.n * (log(filtfd_.wnv) + 2.8378) + slogvk) / 2.; 415 | if (d_ + *hh < .5) { 416 | fdfilt(x, d_ + *hh, &w[w_fil.ly], &slogvk, 417 | &w[w_fil.lamk], &w[w_fil.lak], &w[w_fil.lvk], 418 | &w[w_fil.lphi], &w[w_fil.lpi]); 419 | if (Dims.pq != 0) { 420 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 421 | Dims.nm, 1, &w[w_fil.ly]); 422 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 423 | Dims.nm, 2, &w[w_fil.ly]); 424 | gradpq(&w[w_opt.lwa2], &w[w_opt.la], &w[w_opt.lajac], 425 | Dims.nm); 426 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, 427 | &w[w_opt.la], &c__1, 428 | &w[w_opt.la], &c__1); 429 | d__1 = 1. / filtfd_.wnv; 430 | F77_CALL(dscal)(&Dims.pq, &d__1, &w[w_opt.lwa2], &c__1); 431 | filtfd_.wnv /= (Dims.nm - 1); 432 | } else { 433 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, 434 | &w[w_fil.ly], &c__1, 435 | &w[w_fil.ly], &c__1) / (Dims.nm - 1); 436 | } 437 | fb = -(Dims.n * (log(filtfd_.wnv) + 2.8378) + slogvk)/ 2.; 438 | hd[0] = (fa + fb - filtfd_.cllf * 2.) / (*hh * *hh); 439 | } 440 | else { 441 | fdfilt(x, d_ - *hh * 2., &w[w_fil.ly], &slogvk, 442 | &w[w_fil.lamk], &w[w_fil.lak], &w[w_fil.lvk], 443 | &w[w_fil.lphi], &w[w_fil.lpi]); 444 | if (Dims.pq != 0) { 445 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 446 | Dims.nm, 1, &w[w_fil.ly]); 447 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 448 | Dims.nm, 2, &w[w_fil.ly]); 449 | gradpq(&w[w_opt.lwa2], &w[w_opt.la], &w[w_opt.lajac], 450 | Dims.nm); 451 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, 452 | &w[w_opt.la], &c__1, 453 | &w[w_opt.la], &c__1); 454 | d__1 = 1. / filtfd_.wnv; 455 | F77_CALL(dscal)(&Dims.pq, &d__1, &w[w_opt.lwa2], &c__1); 456 | filtfd_.wnv /= (Dims.nm - 1); 457 | } else { 458 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, 459 | &w[w_fil.ly], &c__1, 460 | &w[w_fil.ly], &c__1) / (Dims.nm - 1); 461 | } 462 | fb = -(Dims.n * (log(filtfd_.wnv) + 2.8378) + slogvk) / 2.; 463 | hd[0] = (filtfd_.cllf + fb - fa * 2.) / (*hh * 2. * *hh); 464 | } 465 | } 466 | else { /* (d_ <= *hh ) : */ 467 | 468 | fdfilt(x, d_ + *hh, &w[w_fil.ly], &slogvk, 469 | &w[w_fil.lamk], &w[w_fil.lak], &w[w_fil.lvk], 470 | &w[w_fil.lphi], &w[w_fil.lpi]); 471 | if (Dims.pq != 0) { 472 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 473 | Dims.nm, 1, &w[w_fil.ly]); 474 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 475 | Dims.nm, 2, &w[w_fil.ly]); 476 | gradpq(&w[w_opt.lwa1], &w[w_opt.la], &w[w_opt.lajac],Dims.nm); 477 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, &w[w_opt.la], &c__1, 478 | &w[w_opt.la], &c__1); 479 | d__1 = 1. / filtfd_.wnv; 480 | F77_CALL(dscal)(&Dims.pq, &d__1, &w[w_opt.lwa1], &c__1); 481 | filtfd_.wnv /= (Dims.nm - 1); 482 | } else { 483 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, &w[w_fil.ly], &c__1, 484 | &w[w_fil.ly], &c__1) / (Dims.nm - 1); 485 | } 486 | fa = -(Dims.n * (log(filtfd_.wnv) + 2.8378) + slogvk) / 2.; 487 | fdfilt(x, d_ + *hh * 2., &w[w_fil.ly], &slogvk, 488 | &w[w_fil.lamk], &w[w_fil.lak], &w[w_fil.lvk], 489 | &w[w_fil.lphi], &w[w_fil.lpi]); 490 | if (Dims.pq != 0) { 491 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 492 | Dims.nm, 1, &w[w_fil.ly]); 493 | ajqp_(&w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], 494 | Dims.nm, 2, &w[w_fil.ly]); 495 | gradpq(&w[w_opt.lwa1], &w[w_opt.la], &w[w_opt.lajac],Dims.nm); 496 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, &w[w_opt.la], &c__1, 497 | &w[w_opt.la], &c__1); 498 | d__1 = 1. / filtfd_.wnv; 499 | F77_CALL(dscal)(&Dims.pq, &d__1, &w[w_opt.lwa1], &c__1); 500 | filtfd_.wnv /= (Dims.nm - 1); 501 | } else { 502 | filtfd_.wnv = F77_CALL(ddot)(&Dims.nm, &w[w_fil.ly], &c__1, 503 | &w[w_fil.ly], &c__1) / (Dims.nm - 1); 504 | } 505 | fb = -(Dims.n * (log(filtfd_.wnv) + 2.8378) + slogvk) / 2.; 506 | hd[0] = (filtfd_.cllf + fb - fa * 2.) / (*hh * 2. * *hh); 507 | } 508 | if (Dims.pq == 0) { 509 | return; 510 | } 511 | F77_CALL(daxpy)(&Dims.pq, &c_m1, &w[w_opt.lwa2], &c__1, 512 | &w[w_opt.lwa1], &c__1); 513 | d__1 = Dims.n / (*hh * 2.); 514 | F77_CALL(dscal)(&Dims.pq, &d__1, &w[w_opt.lwa1], &c__1); 515 | F77_CALL(dcopy)(&Dims.pq, &w[w_opt.lwa1], &c__1, &hd[+1], &c__1); 516 | return; 517 | } /* hesdpq */ 518 | 519 | /****************************************************************************** 520 | *****************************************************************************/ 521 | 522 | void gradpq(double *g, double a[], double ajac[], int l_ajac) 523 | { 524 | /* double precision g(pq), a(nm), ajac(nm,pq) 525 | copyright 1991 Department of Statistics, University of Washington 526 | written by Chris Fraley 527 | -----------------------------------------------------------------------------*/ 528 | 529 | int i, j; 530 | 531 | for (i = 0; i < Dims.p; ++i) 532 | g[i] = F77_CALL(ddot)(&Dims.nm, a, &c__1, 533 | &ajac[(Dims.q + i) * l_ajac], &c__1); 534 | 535 | for (j = 0; j < Dims.q; ++j) 536 | g[Dims.p + j] = F77_CALL(ddot)(&Dims.nm, a, &c__1, 537 | &ajac[j * l_ajac], &c__1); 538 | return; 539 | } /* gradpq */ 540 | 541 | -------------------------------------------------------------------------------- /src/fdgam.c: -------------------------------------------------------------------------------- 1 | /* fdgam.f -- translated by f2c (version 20031025). 2 | * 3 | * and produced by 4 | * 5 | * and manually pretty edited by Martin Maechler, 2004-10-01 6 | */ 7 | 8 | #include 9 | 10 | 11 | #ifndef max 12 | # define max(a, b) ((a) < (b) ? (b) : (a)) 13 | #endif 14 | #ifndef min 15 | # define min(a, b) ((a) > (b) ? (b) : (a)) 16 | #endif 17 | #ifndef abs 18 | # define abs(x) ((x) >= 0 ? (x) : -(x)) 19 | #endif 20 | 21 | /* EXPORTS */ 22 | double dgamma_(double *x); 23 | double dgamr_ (double *x); 24 | 25 | static int dlgams_(double *, double *, double *); 26 | static double dlngam_(double *); 27 | 28 | static void d9gaml_(double *xmin, double *xmax); 29 | static double d9lgmc_(double *); 30 | 31 | static double dcsevl_(double *x, double *a, int *n); 32 | 33 | static int initds_(double *, int *, float *); 34 | 35 | 36 | /* Common Block Declarations --- included as "extern" */ 37 | #define FD_EXTERNAL extern 38 | #include "mach_comm.h" 39 | #include "gamm_comm.h" 40 | 41 | /* Table of constant values */ 42 | 43 | static int c__42 = 42; 44 | static int c__15 = 15; 45 | 46 | double dgamma_(double *x) 47 | { 48 | /* Initialized data */ 49 | 50 | static double gamcs[42] = { .008571195590989331421920062399942, 51 | .004415381324841006757191315771652, 52 | .05685043681599363378632664588789, 53 | -.004219835396418560501012500186624, 54 | .001326808181212460220584006796352, 55 | -1.893024529798880432523947023886e-4, 56 | 3.606925327441245256578082217225e-5, 57 | -6.056761904460864218485548290365e-6, 58 | 1.055829546302283344731823509093e-6, 59 | -1.811967365542384048291855891166e-7, 60 | 3.117724964715322277790254593169e-8, 61 | -5.354219639019687140874081024347e-9, 62 | 9.19327551985958894688778682594e-10, 63 | -1.577941280288339761767423273953e-10, 64 | 2.707980622934954543266540433089e-11, 65 | -4.646818653825730144081661058933e-12, 66 | 7.973350192007419656460767175359e-13, 67 | -1.368078209830916025799499172309e-13, 68 | 2.347319486563800657233471771688e-14, 69 | -4.027432614949066932766570534699e-15, 70 | 6.910051747372100912138336975257e-16, 71 | -1.185584500221992907052387126192e-16, 72 | 2.034148542496373955201026051932e-17, 73 | -3.490054341717405849274012949108e-18, 74 | 5.987993856485305567135051066026e-19, 75 | -1.027378057872228074490069778431e-19, 76 | 1.762702816060529824942759660748e-20, 77 | -3.024320653735306260958772112042e-21, 78 | 5.188914660218397839717833550506e-22, 79 | -8.902770842456576692449251601066e-23, 80 | 1.527474068493342602274596891306e-23, 81 | -2.620731256187362900257328332799e-24, 82 | 4.496464047830538670331046570666e-25, 83 | -7.714712731336877911703901525333e-26, 84 | 1.323635453126044036486572714666e-26, 85 | -2.270999412942928816702313813333e-27, 86 | 3.896418998003991449320816639999e-28, 87 | -6.685198115125953327792127999999e-29, 88 | 1.146998663140024384347613866666e-29, 89 | -1.967938586345134677295103999999e-30, 90 | 3.376448816585338090334890666666e-31, 91 | -5.793070335782135784625493333333e-32 }; 92 | static double pi = 3.1415926535897932384626433832795; 93 | static double sq2pil = .91893853320467274178032973640562; 94 | static int ngam = 0; 95 | static double xmin = 0.; 96 | static double xmax = 0.; 97 | static double xsml = 0.; 98 | static double dxrel = 0.; 99 | 100 | /* System generated locals */ 101 | int i__1; 102 | float r__1; 103 | double ret_val, d__1, d__2; 104 | 105 | /* Local variables */ 106 | static int i__, n; 107 | static double y, temp, sinpiy; 108 | 109 | /* jan 1984 edition. w. fullerton, c3, los alamos scientific lab. */ 110 | /* double precision x, gamcs(42), dxrel, pi, sinpiy, sq2pil, xmax, */ 111 | /* 1 xmin, y, d9lgmc, dcsevl, d1mach, dexp, dint, dlog, */ 112 | /* 2 dsin, dsqrt */ 113 | /* external d1mach, d9lgmc, dcsevl, dexp, dint, dlog, dsin, dsqrt, */ 114 | /* 1 initds */ 115 | 116 | /* series for gam on the interval 0. to 1.00000e+00 */ 117 | /* with weighted error 5.79e-32 */ 118 | /* log weighted error 31.24 */ 119 | /* significant figures required 30.00 */ 120 | /* decimal places required 32.05 */ 121 | 122 | 123 | /* sq2pil is 0.5*alog(2*pi) = alog(sqrt(2*pi)) */ 124 | ret_val = -999.; 125 | 126 | if (ngam == 0) { 127 | /* ngam = initds (gamcs, 42, 0.1*sngl( d1mach) ) */ 128 | r__1 = (float) machfd_.epsmin * .1f; 129 | ngam = initds_(gamcs, &c__42, &r__1); 130 | 131 | d9gaml_(&xmin, &xmax); 132 | if (gammfd_.igamma != 0) { 133 | return ret_val; 134 | } 135 | /* xsml = dexp (dmax1 (dlog(d1mach(1)), -dlog(d1mach(2)))+0.01d0) */ 136 | /* Computing MAX */ 137 | d__1 = log(machfd_.fltmin), d__2 = -log(machfd_.fltmax); 138 | xsml = exp(max(d__1,d__2) + .01); 139 | /* dxrel = dsqrt (d1mach(4)) */ 140 | dxrel = sqrt(machfd_.epsmax); 141 | 142 | } 143 | /* y = fabs(x) */ 144 | y = abs(*x); 145 | if (y > 10.) { 146 | goto L50; 147 | } 148 | 149 | /* compute gamma(x) for -xbnd .le. x .le. xbnd. reduce interval and find */ 150 | /* gamma(1+y) for 0.0 .le. y .lt. 1.0 first of all. */ 151 | 152 | n = (int) (*x); 153 | if (*x < 0.) { 154 | --n; 155 | } 156 | y = *x - (double) ((float) n); 157 | --n; 158 | /* dgamma = 0.9375d0 + dcsevl (2.d0*y-1.d0, gamcs, ngam) */ 159 | d__1 = y * 2. - 1.; 160 | temp = dcsevl_(&d__1, gamcs, &ngam); 161 | if (gammfd_.igamma != 0) { 162 | return ret_val; 163 | } 164 | ret_val = temp + .9375; 165 | if (n == 0) { 166 | return ret_val; 167 | } 168 | 169 | if (n > 0) { 170 | goto L30; 171 | } 172 | 173 | /* compute gamma(x) for x .lt. 1.0 */ 174 | 175 | n = -n; 176 | /* if (x.eq.0.d0) call seteru (14hdgamma x is 0, 14, 4, 2) */ 177 | /* if (x.lt.0d0 .and. x+dble(float(n-2)).eq.0.d0) call seteru ( */ 178 | /* 1 31hdgamma x is a negative integer, 31, 4, 2) */ 179 | /* if (x.lt.(-0.5d0) .and. fabs((x-dint(x-0.5d0))/x).lt.dxrel) call */ 180 | /* 1 seteru (68hdgamma answer lt half precision because x too near n */ 181 | /* 2egative integer, 68, 1, 1) */ 182 | /* if (y.lt.xsml) call seteru ( */ 183 | /* 1 54hdgamma x is so close to 0.0 that the result overflows, */ 184 | /* 2 54, 5, 2) */ 185 | if (*x == 0.) { 186 | /* write(6,*) 'dgamma : x is 0' */ 187 | gammfd_.igamma = 11; 188 | return ret_val; 189 | } 190 | if (*x < 0. && *x + (double) ((float) (n - 2)) == 0.) { 191 | /* write( 6, *) 'dgamma : x is a negative integer' */ 192 | gammfd_.igamma = 12; 193 | return ret_val; 194 | } 195 | if (*x < -.5 && (d__1 = (*x - (double) ((int) (*x - .5))) / *x, 196 | abs(d__1)) < dxrel) { 197 | gammfd_.jgamma = 11; 198 | } 199 | /* 1 write(6,*) 'dgamma : answer lt half precision because */ 200 | /* 2 x too near a negative integer' */ 201 | if (y < xsml) { 202 | /* write(6,*) 'dgamma :, */ 203 | /* 1 x is so close to 0.0 that the result overflows' */ 204 | gammfd_.igamma = 13; 205 | return ret_val; 206 | } 207 | 208 | i__1 = n; 209 | for (i__ = 1; i__ <= i__1; ++i__) { 210 | ret_val /= *x + (double) ((float) (i__ - 1)); 211 | /* L20: */ 212 | } 213 | return ret_val; 214 | 215 | /* gamma(x) for x .ge. 2.0 and x .le. 10.0 */ 216 | 217 | L30: 218 | i__1 = n; 219 | for (i__ = 1; i__ <= i__1; ++i__) { 220 | ret_val = (y + (double) ((float) i__)) * ret_val; 221 | /* L40: */ 222 | } 223 | return ret_val; 224 | 225 | /* gamma(x) for fabs(x) .gt. 10.0. recall y = fabs(x). */ 226 | 227 | L50: 228 | if (*x > xmax) { 229 | /* write(6,*) 'dgamma : x so big gamma overflows' */ 230 | gammfd_.igamma = 14; 231 | return ret_val; 232 | } 233 | 234 | ret_val = 0.; 235 | if (*x < xmin) { 236 | /* write(6,*) 'dgamma : x so small gamma underflows' */ 237 | gammfd_.jgamma = 12; 238 | return ret_val; 239 | } 240 | 241 | /* dgamma = dexp ((y-0.5d0)*dlog(y) - y + sq2pil + d9lgmc(y) ) */ 242 | temp = d9lgmc_(&y); 243 | if (gammfd_.igamma != 0) { 244 | return ret_val; 245 | } 246 | ret_val = exp((y - .5) * log(y) - y + sq2pil + temp); 247 | if (*x > 0.) { 248 | return ret_val; 249 | } 250 | 251 | /* if (fabs((x-dint(x-0.5d0))/x).lt.dxrel) call seteru ( */ 252 | /* 1 61hdgamma answer lt half precision, x too near negative integer */ 253 | /* 2 , 61, 1, 1) */ 254 | if ((d__1 = (*x - (double) ((int) (*x - .5))) / *x, abs(d__1)) < 255 | dxrel) { 256 | gammfd_.jgamma = 11; 257 | } 258 | 259 | /* sinpiy = dsin (pi*y) */ 260 | sinpiy = sin(pi * y); 261 | if (sinpiy == 0.) { 262 | /* write(6,*) 'dgamma : x is a negative integer' */ 263 | gammfd_.igamma = 12; 264 | return ret_val; 265 | } 266 | 267 | ret_val = -pi / (y * sinpiy * ret_val); 268 | return ret_val; 269 | } /* dgamma_ */ 270 | 271 | double dgamr_(double *x) 272 | { 273 | /* System generated locals */ 274 | double ret_val; 275 | 276 | /* Local variables */ 277 | static double temp, alngx, sgngx; 278 | 279 | /* july 1977 edition. w. fullerton, c3, los alamos scientific lab. */ 280 | /* this routine, not dgamma(x), should be the fundamental one. */ 281 | /* ============ ============= */ 282 | /* Calls dgamma(), only if |x| < 10; otherwise dlgams() -> dlngam() -> d9lgmc() */ 283 | /* external dexp, dgamma, dint, d1mach */ 284 | 285 | ret_val = 0.; 286 | if (*x <= 0. && (double) ((int) (*x)) == *x) { 287 | return ret_val; 288 | } 289 | 290 | if (abs(*x) <= 10.) { 291 | /* dgamr = 1.0d0/dgamma(x) */ 292 | temp = dgamma_(x); 293 | if (gammfd_.igamma != 0) { 294 | ret_val = machfd_.fltmax; 295 | return ret_val; 296 | } 297 | ret_val = 1. / temp; 298 | } else { 299 | /* x > 10. : */ 300 | dlgams_(x, &alngx, &sgngx); 301 | if (gammfd_.igamma != 0) { 302 | return ret_val; 303 | } 304 | ret_val = sgngx * exp(-alngx); 305 | } 306 | return ret_val; 307 | } /* dgamr_ */ 308 | 309 | /* Subroutine */ 310 | int dlgams_(double *x, double *dlgam, double *sgngam) 311 | { 312 | /* july 1977 edition. w. fullerton, c3, los alamos scientific lab. */ 313 | 314 | /* evaluate log abs (gamma(x)) and return the sign of gamma(x) in sgngam. */ 315 | /* sgngam is either +1.0 or -1.0. */ 316 | 317 | int intx; 318 | 319 | *dlgam = dlngam_(x); 320 | if (gammfd_.igamma != 0) { 321 | return 0; 322 | } 323 | *sgngam = 1.; 324 | if (*x > 0.) { 325 | return 0; 326 | } 327 | 328 | intx = (int) (fmod(-((double) ((int) (*x))), 2.) + .1); 329 | if (intx == 0) { 330 | *sgngam = -1.; 331 | } 332 | 333 | return 0; 334 | } /* dlgams_ */ 335 | 336 | int initds_(double *dos, int *nos, float *eta) 337 | { 338 | /* System generated locals */ 339 | int ret_val, i__1; 340 | float r__1; 341 | 342 | /* Local variables */ 343 | static int i__, ii; 344 | static double err; 345 | 346 | /* june 1977 edition. w. fullerton, c3, los alamos scientific lab. */ 347 | 348 | /* initialize the double precision orthogonal series dos so that initds */ 349 | /* is the number of terms needed to insure the error is no larger than */ 350 | /* eta. ordinarily eta will be chosen to be one-tenth machine precision. */ 351 | 352 | /* input arguments -- */ 353 | /* dos dble prec array of nos coefficients in an orthogonal series. */ 354 | /* nos number of coefficients in dos. */ 355 | /* eta requested accuracy of series. */ 356 | 357 | 358 | /* if (nos.lt.1) call seteru ( */ 359 | /* 1 35hinitds number of coefficients lt 1, 35, 2, 2) */ 360 | /* Parameter adjustments */ 361 | --dos; 362 | 363 | /* Function Body */ 364 | if (*nos < 1) { 365 | gammfd_.jgamma = 31; 366 | } 367 | 368 | i__ = -1; 369 | err = 0.f; 370 | i__1 = *nos; 371 | for (ii = 1; ii <= i__1; ++ii) { 372 | i__ = *nos + 1 - ii; 373 | err += (r__1 = (float) dos[i__], fabs(r__1)); 374 | if (err > *eta) { 375 | goto L20; 376 | } 377 | /* L10: */ 378 | } 379 | 380 | /* 20 if (i.eq.nos) call seteru (28hinitds eta may be too small, 28, */ 381 | /* 1 1, 2) */ 382 | L20: 383 | /* if (i.eq.nos) write(6,*) 'initds : eta may be too small' */ 384 | if (i__ == *nos) { 385 | gammfd_.jgamma = 32; 386 | } 387 | ret_val = i__; 388 | 389 | return ret_val; 390 | } /* initds_ */ 391 | 392 | /* Subroutine */ 393 | static void d9gaml_(double *xmin, double *xmax) 394 | { 395 | /* System generated locals */ 396 | double d__1, d__2; 397 | 398 | /* Local variables */ 399 | static int i__; 400 | static double xln, xold, alnbig, alnsml; 401 | 402 | /* june 1977 edition. w. fullerton, c3, los alamos scientific lab. */ 403 | 404 | /* calculate the minimum and maximum legal bounds for x in gamma(x). */ 405 | /* xmin and xmax are not the only bounds, but they are the only non- */ 406 | /* trivial ones to calculate. */ 407 | 408 | /* output arguments -- */ 409 | /* xmin dble prec minimum legal value of x in gamma(x). any smaller */ 410 | /* value of x might result in underflow. */ 411 | /* xmax dble prec maximum legal value of x in gamma(x). any larger */ 412 | /* value of x might cause overflow. */ 413 | 414 | /* double precision xmin, xmax, alnbig, alnsml, xln, xold, d1mach, */ 415 | /* 1 dlog */ 416 | /* external d1mach, dlog */ 417 | 418 | /* alnsml = dlog(d1mach(1)) */ 419 | alnsml = log(machfd_.fltmin); 420 | *xmin = -alnsml; 421 | for (i__ = 1; i__ <= 10; ++i__) { 422 | xold = *xmin; 423 | /* xln = dlog(xmin) */ 424 | xln = log(*xmin); 425 | *xmin -= *xmin * ((*xmin + .5) * xln - *xmin - .2258 + alnsml) / (* 426 | xmin * xln + .5); 427 | /* if (fabs(xmin-xold).lt.0.005d0) go to 20 */ 428 | if ((d__1 = *xmin - xold, abs(d__1)) < .005) { 429 | goto L20; 430 | } 431 | /* L10: */ 432 | } 433 | /* call seteru (27hd9gaml unable to find xmin, 27, 1, 2) */ 434 | /* write(6,*) 'd9gaml : unable to find xmin' */ 435 | gammfd_.igamma = 21; 436 | return; 437 | 438 | L20: 439 | *xmin = -(*xmin) + .01; 440 | 441 | /* alnbig = dlog (d1mach(2)) */ 442 | alnbig = log(machfd_.fltmax); 443 | *xmax = alnbig; 444 | for (i__ = 1; i__ <= 10; ++i__) { 445 | xold = *xmax; 446 | /* xln = dlog(xmax) */ 447 | xln = log(*xmax); 448 | *xmax -= *xmax * ((*xmax - .5) * xln - *xmax + .9189 - alnbig) / (* 449 | xmax * xln - .5); 450 | /* if (fabs(xmax-xold).lt.0.005d0) go to 40 */ 451 | if ((d__1 = *xmax - xold, abs(d__1)) < .005) { 452 | goto L40; 453 | } 454 | /* L30: */ 455 | } 456 | /* call seteru (27hd9gaml unable to find xmax, 27, 2, 2) */ 457 | /* write(6,*) 'd9gaml : unable to find xmax' */ 458 | gammfd_.igamma = 22; 459 | return; 460 | 461 | L40: 462 | *xmax += -.01; 463 | /* Computing MAX */ 464 | d__1 = *xmin, d__2 = -(*xmax) + 1.; 465 | *xmin = max(d__1,d__2); 466 | 467 | return; 468 | 469 | } /* d9gaml_ */ 470 | 471 | double d9lgmc_(double *x) 472 | { 473 | /* Initialized data */ 474 | 475 | static double algmcs[15] = { .1666389480451863247205729650822, 476 | -1.384948176067563840732986059135e-5, 477 | 9.810825646924729426157171547487e-9, 478 | -1.809129475572494194263306266719e-11, 479 | 6.221098041892605227126015543416e-14, 480 | -3.399615005417721944303330599666e-16, 481 | 2.683181998482698748957538846666e-18, 482 | -2.868042435334643284144622399999e-20, 483 | 3.962837061046434803679306666666e-22, 484 | -6.831888753985766870111999999999e-24, 485 | 1.429227355942498147573333333333e-25, 486 | -3.547598158101070547199999999999e-27,1.025680058010470912e-28, 487 | -3.401102254316748799999999999999e-30, 488 | 1.276642195630062933333333333333e-31 }; 489 | static int nalgm = 0; 490 | static double xbig = 0.; 491 | static double xmax = 0.; 492 | 493 | /* System generated locals */ 494 | float r__1; 495 | double ret_val, d__1, d__2; 496 | 497 | /* Local variables */ 498 | static double temp; 499 | 500 | /* august 1977 edition. w. fullerton, c3, los alamos scientific lab. */ 501 | 502 | /* compute the log gamma correction factor for x .ge. 10. so that */ 503 | /* dlog (dgamma(x)) = dlog(dsqrt(2*pi)) + (x-.5)*dlog(x) - x + d9lgmc(x) */ 504 | 505 | /* double precision x, algmcs(15), xbig, xmax, dcsevl, d1mach, */ 506 | /* 1 dexp, dlog, dsqrt */ 507 | /* external d1mach, dcsevl, dexp, dlog, dsqrt, initds */ 508 | 509 | /* series for algm on the interval 0. to 1.00000e-02 */ 510 | /* with weighted error 1.28e-31 */ 511 | /* log weighted error 30.89 */ 512 | /* significant figures required 29.81 */ 513 | /* decimal places required 31.48 */ 514 | 515 | 516 | 517 | if (nalgm != 0) { 518 | goto L10; 519 | } 520 | /* nalgm = initds (algmcs, 15, sngl(d1mach(3)) ) */ 521 | r__1 = (float) machfd_.epsmin; 522 | nalgm = initds_(algmcs, &c__15, &r__1); 523 | /* xbig = 1.0d0/dsqrt(d1mach(3)) */ 524 | xbig = 1. / sqrt(machfd_.epsmin); 525 | /* xmax = dexp (dmin1(dlog(d1mach(2)/12.d0), -dlog(12.d0*d1mach(1)))) */ 526 | /* Computing MIN */ 527 | d__1 = log(machfd_.fltmax / 12.), d__2 = -log(machfd_.fltmin * 12.); 528 | xmax = exp((min(d__1,d__2))); 529 | 530 | /* 10 if (x.lt.10.d0) call seteru (23hd9lgmc x must be ge 10, 23, 1, 2) */ 531 | 532 | L10: 533 | if (*x < 10.) { 534 | /* write(6,*) 'd9lgmc : x must be ge 10' */ 535 | gammfd_.igamma = 51; 536 | /* d9lgmc = d1mach(2) */ 537 | ret_val = machfd_.fltmax; 538 | return ret_val; 539 | } 540 | if (*x >= xmax) { 541 | goto L20; 542 | } 543 | 544 | ret_val = 1. / (*x * 12.); 545 | /* if (x.lt.xbig) d9lgmc = dcsevl (2.0d0*(10.d0/x)**2-1.d0, algmcs, */ 546 | /* 1 nalgm) / x */ 547 | if (*x < xbig) { 548 | /* Computing 2nd power */ 549 | d__2 = 10. / *x; 550 | d__1 = d__2 * d__2 * 2. - 1.; 551 | temp = dcsevl_(&d__1, algmcs, &nalgm); 552 | if (gammfd_.igamma != 0) { 553 | /* d9lgmc = d1mach(2) */ 554 | ret_val = machfd_.fltmax; 555 | } else { 556 | ret_val = temp / *x; 557 | } 558 | } 559 | return ret_val; 560 | 561 | L20: 562 | ret_val = 0.; 563 | /* call seteru (34hd9lgmc x so big d9lgmc underflows, 34, 2, 0) */ 564 | /* write(6,*) 'd9lgmc : x so big d9lgmc underflows' */ 565 | gammfd_.jgamma = 51; 566 | return ret_val; 567 | 568 | } /* d9lgmc_ */ 569 | 570 | double dcsevl_(double *x, double *a, int *n) 571 | { 572 | /* System generated locals */ 573 | int i__1; 574 | 575 | /* Local variables */ 576 | int i__, ni; 577 | double b0, b1, b2, twox; 578 | 579 | 580 | /* evaluate the n-term chebyshev series a at x. adapted from */ 581 | /* r. broucke, algorithm 446, c.a.c.m., 16, 254 (1973). */ 582 | 583 | /* input arguments -- */ 584 | /* x dble prec value at which the series is to be evaluated. */ 585 | /* a dble prec array of n terms of a chebyshev series. in eval- */ 586 | /* uating a, only half the first coef is summed. */ 587 | /* n number of terms in array a. */ 588 | 589 | /* double precision d1mach */ 590 | /* external d1mach */ 591 | 592 | /* Parameter adjustments */ 593 | --a; 594 | 595 | /* Function Body */ 596 | b2 = 0.f; 597 | /* if (n.lt.1) call seteru (28hdcsevl number of terms le 0, 28, 2,2) */ 598 | /* if (n.gt.1000) call seteru (31hdcsevl number of terms gt 1000, */ 599 | /* 1 31, 3, 2) */ 600 | /* if (x.lt.(-1.1d0) .or. x.gt.1.1d0) call seteru ( */ 601 | /* 1 25hdcsevl x outside (-1,+1), 25, 1, 1) */ 602 | 603 | if (*n < 1) { 604 | /* 'dcsevl : number of terms le 0' */ 605 | gammfd_.igamma = 41; return machfd_.fltmax; 606 | } 607 | if (*n > 1000) { 608 | /* 'dcsevl : number of terms gt 1000' */ 609 | gammfd_.igamma = 42; return machfd_.fltmax; 610 | } 611 | if (*x < -1.1 || *x > 1.1) { 612 | /* 'dcsevl : x outside (-1,+1)' */ 613 | gammfd_.igamma = 43; return machfd_.fltmax; 614 | } 615 | 616 | twox = *x * 2.; 617 | b1 = 0.; 618 | b0 = 0.; 619 | i__1 = *n; 620 | for (i__ = 1; i__ <= i__1; ++i__) { 621 | b2 = b1; 622 | b1 = b0; 623 | ni = *n - i__ + 1; 624 | b0 = twox * b1 - b2 + a[ni]; 625 | } 626 | 627 | return (b0 - b2) * .5; 628 | 629 | } /* dcsevl_ */ 630 | 631 | double dlngam_(double *x) 632 | { 633 | /* Initialized data */ 634 | 635 | static double sq2pil = .91893853320467274178032973640562; 636 | static double sqpi2l = .225791352644727432363097614947441; 637 | static double pi = 3.1415926535897932384626433832795; 638 | static double xmax = 0.; 639 | static double dxrel = 0.; 640 | 641 | /* System generated locals */ 642 | double ret_val, d__1; 643 | 644 | /* Local variables */ 645 | static double y, temp, sinpiy; 646 | 647 | /* august 1980 edition. w. fullerton, c3, los alamos scientific lab. */ 648 | /* double precision x, dxrel, pi, sinpiy, sqpi2l, sq2pil, */ 649 | /* 1 y, xmax, dint, dgamma, d9lgmc, d1mach, dlog, dsin, dsqrt */ 650 | /* external d1mach, d9lgmc, dgamma, dint, dlog, dsin, dsqrt */ 651 | 652 | /* sq2pil = alog (sqrt(2*pi)), sqpi2l = alog(sqrt(pi/2)) */ 653 | 654 | 655 | ret_val = 0.; 656 | if (xmax == 0.) { 657 | /* xmax = d1mach(2)/dlog(d1mach(2)) */ 658 | xmax = machfd_.fltmax / log(machfd_.fltmax); 659 | /* dxrel = dsqrt (d1mach(4)) */ 660 | dxrel = sqrt(machfd_.fltmax); 661 | } 662 | y = abs(*x); 663 | if (y <= 10.) { 664 | 665 | /* |x| <= 10 : Compute dlngam := dlog (fabs (dgamma(x)) ) */ 666 | 667 | temp = dgamma_(x); 668 | if (gammfd_.igamma != 0) { 669 | ret_val = machfd_.fltmax; 670 | return ret_val; 671 | } 672 | ret_val = log((abs(temp))); 673 | return ret_val; 674 | } 675 | /* ELSE |x| > 10 : Compute dlog ( fabs (dgamma(x)) ) */ 676 | 677 | if (y > xmax) { 678 | /* write(6,*) 'dlngam : abs(x) so big dlngam overflows' */ 679 | gammfd_.igamma = 61; 680 | ret_val = machfd_.fltmax; 681 | return ret_val; 682 | } 683 | 684 | /* if (x.gt.0.d0) dlngam = sq2pil + (x-0.5d0)*dlog(x) - x + d9lgmc(y) */ 685 | temp = d9lgmc_(&y); 686 | if (gammfd_.igamma != 0) { 687 | ret_val = machfd_.fltmax; 688 | return ret_val; 689 | } 690 | if (*x > 0.) { 691 | ret_val = sq2pil + (*x - .5) * log(*x) - *x + temp; 692 | } 693 | if (*x > 0.) { 694 | return ret_val; 695 | } 696 | 697 | sinpiy = (d__1 = sin(pi * y), abs(d__1)); 698 | if (sinpiy == 0.) { 699 | /* write(6,*) 'dlngam : x is a negative integer' */ 700 | gammfd_.igamma = 62; 701 | ret_val = machfd_.fltmax; 702 | return ret_val; 703 | } 704 | 705 | /* dlngam = sqpi2l + (x-0.5d0)*dlog(y) - x - dlog(sinpiy) - d9lgmc(y) */ 706 | temp = d9lgmc_(&y); 707 | if (gammfd_.igamma != 0) { 708 | ret_val = machfd_.fltmax; 709 | return ret_val; 710 | } 711 | ret_val = sqpi2l + (*x - .5) * log(y) - *x - log(sinpiy) - temp; 712 | 713 | /* if (fabs((x-dint(x-0.5d0))*dlngam/x).lt.dxrel) call seteru ( */ 714 | /* 1 68hdlngam answer lt half precision because x too near negative */ 715 | /* 2integer, 68, 1, 1) */ 716 | if ((d__1 = (*x - (double) ((int) (*x - .5))) * ret_val / *x, abs( 717 | d__1)) < dxrel) { 718 | gammfd_.jgamma = 61; 719 | } 720 | return ret_val; 721 | 722 | } /* dlngam_ */ 723 | 724 | -------------------------------------------------------------------------------- /src/fdcore.c: -------------------------------------------------------------------------------- 1 | /*-*- mode: C; kept-old-versions: 12; kept-new-versions: 20; -*- 2 | * 3 | * fdcore.f -- translated by f2c (version 20031025). 4 | * and produced by f2c-clean,v 1.10 2002/03/28 16:37:27 maechler 5 | * 6 | * and manually pretty edited by Martin Maechler, 2004-09-18, ff. 7 | */ 8 | 9 | #include 10 | // for warning(), and "monitoring" output 11 | #include 12 | 13 | 14 | /* dcopy() and ddot() only:*/ 15 | #include 16 | 17 | #include "fracdiff.h" 18 | 19 | extern double dgamr_(double *); 20 | extern double dgamma_(double *); 21 | 22 | static 23 | double dopt(double *x, double dinit, double *drange, int verbose, 24 | double *hood, double *delta, double *w, int *iw, double *min_fnorm); 25 | 26 | static 27 | double pqopt(double *x, double d__, double *w, int *iw, double *min_fnorm); 28 | 29 | 30 | /* These + ajqp_(..) are passed to LMDER1() to be optimized: */ 31 | static void 32 | ajp_(double *p, double *a, double *ajac, int lajac, int op_code, double *y); 33 | 34 | static void 35 | ajq_(double *qp, double *a, double *ajac, int lajac, int op_code, double *y); 36 | 37 | /* Common Block Declarations */ 38 | 39 | /* 1 - local ones --- MM: maybe get rid of (some of) them : */ 40 | static 41 | struct { int maxopt, maxfun, nopt, nfun, ngrd, ifun, igrd, info; } OP; 42 | 43 | static struct { double d, f, x, g; } TOL; 44 | 45 | static struct { int iminpk, jminpk; } MinPck; 46 | 47 | static struct { int ilimit, jlimit; } limsfd_; 48 | 49 | /* 2 - global ones --- 50 | * all defined here :*/ 51 | #define FD_EXTERNAL 52 | 53 | #include "mach_comm.h" 54 | #include "maux_comm.h" 55 | 56 | #include "gamm_comm.h" 57 | 58 | #include "hess_comm.h" 59 | 60 | 61 | /* Table of constant values (used as pointers) */ 62 | 63 | static double c_m99 = -99.; 64 | static int ic__1 = 1; 65 | static int ic__0 = 0; 66 | static double c__1 = 1.; 67 | 68 | /***************************************************************************** 69 | ******************************************************************************/ 70 | void fracdf(double *x, int *n, int *m, int *nar, int *nma, 71 | double *dtol, double *drange, double *hood_etc, 72 | double *d__, double *ar, double *ma, 73 | double *w, int *lenw, int *iw, 74 | int *inform, // <- also use as input for verbose 75 | double *flmin, double *flmax, double *epmin, double *epmax) 76 | { 77 | /* ---------------------------------------------------------------------------- 78 | Input : 79 | 80 | x(n) double time series for the ARIMA model 81 | n int length of the time series 82 | m int number of terms in the likelihood approximation 83 | suggested value 100 (see Haslett and Raftery 1989) 84 | nar int number of autoregressive parameters 85 | nma int number of moving average parameters 86 | dtol double desired length of final interval of uncertainty for d 87 | suggested value : 4th root of machine precision 88 | if dtol < 0 it is automatically set to this value 89 | dtol will be altered if necessary by the program 90 | drange(2) double array of length 2 giving minimum and maximum values f 91 | for the fractional differencing parameter 92 | d double initial guess for optimal fractional differencing parameter 93 | w double work array 94 | lenw int length of double precision workspace w, must be at least 95 | max( p+q+2*(n+M), 3*n+(n+6.5)*(p+q) +1, (3+2*(p+q+1))*(p+q+1)+1) 96 | MM: max( p+q+2*(n+M), 3*n+(n+6.5)*(p+q) +1, 31 * 12) 97 | is what the code below rather checks 98 | 99 | Output : 100 | 101 | dtol double value of dtol ultimately used by the algorithm 102 | d double final value optimal fractional differencing parameter 103 | hood_etc double[3] [1]: logarithm of the maximum likelihood 104 | [2]: minimal objective value 105 | [3]: estimated noise variance 106 | ar double optimal autoregressive parameters 107 | ma double optimal moving average parameters 108 | 109 | ---------------------------------------------------------------------------- 110 | copyright 1991 Department of Statistics, University of Washington 111 | written by Chris Fraley 112 | ----------------------------------------------------------------------------*/ 113 | 114 | /* Local variables */ 115 | double delta; 116 | int lfree, lwfree, verbose = inform[0], w_lqp; 117 | 118 | if (*m <= 0) /* default: */ 119 | *m = 100; 120 | 121 | /* MM: Using 'fdcom' instead of 'code copy' -- FIXME: use #include in C 122 | * initialize several of the above common blocks: */ 123 | fdcom(n, m, nar, nma, &c_m99, flmin, flmax, epmin, epmax); 124 | 125 | w_lqp = w_opt.lqp - 1;// '-1' : so we do *not* need 'w--' 126 | lfree = w_opt.lwa4 + *n - Dims.minpq; 127 | /* = 1+ ipvt + 5.5*npq + n - minpq 128 | = 2+ 6.5*npq + 3*n - 2*minpq + (n-maxpq)*npq 129 | and lvk+M = 1 + npq + 2(n + M) 130 | */ 131 | 132 | lwfree = imax2((12*31), imax2(w_fil.lvk + *m, lfree)); 133 | /* ^^^^^^^ MM: where is this needed? */ 134 | if (lwfree > *lenw + 1) { 135 | limsfd_.ilimit = lwfree - *lenw; 136 | REprintf("** Insufficient storage : Increase length of w by at least %d\n", 137 | limsfd_.ilimit); 138 | *inform = 1; 139 | /* return the *desired* workspace storage: */ 140 | *lenw = lwfree; 141 | return; 142 | } 143 | OP.maxopt = 100; 144 | OP.maxfun = 100; 145 | /* set error and warning flags */ 146 | *inform = 0; 147 | gammfd_.igamma = 0; 148 | MinPck.iminpk = 0; 149 | limsfd_.ilimit = 0; 150 | gammfd_.jgamma = 0; 151 | MinPck.jminpk = 0; 152 | limsfd_.jlimit = 0; 153 | 154 | if (*dtol > .1) 155 | *dtol = .1; 156 | if (*dtol <= 0.) { 157 | TOL.d = mauxfd_.epsp25; 158 | TOL.f = mauxfd_.epspt3; 159 | } else { 160 | TOL.d = fmax2(*dtol, mauxfd_.epspt5); 161 | TOL.f = fmax2(*dtol / 10., mauxfd_.epsp75); 162 | } 163 | TOL.g = TOL.f; 164 | TOL.x = TOL.d; 165 | *dtol = TOL.d; 166 | /* if (npq != 0) call dcopy( npq, zero, 0, w(lqp), 1) */ 167 | if (Dims.pq != 0) { 168 | F77_CALL(dcopy)(&Dims.p, ar, &ic__1, &w[w_lqp + Dims.q], &ic__1); 169 | F77_CALL(dcopy)(&Dims.q, ma, &ic__1, &w[w_lqp], &ic__1); 170 | } 171 | OP.nopt = 0; 172 | OP.nfun = 0; 173 | OP.ngrd = 0; 174 | /* ==== */ 175 | *d__ = dopt(x, *d__, drange, verbose, 176 | /* ===*/ 177 | &hood_etc[0], &delta, w, iw, /* min_fnorm = */&hood_etc[1]); 178 | 179 | hood_etc[2] = filtfd_.wnv; 180 | if (OP.nopt >= OP.maxopt) { 181 | limsfd_.jlimit = 1; 182 | warning("fracdf(): optimization iteration limit %d reached", OP.maxopt); 183 | } 184 | 185 | if (gammfd_.igamma != 0 || MinPck.iminpk != 0) { 186 | *d__ = machfd_.fltmax; 187 | hood_etc[0] = machfd_.fltmax; 188 | F77_CALL(dcopy)(&Dims.p, &machfd_.fltmax, &ic__0, ar, &ic__1); 189 | F77_CALL(dcopy)(&Dims.q, &machfd_.fltmax, &ic__0, ma, &ic__1); 190 | 191 | if (gammfd_.igamma != 0) { *inform = 2; return; } 192 | if (MinPck.iminpk != 0) { *inform = 3; return; } 193 | } 194 | F77_CALL(dcopy)(&Dims.p, &w[w_lqp + Dims.q], &ic__1, ar, &ic__1); 195 | F77_CALL(dcopy)(&Dims.q, &w[w_lqp], &ic__1, ma, &ic__1); 196 | 197 | if (gammfd_.jgamma != 0) { *inform = 4; return; } 198 | if (MinPck.jminpk != 0) { *inform = 5; return; } 199 | if (limsfd_.jlimit != 0) { *inform = 6; } 200 | return; 201 | /* 900 format( 4h itr, 14h d , 14h est mean , 202 | * 16h white noise, 17h log likelihd, 203 | * 4h nf, 3h ng) */ 204 | 205 | } /* fracdf() {main} */ 206 | 207 | 208 | /****************************************************************************** 209 | ***************************************************************************** 210 | 211 | optimization with respect to d based on Brent's fmin algorithm */ 212 | 213 | static 214 | double dopt(double *x, double dinit, double *drange, int verbose, 215 | double *hood, double *delta, double *w, int *iw, double *min_fnorm) 216 | 217 | { 218 | /* float x(n) */ 219 | 220 | /* cc is the squared inverse of the golden ratio, cc := (3-sqrt(5.))/2 : */ 221 | static double cc = .38196601125011; 222 | 223 | static double aa, bb, dd, ee, hh, fu, fv, fw, fx, rr, ss, 224 | tt, uu, vv, ww, xx, eps, tol, tol1, tol2, tol3; 225 | 226 | /* copyright 1991 Department of Statistics, University of Washington 227 | written by Chris Fraley 228 | ------------------------------------------------------------------------------ 229 | */ 230 | 231 | /* eps is approximately the square root of the relative machine precision. */ 232 | eps = machfd_.epsmax; 233 | tol1 = eps + 1.; 234 | eps = sqrt(eps); 235 | 236 | aa = drange[0]; 237 | bb = drange[1]; 238 | if (dinit > aa + TOL.d && 239 | dinit < bb - TOL.d) { 240 | vv = dinit; 241 | } else { 242 | vv = aa + cc * (bb - aa); 243 | } 244 | ww = vv; 245 | xx = vv; 246 | uu = xx; 247 | dd = 0.; 248 | ee = 0.; 249 | OP.nopt = 1; 250 | fx = pqopt(x, xx, w, iw, min_fnorm); 251 | /* ===== */ 252 | if(verbose) { 253 | REprintf("dopt() debugging: dinit = %g ==> xx = %g, fx = pqopt(x[], xx) = %g; min_fnorm = %g\n", 254 | dinit, xx, fx, *min_fnorm); 255 | REprintf(" it. | uu | pqopt(uu) | delta |\n"); 256 | // | 123456789012 | 123456789012 | 1234567890 |\n", 257 | // REprintf(" .. DBG dopt() [%2d]:| %12g | %12g | %10.6e |\n", 258 | } 259 | fv = fx; 260 | fw = fx; 261 | tol = fmax2(TOL.d, 0.); 262 | tol3 = tol / 3.; 263 | 264 | /* main loop starts here ======================================================*/ 265 | L10: 266 | if (gammfd_.igamma != 0 || MinPck.iminpk != 0) { 267 | *hood = machfd_.fltmax; 268 | warning("** dopt() ERROR: invalid gamma (%d) or Minpack (%d) codes", 269 | gammfd_.igamma, MinPck.iminpk); 270 | return -1.; 271 | } 272 | hh = (aa + bb) * .5; 273 | tol1 = eps * (fabs(xx) + 1.) + tol3; 274 | tol2 = tol1 * 2.; 275 | 276 | /* check stopping criterion */ 277 | 278 | *delta = fabs(xx - hh) + (bb - aa) * .5; 279 | /* if (abs(xx-hh) .le. (tol2-half*(bb-aa))) goto 100 */ 280 | if(verbose && OP.nopt > 1) 281 | REprintf(" .. DBG dopt() [%2d]:| %12g | %12g | %10.6e |\n", 282 | OP.nopt, uu, fu, *delta); 283 | if (*delta <= tol2) { 284 | goto L_end; 285 | } 286 | if (OP.nopt >= OP.maxopt) { 287 | goto L_end; 288 | } 289 | /* Maybe another check : 290 | * if (delpq <= EPSMAX*(one+pqnorm)) goto 100 */ 291 | 292 | rr = 0.; 293 | ss = 0.; 294 | tt = 0.; 295 | if (fabs(ee) > tol1) { 296 | 297 | /* fit parabola */ 298 | 299 | rr = (xx - ww) * (fx - fv); 300 | ss = (xx - vv) * (fx - fw); 301 | tt = (xx - vv) * ss - (xx - ww) * rr; 302 | ss = (ss - rr) * 2.; 303 | if (ss <= 0.) { 304 | ss = -ss; 305 | } else { 306 | tt = -tt; 307 | } 308 | rr = ee; 309 | ee = dd; 310 | } 311 | if (fabs(tt) >= fabs(ss * .5 * rr) || tt <= ss * (aa - xx) || 312 | tt >= ss * (bb - xx)) 313 | { /*--- a golden-section step ---*/ 314 | 315 | if (xx >= hh) { 316 | ee = aa - xx; 317 | } else { 318 | ee = bb - xx; 319 | } 320 | dd = cc * ee; 321 | 322 | } 323 | else { /*--- a parabolic-interpolation step ---*/ 324 | 325 | dd = tt / ss; 326 | uu = xx + dd; 327 | 328 | /* f must not be evaluated too close to aa or bb */ 329 | 330 | if (uu - aa < tol2 || bb - uu < tol2) { 331 | dd = tol1; 332 | if (xx >= hh) { 333 | dd = -dd; 334 | } 335 | } 336 | } 337 | 338 | /* f must not be evaluated too close to xx */ 339 | 340 | if (fabs(dd) >= tol1) { 341 | uu = xx + dd; 342 | } else { 343 | if (dd <= 0.) { 344 | uu = xx - tol1; 345 | } else { 346 | uu = xx + tol1; 347 | } 348 | } 349 | ++OP.nopt; 350 | fu = pqopt(x, uu, w, iw, min_fnorm); 351 | 352 | /* update aa, bb, vv, ww, and xx */ 353 | 354 | if (fx >= fu) { 355 | if (uu >= xx) { 356 | aa = xx; 357 | } else { 358 | bb = xx; 359 | } 360 | vv = ww; 361 | fv = fw; 362 | ww = xx; 363 | fw = fx; 364 | xx = uu; 365 | fx = fu; 366 | } else { 367 | if (uu >= xx) { 368 | bb = uu; 369 | } else { 370 | aa = uu; 371 | } 372 | if (fu > fw && ww != xx) { 373 | if (fu <= fv || vv == xx || vv == ww) { 374 | vv = uu; 375 | fv = fu; 376 | } 377 | } else { 378 | vv = ww; 379 | fv = fw; 380 | ww = uu; 381 | fw = fu; 382 | } 383 | } 384 | goto L10; 385 | 386 | /* end of main loop */ 387 | 388 | L_end: 389 | *hood = -fx; 390 | filtfd_.cllf = *hood; 391 | return xx; 392 | /* 900 format( i4, 2(1pe14.6), 1pe16.7, 1pe17.8, 1x, 2(i3)) 393 | 901 format( i4, 3(1pe10.2), 1pe11.2, 2(i3), 3(1pe8.1), i2) */ 394 | } /* dopt */ 395 | 396 | /* **************************************************************************** 397 | ******************************************************************************/ 398 | 399 | void fdcom(int *n, int *m, int *nar, int *nma, 400 | double *hood, double *flmin, double *flmax, 401 | double *epmin, double *epmax) 402 | /* is also called from R --> need all pointers */ 403 | { 404 | /* Fill "parameter"s into global variables (Common blocks) needed later: 405 | * 406 | * copyright 1991 Department of Statistics, University of Washington 407 | written by Chris Fraley 408 | -----------------------------------------------------------------------------*/ 409 | 410 | filtfd_.cllf = *hood; 411 | 412 | /* machine constants */ 413 | machfd_.fltmin = *flmin; 414 | machfd_.fltmax = *flmax; 415 | machfd_.epsmin = *epmin; 416 | machfd_.epsmax = *epmax; 417 | mauxfd_.epspt5 = sqrt(machfd_.epsmin); 418 | mauxfd_.epsp25 = sqrt(mauxfd_.epspt5); 419 | mauxfd_.epspt3 = pow(machfd_.epsmin, 0.3); 420 | mauxfd_.epsp75 = pow(machfd_.epsmin, 0.75); 421 | mauxfd_.bignum = 1. / machfd_.epsmin; 422 | 423 | /* useful quantities -- integer "dimensions" : */ 424 | Dims.n = *n; 425 | Dims.m = *m; 426 | Dims.p = *nar; 427 | Dims.q = *nma; 428 | Dims.pq = Dims.p + Dims.q; 429 | Dims.pq1 = Dims.pq + 1; 430 | if(Dims.p >= Dims.q) { 431 | Dims.maxpq = Dims.p; 432 | Dims.minpq = Dims.q; 433 | } else { 434 | Dims.maxpq = Dims.q; 435 | Dims.minpq = Dims.p; 436 | } 437 | Dims.maxpq1 = Dims.maxpq + 1; 438 | Dims.nm = *n - Dims.maxpq; 439 | 440 | /* workspace allocation */ 441 | w_opt.lqp = 1; 442 | w_fil.ly = w_opt.lqp + Dims.pq; 443 | w_fil.lamk = w_fil.ly; 444 | w_fil.lak = w_fil.lamk + *n; 445 | w_fil.lphi= w_fil.lak + *n; 446 | w_fil.lvk = w_fil.lphi + *m; /* = lamk + 2*n + M = 1 + npq + 2n + M */ 447 | w_fil.lpi = w_fil.lphi; 448 | w_opt.la = w_fil.ly + *n; 449 | w_opt.lajac = w_opt.la + *n - Dims.minpq; 450 | /* old ipvt = lajac + max( (n-np)*np, (n-nq)*nq, (n-maxpq)*npq) */ 451 | w_opt.ipvt = w_opt.lajac + (*n - Dims.maxpq) * Dims.pq; 452 | w_opt.ldiag= w_opt.ipvt + Dims.pq / 2 + 1; 453 | w_opt.lqtf = w_opt.ldiag + Dims.pq; 454 | w_opt.lwa1 = w_opt.lqtf + Dims.pq; 455 | w_opt.lwa2 = w_opt.lwa1 + Dims.pq; 456 | w_opt.lwa3 = w_opt.lwa2 + Dims.pq; 457 | w_opt.lwa4 = w_opt.lwa3 + Dims.pq; 458 | /* lfree = lwa4 + n - minpq */ 459 | return; 460 | } /* fdcom */ 461 | 462 | 463 | 464 | /************************************************************************** 465 | ************************************************************************** */ 466 | static 467 | double pqopt(double *x, double d__, double *w, int *iw, double *min_fnorm) 468 | { 469 | /* x: double x(n) */ 470 | /* w: work array exactly as in main fracdf() */ 471 | 472 | /* 'const' (but need to pass pointers of these): */ 473 | static int modelm = 1; 474 | static double factlm = 100.; 475 | 476 | /* Local variables */ 477 | double t, u, slogvk; 478 | 479 | /* Parameter adjustments */ 480 | --w; 481 | 482 | /* copyright 1991 Department of Statistics, University of Washington 483 | * written by Chris Fraley 484 | ---------------------------------------------------------------------------- */ 485 | fdfilt(x, d__, 486 | &w[(0 + (0 + (w_fil.ly << 3))) / 8], &slogvk, 487 | &w[(0 + (0 + (w_fil.lamk << 3))) / 8], 488 | &w[(0 + (0 + (w_fil.lak << 3))) / 8], 489 | &w[(0 + (0 + (w_fil.lvk << 3))) / 8], 490 | &w[(0 + (0 + (w_fil.lphi << 3))) / 8], 491 | &w[(0 + (0 + (w_fil.lpi << 3))) / 8]); 492 | if (gammfd_.igamma != 0) { 493 | filtfd_.wnv = machfd_.fltmax; 494 | filtfd_.cllf = -machfd_.fltmax; 495 | warning("** pqopt() gamma error (%d)", gammfd_.igamma); 496 | return machfd_.fltmax; 497 | } 498 | t = (double) Dims.n; 499 | 500 | if (Dims.pq == 0) { /* trivial case --- p = q = 0 : */ 501 | 502 | filtfd_.wnv = F77_CALL(ddot)(&Dims.n, 503 | &w[w_fil.ly], &ic__1, 504 | &w[w_fil.ly], &ic__1) / t; 505 | OP.ifun = 0; 506 | OP.igrd = 0; 507 | OP.info = -1; 508 | } 509 | else { 510 | 511 | /* optimize as an unconstrained optimization problem */ 512 | 513 | if (modelm == 2) { 514 | F77_CALL(dcopy)(&Dims.pq, &c__1, &ic__0, 515 | &w[w_opt.ldiag], &ic__1); 516 | } 517 | if (OP.nopt < 0) { // (never used ??) 518 | REprintf("pqopt() -- nopt < 0 case --- should never happen. Please report!"); 519 | if (Dims.p != 0) { 520 | int n_p = Dims.n - Dims.p; 521 | lmder1((S_fp)ajp_, n_p, Dims.p, 522 | &w[w_opt.lqp + Dims.q], &w[w_opt.la], &w[w_opt.lajac], n_p, 523 | TOL.f, TOL.x, TOL.g, OP.maxfun, &w[w_opt.ldiag], 524 | modelm, factlm, &OP.info, &OP.ifun, &OP.igrd, 525 | iw /* was &w[w_opt.ipvt] */, &w[w_opt.lqtf], 526 | &w[w_opt.lwa1], &w[w_opt.lwa2], &w[w_opt.lwa3], &w[w_opt.lwa4], 527 | &w[w_fil.ly]); 528 | } 529 | if (Dims.q != 0) { 530 | int n_q = Dims.n - Dims.q; 531 | lmder1((S_fp)ajq_, n_q, Dims.q, 532 | &w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], n_q, 533 | TOL.f, TOL.x, TOL.g, OP.maxfun, &w[w_opt.ldiag], 534 | modelm, factlm, &OP.info, &OP.ifun, &OP.igrd, 535 | iw /* was &w[w_opt.ipvt] */, &w[w_opt.lqtf], 536 | &w[w_opt.lwa1], &w[w_opt.lwa2], &w[w_opt.lwa3], &w[w_opt.lwa4], 537 | &w[w_fil.ly]); 538 | } 539 | } 540 | *min_fnorm = 541 | lmder1((S_fp)ajqp_, Dims.nm, Dims.pq, 542 | &w[w_opt.lqp], &w[w_opt.la], &w[w_opt.lajac], Dims.nm, 543 | TOL.f, TOL.x, TOL.g, OP.maxfun, &w[w_opt.ldiag], 544 | modelm, factlm, &OP.info, &OP.ifun, &OP.igrd, 545 | iw /* was &w[w_opt.ipvt] */, &w[w_opt.lqtf], 546 | &w[w_opt.lwa1], &w[w_opt.lwa2], &w[w_opt.lwa3], &w[w_opt.lwa4], 547 | &w[w_fil.ly]); 548 | 549 | if (OP.info == 0) { /* 'MINPACK : improper input parameters */ 550 | MinPck.iminpk = 10; 551 | filtfd_.wnv = machfd_.fltmax; 552 | filtfd_.cllf = -machfd_.fltmax; 553 | return machfd_.fltmax; 554 | } 555 | 556 | if(OP.info== 5) MinPck.jminpk = 5; /* MINPACK : function evaluation limit reached */ 557 | if(OP.info== 6) MinPck.jminpk = 6; /* MINPACK : ftol is too small */ 558 | if(OP.info== 7) MinPck.jminpk = 7; /* MINPACK : xtol is too small */ 559 | if(OP.info== 8) MinPck.jminpk = 8; /* MINPACK : gtol is too small */ 560 | 561 | 562 | /* call daxpy( npq, (-one), w(lpq), 1, w(lqp), 1 563 | delpq = sqrt(ddot( npq, w(lqp), 1, w(lqp), 1)) 564 | pqnorm = sqrt(ddot( npq, w(lpq), 1, w(lpq), 1)) */ 565 | 566 | filtfd_.wnv = *min_fnorm * *min_fnorm / (double) (Dims.nm - 1); 567 | } 568 | u = t * (log(filtfd_.wnv) + 2.8378) + slogvk; 569 | /* unused: BIC = u + (double) (Dims.p + Dims.q + 1) * log(t); */ 570 | filtfd_.cllf = -u / 2.; 571 | return u / 2; 572 | } /* End pqopt() */ 573 | 574 | /*************************************************************************** */ 575 | 576 | void 577 | fdfilt(double *x, double d__, 578 | /* -> output */ 579 | double *y, double *slogvk, 580 | /* using */ 581 | double *amk, double *ak, double *vk, 582 | double *phi, double *pi) 583 | { 584 | /* called as fdfilt( x, d, w(ly), slogvk, 585 | w(lamk), w(lak), w(lvk), w(lphi), w(lpi)) 586 | float x(n) 587 | double precision y(n), amk(n), ak(n) 588 | double precision vk(M), phi(M), pi(M) 589 | ************************************************************************** 590 | input : 591 | x float original time series 592 | d double estimated value of d 593 | output : 594 | y double filtered series 595 | slogvk double the sum of the logarithms of the vk 596 | notes : 597 | y can use the same storage as either ak or amk 598 | phi and pi can use the same storage 599 | can be arranged so that phi, pi and vk share the same storage 600 | 601 | MM: Which filtering exactly ???? 602 | -- --> look at ./fdsim.c which is similar (but simpler) 603 | and ../filters.R 604 | 605 | ************************************************************************** 606 | copyright 1991 Department of Statistics, University of Washington 607 | written by Chris Fraley 608 | -----------------------------------------------------------------------*/ 609 | 610 | /* System generated locals */ 611 | double d__1; 612 | 613 | /* Local variables */ 614 | int j, k, km, mcap; 615 | double r__, s, t, u, v, z__, g0; 616 | 617 | /* Parameter adjustments */ 618 | --pi; 619 | --phi; 620 | --vk; 621 | --ak; 622 | --amk; 623 | --y; 624 | --x; 625 | 626 | /* Function Body */ 627 | mcap = imin2(Dims.m, Dims.n); 628 | 629 | /* calculate amk(k), vk(k), and ak(k) for k=1,n (see W522-4 for notation). */ 630 | 631 | 632 | /* k = 1 */ 633 | 634 | amk[1] = 0.; 635 | ak[1] = 1.; 636 | 637 | /* k = 2 ; initialize phi(1) */ 638 | 639 | z__ = d__ / (1. - d__); 640 | amk[2] = z__ * x[1]; 641 | ak[2] = 1. - z__; 642 | phi[1] = z__; 643 | d__1 = 1. - d__; 644 | t = dgamr_(&d__1); 645 | if (gammfd_.igamma != 0) { 646 | return; 647 | } 648 | d__1 = 1. - d__ * 2.; 649 | g0 = dgamma_(&d__1) * (t * t); 650 | if (gammfd_.igamma != 0) { 651 | return; 652 | } 653 | vk[1] = g0; 654 | vk[2] = g0 * (1. - z__ * z__); 655 | 656 | /* k = 3, mcap */ 657 | 658 | for (k = 3; k <= mcap; ++k) { 659 | km = k - 1; 660 | t = (double) km; 661 | u = t - d__; 662 | 663 | /* calculate phi() and vk() using the recursion formula on W498 */ 664 | 665 | for (j = 1; j <= (km - 1); ++j) { 666 | s = t - (double) j; 667 | phi[j] *= t * (s - d__) / (u * s); 668 | } 669 | v = d__ / u; 670 | phi[km] = v; 671 | vk[k] = vk[km] * (1. - v * v); 672 | 673 | /* form amk(k) and ak(k) */ 674 | 675 | u = 0.; 676 | v = 1.; 677 | for (j = 1; j <= km; ++j) { 678 | t = phi[j]; 679 | u += t * x[k - j]; 680 | v -= t; 681 | } 682 | amk[k] = u; 683 | ak[k] = v; 684 | } 685 | 686 | /* k = mcap+1, n */ 687 | 688 | if (Dims.m < Dims.n) { /* i.e. mcap = min(M,n) != n */ 689 | 690 | /* calculate pi(j), j = 1,mcap */ 691 | 692 | pi[1] = d__; 693 | s = d__; 694 | for (j = 2; j <= mcap; ++j) { 695 | u = (double) j; 696 | t = pi[j - 1] * ((u - 1. - d__) / u); 697 | s += t; 698 | pi[j] = t; 699 | } 700 | s = 1. - s; 701 | r__ = 0.; 702 | u = (double) mcap; 703 | t = u * pi[mcap]; 704 | 705 | for (k = mcap+1; k <= Dims.n; ++k) { 706 | km = k - mcap; 707 | z__ = 0.; 708 | for (j = 1; j <= mcap; ++j) { 709 | z__ += pi[j] * x[k - j]; 710 | } 711 | if (r__ == 0.) { 712 | amk[k] = z__; 713 | ak[k] = s; 714 | } else { 715 | v = t * (1. - pow(u / k, d__)) / d__; 716 | amk[k] = z__ + v * r__ / ((double) km - 1.); 717 | ak[k] = s - v; 718 | } 719 | r__ += x[km]; 720 | } 721 | } 722 | 723 | /* form muhat - see formula on W523. */ 724 | 725 | r__ = 0.; 726 | s = 0.; 727 | for (k = 1; k <= (Dims.n); ++k) { 728 | t = ak[k]; 729 | u = (x[k] - amk[k]) * t; 730 | v = t * t; 731 | if (k <= mcap) { 732 | z__ = vk[k]; 733 | u /= z__; 734 | v /= z__; 735 | } 736 | r__ += u; 737 | s += v; 738 | } 739 | filtfd_.hatmu = r__ / s; 740 | 741 | /* form filtered version */ 742 | 743 | s = 0.; 744 | for (k = 1; k <= mcap; ++k) 745 | s += log(vk[k]); 746 | 747 | *slogvk = s; 748 | s = 0.; 749 | for (k = 1; k <= (Dims.n); ++k) { 750 | t = x[k] - amk[k] - filtfd_.hatmu * ak[k]; 751 | if (k <= mcap) 752 | t /= sqrt(vk[k]); 753 | 754 | s += t; 755 | y[k] = t; 756 | } 757 | if (Dims.pq == 0) { 758 | return; 759 | } 760 | t = (double) Dims.n; 761 | u = z__ / t; 762 | for (k = 1; k <= Dims.n; ++k) 763 | y[k] -= u; 764 | 765 | return; 766 | } /* fdfilt */ 767 | 768 | 769 | /**************************************************************************** 770 | *****************************************************************************/ 771 | /* Passed to lmder1() minimizer, but also called from 772 | * hesdpq() in ./fdhess.c : */ 773 | void ajqp_(double *qp, double *a, double *ajac, int lajac, int op_code, double *y) 774 | { 775 | /* System generated locals */ 776 | int ajac_dim1, ajac_offset; 777 | 778 | /* Local variables */ 779 | static int i, k, l; 780 | static double s, t; 781 | static int km; 782 | 783 | /* double precision qp(npq), a(nm), ajac(nm,npq), y(n) 784 | copyright 1991 Department of Statistics, University of Washington 785 | written by Chris Fraley 786 | -------------------------------------------------------------------------- 787 | Parameter adjustments */ 788 | --qp; 789 | --a; 790 | ajac_dim1 = lajac; 791 | ajac_offset = 1 + ajac_dim1; 792 | ajac -= ajac_offset; 793 | --y; 794 | 795 | if (op_code == 1) { /* objective calculation */ 796 | 797 | for (k = Dims.maxpq1; k <= (Dims.n); ++k) { 798 | km = k - Dims.maxpq; 799 | t = 0.; 800 | if (Dims.p != 0) { 801 | for (l = 1; l <= (Dims.p); ++l) { 802 | t -= qp[Dims.q + l] * y[k - l]; 803 | } 804 | } 805 | s = 0.; 806 | if (Dims.q != 0) { 807 | for (l = 1; l <= (Dims.q); ++l) { 808 | if (km <= l) 809 | break; 810 | s += qp[l] * a[km - l]; 811 | } 812 | } 813 | 814 | s = y[k] + (t + s); 815 | if (fabs(s) <= mauxfd_.bignum) { 816 | a[km] = s; 817 | } else { 818 | a[km] = sign(s) * mauxfd_.bignum; 819 | } 820 | } 821 | ++OP.nfun; 822 | 823 | } else if (op_code == 2) { /* jacobian calculation */ 824 | 825 | for (i = 1; i <= (Dims.pq); ++i) { 826 | for (k = Dims.maxpq1; k <= (Dims.n); ++k) { 827 | km = k - Dims.maxpq; 828 | t = 0.; 829 | if (Dims.q != 0) { 830 | for (l = 1; l <= (Dims.q); ++l) { 831 | if (km <= l) 832 | break; 833 | t += qp[l] * ajac[km - l + i * ajac_dim1]; 834 | } 835 | } 836 | 837 | if (i <= Dims.q) { 838 | if (km > i) { 839 | s = a[km - i] + t; 840 | } else { 841 | s = t; 842 | } 843 | } else { 844 | s = -y[k - (i - Dims.q)] + t; 845 | } 846 | if (fabs(s) <= mauxfd_.bignum) { 847 | ajac[km + i * ajac_dim1] = s; 848 | } else { 849 | ajac[km + i * ajac_dim1] = sign(s) * mauxfd_.bignum; 850 | } 851 | } 852 | } 853 | ++OP.ngrd; 854 | } 855 | else { // invalid op_code 856 | warning("ajqp_(): invalid op_code = %d", op_code); 857 | } 858 | return; 859 | } /* ajqp_ */ 860 | 861 | /**************************************************************************** 862 | ****************************************************************************/ 863 | 864 | static void 865 | ajp_(double *p, double *a, double *ajac, int lajac, int op_code, double *y) 866 | /* p(np), a(nm), ajac(nm,npq), y(n) */ 867 | { 868 | /* copyright 1991 Department of Statistics, University of Washington 869 | written by Chris Fraley 870 | ------------------------------------------------------------------------- 871 | */ 872 | 873 | /* Local variables */ 874 | int i, k; 875 | 876 | /* Parameter adjustments */ 877 | --p; 878 | --a; 879 | --y; 880 | 881 | /* Function Body */ 882 | 883 | if (op_code == 1) { /* objective calculation */ 884 | 885 | if (Dims.p == 0) { 886 | 887 | } 888 | for (k = Dims.p + 1; k <= (Dims.n); ++k) { 889 | double t = 0; 890 | for (i = 1; i <= (Dims.p); ++i) 891 | t -= p[i] * y[k - i]; 892 | 893 | a[k - Dims.p] = y[k] + t; 894 | } 895 | } 896 | else if (op_code == 2) { /* jacobian calculation */ 897 | /* L200: */ 898 | 899 | /* Matrix 1-indexing adjustments (System generated): */ 900 | int ajac_dim1 = lajac; 901 | ajac -= (1 + ajac_dim1); 902 | 903 | for (i = 1; i <= Dims.p; ++i) 904 | for (k = Dims.p + 1; k <= (Dims.n); ++k) 905 | ajac[k - Dims.p + i * ajac_dim1] = - y[k - i]; 906 | } 907 | return; 908 | } /* ajp_ 909 | **************************************************************************** 910 | ****************************************************************************/ 911 | 912 | static void 913 | ajq_(double *qp, double *a, double *ajac, int lajac, int op_code, double *y) 914 | /* double precision qp(npq), a(nm), ajac(nm,npq), y(n) */ 915 | { 916 | /* copyright 1991 Department of Statistics, University of Washington 917 | written by Chris Fraley 918 | ------------------------------------------------------------------- 919 | */ 920 | 921 | /* Local variables */ 922 | int i, k, l, km; 923 | double s, t; 924 | 925 | /* Parameter adjustments */ 926 | --qp; 927 | --a; 928 | --y; 929 | 930 | if (op_code == 1) { /*--- objective calculation ---*/ 931 | 932 | if (Dims.q == 0) 933 | return; 934 | 935 | for (k = Dims.maxpq1; k <= (Dims.n); ++k) { 936 | km = k - Dims.maxpq; 937 | t = 0.; 938 | if (Dims.p != 0) { 939 | for (l = 1; l <= (Dims.p); ++l) { 940 | t -= qp[Dims.q + l] * y[k - l]; 941 | } 942 | } 943 | s = 0.; 944 | if (Dims.q != 0) { 945 | for (l = 1; l <= (Dims.q); ++l) { 946 | if (km <= l) 947 | break; 948 | s += qp[l] * a[km - l]; 949 | } 950 | } 951 | a[km] = y[k] + (t + s); 952 | } 953 | ++OP.nfun; 954 | } 955 | else if (op_code == 2) { /*--- jacobian calculation ---*/ 956 | /* L200: */ 957 | 958 | /* Matrix 1-indexing adjustments (System generated): */ 959 | int ajac_dim1 = lajac; 960 | ajac -= (1 + ajac_dim1); 961 | 962 | for (i = 1; i <= (Dims.pq); ++i) { 963 | for (k = Dims.maxpq1; k <= (Dims.n); ++k) { 964 | km = k - Dims.maxpq; 965 | t = 0.; 966 | if (Dims.q != 0) { 967 | for (l = 1; l <= (Dims.q); ++l) { 968 | if (km <= l) 969 | break; 970 | t += qp[l] * ajac[km - l + i * ajac_dim1]; 971 | } 972 | } 973 | if (i <= Dims.q) { 974 | if (km > i) { 975 | ajac[km + i * ajac_dim1] = a[km - i] + t; 976 | } else { 977 | ajac[km + i * ajac_dim1] = t; 978 | } 979 | } else { 980 | ajac[km + i * ajac_dim1] = -y[k - (i - Dims.q)] + t; 981 | } 982 | } 983 | } 984 | ++OP.ngrd; 985 | } 986 | return; 987 | } /* ajq_ */ 988 | 989 | --------------------------------------------------------------------------------