expm/0000755000176200001440000000000014660661247011237 5ustar liggesusersexpm/tests/0000755000176200001440000000000014660607514012376 5ustar liggesusersexpm/tests/ex.R0000644000176200001440000002165514655414132013142 0ustar liggesuserslibrary(expm) (sI <- sessionInfo()) packageDescription("Matrix") packageDescription("expm") source(system.file("test-tools.R", package= "expm"), keep.source=FALSE) ## Note that these results are achieved with the default ## settings order=8, method="Pade" -- accuracy could ## presumably be improved still further by some tuning ## of these settings. ### Latest ATLAS (for BDR on F 36; R-devel Oct.2023) has much worse precision: ##==> use much larger tolerance in such cases: ## Simplified (needs R 3.4.0 and newer, from robustbase/inst/xtraR/platform-sessionInfo.R ) : BLAS <- extSoftVersion()[["BLAS"]] Lapack <- La_library() is.BLAS.Lapack <- identical(BLAS, Lapack) ## A cheap check (that works on KH's debian-gcc setup, 2019-05): if(!length(BLAS.is.openBLAS <- grepl("openblas", BLAS, ignore.case=TRUE))) BLAS.is.openBLAS <- NA if(!length(Lapack.is.openBLAS <- grepl("openblas", Lapack, ignore.case=TRUE))) Lapack.is.openBLAS <- NA (maybeATLAS <- is.BLAS.Lapack && !BLAS.is.openBLAS) ## ---------------------------- ## Test case 1 from Ward (1977) ## ---------------------------- T1 <- rbind(c(4, 2, 0), c(1, 4, 1), c(1, 1, 4)) (m1 <- expm(T1, method="Pade")) (m1O <- expm(T1, method="PadeO"))# very slightly different (m1T <- expm(T1, method="Taylor")) (m1TO <- expm(T1, method="TaylorO")) ## True Eigenvalue Decomposition of T1 s2 <- sqrt(2) eV1 <- matrix(c(s2,s2,s2, -2,1,1, 2,-1,-1) / sqrt(6), 3,3) L1 <- diag(lm1 <- c(6, 3, 3)) stopifnot( all.equal(eV1 %*% L1, T1 %*% eV1, tolerance=1e-15) ) ## However, eV1 is not orthogonal, but of rank 2 if(FALSE) { ## require("Rmpfr")) { ## 200 bit precision version of that S2 <- sqrt(mpfr(2,200)) E1 <- c(S2,S2,S2, -2,1,1, 2,-1,-1) / sqrt(mpfr(6,200)) dim(E1) <- c(3,3) print(E1 %*% L1) print(E1) } ## "true" result m1.t <- matrix(c(147.866622446369, 127.781085523181, 127.781085523182, 183.765138646367, 183.765138646366, 163.679601723179, 71.797032399996, 91.8825693231832, 111.968106246371), 3,3) stopifnot(all.equal(m1.t, m1, check.attributes=FALSE, tolerance = 1e-13), all.equal(m1.t, m1O, check.attributes=FALSE, tolerance = 1e-13), all.equal(m1.t,m1T, check.attributes=FALSE, tolerance = 1e-13), all.equal(m1.t,m1TO, check.attributes=FALSE, tolerance = 1e-13), all.equal(m1.t, expm(T1,"Ward77"), tolerance = 1e-13), all.equal(m1.t, expm(T1,"R_Pade"), tolerance = 1e-13), all.equal(m1.t, expm(T1,"R_Ward77"), tolerance = 1e-13)) ## -- these agree with ward (1977, p608) ## m1.2 <- try( expm(T1, "R_Eigen") ) ## 32-bit: gives an error from solve; 64-bit "ok" if(!inherits(m1.2, "try-error")) { if(FALSE)## with libatlas R_Eigen is "sehr eigen" stopifnot(all.equal(m1.t, m1.2, check.attributes=FALSE)) ## but it's less accurate: print( all.equal(m1.t, m1.2, check.attributes=FALSE, tolerance= 1e-12)) ##-> rel.diff = 6.44e-10 / 6.2023e-10 ##__ BUT 0.1228099 ##__ with libatlas (ubuntu 12.04 libatlas-base-dev Version: 3.8.4-3build1) } ## ## ---------------------------- ## Test case 2 from Ward (1977) ## ---------------------------- T2 <- t(matrix(c( 29.87942128909879, .7815750847907159, -2.289519314033932, .7815750847907159, 25.72656945571064, 8.680737820540137, -2.289519314033932, 8.680737820540137, 34.39400925519054), 3, 3)) (m2 <- expm(T2, method="Pade")) ## [,1] [,2] [,3] ##[1,] 5496313853692357 -18231880972009844 -30475770808580828 ##[2,] -18231880972009852 60605228702227024 101291842930256144 ##[3,] -30475770808580840 101291842930256144 169294411240859072 ## -- which agrees with Ward (1977) to 13 significant figures (m2O <- expm(T2, method="PadeO")) (m2T <- expm(T2,method="Taylor")) (m2TO <- expm(T2,method="TaylorO")) m2.t <- matrix(c(5496313853692216, -18231880972008932, -30475770808579672, -18231880972008928, 60605228702222480, 101291842930249776, -30475770808579672, 101291842930249808, 169294411240850528), 3, 3) ## -- in this case a very similar degree of accuracy -- even Taylor is ok stopifnot(all.equal(m2.t, m2, check.attributes=FALSE, tolerance = 1e-12), all.equal(m2.t, m2O,check.attributes=FALSE, tolerance = 1e-12), all.equal(m2.t,m2T, check.attributes=FALSE, tolerance = 1e-12), all.equal(m2.t,m2TO,check.attributes=FALSE, tolerance = 1e-12), all.equal(m2.t, expm(T2,"Ward77"), tolerance = 1e-12), all.equal(m2.t, expm(T2,"R_Ward77"), tolerance = 1e-12), all.equal(m2.t, expm(T2,"R_Pade"), tolerance = 1e-12), TRUE) ## ---------------------------- ## Test case 3 from Ward (1977) ## ---------------------------- T3 <- t(matrix(c( -131, 19, 18, -390, 56, 54, -387, 57, 52), 3, 3)) (m3 <- expm(T3, method="Pade")) ## [,1] [,2] [,3] ##[1,] -1.5096441587713636 0.36787943910439874 0.13533528117301735 ##[2,] -5.6325707997970271 1.47151775847745725 0.40600584351567010 ##[3,] -4.9349383260294299 1.10363831731417195 0.54134112675653534 ## -- agrees to 10dp with Ward (1977), p608. (m3O <- expm(T3, method="PadeO")) (m3T <- expm(T3,method="Taylor")) (m3TO <- expm(T3,method="TaylorO")) m3.t <- matrix(c(-1.50964415879218, -5.6325707998812, -4.934938326092, 0.367879439109187, 1.47151775849686, 1.10363831732856, 0.135335281175235, 0.406005843524598, 0.541341126763207), 3,3) stopifnot(all.equal(m3.t, m3, check.attributes=FALSE, tolerance = 3e-11), # ^^^^^ # 1.2455e-11 for libatlas (above) all.equal(m3.t, m3T, check.attributes=FALSE, tolerance = 1e-11), all.equal(m3.t, m3O, check.attributes=FALSE, tolerance = 8e-11),# M1: 1.39e-11 all.equal(m3.t, m3TO, check.attributes=FALSE, tolerance = 1e-11), all.equal(m3.t, expm(T3,"R_Eigen"), tolerance = 1e-11), all.equal(m3.t, expm(T3,"Ward77"), tolerance = 1e-11), all.equal(m3.t, expm(T3,"R_Ward"), tolerance = 1e-11), all.equal(m3.t, expm(T3,"R_Pade"), tolerance = 1e-11), TRUE) ## -- in this case, a similar level of agreement with Ward (1977). ##-------- expm() ------------------- z3 <- T3 * (1 + 1i) Lz3 <- expmAll(z3) str(Lz3) Lz3. <- Lz3[.methComplex] str(allEq(Lz3., tol=0)) # -> max seen (Lnx 64): 1.3376e-12 stopifnot(unlist(allEq(Lz3.))) ## ---------------------------- ## Test case 4 from Ward (1977) ## ---------------------------- T4 <- array(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 1e-10, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0), dim = c(10, 10)) (m4 <- expm(T4, method="Pade")) (m4O <- expm(T4, method="PadeO")) (m4T <- expm(T4,method="Taylor")) (m4TO <- expm(T4,method="TaylorO")) ## ATLAS on BDR's gannet (Fedora 26; gcc-13; R-devel 2023-10-24) tol1 <- if(maybeATLAS) 4e-7 else 5e-15 # (m4, m4O) gave "Mean relative difference: 1.242879e-07" stopifnot(all.equal(m4 [,10], 1/gamma(10:1), tolerance=1e-14), all.equal(m4O [,10], 1/gamma(10:1), tolerance=1e-14), all.equal(m4T [,10], 1/gamma(10:1), tolerance=1e-14), all.equal(m4TO[,10], 1/gamma(10:1), tolerance=1e-14), all.equal(m4, m4O, check.attributes=FALSE, tolerance=tol1), all.equal(m4, m4T, check.attributes=FALSE, tolerance=tol1), all.equal(m4, m4TO,check.attributes=FALSE, tolerance=tol1), all.equal(m4, expm(T4,"Ward77"), check.attributes=FALSE, tolerance = 1e-14), all.equal(m4, expm(T4,"R_Ward"), check.attributes=FALSE, tolerance = 1e-14), all.equal(m4, expm(T4,"R_Pade"), check.attributes=FALSE, tolerance = 1e-14), max(abs(m4 - expm(T4,"R_Eigen"))) < 1e-7) ## here expm(., EV ) is accurate only to 7 d.p., whereas ## expm(.,Pade) is correct to at least 14 d.p. ### Test case with diagonalizable matrix with multiple Eigen values: A4 <- rbind(c(-1, 3, -1), c(-3, 5, -1), c(-3, 3, 1)) Ea4 <- eigen(A4) stopifnot(all.equal(Ea4$values, (lam4 <- c(2,2,1)))) ## However, the eigen values don't show the nice property: V4 <- Ea4$vectors crossprod(V4) ## i.e., they are *not* orthogonal ## but still diagonalize: stopifnot(all.equal(A4, V4 %*% diag(x=lam4) %*% solve(V4))) ## whereas this diagonalizes *and* looks nice W4 <- rbind(c(1, 1, -1), c(1, 1, 0), c(1, 0, 3)) (sW4 <- solve(W4)) assert.EQ(diag(x = c(1,2,2)), solve(W4) %*% A4 %*% W4, giveRE=TRUE) assert.EQ(A4, logm(expm(A4)), tol = 3e-13, giveRE=TRUE) ## seen 5.5e-14 with R's own matprod expm/tests/log+sqrt.R0000644000176200001440000000536312407501461014265 0ustar liggesuserslibrary(Matrix) library(expm) source(system.file("test-tools.R", package = "expm"), keep.source=FALSE) doExtras tst.sqrtm <- function(m, tol = 1e-12, zap.Im.tol = 1e-10) { r.m <- sqrtm(m)## should now work s <- r.m %*% r.m if(is.complex(s) && all(abs(Im(s)) < mean(abs(s)) * zap.Im.tol)) s <- Re(s) all.equal(m, s, tolerance=tol) } options(verbose = TRUE) # -> get some messages from logm.Higham ### ---- Small exact : ---------- L2 <- cbind(1, 0:1) lL2 <- cbind(0:1, 0) (L3 <- rbind(cbind(1,cbind(0:1,0)),1)) (lL3 <- cbind(rbind(0, cbind((2:1)/2,0:1)), 0)) assertError(logm(L2, method="Eigen")) assertError(logm(L3, method="Eigen")) logm.Higham08 <- expm:::logm.Higham08 l.L2 <- logm.Higham08(L2) l.L3 <- logm.Higham08(L3) all.equal(l.L2, lL2, tolerance=0)# 5.64 e-14 (32-bit *and* 64-bit) all.equal(l.L3, lL3, tolerance=0)# 2.40 e-15 (ditto) stopifnot(all.equal(l.L2, lL2, tolerance= 1000e-16), all.equal(l.L3, lL3, tolerance= 80e-16)) showProc.time() ### --------- More & larger randomly generated examples : ----------------- set.seed(101) EA <- expm.Higham08(A <- matrix(round(rnorm(25),1), 5)) all.equal(EA, expm.Higham08(logm.Higham08(EA)), tolerance=0) ## "Mean relative difference: 1.020137e-13" stopifnot(all.equal(EA, expm.Higham08(logm.Higham08(EA)), tolerance=1e-12)) S <- crossprod(A) all.equal(S, sqrtm(S) %*% sqrtm(S), tolerance=0) ## "Mean relative difference: 2.26885e-15" stopifnot(all.equal(S, sqrtm(S) %*% sqrtm(S), tolerance=1e-14)) showProc.time() set.seed(3) ## n = 50 is already "too" slow (well: logm.Higham08(.) needs 2.2 sec ## --> CPU measurements below for(n in c(2:5, 10:11, if(doExtras) 30)) { cat("n = ",n,": ") for(kk in seq_len(if(doExtras) 30 else 10)) { ## Testing logm() EA <- expm.Higham08(A <- matrix(round(rnorm(n^2),2), n,n)) stopifnot(all.equal(EA, expm.Higham08(logm.Higham08(EA)), tolerance=1e-12)) cat(" ") ## Testing sqrtm() --- for positive definite *and* arbitrary stopifnot(tst.sqrtm(A))# A is completely random S <- crossprod(A) + rnorm(n^2) / 1000 stopifnot(tst.sqrtm(S)) cat(".") } cat("\n") } showProc.time() ### CPU-measurements for logm() options(verbose = FALSE)# printing costs .. set.seed(5) if(doExtras) { n <- 50 sim <- 32 } else { n <- 21 sim <- 8 } cpuT <- numeric(sim) for(k in seq_len(sim)) { EA <- expm.Higham08(A <- matrix(rnorm(n^2), n,n)) cat(".") cpuT[k] <- system.time(LEA <- logm.Higham08(EA))[1] stopifnot(all.equal(EA, expm.Higham08(LEA), tolerance=1e-12)) }; cat("\n") summary(cpuT) ## cmath-5 {Feb.2009}; Michi's original code: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## 1.794 2.249 2.389 2.388 2.515 2.831 showProc.time() expm/tests/matpow-ex.R0000644000176200001440000000276314655414337014455 0ustar liggesuserslibrary(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE) ## -> assertError()... doExtras doExtras ## Missing REPROTECT(), till 2014-09-03 [because 'A' is *integer*]: set.seed(17) n <- 300 A <- matrix(rbinom(n^2, size=1, prob=0.1), n,n) stopifnot(is.integer(A)) A2 <- A %^% 2 for(i in 1:100) { A. <- A %^% 2 if(!isTRUE(all.equal(A2, A.))) cat("not equal; i=",i,"\n") } ## MM: On nb-mm3, I get a different error which shows memory corruption: ## REAL() can only be applied to a 'numeric', not a 'character' ## or REAL() can only be applied to a 'numeric', not a 'NULL' ## Check that *large* matrices now work if(FALSE) ## << even m %^% 2 takes > 20 hours (!!!) [but no longer stops early!] if(doExtras && require("sfsmisc") && exists("Sys.memGB", "package:sfsmisc", mode="function") && sfsmisc::Sys.memGB() > 50) { ## seems to need 3 x size(m) ## n <- 46341 print(as.integer(n^2))# integer overflow cat("Creating large matrix 'm' (more than max_int entries):\n ") print(system.time(m <- diag(x = (1:n)^3, nrow = n))) # 9.1 sec i <- 1:(n-1) print(system.time( m[cbind(i,i+1)] <- i )) # 11.3 sec cat("object.size(m): "); print(object.size(m), units="Gb") ## 16 Gb (= 17.78 e9 bytes) ## This __STILL__ takes hours cat("m %^% 2: "); print(system.time(m2 <- m %^% 2)) ## user system elapsed ## 127199.580 9608.373 137236.405 ==> cat("m %^% 4: "); print(system.time(m4 <- m %^% 4)) # } expm/tests/bal-ex.R0000644000176200001440000000721314655414337013677 0ustar liggesuserslibrary(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE)## -> assertError()... ## A matrix with 'Inf' mI <- rbind(0, c(-Inf, Inf, 0, 0), 0, 0) bal3 <- list(dB = dgebal(mI, "B"), # = default dP = dgebal(mI, "P"), dN = dgebal(mI, "N")) str(bal3) stopifnot(identical(mI, bal3$dN$z), with(bal3, all.equal(dB, dP, tol=1e-14)), all.equal(bal3$dB$z, rbind(c(Inf,-Inf,0,0), 0,0,0), tol=1e-14), all.equal(bal3$dB$scale, c(1,1,3,4))) assertError(dgebal(mI, "S"), verbose=TRUE)# gave infinite loop ## Compare the two different "balance" pre-conditioning versions in Ward77: set.seed(1) mList <- lapply(integer(100), function(...) rSpMatrix(20, nnz=80)) re20 <- sapply(mList, function(M) relErr(expm(M, precond = "2bal"), expm(M, precond = "1bal"))) re20 ## ahh.: zero or ~ 1e-13 ... good table(re20 == 0) summary(re20[re20 != 0]) ## Pentium M (ubuntu) ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## 2.593e-14 8.703e-14 1.282e-13 2.434e-13 4.177e-13 6.295e-13 demo(balanceTst) #-> the function definition and the first few examples ## ========== dm4. <- dgebal(m4) storage.mode(m4) <- "integer" stopifnot(identical(dm4., dgebal(m4))) expm(m) expm(m,"Pade") ## are different indeed {when bug still existed} expm(m,"R_Pade")# same as Pade ## a non-empty ``non-balanced'' example --- expm.t.identity(m4, "Ward") m6 <- zeroTrace(matrix(outer(2^(-8:9),c(-1,1)), 6,6)); m6 m6[lower.tri(m6)] <- 0 ## plus one non-zero m6[4,2] <- 77 p <- c(6,4,5,2:1,3); m6 <- m6[p,p] expm.t.identity(m6, "Ward") ## difference; indeed expm(m6) # is very different from expm(m6,"R_Pade") str(dm6 <- balanceTst(m6)) ## Now, that's interesting: ## ## 1. 'S' scales *more* (2 .. 5) than just (2:4 == i1:i2) ! ## ## 2. 'B' has quite different scaling and it does (must!) obey rule ## scale i1:i2 only ## ## 3. 'B'(oth) is better than "P" and "S" separately: ## kappa(eigen(m6)$vectors)# 597.5588 kappa(eigen(dm6$P$z)$vectors)# 597.5588 kappa(eigen(dm6$S$z)$vectors)# 42.58396 kappa(eigen(dm6$B$z)$vectors)# 22.20266 ## An n=17 example where octave's expm() is wrong too m17 <- matrix(c(10,0, 0, 2, 3,-1, 0, 0, 0, 0, 0, 4, 0, 5, 0, 0,-2, 0, 0, 0, 0,-3, 0, 0, 0, 0, 0, 0, 0, 0, 6, 0, 7, 0, 0, 0,10, 0, 0,-4, 9, 0, 0, 0,-5, 0,-6, 0, 0, 0, 0, 0, 0,-7, 0, 0, 0, 0, 0, 0,10, 0, 0, 0, 0, 0,11, 0, 0, 0, 0, 0, 0, 0,12, 0, 0, 0, 0, 0,-8, 0, 0, 0, 0, 0, 0,-9, 0, 0, 0, 0, 0, 0,-10,0,13,14,-11,-12,-13, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,10, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,-14,16,0,-10,0,17, 0, 0, 0, 0, 0, 0, 0, 0,-16,0, 0,18,19, 0, 0, 0, 0, 0, 0, 0,20, 0, 21, 22,0, 0, 0, 0, 0,-17,0, 0, 0,-10,-19,-20,0,0,0, 0, 0,-21,0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,23,24, 0,25,26, 0, 0,27,-22,0,28,-23,0,-24, 0,-25,0,29, 0, 0, 0, 0, 0, 0, 0,30,31, 0, 0, 0, 0, 0, 0,-26,32,0, 0, 0, 0, 0,-27,0,33,34, 0, 0, 0, 0, 0,-28,-29,0,0, 0,35, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,36,37, 0, 0, 0, 0, 0, 0, 0, 0,-10), 17, 17) str(dm17 <- balanceTst(m17)) sapply(dm17[1:3], `[[`, "scale") ## The balancing was really rather harmful -- cond(V) *not* improved: condX <- function(x) kappa(x, exact=TRUE) condX(eigen(m17)$vectors)# 8.9e16 condX(eigen(dm17$P$z)$vectors)# 1.37e17 condX(eigen(dm17$S$z)$vectors)# 1.44e17 condX(eigen(dm17$B$z)$vectors)# 1.43e17 (very slightly smaller) expm/tests/exact-ex.R0000644000176200001440000004147514660607502014247 0ustar liggesusers#### Examples where we know the result "exactly" library(expm) options(digits = 4, width = 99, keep.source = FALSE) mSource <- function(file, ...) source(system.file(file, ..., package = "expm", mustWork=TRUE)) mSource("test-tools.R")## -> assertError(), rMat(), .. doExtras mSource("demo", "exact-fn.R")# -> nilA3(), facMat(), m2ex3(), .... doExtras re.nilA3 <- function(xyz, EXPMlist) { stopifnot(is.list(EXPMlist)) r <- do.call(nilA3, as.list(xyz)) sapply(EXPMlist, function(Efn) relErr(r$expA, Efn(r$A))) } re.facMat <- function(n, EXPMlist, rFUN = rnorm, ...) { stopifnot(is.list(EXPMlist)) r <- facMat(n, rFUN, ...) vapply(EXPMlist, function(EXPM) { ct <- system.time(E <- EXPM(r$A), gcFirst = FALSE)[[1]] c(relErr = relErr(r$expA, E), c.time = ct) }, double(2)) } re.m2ex3 <- function(eps, EXPMlist) { stopifnot(is.list(EXPMlist)) r <- m2ex3(eps) sapply(EXPMlist, function(EXPM) relErr(r$expA, EXPM(r$A))) } ## check 1x1 matrices stopifnot( ## these had failed before 2017-03-28 (= Liselotte's 58-th birthday): all.equal(as.matrix(sqrtm(matrix(4))), matrix(2)) , all.equal(as.matrix(logm (matrix(pi))), matrix(log(pi))) , ## these had "always" worked : all.equal(as.matrix(expm (matrix(0))), matrix(1)) , all.equal(as.matrix(expm (matrix(1))), matrix(exp(1))) ) set.seed(321) re <- replicate(1000, c(re.nilA3(rlnorm(3),list(function(x)expm(x,"Pade"))), re.nilA3(rnorm(3), list(function(x)expm(x,"Pade"))))) summary(t(re)) stopifnot(rowMeans(re) < 1e-15, apply(re, 1, quantile, 0.80) < 1e-16, apply(re, 1, quantile, 0.90) < 2e-15, apply(re, 1, max) < c(4e-14, 6e-15)) showProc.time() ## Check *many* random nilpotent 3 x 3 matrices: set.seed(321) RE <- replicate(1000, c(re.nilA3(rlnorm(3), list(function(x) expm(x, "Ward77"))), re.nilA3(rnorm(3), list(function(x) expm(x, "Ward77"))))) stopifnot(rowMeans(RE) < 1e-15, apply(RE, 1, quantile, 0.80) < 1e-16, apply(RE, 1, quantile, 0.90) < 2e-15, apply(RE, 1, max) < c(4e-14, 6e-15)) print(summary(t(RE))) epsC <- .Machine$double.eps cat("relErr(expm(.,Pade)) - relErr(expm(.,Ward77)) in Machine_eps units:\n") print(summary(c(re - RE)) / epsC) ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## -0.6183442 0.0000000 0.0000000 1.3650410 0.1399719 94.9809161 ## nb-mm3; ditto lynne (both x64), 2014-09-11: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## -0.8422 0.0000 0.0000 0.0725 0.1067 1.2205 ## 32-bit [i686, florence, Linx 3.14.8-100.fc19..]: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## -0.62 0.00 0.00 1.36 0.14 95.93 showProc.time() ###--- A second group --- where we know the diagonalization of A --- if(!require("Matrix")) q('no') ## ------ the rest really uses 'Matrix' ##---> now use expm::expm() since Matrix has its own may mask the expm one ## ^^^^^^^^^^^^ (osV <- abbreviate(gsub("[^[:alnum:]]", '', sub("\\(.*", '', osVersion)), 12)) if(!dev.interactive(TRUE)) pdf(paste0("expm_exact-ex_", osV, ".pdf"), width = 9, height=5) ## myRversion <- paste(R.version.string, "--", osVersion) if((mach <- Sys.info()[["machine"]]) != "x86_64") myRversion <- paste0(myRversion, "_", mach) if(!capabilities("long.double")) myRversion <- paste0(myRversion, "_no_LDbl") myRversion ## in plots use mtext(myRversion, adj=1, cex=3/4) ## rMat() relies on Matrix::rcond(): ## Now with the change default rcondMin, this "works" R40 <- rMat(40) R80 <- rMat(80) showProc.time() expm.safe.Eigen <- function(x, silent = FALSE) { r <- try(expm::expm(x, "R_Eigen"), silent = silent) if(inherits(r, "try-error")) NA else r } ## the S4 generic Matrix::expm ## the dgeMatrix method - adapted to Matrix changes, had *more versatile* ..2dge() : expm.Matr.dge <- function(x) getDataPart(getMethod("expm", "dgeMatrix"))(Matrix::.m2dense(x)) expmList <- list(Matr = Matrix::expm, Matr.d = expm.Matr.dge, Ward = function(x) expm::expm(x, "Ward77"), Ward1b = function(x) expm::expm(x, "Ward77", preconditioning = "1bal"), RWard6 = function(x) expm::expm(x, "R_Ward77", order = 6), RWard7 = function(x) expm::expm(x, "R_Ward77", order = 7), RWard8 = function(x) expm::expm(x, "R_Ward77", order = 8), # default RWard9 = function(x) expm::expm(x, "R_Ward77", order = 9), s.P.s7 = function(x) expm::expm(x, "Pade", order = 7), s.POs7 = function(x) expm::expm(x, "PadeO",order = 7), s.P.s8 = function(x) expm::expm(x, "Pade" ,order = 8), # default s.POs8 = function(x) expm::expm(x, "PadeO",order = 8), # default s.P.s9 = function(x) expm::expm(x, "Pade", order = 9), s.POs9 = function(x) expm::expm(x, "PadeO",order = 9), s.P.sRBS = function(x) expm::expm(x, "PadeRBS"), Rs.P.s7 = function(x) expm::expm(x, "R_Pade", order = 7), Rs.P.s8 = function(x) expm::expm(x, "R_Pade", order = 8), # default Rs.P.s9 = function(x) expm::expm(x, "R_Pade", order = 9), sPs.H08. = function(x) expm:: expm.Higham08(x, balancing=FALSE), sPs.H08b = function(x) expm:: expm.Higham08(x, balancing= TRUE), ## AmHi09.06= function(x) expm:::expm.AlMoHi09(x, p = 6), AmHi09.07= function(x) expm:::expm.AlMoHi09(x, p = 7), AmHi09.08= function(x) expm:::expm.AlMoHi09(x, p = 8), # default -- really sub optimal AmHi09.09= function(x) expm:::expm.AlMoHi09(x, p = 9), AmHi09.10= function(x) expm:::expm.AlMoHi09(x, p = 10), AmHi09.11= function(x) expm:::expm.AlMoHi09(x, p = 11), AmHi09.12= function(x) expm:::expm.AlMoHi09(x, p = 12), AmHi09.13= function(x) expm:::expm.AlMoHi09(x, p = 13), s.T.s7 = function(x) expm::expm(x, "Taylor", order = 7), s.TOs7 = function(x) expm::expm(x, "TaylorO",order = 7), s.T.s8 = function(x) expm::expm(x, "Taylor", order = 8), # default s.TOs8 = function(x) expm::expm(x, "TaylorO",order = 8), # default s.T.s9 = function(x) expm::expm(x, "Taylor", order = 9), s.TOs9 = function(x) expm::expm(x, "TaylorO",order = 9), Eigen = expm.safe.Eigen, # "R_Eigen" hybrid = function(x) expm::expm(x, "hybrid") ) ## set.seed(12) ## facMchk <- replicate(if(doExtras) 100 else 20, facMat(20, rnorm)) set.seed(12) fRE <- replicate(if(doExtras) 100 else 20, re.facMat(20, expmList)) # if(doExtras) gives one "No Matrix found ..." warning nDig <- -log10(t(fRE["relErr",,])) cat("Number of correct decimal digits for facMat(20, rnorm):\n") t(apply(nDig, 2, summary)) ## Now look at that: eaxis <- if(requireNamespace("sfsmisc")) sfsmisc::eaxis else axis op <- par(mar=.1 + c(5,4 + 1.5, 4,2)) boxplot(t(fRE["relErr",,]), log="x", xaxt="n", notch=TRUE, ylim = c(8e-16, 4e-9), horizontal=TRUE, las = 1, main = "relative errors for 'random' eigen-ok 20 x 20 matrix") eaxis(1); grid(lty = 3); mtext(myRversion, adj=1, cex=3/4) par(op) showProc.time() if(doExtras) withAutoprint({ # also "large" n = 100 ------------------------------------------ str(rf100 <- replicate(20, re.facMat(100, expmList))) 1000*t(apply(rf100["c.time",,], 1, summary)) ## lynne {Linux 2.6.34.7-56.fc13.x86_64 --- AMD Phenom II X4 925}: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## Ward 23 24 24.5 24.4 25.0 25 ## s.P.s 107 109 109.0 109.0 109.0 112 ## s.POs 188 190 191.0 192.0 193.0 198 ## s.P.sRBS 17 18 19.0 18.9 19.2 21 ## sPs.H08. 15 17 18.0 17.6 18.0 19 ## sPs.H08b 18 18 19.0 23.4 20.0 107 ## s.T.s 44 45 45.0 45.6 46.0 48 ## s.TOs 96 98 99.0 100.0 100.0 116 ## Eigen 18 19 20.0 24.4 21.0 109 ## hybrid 40 42 42.0 47.1 44.0 133 nDig <- -log10(t(rf100["relErr",,])) cat("Number of correct decimal digits for facMat(100, rnorm):\n") t(apply(nDig, 2, summary)) ##--> take out the real slow ones for the subsequent tests: (not.slow <- grep("^s\\.[PT]", names(expmList), invert = TRUE, value = TRUE)) set.seed(18) ## 12 replicates is too small .. but then it's too slow otherwise: rf400 <- replicate(12, re.facMat(400, expmList[not.slow])) showProc.time() 1000*t(apply(rf400["c.time",,], 1, summary)) ## lynne: ## Min. 1st Qu. Median Mean 3rd Qu. Max. ## Ward 1740 1790 1830 1820 1860 1900 ## s.P.sRBS 1350 1420 1440 1430 1450 1460 ## sPs.H08. 1020 1030 1130 1140 1210 1290 ## sPs.H08b 1120 1130 1220 1220 1300 1390 ## Eigen 962 977 989 992 1000 1030 ## hybrid 2740 2800 2840 2840 2890 2910 nDig <- -log10(t(rf400["relErr",,])) cat("Number of correct decimal digits for (12 rep. of) facMat(400, rnorm):\n") t(apply(nDig, 2, summary)) }) else { # *not* (doExtras) ----------------------------------------------------------------- ## times (in millisec): print(1000*t(apply(fRE["c.time",,], 1, summary))) } ## Now try an example with badly conditioned "random" M matrix... ## ... ## ... (not yet -- TODO?) ### m2ex3() --- The 2x2 example with bad condition , see A3 in ./ex2.R RE <- re.m2ex3(1e-8, expmList) sort(RE)# Ward + both sps.H08 are best; s.P.s fair, Eigen (and hybrid): ~1e-9 eps <- 10^-(1:18) t.m2 <- t(sapply(eps, re.m2ex3, EXPMlist = expmList)) ## --> 3 error messages from solve(V), 5 error messages from try(. "R_Eigen" ...) showProc.time() cbind(sort(apply(log(t.m2),2, median, na.rm=TRUE))) ## 'na.rm=TRUE' needed for Eigen which blows up for the last 3 eps t.m2.ranks <- sort(rowMeans(apply(t.m2, 1, rank))) cbind(signif(t.m2.ranks, 3)) ## lynne (x86_64, Linux 3.14.4-100; Intel i7-4765T), 2014-09: ## sPs.H08. 2.67 ## sPs.H08b 2.67 ## s.P.sRBS 3.06 ## Ward 4.03 ## AmHi09.13 4.33 <<- still not close to H08 ! ## AmHi09.12 5.86 ## s.T.s 8.33 ## s.TOs 8.33 ## s.P.s 9.11 ## s.POs 9.11 ## hybrid 10.80 ## AmHi09.10 11.70 << astonishingly bad ## Eigen 12.60 ## AmHi09.08 13.10 ## AmHi09.06 14.40 print(t.m2[, names(t.m2.ranks)[1:8]], digits = 3) ## ==> 1st class: H08 (both) and (but slightly better than) Ward ## 2nd class s.T.s and s.P.s ## "bad" : hybrid and Eigen ## ??? AmHi09 - methods, up to order = 10 are worse ! if(require(RColorBrewer)) { ## Bcol <- brewer.pal(ncol(t.m2),"Dark2") Bcol <- brewer.pal(min(9, ncol(t.m2)), "Set1") Bcol <- Bcol[sqrt(colSums(col2rgb(Bcol)^2)) < 340] ## FIXME: more colors ==> ~/R/MM/GRAPHICS/color-palettes.R } else { ## 7 from Dark2 ## Bcol <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A", ## "#66A61E", "#E6AB02", "#A6761D") ## Rather: those from "Set1" Bcol <- c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00", # too bright: "#FFFF33", "#A65628", "#F781BF", "#999999") } matplot(eps, t.m2, type = "b", log = "xy", col=Bcol, lty = 1:9, pch=1:15, axes=FALSE, frame = TRUE, xlab = expression(epsilon), ylab = "relative error", main = expression(expm(A, method == "*") *" relative errors for " * A == bgroup("[", atop({-1} *" "* 1, {epsilon^2} *" "*{-1}), "]"))) legend("bottomright",colnames(t.m2), col=Bcol, lty = 1:9, pch=1:15, inset = 0.02) if(requireNamespace("sfsmisc")) { sfsmisc::eaxis(1, labels=FALSE) sfsmisc::eaxis(1, at = eps[c(TRUE,FALSE)]) sfsmisc::eaxis(2) ## sfsmisc::eaxis(2, labels=FALSE) ## op <- par(las=2) ## sfsmisc::eaxis(2, at = axTicks(2,log=TRUE)[c(TRUE,FALSE,FALSE)]) ## par(op) } else { axis(1) axis(2) } ## typical case: ep <- 1e-10 (me <- m2ex3(ep)) me$expA * exp(1) ## the correct value ; numerically identical to simple matrix: ## identical() not fulfilled e.g. on Solaris stopifnot(all.equal(me$expA * exp(1), rbind(c( 1, 1), c(ep^2, 1)), tolerance = 1e-14)) ## The relative error (matrices): lapply(expmList, function(EXPM) 1 - EXPM(me$A)/me$expA) ## Average number of correct digits [less "extreme" than plot above] nDig <- sapply(expmList, function(EXPM) -log10(mean(abs(1 - EXPM(me$A)/me$expA)))) round(nDig, 2) ## Ward s.P.s s.POs s.T.s s.TOs Eigen hybrid ## 16.26 14.65 14.65 14.65 14.65 6.20 6.39 [AMD Opteron 64-bit] ## Inf 14.65 14.65 14.65 14.65 6.74 6.33 [Pentium-M (32-bit)] showProc.time() ###--- rnilMat() : random upper triangular (zero-diagonal) nilpotent n x n matrix set.seed(17) m <- rnilMat(10) (m. <- as(m,"sparseMatrix"))# for nicer printing - and more *below* E.m <- expm::expm(m, method="Pade") as(E.m, "sparseMatrix") (dN <- 9*7*320) # 20160 stopifnot(abs(round(E.m * dN) - (E.m * dN)) < 9e-6) EmN <- matrix(c(dN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3*dN, dN, 0, 0, 0, 0, 0, 0, 0, 0, 352800, 5*dN, dN, 0, 0, 0, 0, 0, 0, 0, 1018080, 332640, 5*dN, dN, 0, 0, 0, 0, 0, 0, 2235240, 786240, 292320, 3*dN, dN, 0, 0, 0, 0, 0, 9368520, 3483480, 1582560, 413280, 181440, dN, 0, 0, 0, 0, 24676176, 9598680, 5073600, 1562400, 826560, 161280, dN, 0,0,0, 43730160, 17451000, 10051440, 3430560, 1955520, 504000, 5*dN, dN, 0, 0, 68438436, 27747480, 16853760, 6036240, 3638880, 1038240, 252000, 3*dN, dN, 0, 119725855, 49165892, 31046760, 11652480, 7198800, 2264640, 614880, 191520, 3*dN, dN), 10, 10) Em.xct <- EmN / dN all.equal(E.m, Em.xct, check.attributes = FALSE, tolerance = 0) stopifnot(all.equal(E.m, Em.xct, check.attributes = FALSE, tolerance= 1e-13)) re.x <- sapply(expmList, function(EXPM) relErr(Em.xct, EXPM(m))) ## with error message from "safe.Eigen" --> Eigen is NA here ## result depends quite a bit on platform which(is.na(re.x)) # gives c(Eigen = 16L) (but not everywhere ?!?) (re.x <- re.x[!is.na(re.x)]) ## Pentium-M 32-bit ubuntu gave ## Ward s.P.s s.POs sPs.H08. sPs.H08b s.T.s s.TOs hybrid ## 1.079e-16 4.505e-14 4.503e-14 9.379e-17 9.379e-17 3.716e-17 7.079e-18 1.079e-16 ## 32-bit Quad-Core AMD Opteron 2380 (Linux 2.6.30.10-105.2.23.fc11.i686.PAE): ## Ward s.P.s s.POs sPs.H08. sPs.H08b s.T.s s.TOs hybrid ## 1.079e-16 4.505e-14 4.503e-14 9.379e-17 9.379e-17 3.716e-17 7.079e-18 1.079e-16 ## "Ward77": again more accurate than s+Pade+s, but s+Taylor+s is even more accurate ## but on 64-bit AMD Opterons ## Ward s.P.s s.POs sPs.H08. sPs.H08b s.T.s s.TOs hybrid ## 4.42e-17 3.99e-17 3.99e-17 1.10e-16 1.10e-16 8.44e-17 8.44e-17 4.42e-17 ## ## even more astonishing the result on Mac OSX (x86_32_mac; R-forge, R 2.9.0 patch.) ## Ward s.P.s s.POs sPs.H08. sPs.H08b s.T.s s.TOs hybrid ## 5.13e-17 3.99e-17 3.99e-17 1.84e-15 1.84e-15 8.44e-17 8.44e-17 5.13e-17 ## 2014-09: AmHi09 are very good (64bit: 8e-17) for p >= 8 (p=6 has 1.5e-11) not.09.06 <- which(names(re.x) != "AmHi09.06") stopifnot(re.x[c("Ward", "s.T.s8", "s.TOs8")] < 3e-16, ## re.x[["AmHi09.06"]] < 9e-11, # x64 & 686(lnx): = 1.509e-11 re.x[not.09.06] < 4e-13)# max: 686(32b): 4.52e-14, x64(lnx): 1.103e-16 ##-- Looking at *sparse* matrices: [C,Fortran "dense" code based methods will fail]: (meths <- eval(formals(expm)$method)) ems <- sapply(meths, function(met) tryCatch(expm::expm(m., method=met), error=identity)) ok <- !sapply(ems, is, class2="error") meths[ok] # now most... are showProc.time() ## Complex Matrices re.facMat.Z <- function(n, EXPMlist, rFUN = function(n) rnorm(n) + 1i*rnorm(n), ...) { stopifnot(is.list(EXPMlist)) r <- facMat(n, rFUN, ...) vapply(EXPMlist, function(EXPM) { ct <- system.time(E <- EXPM(r$A), gcFirst = FALSE)[[1]] c(relErr = relErr(r$expA, E), c.time = ct) }, double(2)) } (nmL <- names(expmList)) ## [1] "Matr" "Matr.d" "Ward" "Ward1b" "s.P.s" "s.POs" "s.P.s7" ## [8] "s.POs7" "s.P.s9" "s.POs9" "s.P.sRBS" "sPs.H08." "sPs.H08b" "AmHi09.06" ## [15] "AmHi09.07" "AmHi09.08" "AmHi09.09" "AmHi09.10" "AmHi09.12" "AmHi09.13" "s.T.s" ## [22] "s.TOs" "s.T.s7" "s.TOs7" "s.T.s9" "s.TOs9" "Eigen" "hybrid" ## dropping "Matr", "Matr.d" (which gives "dgeMatrix" currently --> mean(.) fails ... ## "Ward" "Ward1b" and "hybrid" error "not a numeric Matrix" ## "AmHi09": C code currently only for double precision ((FIXME)) (cplxN <- grep("^(Matr|Ward|hybr|AmHi09|s\\.[PT])", nmL, invert = TRUE, value = TRUE)) rr <- re.facMat.Z(4, expmList[cplxN]) set.seed(47) fREZ <- replicate(if(doExtras) 64 else 12, re.facMat.Z(15, expmList[cplxN])) nDig <- -log10(t(fREZ["relErr",,])) cat("Number of correct decimal digits for facMat(20, rnorm + i*rnorm):\n") t(apply(nDig, 2, summary)) ## times (in millisec): print(1000*t(apply(fREZ["c.time",,], 1, summary))) ## Now look at that: op <- par(mar=.1 + c(5,4 + 1.5, 4,2)) boxplot(t(fREZ["relErr",,]), log="x", xaxt="n", notch=TRUE, # ylim = c(8e-16, 4e-9), horizontal=TRUE, las = 1, main = "relative errors for 'random' eigen-ok 20 x 20 matrix") eaxis(1); grid(lty = 3); mtext(myRversion, adj=1, cex=3/4) par(op) showProc.time() expm/tests/ex2.R0000644000176200001440000001450214655414132013215 0ustar liggesusers #### Example matrices from the Matlab demos // expAtv() examples library(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE) ## -> assertError(), .., expmAll(), allEq(), doExtras ## --- 1 --- ## Here, all three {eigen; Taylor; Pade(Scaling & Squaring)} should do well A1 <- rbind(0:2, c(0.5, 0, 1), 2:0) A1 ml1 <- lapply(c(4:10,20), function(order) expm(A1, "Pade", order=order)) for(k in seq_len(length(ml1) - 1)) stopifnot(all.equal(ml1[[k]], ml1[[k + 1]], tolerance = 1e-12)) for(k in seq_len(length(ml1) - 1)) { print(all.equal(ml1[[k]], ml1[[k + 1]], tolerance = 0)) } mA1 <- ml1[[4]] stopifnot(all.equal(mA1, matrix(c(5.3090812852106, 2.8087900904073, 5.1737460019740, 4.0012030182399, 2.8845155413486, 4.0012030182399, 5.5778402926177, 3.1930144369526, 5.7131755758543), 3, 3), check.attributes = FALSE, tolerance = 1e-11)) ## --- 2 --- ## Here, Taylor "fails": ## A matrix where the terms in the Taylor series become very large ## before they go to zero. A2 <- rbind(c(-147, 72), c(-192, 93)) A2 (mA2 <- expm(A2, method="Pade")) stopifnot(all.equal(mA2, matrix(c(-0.099574136735459, -0.199148273470915, 0.074680602551593 , 0.149361205103183), 2, 2), check.attributes = FALSE, tolerance = 1e-11)) mA2.T <- expm(A2, method = "Taylor") stopifnot(all.equal(mA2, mA2.T, tolerance=1e-10)) all.equal(mA2, mA2.T, tolerance=1e-14)#-> 3.2e-12 {MM: I think that's pretty good} ## Try all methods -------------------------------------- (meths <- eval(formals(expm)$method)) # >= 13 .. L2 <- expmAll(A2) str(L2) str(allEq(L2, tol=0)) # -> max seen (Lnx 64): 2.7227e-12 stopifnot(unlist(allEq(L2))) ## --- 3 --- ## Here, Eigenvalues must fail ("not a full set"): A3 <- rbind(c(-1, 1), c(0, -1)) (mA3 <- expm(A3, method="Pade")) assertError(expm(mA3, method="R_Eigen"), verbose=TRUE) em1 <- exp(-1) stopifnot(all.equal(mA3, ## and the exact solution: matrix(c(em1, 0, em1, em1), 2, 2), check.attributes = FALSE, tolerance = 1e-14)) ## using 'eps' instead of 0 : ## ---> see m2ex3() etc in ./exact-ex.R L3 <- expmAll(A3) str(L3) # R_Eigen -- ".. computationally singular .." L3. <- L3[names(L3) != "R_Eigen"] str(allEq(L3., tol=0)) # -> max seen (Lnx 64): AlMohy-Hi09 -- ".. rel.diff.: 4.8188e-9" stopifnot(unlist(allEq(L3., tol = 2e-8))) ## --- 4 --- ## Here, some version of do_expm() failed: (m <- matrix(c(0,2:0),2)) ## Eigenvalue decomposition: d <- c(sqrt(2), -sqrt(2)) V <- rbind(c(sqrt(1/3), -sqrt(1/3)), c(sqrt(2/3), sqrt(2/3))) ## ==> IV <- rbind(c( sqrt(3/4), sqrt(3/8)), c(-sqrt(3/4), sqrt(3/8))) V.IV <- V %*% IV all.equal(V.IV, diag(2), tolerance=0) stopifnot(all.equal(V.IV, diag(2))) em.true <- V %*% (exp(d) * IV) all.equal(em.true, expm::expm(m), tolerance=0) stopifnot(all.equal(em.true, expm::expm(m)), all.equal(em.true, expm::expm(m,"Pade"), check.attributes=FALSE)) L4 <- expmAll(m) str(L4) str(allEq(L4, tol=0)) # -> max seen (Lnx 64): AlMohy-Hi09 -- rel.diff.: 3.575281e-8 stopifnot(unlist(allEq(L4, tol = 1e-7))) L4n09 <- L4[names(L4) != "AlMohy-Hi09"] str(allEq(L4n09, tol=0)) # -> max seen (Lnx 64): 2.8625e-15 stopifnot(unlist(allEq(L4n09, tol = 1e-13))) ###----------- expAtv() ---------------- ## Bug report, 8 Sep 2014 (R-forge Bugs item #5919), by: Peter Ralph stopifnot(expAtv(A3, v=c(0,0))$eAtv == 0) n <- 500 A <- bandSparse(n,n, -1:1, diagonals = list(-(2:n), -5*(1:n), 1:(n-1))) v <- 100*(n:1) t.v <- showSys.time(rr <- expAtv(A, v=v)) if(doExtras) { ## this is an order of magnitude slower : t.A <- system.time(w. <- (eA <- expm(A, "Higham08")) %*% v) stopifnot(all.equal(rr$eAtv, as.numeric(w.))) print( mean((t.A / t.v)[c(1,3)]) )## 23.57 {nb-mm3}; 21.0 {lynne} } ## Bug report on R-forge by Peter Ralph (petrelharp) ## If the entries of A are less than about 1e-8, then expAtv(A,v) fails ## with Error: length(d <- dim(x)) == 2 is not TRUE ## ... an error that comes from expm, because it has got a 1x1 matrix. (I can't tell why this causes an error; outside of expAtv this doesn't cause an error...) ## To reproduce: ##' @title Compute several "scaled" versions of e^{At} v : ##' @param A n x n matrix ##' @param v n vector ##' @param s vector of scales ##' @return list of expAtv() results ##' @author Martin Maechler, based on Peter Ralph's idea: scl.e.Atv <- function(A, v, s) { c(list(I = expAtv(A, v)), unlist(lapply(s, function(l) { ## cat(sprintf(" %7g\n", l)) list(lA = expAtv(l*A, v), lAI = expAtv(l*A, v, t=1/l)) }), recursive = FALSE)) } A <- matrix( 1:9, nrow=3 )/8 v <- rep(1,3) sc <- 4^c(-500, -200, -100, -5*(15:6), -2*(14:9), -17:15) ## 10^9 is too large => expm() "overflow" NaN r <- scl.e.Atv(A,v, s = sc) # at least without error (eAv <- t(sapply(r, `[[`, "eAtv"))) ## Ensure that indeed expAtv(A, v) =.= expAtv(e*A, v, 1/e) for e > 0 ## ----- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ eAv[1,] assert.EQ.mat(unname( eAv[rep(1, length(sc)), ]), unname( eAv[1+2*seq_along(sc), ] ), tol = 1e-14) # 64-bit lynne: 2.7e-16 !! sc.Atv <- function(A,v, s) { vapply(s, function(l) expAtv(l*A, v, t=1/l)$eAtv, v) } chk.sc.Atv <- function(A,v, s, tol=1e-15) { r <- vapply(s, function(l) expAtv(l*A, v, t=1/l)$eAtv, v) I <- expAtv(A,v)$eAtv if (!isTRUE(eq <- all.equal(as.vector(r), rep(I, length(s)), tolerance = tol))) stop("not all.equal() |-> ", eq) } chk.sc.Atv(A,v, sc, tol=1e-14) ## for information: see the precision: tryCatch( chk.sc.Atv(A,v, sc, tol= 0), error=identity)$message A0 <- matrix( c(-3,1,2,1,-2,1,0,1,-1), nrow=3, byrow=TRUE) A1 <- A0 + 1e-16*rnorm(9) ## These two also failed originally chk.sc.Atv(A0, v=10^(1:3), s=sc, tol=1e-14) chk.sc.Atv(A1, v=rep(1,3), s=sc, tol=1e-14) set.seed(17) S <- rSpMatrix(29, density = 1/64) v <- round(100*rnorm(nrow(S))) if(FALSE) ## Error in balance(baP$z, "S") : ## BLAS/LAPACK routine 'DGEBAL' gave error code -3 chk.sc.Atv(S/64, v, s=sc, tol=1e-14) if(FALSE) { ## after debug(chk.sc.Atv) ## this is revealing: image(as(relErrV(I, r),"sparseMatrix")) ## ==> sc[28:29] # are giving the largest differences } expm/tests/expm-Cond.R0000644000176200001440000000216112311702321014332 0ustar liggesusers#### Testing the Exponential Condition Number computations library(expm) mSource <- function(file, ...) source(system.file(file, ..., package = "expm", mustWork=TRUE), keep.source = FALSE) mSource("test-tools.R")## -> assertError(), rMat() ## getting examples where we know expm(.) "exactly": mSource("demo", "exact-fn.R") M <- xct10$m eC <- list(expmCondF = 566.582631819923, expmCond1 = 137.455837652872) C1 <- expmCond(M, "exact") (C2 <- expmCond(M, "1.est", expm=FALSE)) (C3. <- expmCond(M, "F.est", abstol = 0.1)[[1]]) (C3.1 <- expmCond(M, "F.est", abstol = 0.01, reltol = 1e-12)[[1]]) stopifnot(all.equal(C1[1:2], eC, tolerance = 1e-14), all.equal(C2 , eC$expmCond1, tolerance = 1e-14), all.equal(C3. , eC$expmCondF, tolerance = 1e-14, check.attributes = FALSE), all.equal(C3.1, eC$expmCondF, tolerance = 1e-14, check.attributes = FALSE)) cat('Time elapsed: ', (p1 <- proc.time()),'\n') # for ``statistical reasons'' ## cat('Time elapsed: ',(p2 <- proc.time())-p1,'\n') # for ``statistical reasons'' ## cat('Time elapsed: ',(p3 <- proc.time())-p2,'\n') # for ``statistical reasons'' expm/tests/Frechet-test.R0000644000176200001440000000123712021132600015033 0ustar liggesuserslibrary(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE)# relErr() set.seed(101) for(n in c(1:5, 10:11, if(doExtras) 100:101 else 25)) { cat("n = ",n,"\n-----\n") for(i in seq_len(if(doExtras)10 else 3)) { A <- matrix(round(10*rnorm(n^2))/4, n,n) E <- matrix(rnorm(n^2, sd = 1e-3), n,n) F1 <- expmFrechet(A, E) F2 <- expmFrechet(A, E, "block") if(i == 1 && n < 9) print(F1) stopifnot(all.equal(F1, F2, tol = 6e-15 * n)) cat(sprintf("%5.2f ", relErr(F1 $ L, F2 $ L) * 2^52)) } cat(" * eps_C \n") } cat('Time elapsed: ', proc.time(), '\n') # for "statistical reasons" expm/MD50000644000176200001440000000703014660661247011547 0ustar liggesusersdac8da548f6a3e7c23480032d4bcc428 *ChangeLog c25caa57298725f19cd3e082cdd4e730 *DESCRIPTION 3ee14efd17d2cd9b7fd543f899e3f908 *NAMESPACE b93f40d38f2fcb0567e4f14c62fceadc *R/balance.R 8b4cf76df53fea0587203508b91b3145 *R/expm.R 6e74ecbbbd487489d4c758aa510209a9 *R/expm2.R f15efdadae53fd8445cd9064188e7ac9 *R/expmCond-all.R dbc522a7c2b2a50ce050493daba661e0 *R/expm_vec.R 23da2e8766976b676dd5913eecd86d94 *R/logm.Higham08.R 38bab978acbf5b04597dfbd580a9e9f5 *R/logm.R 45e07bacddb49c9238b3e9d1767992f7 *R/matpow.R bc755b8cc2fb5ecfd62786985776d3e2 *R/sqrtm.R 62dbcce738cc4dafde0cbb7a5b92aabc *TODO e23903adc990d9515ba1ebd23e3bff59 *build/partial.rdb dc07bc03f64c9679666c699f0196b36f *build/vignette.rds d31374f27f2d6e5c5b459e0b1541cbbd *data/matStig.R b544e04306e3002383308b520878ea59 *demo/00Index 3cbd9cf2cbe6026c3d98fff57be94557 *demo/balanceTst.R dc4b47df779d6f697f97de0d2733c7fe *demo/exact-fn.R a7888660aaa93bdd9d3acf95a8ef2301 *demo/expm.R 07ac2c2c3add1d02cb9ecfbdfb2ac077 *inst/doc/expm.R 61655a9c17ec4f2e874bc1ee2af64e96 *inst/doc/expm.Rnw c5fcbb1c50d386df1eb2f9fd8ae36f11 *inst/doc/expm.pdf 959a1dbb1f1633688fa783b489503e7a *inst/po/de/LC_MESSAGES/R-expm.mo e1c6033c302666b96039a0c50fb0d5ee *inst/po/en@quot/LC_MESSAGES/R-expm.mo 686ec00b0ae0f137c6f6edc3825e450c *inst/po/en@quot/LC_MESSAGES/expm.mo 790f34095af968c11197315394be494b *inst/po/expm-de/LC_MESSAGES/expm.mo 26ad8d9fef04a4dd36adb264608be90f *inst/po/fr/LC_MESSAGES/expm.mo 274e76f34f3671b5db44d6a1dbc701a9 *inst/po/fr/LC_MESSAGES/fr.mo b033b604114fe0cd35de1b2e91081e11 *inst/test-tools.R 0f74bc4325b77b6677b76394a633ede5 *man/balance.Rd 7fff49facea2b47092e143d7cad3dd8c *man/expAtv.Rd 6f286cf10cc948610236e0a1675916a9 *man/expm.Higham08.Rd bfe7a22d2f4d32b43a771a52381bc142 *man/expm.Rd 72507358477c557080b129848dc9ecbc *man/expmCond.Rd 697d7311ef6c64384bedb7a9c345b41c *man/expmFrechet.Rd 4bebe0d3ed49104170f40b5afd854d34 *man/logm.Rd 0835f0173e75dabe7a9b97ee7a540fd5 *man/matStig.Rd 6ee3836206b4a414be64b72a941a6de7 *man/matpow.Rd 915ff3260a6359ff21eef5bc62c204da *man/sqrtm.Rd 2ce01bdc9fddbf5b7ca24ba416a6bdf2 *po/R-de.po 5a555b4c659a06af5c98056a920f12ef *po/R-expm.pot 4357e47bcc2633eb3727064d748bf9f1 *po/expm-de.po 360dd0e7e29e17c70b81b9c4e16e5127 *po/expm.pot 2356bfbc6cfb784c2eeb782d5d05f73f *po/fr.po 75718ca5d84af7708ee94918f85ac436 *src/Makevars d962e154a1fa708ec850fb4c0726843c *src/R_NLS_locale.h 22690db56df01681e608cb2502464552 *src/R_dgebal.c b92918abbf05ce66d66e24c25f69fb36 *src/expm-eigen.c 0c200dfcb2b08aa9e69351514ddc11d1 *src/expm-eigen.h 1ece2d30704eaa6982baded2790e0b86 *src/expm.c 8fac9e41f9b6cdc6588ff23d492bd0f2 *src/expm.h 973513fb9559c995c9caa0dcb2d6a0f6 *src/init.c f60a25fbd2af66b94d8da84c5e1a023e *src/logm-eigen.c 1f6cfa33732ff53d58d2ff33e72fb142 *src/logm-eigen.h 8685b3faef183159c5044570e81b31b1 *src/matexp.f f2c717c9cf668e2558088bf874de1b09 *src/matexp_MH09.c 1ec90cfc41a895f78d29019c3c439dba *src/matpow.c ed9e7327b82a66d8d662f8cb99596537 *src/matpow.h b85b0dbcc9fed3def6ff8231525935e3 *src/matrexp.f d4cda3837efeafa9bdf66bf5b51a4c1f *src/matrexpO.f 1a8c861e1c2c64ab0af2c7742aac4acc *src/mexp-common.f a22fd1e243d0d2e96802f551a4ff7f28 *tests/Frechet-test.R 2619011a14d93ce691a9030eec8fbc06 *tests/bal-ex.R 29dbb3e7aa20152fd5b2b859a8b3403d *tests/ex.R 2fe7c165524314ef9665c4f91c5f595d *tests/ex2.R 2844cc304bc759e1d7ebf7565f839dd0 *tests/exact-ex.R a43d9bcf58d286dd0745b058b5b003ca *tests/expm-Cond.R ed2a4e750c0f271b198982795a272892 *tests/log+sqrt.R b98abafa11d5dc9cc6e261cc8716479c *tests/matpow-ex.R 61655a9c17ec4f2e874bc1ee2af64e96 *vignettes/expm.Rnw e1d639c199dadb136a99c08a9aed0dd7 *vignettes/expm.bib expm/po/0000755000176200001440000000000014660607514011652 5ustar liggesusersexpm/po/R-expm.pot0000644000176200001440000000324014107534174013542 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: expm 0.999-6\n" "POT-Creation-Date: 2021-08-19 21:54\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" msgid "argument is not a matrix" msgstr "" msgid "matrix not square" msgstr "" msgid "coercing to dense matrix, as required by method %s" msgstr "" msgid "invalid 'preconditioning'" msgstr "" msgid "Unable to determine matrix exponential" msgstr "" msgid "'%s' must be a square matrix" msgstr "" msgid "Pade approximation order 'p' must be between 1 and 13." msgstr "" msgid "'A' must be a square matrix of dimension at least 2" msgstr "" msgid "invalid 'method'" msgstr "" msgid "'lucky guess' was better and is used for expmCond" msgstr "" msgid "reached maxiter = %d iterations; tolerances too small?" msgstr "" msgid "A and E need to have the same dimension" msgstr "" msgid "'A' is not a matrix" msgstr "" msgid "nrow(A) must be >= 1" msgstr "" msgid "NaN phi values; probably overflow in expm()" msgstr "" msgid "The requested tolerance (tol=%g) is too small for mxrej=%d." msgstr "" msgid "'x' has negative real eigenvalues; maybe ok for %s" msgstr "" msgid "The matrix logarithm may not exist for this matrix." msgstr "" msgid "Inverse scaling did not work (t = %g)." msgstr "" msgid "Setting m = 3 arbitrarily." msgstr "" msgid "logm.Higham08() -> (k, m) = (%d, %d)" msgstr "" msgid "NA/NaN from || Tr - I || after %d step.\n%s" msgid_plural "NA/NaN from || Tr - I || after %d steps.\n%s" msgstr[0] "" msgstr[1] "" expm/po/expm-de.po0000644000176200001440000000471714107534174013557 0ustar liggesusers# Translation of expm.pot to German # Copyright (C) 2021 Martin Maechler # This file is distributed under the same license as the expm package. # Martin Maechler , 2021. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: expm 0.999-6\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2021-08-19 20:28+0200\n" "PO-Revision-Date: 2021-08-19 21:14+0200\n" "Last-Translator: FULL NAME \n" "Language-Team: German \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=utf-8\n" "Content-Transfer-Encoding: 8bit\n" #: R_dgebal.c:11 #, c-format, fuzzy msgid "argument type='%s' must be a character string of string length 1" msgstr "Das Argument type=\"%s\" muss eine Buchstabenfolge der Länge 1 sein" #: R_dgebal.c:16 #, c-format msgid "argument type='%s' must be one of 'N', 'P', 'S', or 'B'" msgstr "Das Argument type='%s' muss eines von 'N', 'P', 'S', oder 'B' sein" #: R_dgebal.c:28 msgid "invalid 'x': not a numeric (classical R) matrix" msgstr "" #: R_dgebal.c:32 expm-eigen.c:209 expm.c:307 logm-eigen.c:213 matpow.c:23 msgid "non-square matrix" msgstr "keine quadratische Matrix" #: R_dgebal.c:46 msgid "R_dgebal(*, type=\"S\"): Infinite matrix entry" msgstr "" #: R_dgebal.c:69 #, c-format msgid "LAPACK's dgebal(%s) returned info code %d" msgstr "" #: expm-eigen.c:60 expm-eigen.c:68 logm-eigen.c:64 logm-eigen.c:72 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:118 logm-eigen.c:122 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:200 expm.c:289 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:101 #, c-format msgid "LAPACK routine dgebal returned info code %d when permuting" msgstr "" #: expm.c:106 #, c-format msgid "LAPACK routine dgebal returned info code %d when scaling" msgstr "" #: expm.c:112 #, c-format msgid "LAPACK' dgebal(\"B\",.) returned info code %d" msgstr "" #: expm.c:116 #, c-format msgid "invalid 'precond_kind: %d" msgstr "" #: expm.c:165 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "" #: expm.c:168 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "" #: expm.c:302 #, c-format msgid "invalid 'kind' argument: %s\n" msgstr "" #: logm-eigen.c:207 msgid "invalid argument" msgstr "" #: matpow.c:14 msgid "not a matrix" msgstr "" #: matpow.c:54 msgid "" "power must be a positive integer; use solve() directly for negative powers" msgstr "" expm/po/fr.po0000644000176200001440000000565614107534174012632 0ustar liggesusers# French translations for expm package # Traduction franaise du package expm. # Copyright (C) 2007 Vincent Goulet # This file is distributed under the same license as the expm package. # Vincent Goulet , 2007. # msgid "" msgstr "" "Project-Id-Version: expm 0.999-0\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2021-08-19 20:28+0200\n" "PO-Revision-Date: 2007-11-20 13:56-0500\n" "Last-Translator: Vincent Goulet \n" "Language-Team: Vincent Goulet \n" "Language: fr\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=ISO-8859-1\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" #: R_dgebal.c:11 #, c-format msgid "argument type='%s' must be a character string of string length 1" msgstr "" #: R_dgebal.c:16 #, c-format msgid "argument type='%s' must be one of 'N', 'P', 'S', or 'B'" msgstr "" #: R_dgebal.c:28 msgid "invalid 'x': not a numeric (classical R) matrix" msgstr "" #: R_dgebal.c:32 expm-eigen.c:209 expm.c:307 logm-eigen.c:213 matpow.c:23 msgid "non-square matrix" msgstr "matrice non carre" #: R_dgebal.c:46 msgid "R_dgebal(*, type=\"S\"): Infinite matrix entry" msgstr "" #: R_dgebal.c:69 #, fuzzy, c-format msgid "LAPACK's dgebal(%s) returned info code %d" msgstr "la procdure LAPACK dgetrs a produit le code d'erreur %d" #: expm-eigen.c:60 expm-eigen.c:68 logm-eigen.c:64 logm-eigen.c:72 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:118 logm-eigen.c:122 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:200 expm.c:289 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:101 #, c-format msgid "LAPACK routine dgebal returned info code %d when permuting" msgstr "" "la procdure LAPACK dgebal a produit le code d'erreur %d lors de la " "permutation" #: expm.c:106 #, c-format msgid "LAPACK routine dgebal returned info code %d when scaling" msgstr "" "la procdure LAPACK dgebal a produit le code d'erreur %d lors de la mis " "l'chelle" #: expm.c:112 #, fuzzy, c-format msgid "LAPACK' dgebal(\"B\",.) returned info code %d" msgstr "la procdure LAPACK dgetrf a produit le code d'erreur %d" #: expm.c:116 #, c-format msgid "invalid 'precond_kind: %d" msgstr "" #: expm.c:165 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "la procdure LAPACK dgetrf a produit le code d'erreur %d" #: expm.c:168 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "la procdure LAPACK dgetrs a produit le code d'erreur %d" #: expm.c:302 #, fuzzy, c-format msgid "invalid 'kind' argument: %s\n" msgstr "argument incorrect" #: logm-eigen.c:207 msgid "invalid argument" msgstr "argument incorrect" #: matpow.c:14 #, fuzzy msgid "not a matrix" msgstr "matrice non carre" #: matpow.c:54 msgid "" "power must be a positive integer; use solve() directly for negative powers" msgstr "" expm/po/expm.pot0000644000176200001440000000445214107534174013351 0ustar liggesusers# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the expm package. # FIRST AUTHOR , YEAR. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: expm 0.999-6\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2021-08-19 21:49+0200\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" "Language: \n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" #: R_dgebal.c:11 #, c-format msgid "argument type='%s' must be a character string of string length 1" msgstr "" #: R_dgebal.c:16 #, c-format msgid "argument type='%s' must be one of 'N', 'P', 'S', or 'B'" msgstr "" #: R_dgebal.c:28 msgid "invalid 'x': not a numeric (classical R) matrix" msgstr "" #: R_dgebal.c:32 expm-eigen.c:209 expm.c:307 logm-eigen.c:213 matpow.c:23 msgid "non-square matrix" msgstr "" #: R_dgebal.c:46 msgid "R_dgebal(*, type=\"S\"): Infinite matrix entry" msgstr "" #: R_dgebal.c:69 #, c-format msgid "LAPACK's dgebal(%s) returned info code %d" msgstr "" #: expm-eigen.c:60 expm-eigen.c:68 logm-eigen.c:64 logm-eigen.c:72 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:118 logm-eigen.c:122 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:200 expm.c:289 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:101 #, c-format msgid "LAPACK routine dgebal returned info code %d when permuting" msgstr "" #: expm.c:106 #, c-format msgid "LAPACK routine dgebal returned info code %d when scaling" msgstr "" #: expm.c:112 #, c-format msgid "LAPACK' dgebal(\"B\",.) returned info code %d" msgstr "" #: expm.c:116 #, c-format msgid "invalid 'precond_kind: %d" msgstr "" #: expm.c:165 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "" #: expm.c:168 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "" #: expm.c:302 #, c-format msgid "invalid 'kind' argument: %s\n" msgstr "" #: logm-eigen.c:207 msgid "invalid argument" msgstr "" #: matpow.c:14 msgid "not a matrix" msgstr "" #: matpow.c:54 msgid "" "power must be a positive integer; use solve() directly for negative powers" msgstr "" expm/po/R-de.po0000644000176200001440000000461014107534174012777 0ustar liggesusers# Copyright (C) 2021 Martin Maechler # This file is distributed under the same license as the expm package. # Martin Maechler , 2021. msgid "" msgstr "" "Project-Id-Version: expm 0.999-6\n" "POT-Creation-Date: 2021-08-19 21:54\n" "PO-Revision-Date: 2021-08-19 21:57+0200\n" "Last-Translator: Martin Maechler \n" "Language-Team: German \n" "Language: de\n" "MIME-Version: 1.0\n" "Content-Type: text/plain; charset=utf-8\n" "Content-Transfer-Encoding: 8bit\n" msgid "argument is not a matrix" msgstr "Argument ist keine Matrix" msgid "matrix not square" msgstr "Matrix ist nicht quadratisch" msgid "coercing to dense matrix, as required by method %s" msgstr "Umwandlung in dichte (\"dense\") Matrix, wie von der Methode %s verlangt" msgid "invalid 'preconditioning'" msgstr "ungültiges 'preconditioning'" msgid "Unable to determine matrix exponential" msgstr "Das Matrix Exponential kann nicht bestimmt werden" msgid "'%s' must be a square matrix" msgstr "'%s' muss eine quadratische Matrix sein" msgid "Pade approximation order 'p' must be between 1 and 13." msgstr "Padé Approximation der Ordnung 'p' muss zwischen 1 und 13 sein." msgid "'A' must be a square matrix of dimension at least 2" msgstr "'A' muss eine quadratische Matrix der Dimension mindestens 2 sein" msgid "invalid 'method'" msgstr "ungültige 'method'" msgid "'lucky guess' was better and is used for expmCond" msgstr "" msgid "reached maxiter = %d iterations; tolerances too small?" msgstr "" "haben maxiter = %d Iterationen erreicht; sind die Toleranzen zu klein?" msgid "A and E need to have the same dimension" msgstr "A und E müssen die gleiche Dimension haben" msgid "'A' is not a matrix" msgstr "" msgid "nrow(A) must be >= 1" msgstr "" msgid "NaN phi values; probably overflow in expm()" msgstr "" msgid "The requested tolerance (tol=%g) is too small for mxrej=%d." msgstr "Die verlangte Toleranz (tol=%g) ist zu klein für mxrej=%d." msgid "'x' has negative real eigenvalues; maybe ok for %s" msgstr "" msgid "The matrix logarithm may not exist for this matrix." msgstr "" msgid "Inverse scaling did not work (t = %g)." msgstr "" msgid "Setting m = 3 arbitrarily." msgstr "" msgid "logm.Higham08() -> (k, m) = (%d, %d)" msgstr "" msgid "" "NA/NaN from || Tr - I || after %d step.\n" "%s" msgid_plural "" "NA/NaN from || Tr - I || after %d steps.\n" "%s" msgstr[0] "" msgstr[1] "" expm/R/0000755000176200001440000000000014660607514011435 5ustar liggesusersexpm/R/logm.R0000644000176200001440000000133614107534174012516 0ustar liggesusers### ===== File part of R package expm ===== ### ### Function to compute the matrix logarithm ### logm <- function(x, method = c("Higham08", "Eigen"), ## order = 8, trySym = TRUE, tol = .Machine$double.eps) { ## work with "Matrix" too: A<-as.matrix(A) d <- dim(x) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "x"), domain=NA) method <- match.arg(method) switch(method, "Higham08" = logm.Higham08(x) , "Eigen" = { ## AUTHOR: Christophe Dutang ## matrix exponential using eigenvalues / spectral decomposition and ## Ward(1977) algorithm if x is numerically non diagonalisable .Call(do_logm_eigen, x, tol) }) } expm/R/expmCond-all.R0000644000176200001440000003323014107534174014101 0ustar liggesusers#### -------------------*- mode: R; kept-new-versions: 25; kept-old-versions: 20 -*- #### Exponential Condition Number #### --------------------- #### Compute the Exponential Condition Number #### ("1" and Frobenius-Norm) "exactly" and approximately. #### #### All algorithms are based on the Fréchet derivative, #### i.e., the expmCond() functions call expmFrechet() #### for the calculation of the Fréchet derivative. expmCond <- function(A, method = c("1.est", "F.est", "exact"), expm = TRUE, abstol = 0.1, reltol = 1e-6, give.exact = c("both", "1.norm", "F.norm")) { ## Input: A; nxn Matrix ## Output: list $ expmCondF: Exponentialconditionnumber Frobeniusnorm; scalar ## $ expmCond1: Exponentialconditionnumber 1-Norm; scalar ## $ expm: e^A Matrixexponential; nxn Matrix d <- dim(A) if(length(d) != 2 || d[1] != d[2] || d[1] <= 1) stop("'A' must be a square matrix of dimension at least 2") method <- match.arg(method) give.exact <- match.arg(give.exact) switch(method, "1.est" = .expmCond.1(A, expm = expm), "F.est" = .expmCond.F (A, expm = expm, abstol=abstol, reltol=reltol), "exact" = .expmCond.X(A, expm = expm, give = give.exact), stop("invalid 'method'")) } ### The former 4 files from Michi Stadelmann --- all in one file ## byte date name ## ---- ------------ --------------- ## 2006 Jan 30 12:12 expcond.r ## 2086 Jan 30 10:45 expcondest1.r ## 1782 Jan 30 10:45 expcondestfrob.r ## 4544 Jan 30 12:22 expm2frech.r ###------------------ expcond.r ------------------------------------------- ## Function for *eXact* (slow!) calculation of the Exponentialconditionnumber ## ("1" and Frobenius-Norm). ## R-Implementation of Higham's Algorithm from the book ## "Functions of Matrices - Theory and Computation", chapter 3.4, algorithm 3.17 ## Step 1: Calculate Kroneckermatrix of L(A) ## Step 2: Calculate Expentialconditionnumber ("1" & Frobenius-Norm) .expmCond.X <- function(A, give= c("both", "1.norm", "F.norm"), expm = TRUE) { ## Input: A; nxn Matrix ## Output: list $ expmCondF: Exponentialconditionnumber Frobeniusnorm; scalar ## $ expmCond1: Exponentialconditionnumber 1-Norm; scalar ## $ expm: e^A Matrixexponential; nxn Matrix d <- dim(A) if(length(d) != 2 || d[1] != d[2] || d[1] <= 1) stop("'A' must be a square matrix of dimension at least 2") n <- d[1] ##---------STEP 1: Calculate Kroneckermatrix of L(A)------------------------ K <- matrix(0, n^2, n^2) E0 <- matrix(0, n,n) E.unit <- function(i,j) { ## Compute E_ij in R^{n x n} , the ij-th unit Matrix E <- E0 E[i,j] <- 1 E } give <- match.arg(give) jj <- 0 for (j in 1:n) { for (i in 1:n) { calc <- expmFrechet(A, E.unit(i,j), expm=(j == n) && (i == n)) K[, (jj <- jj + 1)] <- calc$Lexpm } } ##-------STEP 2 CALCULATE EXPONENTIALCONDITIONNUMBER ------------------------ ## Frobenius-Norm do.F <- (give %in% c("F.norm", "both")) do.1 <- (give %in% c("1.norm", "both")) if(do.F) normk <- sqrt(max(eigen(crossprod(K))$values)) # crossprod(K) := K' K list(expmCondF = ## Frobenius Norm if(do.F) normk * norm(A,"F") / norm(calc$expm,"F"), expmCond1 = ## 1-Norm if(do.1) norm(K,"1")* norm(A,"1") / (norm(calc$expm,"1")*n), expm = if(expm) calc$expm) } ###------------------ expcondest1.r --------------------------------------- ## Function for Estimation of the "1"-norm exponentialcondtionnumber based on ## the LAPACK marix norm estimator. ## R-Implementation of Higham's Algorithm from the book ## "Functions of Matrices - Theory and Computation", chapter 3.4, algorithm 3.21 ## Step 1: Estimate "1"-Norm of Kroneckermatrix K(A) ## This step is based on the equation: K(A)vec(E)=vec(L(A,E)) ## Step 2: Calculate Expentialconditionnumber ("1"-Norm) .expmCond.1 <- function(A, expm = TRUE) { ## Input: A; nxn Matrix ## Output: list $ expmCond: Exponentialconditionnumber "1"-Norm; scalar ## $ expm: e^A Matrixexponential; nxn Matrix ##-------STEP 1 ESTIMATE "1"-NORM FROM THE KRONECKERMATRIX-------------- ## Check if A is square d <- dim(A) if(length(d) != 2 || d[1] != d[2] || d[1] <= 1) stop("'A' must be a square matrix of dimension at least 2") n <- d[1] tA <- t(A) E <- matrix(1/n^2, n,n) calc <- expmFrechet(A,E) V <- calc$Lexpm G <- sum(abs(V)) Z <- sign(V) X <- expmFrechet(tA,Z, expm=FALSE)$Lexpm k <- 2 E0 <- matrix(0, n,n) repeat { ## at most steps k = 2, 3, 4, 5 j <- which.max(as.vector(abs(X))) Ej <- E0; Ej[j] <- 1 V <- expmFrechet(A,Ej, expm=FALSE)$Lexpm G <- sum(abs(V)) sV <- sign(V) if (identical(sV, Z) || identical(sV,-Z)) break Z <- sV X <- expmFrechet(tA,Z, expm=FALSE)$Lexpm k <- k+1 if (k > 5 || max(abs(X)) == X[j]) break } ## 'G' = gamma now is our desired lower bound ## Now, try another "lucky guess" and increase G if the guess *was* lucky : for (l in 1:(n^2)) { ## FIXME: vectorize this! X[l] <- (-1)^(l+1) * (1+(l-1)/(n^2-1)) } X <- expmFrechet(A,X, expm=FALSE)$Lexpm G. <- 2*sum(abs(X))/(3*n^2) if (G < G.) { message("'lucky guess' was better and is used for expmCond") G <- G. } ##-------STEP 2 CALCULATE EXPONENTIALCONDITIONNUMBER------------------ C1 <- G * norm(A,"1") / (norm(calc$expm,"1")*n) if(expm) list(condExpm = C1, expm = calc$expm) else C1 } ###------------------ expcondestfrob.r ------------------------------------ ## Function for estimation of the frobenius-Norm exponentialcondtionnumber based ## on the powermethod-matrixnorm estimation. ## R-Implementation of Higham's Algorithm from the book ## "Functions of Matrices - Theory and Computation", chapter 3.4, algorithm 3.19 ## Step 1: Estimate "2"-Norm of Kroneckermatrix K(A) ## This step is based on the equation: K(A)vec(E)=vec(L(A,E)) ## Step 2: Calculate Expentialconditionnumber (Frobenius-Norm) .expmCond.F <- function(A, abstol = 0.1, reltol = 1e-6, maxiter = 100, expm = TRUE) { ## Input: A; nxn Matrix ## Output: list C: C$expmCond: Exponentialconditionnumber Frobeniusnorm; scalar ## C$expm: e^A Matrixexponential; nxn Matrix ## Check if A is square d <- dim(A) if(length(d) != 2 || d[1] != d[2] || d[1] <= 1) stop("'A' must be a square matrix of dimension at least 2") n <- d[1] ##-------STEP 1 ESTIMATE 2-NORM OF KRONECKERMATRIX------------------------------- Z1 <- if(is(A,"Matrix")) Matrix(rnorm(n*n),n,n) else matrix(rnorm(n*n),n,n) tA <- t(A) calc <- expmFrechet(A,Z1) W1 <- calc$Lexpm Z1 <- expmFrechet(tA,W1, expm=FALSE)$Lexpm G2 <- norm(Z1,"F")/norm(W1,"F") it <- 0 repeat { G1 <- G2 W2 <- expmFrechet(A, Z1, expm=FALSE)$Lexpm Z2 <- expmFrechet(tA,W2, expm=FALSE)$Lexpm G2 <- norm(Z2,"F")/norm(W2,"F") Z1 <- Z2 dG <- abs(G1-G2) it <- it+1 if (it > maxiter || dG < abstol && dG < reltol*G2) break } if(it > maxiter) warning(gettextf("reached maxiter = %d iterations; tolerances too small?", maxiter), domain=NA) ##-------STEP 2 CALCULATE EXPONENTIALCONDITIONNUMBER-------------------- cF <- G2*norm(A,"F") / norm(calc$expm,"F") attr(cF, "iter") <- it if(expm) list(condExpm = cF, expm = calc$expm) else cF } ###------------------ expm2frech.r ---------------------------------------------- ## Calculation of e^A and the Exponential Frechet-Derivation L(A,E) ## with the Scaling & Squaring Method ## R-Implementation of Higham's Algorithm from the Article ## "Computing Fréchet Derivative of the Matrix Exponential, with an application ## to Condition Number Estimation", MIMS EPrint 2008.26, Algorithm 6.4 ## Step 1: Scaling (of A and E) ## Step 2: Padé-Approximation of e^A and L(A,E) ## Step 3: Squaring expmFrechet <- function(A,E, method = c("SPS","blockEnlarge"), expm = TRUE) { ## Input: A; nxn Matrix ## E; nxn Matrix ## Output: list X: X$expm; e^A Matrixeponential; nxn Matrix ## X$Lexpm; Exponential-Frechet-Derivative L(A,E); nxn Matrix ## Check if A is square d <- dim(A) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "A"), domain=NA) stopifnot(is.matrix(E)) if(!identical(d,dim(E))) stop("A and E need to have the same dimension") n <- d[1] if (n <= 1) { X <- exp(A) X2<- E*X return(if(expm) list(expm= X, Lexpm = X2) else list(Lexpm = X2)) } ## else n >= 2 ... non-trivial case : ------------- method <- match.arg(method) switch(method, "SPS" = .expmFrechet2008.26(A,E, expm = expm) , "blockEnlarge" = { ## From: Daniel Kressner @ math ETH Zurich ## To: Stadelmann Michael, Cc: Martin Maechler ## Subject: Frechet-Ableitung von f testen ## Date: Mon, 26 Jan 2009 ## mir ist noch ein weiterer Weg zum Test Deines ## Algorithmus fuer die Frechet-Ableitung eingefallen. ## Berechnet man f ([A E, 0 A]) ## dann enthaelt der (1,2)-Block die Ableitung von f an ## der Stelle A in Richtung E (siehe Higham). OO <- array(0, dim=d) B <- rbind(cbind(A, E), cbind(OO, A)) ## stopifnot(dim(B) == 2*d) fB <- expm.Higham08(B)[1:n, ] L <- fB[ , n+ 1:n] if(expm) list(expm = fB[ , 1:n], Lexpm = L) else list(Lexpm = L) }) } ## expmFrechet .expmFrechet2008.26 <- function(A, E, expm = TRUE) { ## No error checking! --> not to be called by the user! ## R-Implementation of Higham's Algorithm from the Article ## "Computing Fréchet Derivative of the Matrix Exponential, with an application ## to Condition Number Estimation", MIMS EPrint 2008.26, Algorithm 6.4 ## Step 1: Scaling (of A and E) ## Step 2: Padé-Approximation of e^A and L(A,E) ## Step 3: Squaring ##-----------STEP 1 & STEP 2: SCALING & PADÉ APPROXIMATION------------------- ## Informations about the given matrix nA <- norm(A ,"1") ## == Matrix::norm n <- nrow(A)# == ncol(A) .. tested "in the caller" ## try to remain in the same matrix class system: I <- if(is(A,"Matrix")) Diagonal(n) else diag(n) ## If the norm is small enough, use directly the Padé-Approximation (PA) if (nA <= 1.78) { t <- c(0.0108,0.2,0.783,1.78) ## the minimal m for the PA : l <- which.max(nA <= t) ## Calculate PA for e^A and L(A,E) C <- rbind(c(120,60,12,1,0,0,0,0,0,0), c(30240,15120,3360,420,30,1,0,0,0,0), c(17297280,8648640,1995840,277200,25200,1512,56,1,0,0), c(17643225600,8821612800,2075673600,302702400,30270240, 2162160,110880,3960,90,1)) [l , ] # only need l-th row P <- I U <- C[2]*I V <- C[1]*I A2 <- A %*% A M2 <- A %*% E + E %*% A M <- M2 LU <- C[4]*M LV <- C[3]*M oC <- 2 for (k in seq_len(l-1)) { ## oC == 2k ## PA e^A P <- P %*% A2 U <- U+C[oC+ 2]*P V <- V+C[oC+ 1]*P ## PA L(A,E) M <- A2 %*% M + M2 %*% P LU <- LU + C[oC+ 4]*M LV <- LV + C[oC+ 3]*M oC <- oC + 2 } ## PA e^A & L(A,E) P <- P %*% A2 U <- U + C[oC+ 2]*P LU <- A %*% LU + E %*% U U <- A %*% U V <- V + C[oC+ 1]*P X <- solve(V-U, V+U) X2 <- solve(V-U, LU+LV + (LU-LV)%*%X) } ## Else, check if norm of A is small enough for PA with m=13. ## If not, scale the matrix else { s <- log2(nA/4.74) B <- A D <- E ## Scaling if (s > 0){ s <- ceiling(s) B <- A/(2^s) D <- D/(2^s) } C. <- c(64764752532480000,32382376266240000,7771770303897600,1187353796428800, 129060195264000,10559470521600,670442572800,33522128640,1323241920, 40840800,960960,16380,182,1) ## Calculate PA ## PA e^A B2 <- B%*%B B4 <- B2%*%B2 B6 <- B2%*%B4 W1 <- C.[14]*B6+ C.[12]*B4+ C.[10]*B2 W2 <- C.[ 8]*B6+ C.[ 6]*B4+ C.[ 4]*B2+C.[2]*I Z1 <- C.[13]*B6+ C.[11]*B4+ C.[ 9]*B2 Z2 <- C.[ 7]*B6+ C.[ 5]*B4+ C.[ 3]*B2+C.[1]*I W <- B6%*%W1+W2 U <- B%*%W V <- B6%*%Z1+Z2 ## PA L(A,E) M2 <- B%*%D + D%*%B M4 <- B2%*%M2 + M2%*%B2 M6 <- B4%*%M2 + M4%*%B2 LW1 <- C.[14]*M6+ C.[12]*M4+ C.[10]*M2 LW2 <- C.[ 8]*M6+ C.[ 6]*M4+ C.[ 4]*M2 LZ1 <- C.[13]*M6+ C.[11]*M4+ C.[ 9]*M2 LZ2 <- C.[ 7]*M6+ C.[ 5]*M4+ C.[ 3]*M2 LW <- B6%*%LW1 + M6%*%W1 + LW2 LU <- B%*%LW + D%*%W LV <- B6%*%LZ1 + M6%*%Z1 + LZ2 X <- solve(V-U, V+U) X2 <- solve(V-U, LU+LV + (LU-LV)%*%X) ##----------STEP 3 SQUARING---------------------------------------------- ## Squaring if (s > 0) for (t in seq_len(s)) { X2 <- X2 %*% X + X %*% X2 if(expm || t != s) X <- X %*% X } } if(expm) list(expm = X, Lexpm = X2) else list(Lexpm = X2) } ## .expmFrechet2008.26 expm/R/expm2.R0000644000176200001440000001063014655414337012616 0ustar liggesusers ##' Calculation of e^A with the Scaling & Squaring Method with Balancing ##' according to Higham (2008) ##' ##' R-Implementation of Higham's Algorithm from the Book (2008) ##' "Functions of Matrices - Theory and Computation", Chapter 10, Algorithm 10.20 ##' Step 0: Balancing ##' Step 1: Scaling ##' Step 2: Padé-Approximation ##' Step 3: Squaring ##' Step 4: Reverse Balancing ##' ##' @title Matrix Exponential with Scaling & Squaring and Balancing ##' @param A nxn Matrix ##' @param balancing logical indicating if balancing (step 0) should be applied ##' @return e^A Matrixeponential; nxn Matrix ##' @author Martin Maechler expm.Higham08 <- function(A, balancing=TRUE) { ## Check if A is square d <- dim(A) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "A"), domain=NA) n <- d[1] if (n <= 1) return(exp(A)) ## else n >= 2 ... non-trivial case : ------------- ##---------STEP 0: BALANCING------------------------------------------------ ## if balancing is asked for, balance the matrix A if (balancing) { baP <- balance(A, "P")# -> error for non-classical matrix -- "FIXME": balance() baS <- balance(baP$z, "S") A <- baS$z } ##--------STEP 1 and STEP 2 SCALING & PADÉ APPROXIMATION-------------------- ## Informations about the given matrix nA <- Matrix::norm(A, "1") ## try to remain in the same matrix class system: I <- if(is(A,"Matrix")) Diagonal(n) else diag(n) ## If the norm is small enough, use the Padé-Approximation (PA) directly if (nA <= 2.1) { t <- c(0.015, 0.25, 0.95, 2.1) ## the minimal m for the PA : l <- which.max(nA <= t) ## Calculate PA C <- rbind(c(120,60,12,1,0,0,0,0,0,0), c(30240,15120,3360,420,30,1,0,0,0,0), c(17297280,8648640,1995840,277200,25200,1512,56,1,0,0), c(17643225600,8821612800,2075673600,302702400,30270240, 2162160,110880,3960,90,1)) A2 <- A %*% A P <- I U <- C[l,2]*I V <- C[l,1]*I for (k in 1:l) { P <- P %*% A2 U <- U + C[l,(2*k)+2]*P V <- V + C[l,(2*k)+1]*P } U <- A %*% U X <- solve(V-U,V+U) } ## Else, check if norm of A is small enough for m=13. ## If not, scale the matrix else { s <- log2(nA/5.4) B <- A ## Scaling if (s > 0) { s <- ceiling(s) B <- B/(2^s) } ## Calculate PA c. <- c(64764752532480000,32382376266240000,7771770303897600, 1187353796428800, 129060195264000,10559470521600, 670442572800, 33522128640, 1323241920, 40840800,960960,16380, 182,1) B2 <- B %*% B B4 <- B2 %*% B2 B6 <- B2 %*% B4 U <- B %*% (B6 %*% (c.[14]*B6 + c.[12]*B4 + c.[10]*B2) + c.[8]*B6 + c.[6]*B4 + c.[4]*B2 + c.[2]*I) V <- B6 %*% (c.[13]*B6 + c.[11]*B4 + c.[9]*B2) + c.[7]*B6 + c.[5]*B4 + c.[3]*B2 + c.[1]*I X <- solve(V-U,V+U) ##---------------STEP 3 SQUARING---------------------------------------------- if (s > 0) for (t in 1:s) X <- X %*% X } ##-----------------STEP 4 REVERSE BALANCING--------------------------------- if (balancing) { ## reverse the balancing d <- baS$scale X <- X * (d * rep(1/d, each = n)) ## apply inverse permutation (of rows and columns): pp <- as.integer(baP$scale) if(baP$i1 > 1) { ## The lower part for(i in (baP$i1-1):1) { # 'p1' in *reverse* order tt <- X[,i]; X[,i] <- X[,pp[i]]; X[,pp[i]] <- tt tt <- X[i,]; X[i,] <- X[pp[i],]; X[pp[i],] <- tt } } if(baP$i2 < n) { ## The upper part for(i in (baP$i2+1):n) { # 'p2' in *forward* order ## swap i <-> pp[i] both rows and columns tt <- X[,i]; X[,i] <- X[,pp[i]]; X[,pp[i]] <- tt tt <- X[i,]; X[i,] <- X[pp[i],]; X[pp[i],] <- tt } } } X } ##' Matrix Exponential -- using Al-Mohy and Higham (2009)'s algorithm ##' --> ../src/matexp_MH09.c ##' @param x square matrix ##' @param p the order of the Pade' approximation, 1 <= p <= 13. The ##' default, 6, is what \file{expokit} uses. expm.AlMoHi09 <- function(x, p = 6) { d <- dim(x) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "x"), domain=NA) stopifnot(length(p <- as.integer(p)) == 1L) if (p < 1 || p > 13) stop("Pade approximation order 'p' must be between 1 and 13.") .Call(R_matexp_MH09, if(is.atomic(x)) x else as(x, "matrix"), p) } expm/R/expm_vec.R0000644000176200001440000001100012404606717013354 0ustar liggesusers#### Originally by Roger B. Sidje (rbs@maths.uq.edu.au) #### EXPOKIT: Software Package for Computing Matrix Exponentials. #### ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 ##' Performs exp(A t) %*% v directly w/o evaluating exp(A) ##' Originally by Roger B. Sidje ##' EXPOKIT: Software Package for Computing Matrix Exponentials. ##' ACM - Transactions On Mathematical Software, 24(1):130-156, 1998 ##' @title Compute exp(A t) %*% v directly ##' @param A n x n matrix ##' @param v n - vector ##' @param t number (scalar) ___ FIXME allow vector ? ___ ##' @param tol ##' @param btol ##' @param m.max integer constants you should only change if you know what you're doing ##' @param mxrej ##' @param verbose flag indicating if the algorithm should be verbose.. ##' @return a list with components ##' @author Ravi Varadhan, Johns Hopkins University; Martin Maechler (cosmetic) expAtv <- function(A, v, t=1, method = "Sidje98", ## currently only one method, with these arguments: ## FIXME argMeth=list( ... ) rescaleBelow = 1e-6, tol=1e-7, btol = 1e-7, m.max = 30, mxrej = 10, verbose = getOption("verbose")) { ## R translation: Ravi Varadhan, Johns Hopkins University ## "cosmetic", apply to sparse A: Martin Maechler, ETH Zurich if(length(d <- dim(A)) != 2) stop("'A' is not a matrix") # <- also for sparseMatrix stopifnot(length(v) == (n <- d[1]), m.max >= 2) if(n <= 1) { if(n == 1) return(list(eAtv = exp(A*t)*v, error = 0, nstep = 0L, n.reject = 0L)) stop("nrow(A) must be >= 1") } method <- match.arg(method) m <- min(n, m.max)# >= 2 ##- these are function arguments as well : gamma <- 0.9 delta <- 1.2 ##- nA <- norm(A, "I") if(nA < rescaleBelow) { ## rescaling, by MMaechler, needed for small norms A <- A/nA t <- t*nA nA <- 1 } rndoff <- nA * .Machine$double.eps t_1 <- abs(t) sgn <- sign(t) t_now <- 0 s_error <- 0 k1 <- 2 mb <- m xm <- 1/m beta <- sqrt(sum(v*v))# = norm(v) = |\ v || if(beta == 0) ## border case: v is all 0, and the result is too return(list(eAtv = v, error = 0L, nstep = 0L, n.reject = 0L)) fact <- (((m+1)/exp(1))^(m+1))*sqrt(2*pi*(m+1)) myRound <- function(tt) { s <- 10^(floor(log10(tt)) - 1) ceiling(tt/s)*s } t_new <- myRound( (1/nA)*(fact*tol/(4*beta*nA))^xm ) V <- matrix(0, n, m+1) H <- matrix(0, m+2, m+2) nstep <- n.rej <- 0L w <- v while (t_now < t_1) { nstep <- nstep + 1L t_step <- min(t_1 - t_now, t_new) if(verbose) cat(sprintf("while(t_now = %g < ..): nstep=%d, t_step=%g\n", t_now, nstep, t_step)) V[,1] <- (1/beta)*w for (j in 1:m) { p <- as.vector(A %*% V[,j]) for (i in 1:j) { H[i,j] <- s <- sum(V[,i] * p) p <- p - s * V[,i] } s <- sqrt(sum(p*p)) if (s < btol) { k1 <- 0 mb <- j t_step <- t_1 - t_now break } H[j+1, j] <- s V[, j+1] <- p / s } ## j-loop complete if (k1 != 0) { H[m+2, m+1] <- 1 av <- A %*% V[, m+1] avnorm <- sqrt(sum(av * av)) } i.rej <- 0L while (i.rej <= mxrej) { mx <- mb + k1; imx <- seq_len(mx) # = 1:mx if(verbose) cat(sprintf(" inner while: k1=%d -> mx=%d\n", k1, mx)) F <- expm(sgn * t_step * H[imx,imx, drop=FALSE]) if (k1 == 0) { err_loc <- btol break } else { phi1 <- abs(beta * F[m+1,1]) phi2 <- abs(beta * F[m+2,1] * avnorm) if(is.nan(phi1) || is.nan(phi2)) stop("NaN phi values; probably overflow in expm()") if (phi1 > 10*phi2) { err_loc <- phi2 xm <- 1/m } else if (phi1 > phi2) { err_loc <- (phi1 * phi2)/(phi1 - phi2) xm <- 1/m } else { err_loc <- phi1 xm <- 1/(m-1) } } if (err_loc <= delta * t_step*tol) break else { if (i.rej == mxrej) stop(gettextf('The requested tolerance (tol=%g) is too small for mxrej=%d.', tol, mxrej)) t_step <- gamma * t_step * (t_step * tol / err_loc)^xm s <- 10^(floor(log10(t_step))-1) t_step <- s * ceiling(t_step / s) i.rej <- i.rej + 1L } }## end{ while (i.rej < mx..) } n.rej <- n.rej + i.rej mx <- mb + max(0, k1-1); imx <- seq_len(mx) # = 1:mx w <- as.vector(V[, imx] %*% (beta*F[imx,1, drop=FALSE])) beta <- sqrt(sum(w*w)) t_now <- t_now + t_step t_new <- myRound(gamma * t_step * (t_step*tol/err_loc)^xm) err_loc <- max(err_loc, rndoff) s_error <- s_error + err_loc }# end{ while } list(eAtv = w, error = s_error, nstep = nstep, n.reject = n.rej) } expm/R/matpow.R0000644000176200001440000000016610772074007013065 0ustar liggesusers### M^k for a matrix M and non-negative integer 'k' "%^%" <- function(x, k) .Call(R_matpow, x, as.integer(k)) expm/R/logm.Higham08.R0000644000176200001440000002376514107534174014074 0ustar liggesusers##------OVERVIEW---------------------------------------------------------------- ## Input: A; nxn Matrix, no eigenvalues <=0, not singular ## Output: log(A); Matrixlogarithm; nxn Matrix ## Function for Calculation of log(A) with the Inverse Scaling&Squaring Method ## Step 0: Schur Decompostion Tr ## Step 1: Scaling (root of Tr) ## Step 2: Padé-Approximation ## Step 3: Squaring ## Step 4: Reverse Schur Decomposition ## R-Implementation of Higham's Algorithm from the Book ## "Functions of Matrices - Theory and Computation", Chapter 11, Algorithm 11.9 ##-------CODE------------------------------------------------------------------- ## The coefficients for the Padé-approximation can be computed at install time: ## r: exponents are in (-51):(-56) ## p: exponents are in c((-47):(-53), -56) logm.H08.r <- rbind(c(5003999585967230*2^(-54), 8006399337547537*2^(-54), 5/18, 0,0,0,0), c(5640779706068081*2^(-51), 8899746432686114*2^(-53), 8767290225458872*2^(-54), 6733946100265013*2^(-55), 0,0,0), c(5686538473148996*2^(-51), 4670441098084653*2^(-52), 5124095576030447*2^(-53), 5604406634440294*2^(-54), 8956332917077493*2^(-56), 0,0), c(5712804453675980*2^(-51), 4795663223967718*2^(-52), 5535461316768070*2^(-53), 6805310445892841*2^(-54), 7824302940658783*2^(-55), 6388318485698934*2^(-56), 0), c(5729264333934497*2^(-51), 4873628951352824*2^(-52), 5788422587681293*2^(-53), 7529283295392226*2^(-54), 4892742764696865*2^(-54), 5786545115272933*2^(-55), 4786997716777457*2^(-56))) logm.H08.p <- - rbind(c(7992072898328873*2^(-53), 1/2, 8121010851296995*2^(-56), 0,0,0,0), c(8107950463991866*2^(-49), 6823439817291852*2^(-51), 6721885580294475*2^(-52), 4839623620596807*2^(-52), 0,0,0), c(6000309411699298*2^(-48), 4878981751356277*2^(-50), 2, 5854649940415304*2^(-52), 4725262033344781*2^(-52),0,0), c(8336234321115872*2^(-48), 6646582649377394*2^(-50), 5915042177386279*2^(-51), 7271968136730531*2^(-52), 5422073417188307*2^(-52), 4660978705505908*2^(-52), 0), c(5530820008925390*2^(-47), 8712075454469181*2^(-50), 7579841581383744*2^(-51), 4503599627370617*2^(-51), 6406963985981958*2^(-52), 5171999978649488*2^(-52), 4621190647118544*2^(-52))) logm.Higham08 <- function(x) { ## work with "Matrix" too: x<-as.matrix(x) ##MM: No need to really check here; we get correct error msg later anyway ## and don't need to compute det() here, in the good cases ! ## if (det(x) == 0) stop("'x' is singular") ##-------Step 0: Schur Decomposition----------------------------------------- ## Schur() checks for square matrix also: Sch.x <- Schur(Matrix(x, sparse=FALSE)) ## FIXME 'sparse=FALSE' is workaround - good as long Matrix has no sparse Schur() ev <- Sch.x@EValues if(getOption("verbose") && any(abs(Arg(ev) - pi) < 1e-7)) ## Let's see what works: temporarily *NOT* stop()ping : message(gettextf("'x' has negative real eigenvalues; maybe ok for %s", "logm()"), domain=NA) n <- Sch.x@Dim[1] Tr <- as.matrix(Sch.x@T) Q <- as.matrix(Sch.x@Q) ##----- Step 1: [Inverse] Scaling ------------------------------------------- I <- diag(n) thMax <- 0.264 theta <- c(0.0162, 0.0539, 0.114, 0.187, thMax) p <- k <- 0 ; t.o <- -1 ## NB: The following could loop forever, e.g., for logm(Diagonal(x=1:0)) repeat{ t <- norm(Tr - I, "1") # norm(x, .) : currently x is coerced to dgeMatrix if(is.na(t)) { warning(sprintf(ngettext(k, "NA/NaN from || Tr - I || after %d step.\n%s", "NA/NaN from || Tr - I || after %d steps.\n%s"), k, "The matrix logarithm may not exist for this matrix.")) return(array(t, dim=dim(Tr))) } if (t < thMax) { ## FIXME: use findInterval() j2 <- which.max( t <= theta) j1 <- which.max( (t/2) <= theta) if ((j2-j1 <= 1) || ((p <- p+1) == 2)) { m <- j2 ## m := order of the Padé-approximation break } } else if(k > 20 && abs(t.o - t) < 1e-7*t) { ## warning(gettextf("Inverse scaling did not work (t = %g).\n", t), "The matrix logarithm may not exist for this matrix.", "Setting m = 3 arbitrarily.") m <- 3 break } Tr <- rootS(Tr)##--> Matrix Square root of Jordan T ## ----- [see below; compare with ./sqrtm.R t.o <- t k <- k+1 } if(getOption("verbose")) message(gettextf("logm.Higham08() -> (k, m) = (%d, %d)", k,m), domain=NA) ##------ Step 2: Padé-Approximation ----------------------------------------- ## of order m : r.m <- logm.H08.r[m,] p.m <- logm.H08.p[m,] X <- 0 Tr <- Tr-I for (s in 1:(m+2)) { X <- X + r.m[s]*solve(Tr - p.m[s]*I, Tr) } ##--- Step 3 & 4: Squaring & reverse Schur Decomposition ----------------- 2^k* Q %*% X %*% solve(Q) } ### --- was rootS.r ----------------------------------------------------------- ### ~~~~~~~ ##------OVERVIEW---------------------------------------------------------------- ## Input: UT; nxn upper triangular block matrix (real Schur decomposition) ## Output: root of matrix UT, nxn upper triangular Matrix ## Function for calculation of UT^(1/2), which is used for the logarithm function ## Step 0: Analyse block structure ## Step 1: Calculate diagonal elements/blocks ## Step 2: Calculate superdiagonal elements/blocks ## R-Implementation of Higham's Algorithm from the Book ## "Functions of Matrices - Theory and Computation", Chapter 6, Algorithm 6.7 ## NB: Much in parallel with sqrtm() in ./sqrtm.R <<< keep in sync ## ~~~~~ ~~~~~~~ rootS <- function(x) { ## Generate Basic informations of Matrix x stopifnot(length(d <- dim(x)) == 2, is.numeric(d), (n <- d[1]) == d[2], n >= 1) ## FIXME : should work for "Matrix" too: not S <- as.matrix(x) S <- x ##------- STEP 0: Analyse block structure ---------------------------------- if(n > 1L) { ## Count 2x2 blocks (as Schur(x) is the real Schur Decompostion) J.has.2 <- S[cbind(2:n, 1:(n-1))] != 0 k <- sum(J.has.2) ## := number of non-zero SUB-diagonals } else k <- 0L ## Generate Blockstructure and save it as R.index R.index <- vector("list",n-k) l <- 1L i <- 1L while(i < n) { ## i advances by 1 or 2, depending on 1- or 2- Jordan Block if (S[i+1L,i] == 0) { R.index[[l]] <- i } else { i1 <- i+1L R.index[[l]] <- c(i,i1) # = i:(i+1) i <- i1 } i <- i+1L l <- l+1L } if (is.null(R.index[[n-k]])) { # needed; FIXME: should be able to "know" ##message(gettextf("R.index[n-k = %d]] is NULL, set to n=%d", n-k,n), domain=NA) R.index[[n-k]] <- n } ##---------STEP 1: Calculate diagonal elements/blocks------------------------ ## Calculate the root of the diagonal blocks of the Schur Decompostion S I <- diag(2) X <- matrix(0,n,n) for (j in seq_len(n-k)) { ij <- R.index[[j]] if (length(ij) == 1L) { ## Sij <- S[ij,ij] ## if(Sij < 0) ## ## FIXME(?) : in sqrtm(), we take *complex* sqrt() if needed : ## ## ----- but afterwards norm(Tr - I, "1") fails with complex ## ## Sij <- complex(real = Sij, imaginary = 0) ## stop("negative diagonal entry -- matrix square does not exist") ## X[ij,ij] <- sqrt(Sij) X[ij,ij] <- sqrt(S[ij,ij]) } else { ## "FIXME"(better algorithm): only need largest eigen value ev1 <- eigen(S[ij,ij], only.values=TRUE)$values[1] r1 <- Re(sqrt(ev1)) ## sqrt() ... X[ij,ij] <- r1*I + 1/(2*r1)*(S[ij,ij] - Re(ev1)*I) } } ### ___ FIXME __ code re-use: All the following is identical to 'STEP 3' in sqrtm() ### ----- and almost all of STEP 1 above is == 'STEP 2' of sqrtm() ##---------STEP 2: Calculate superdiagonal elements/blocks------------------- ## Calculate the remaining, not-diagonal blocks if (n-k > 1L) for (j in 2L:(n-k)) { ij <- R.index[[j]] for (i in (j-1L):1L) { ii <- R.index[[i]] sumU <- 0 ## Calculation for 1x1 Blocks if (length(ij) == 1L & length(ii) == 1L ) { if (j-i > 1L) for (l in (i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(X[ii,ii]+X[ij,ij],S[ii,ij]-sumU) } ## Calculation for 1x2 Blocks else if (length(ij) == 2 & length(ii) == 1L ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(t(X[ii,ii]*I + X[ij,ij]), as.vector(S[ii,ij] - sumU)) } ## Calculation for 2x1 Blocks else if (length(ij) == 1L & length(ii) == 2 ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(X[ii,ii]+X[ij,ij]*I,S[ii,ij]-sumU) } ## Calculation for 2x2 Blocks with special equation for solver else if (length(ij) == 2 & length(ii) == 2 ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il] %*% X[il,ij] else X[ii,il] %*% t(X[il,ij]) } } tUii <- matrix(0,4,4) tUii[1:2,1:2] <- X[ii,ii] tUii[3:4,3:4] <- X[ii,ii] tUjj <- matrix(0,4,4) tUjj[1:2,1:2] <- t(X[ij,ij])[1L,1L]*I tUjj[3:4,3:4] <- t(X[ij,ij])[2L,2L]*I tUjj[1:2,3:4] <- t(X[ij,ij])[1L,2L]*I tUjj[3:4,1:2] <- t(X[ij,ij])[2L,1L]*I X[ii,ij] <- solve(tUii+tUjj,as.vector(S[ii,ij]-sumU)) } } } X } expm/R/expm.R0000644000176200001440000002034314655414337012536 0ustar liggesusers### ===== File part of R package expm ===== ### ### Function to compute the matrix exponential ### ### exp(M) = sum(n = 0:Inf; M^n / n!), ### ### where M is an (n x n) matrix. ### expm.s.Pade.s <- function(x, order, n = nrow(x), ## s := the number of [s]quarings s = max(ceiling(log2(max(rowSums(abs(x)))))+1, 0) ) { stopifnot((order <- as.integer(order)) >= 2L) if(!missing(s)) stopifnot((s <- as.integer(s)) >= 0L) ## not much checking here; is not to be called by the user ## try have this work with "mpfrMatrix" <==> solve() ## preconditions x : x <- x / (2^s) ## Pade approximation for exp(x) c <- .5 D <- diag(1, n) E <- D + c*x D <- D - c*x X <- x p <- TRUE for(k in 2:order) { c <- c * (N <- order-k+1L) / k / (N + order) X <- x %*% X # now X = x ^ k cX <- c*X E <- E + cX D <- if(p) D + cX else D - cX p <- !p } E <- solve(D, E) ## Undo the scaling by repeated squaring : for(k in seq_len(s)) E <- E %*% E E } .methSparse <- c("Higham08", "R_Eigen", "R_Pade") ## keep this list up-to-date - test by setting R_EXPM_NO_DENSE_COERCION ## but NOTE: It may make sense to *keep* the message() about coercion to dense (memory blow up!) .methComplex <- c("Higham08.b", "Higham08", "R_Eigen", "R_Pade", "R_Ward77") expm <- function(x, method = c("Higham08.b", "Higham08", "AlMohy-Hi09", "Ward77", "PadeRBS", "Pade", "Taylor", "PadeO", "TaylorO", "R_Eigen", "R_Pade", "R_Ward77", "hybrid_Eigen_Ward"), order = 8, trySym = TRUE, tol = .Machine$double.eps, do.sparseMsg = TRUE, preconditioning = c("2bal", "1bal", "buggy")) { ## some methods work for "matrix", "Matrix", or "mpfrMatrix", iff solve(.,.) worked: isM <- isZ <- FALSE # (so we can use shortcut `||` ) stopifnot(is.numeric(x) || is.complex(x) || is.logical(x) || (isM <- inherits(x, "dMatrix") || inherits(x, "lMatrix")|| inherits(x, "iMatrix")) || inherits(x, "mpfrMatrix") || (isZ <- inherits(x, "zMatrix"))) if(length(d <- dim(x)) != 2) stop("argument is not a matrix") if (d[1] != d[2]) stop("matrix not square") method <- match.arg(method) checkSparse <- !nzchar(Sys.getenv("R_EXPM_NO_DENSE_COERCION")) ## no-op: isM <- !is.numeric(x) && isM if(isM && checkSparse) { # i.e., a "dMatrix", "iMatrix",.. if(!(method %in% .methSparse) && is(x, "sparseMatrix")) { if(do.sparseMsg) message(gettextf("coercing to dense matrix, as required by method %s", dQuote(method)), domain=NA) x <- as(x, "denseMatrix") } } switch(method, "AlMohy-Hi09" = expm.AlMoHi09(x, p = order) , "Higham08.b" = expm.Higham08(x, balancing = TRUE) , "Higham08" = expm.Higham08(x, balancing = FALSE) , "Ward77" = { ## AUTHORS: Christophe Dutang, Vincent Goulet at act ulaval ca ## built on "Matrix" package, built on 'octave' code ## Martin Maechler, for the preconditioning etc if(!is.atomic(x)) x <- as(x, "matrix") switch(match.arg(preconditioning), "2bal" = .Call(do_expm, x, "Ward77"), "1bal" = .Call(do_expm, x, "Ward77_1"), "buggy"= .Call(do_expm, x, "buggy_Ward77"), stop("invalid 'preconditioning'")) }, "R_Eigen" = { ## matrix exponential using eigenvalues / spectral decomposition : ## == Dubious Way 'Method 14' : is ## good for 'symmetric' or 'orthogonal' (or other 'normal' : A'A = AA' ): ## MM: improved from mexp2() with 'trySym' and isSymmetric() isCplx <- isZ || is.complex(x) # isSymmetric.*() also for cplx: isSym <- if(trySym) isSymmetric.matrix(x) else FALSE z <- eigen(x, symmetric = isSym) V <- z$vectors Vi <- if(isSym) t(V) else solve(V) if(isCplx) ( V %*% ( exp(z$values) * Vi)) else Re(V %*% ( exp(z$values) * Vi)) ## == ##(V %*% diag(exp(z$values)) %*% Vi) }, "hybrid_Eigen_Ward" = { ## AUTHOR: Christophe Dutang ## matrix exponential using eigenvalues / spectral decomposition and ## Ward(1977) algorithm if x is numerically non diagonalisable if(!is.atomic(x)) x <- as(x, "matrix") .Call(do_expm_eigen, x, tol) }, "R_Pade"= { ## use scaling + Pade + squaring with R code: ## matrix exponential using a scaling and squaring algorithm ## with a Pade approximation ## source code translated from expmdemo1.m in Matlab ## by Stig Mortensen , ## prettified by MM -- works for "matrix" or "Matrix" matrices ! expm.s.Pade.s(x, order, n=d[1]) }, "R_Ward77" = { ## R implementation of "Ward(1977)" ## also works for "Matrix" matrices stopifnot(order >= 2) n <- d[1] ## Preconditioning Step 1: shift diagonal by average diagonal trShift <- sum(d.x <- diag(x)) if(trShift) { trShift <- trShift/n diag(x) <- d.x - trShift } ## Preconditioning Step 2: balancing with balance. ## ------ ## For now, do as the octave implementation ## TODO later: use "B" (faster; better condition of result) baP <- balance(x, "P") baS <- balance(baP$z, "S") x <- expm.s.Pade.s(baS$z, order) ## ------------- scaling + Pade + squaring ------ ## i.e., entails Preconditioning Step 3 (and its reverse) ## Reverse step 2: ------------------ ## ## Step 2 b: apply inverse scaling d <- baS$scale x <- x * (d * rep(1/d, each = n)) ## ## Step 2 a: apply inverse permutation (of rows and columns): pp <- as.integer(baP$scale) if(baP$i1 > 1) { ## The lower part for(i in (baP$i1-1):1) { # 'p1' in *reverse* order tt <- x[,i]; x[,i] <- x[,pp[i]]; x[,pp[i]] <- tt tt <- x[i,]; x[i,] <- x[pp[i],]; x[pp[i],] <- tt } } if(baP$i2 < n) { ## The upper part for(i in (baP$i2+1):n) { # 'p2' in *forward* order ## swap i <-> pp[i] both rows and columns tt <- x[,i]; x[,i] <- x[,pp[i]]; x[,pp[i]] <- tt tt <- x[i,]; x[i,] <- x[pp[i],]; x[pp[i],] <- tt } } ## reverse step 1 (diagonal shift) if(trShift) { exp(trShift) * x } else x }, "PadeRBS" = { ## the "expofit" method by Roger B. Sidje (U.Queensland, AU) stopifnot((order <- as.integer(order)) >= 1L) if(!is.atomic(x)) x <- as(x, "matrix") if(is.complex(x)) stop(gettextf("expm(, method='%s') is not (yet) implemented", method), domain=NA) if(!is.double(x)) storage.mode(x) <- "double" Fobj <- .Fortran(matexpRBS, order, # IDEG 1 as.integer(d[1]), # M 2 T = 1., # T 3 H = x, # H 4 iflag = integer(1) # IFLAG 5 )[c("H","iflag")] if(Fobj[["iflag"]] < 0) stop("Unable to determine matrix exponential") Fobj[["H"]] } , { ## the "mexp" methods {"Pade", "Taylor", "PadeO", "TaylorO"}, by ## AUTHORS: Marina Shapira and David Firth -------------- if(!is.atomic(x)) x <- as(x, "matrix") if(is.complex(x)) stop(gettextf("expm(, method='%s') is not (yet) implemented", method), domain=NA) if(!is.double(x)) storage.mode(x) <- "double" order <- as.integer(order) ## MM: a "silly" way to code the method / order ntaylor <- npade <- 0L if (substr(method,1,4) == "Pade") npade <- order else ntaylor <- order res <- if(identical(grep("O$", method), 1L)) .Fortran(matrexpO, X = x, size = d[1], ntaylor, npade, accuracy = double(1))[c("X", "accuracy")] else .Fortran(matrexp, X = x, size = d[1], ntaylor, npade, accuracy = double(1))[c("X", "accuracy")] structure(res$X, accuracy = res$accuracy) })## end{switch} } expm/R/balance.R0000644000176200001440000000167414655414337013160 0ustar liggesusers## NOTA BENE: In Matlab, there's the function balance(.) which ## calls LAPACK's dgebal *AND* which has the option to also return the ## transformation *diagonal* matrix D , not just the transformed matrix. balance <- function(A, job = c("B", "N", "P","S")) { if(!is.atomic(A)) A <- as(A, "matrix") job <- match.arg(job) if(is.numeric(A) || is.logical(A)) .Call(R_dgebal, A, job) else if(is.complex(A)) .Call(R_zgebal, A, job) else stop("invalid matrix type ", typeof(A)) } ## dgebal <- balance ## till ## 2020-07-21: Finally deprecated: dgebal <- function(A, job = c("B","N", "P","S")) { .Deprecated("balance") .Call("R_dgebal", A, match.arg(job)) } ## Not exported, used to make 'R CMD check ' be faster *or* more extensive: doExtras <- function(int = interactive()) { int || nzchar(Sys.getenv("R_expm_check_extra")) || identical("true", unname(Sys.getenv("R_PKG_CHECKING_doExtras"))) } expm/R/sqrtm.R0000644000176200001440000001234114107534174012724 0ustar liggesusers#### Define sqrtm() --- was Michael Stadelmann's root.r #### ======= ~~~~~~ ##------OVERVIEW---------------------------------------------------------------- ## Input: A; nxn matrix, no eigenvalues <=0, not singular ## Output: root of matrix A, nxn Matrix ## Function for calculation of A^(1/2) with the real Schur decomposition ## Step 0: real Schur decomposition T of A ## Step 1: Aalyse block structure of T ## Step 2: Calculate diagonal elements/blocks of T^(1/2) ## Step 3: Calculate superdiagonal elements/blocks of T^(1/2) ## Step 4: reverse Schur decompostion ## R-Implementation of Higham's Algorithm from the Book ## "Functions of Matrices - Theory and Computation", Chapter 6, Algorithm 6.7 ## NB: Much in parallel with rootS() in ./logm.Higham08.R <<< keep in sync ## ~~~~~ ~~~~~~~~~~~~~~~ sqrtm <- function(x) { ## Generate Basic informations of matrix x ## FIXME : should work for "Matrix" too, hence _not_ S <- as.matrix(x) d <- dim(x) if(length(d) != 2 || d[1] != d[2]) stop(gettextf("'%s' must be a square matrix", "x"), domain=NA) ##MM: No need to really check here; we get correct error msg later anyway ## and don't need to compute det() here, in the good cases ! ## if (det(x) == 0) stop("'x' is singular") n <- d[1] ##------- STEP 0: Schur Decomposition --------------------------------------- Sch.x <- Schur(Matrix(x)) ## <- {FIXME [Matrix]} ev <- Sch.x@EValues if(getOption("verbose") && any(abs(Arg(ev) - pi) < 1e-7)) ## Let's see what works: temporarily *NOT* stop()ping : message(gettextf("'x' has negative real eigenvalues; maybe ok for %s", "sqrtm()"), domain=NA) S <- as.matrix(Sch.x@T) Q <- as.matrix(Sch.x@Q) ##---------STEP 1: Analyse block structure----------------------------------- if(n > 1L) { ## Count 2x2 blocks (as Schur(x) is the real Schur Decompostion) J.has.2 <- S[cbind(2:n, 1:(n-1))] != 0 k <- sum(J.has.2) ## := number of non-zero SUB-diagonals } else k <- 0L ## Generate Blockstructure and save it as R.index R.index <- vector("list",n-k) l <- 1L i <- 1L while(i < n) { ## i advances by 1 or 2, depending on 1- or 2- Jordan Block if (S[i+1L,i] == 0) { R.index[[l]] <- i } else { i1 <- i+1L R.index[[l]] <- c(i,i1) # = i:(i+1) i <- i1 } i <- i+1L l <- l+1L } if (is.null(R.index[[n-k]])) { # needed; FIXME: should be able to "know" ##message(gettextf("R.index[n-k = %d]] is NULL, set to n=%d", n-k,n), domain=NA) R.index[[n-k]] <- n } ##---------STEP 2: Calculate diagonal elements/blocks------------------------ ## Calculate the root of the diagonal blocks of the Schur Decompostion S I <- diag(2) X <- matrix(0,n,n) for (j in seq_len(n-k)) { ij <- R.index[[j]] if (length(ij) == 1L) { X[ij,ij] <- if((.s <- S[ij,ij]) < 0) sqrt(.s + 0i) else sqrt(.s) } else { ev1 <- ev[ij[1]] r1 <- Re(sqrt(ev1)) ## sqrt() ... X[ij,ij] <- r1*I + 1/(2*r1)*(S[ij,ij] - Re(ev1)*I) } } ##---------STEP 3: Calculate superdiagonal elements/blocks------------------- ## Calculate the remaining, not-diagonal blocks if (n-k > 1L) for (j in 2L:(n-k)) { ij <- R.index[[j]] for (i in (j-1L):1L) { ii <- R.index[[i]] sumU <- 0 ## Calculation for 1x1 Blocks if (length(ij) == 1L & length(ii) == 1L) { if (j-i > 1L) for (l in (i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(X[ii,ii]+X[ij,ij],S[ii,ij]-sumU) } ## Calculation for 1x2 Blocks else if (length(ij) == 2 & length(ii) == 1L ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(t(X[ii,ii]*I + X[ij,ij]), as.vector(S[ii,ij] - sumU)) } ## Calculation for 2x1 Blocks else if (length(ij) == 1L & length(ii) == 2 ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il]%*%X[il,ij] else X[ii,il] * X[il,ij] } } X[ii,ij] <- solve(X[ii,ii]+X[ij,ij]*I, S[ii,ij]-sumU) } ## Calculation for 2x2 Blocks with special equation for solver else if (length(ij) == 2 & length(ii) == 2 ) { if (j-i > 1L) for (l in(i+1L):(j-1L)) { il <- R.index[[l]] sumU <- sumU + { if (length(il) == 2 ) X[ii,il] %*% X[il,ij] else X[ii,il] %*% t(X[il,ij]) } } tUii <- matrix(0,4,4) tUii[1:2,1:2] <- X[ii,ii] tUii[3:4,3:4] <- X[ii,ii] tUjj <- matrix(0,4,4) tUjj[1:2,1:2] <- t(X[ij,ij])[1L,1L]*I tUjj[3:4,3:4] <- t(X[ij,ij])[2L,2L]*I tUjj[1:2,3:4] <- t(X[ij,ij])[1L,2L]*I tUjj[3:4,1:2] <- t(X[ij,ij])[2L,1L]*I X[ii,ij] <- solve(tUii+tUjj, as.vector(S[ii,ij]-sumU)) } } ## for (i in (j-1):1) .. } ## for (j in 2:(n-k)) ... ##------- STEP 4: Reverse the Schur Decomposition -------------------------- ## Reverse the Schur Decomposition Q %*% X %*% solve(Q) } expm/demo/0000755000176200001440000000000014660607514012160 5ustar liggesusersexpm/demo/exact-fn.R0000644000176200001440000001062114655414337014013 0ustar liggesusers#### "demo": Make these (function) definitions easily available to useRs #### ---- --> we use them in tests in ../tests/exact-ex.R ## ~~~~~~~~~~~~~~~~~~~ ### For nilpotent matrices A, exp(A) is polynomial in A ### Mathworld gives the example of the general 3 x 3 upper triangle nilA3 <- function(x,y,z) { ## Purpose: simple nilpotent matrix 3x3 A (with A^n = 0 for n >= 3) ## / 0 x z \ ## A = [ 0 0 y ] ## \ 0 0 0 / ## and its exact matrix exponential ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 19 Jan 2008 stopifnot((n <- length(x)) == 1, length(y) == 1, length(z) == 1, is.numeric(x), is.numeric(y), is.numeric(z)) list(A = cbind(0, rbind(matrix(c(x,0,z,y), 2,2), 0)), expA = cbind(c(1,0,0), c(x,1,0), c(z + x*y/2, y, 1))) } ## The relative error typically returned by all.equal -- simplified here relErr <- function(target, current) mean(abs(target - current)) / mean(abs(target)) facMat <- function(n, R_FUN, ev = R_FUN(n), M = rMat(n, R_FUN = R_FUN)) { ## Purpose: Construct random matrix x of which we "know" expm(x) ## because we set x := M %*% diag(ev) %*% solve(M) ## ---------------------------------------------------------------------- ## Arguments: n: dimension of matrices ## R_FUN: random number generator function (n) ## ev: numeric length-n vector of eigenvalues ## M: n x n matrix. Note that the default, ## rMat() will give matrices ``not close to singular'' ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: Feb 2008 / Aug. 2024 for R_FUN <- match.fun(R_FUN) num <- is.numeric(ev) stopifnot(n > 0, num || is.complex(ev), length(ev) == n, dim(M) == c(n,n), is.numeric(M) || is.complex(M)) iM <- solve(M) ## D <- diag(ev); A = M %*% D %*% iM list(A = M %*% (ev * iM), expA = M %*% (exp(ev) * iM)) } ### --- The 2x2 example with bad condition , see A3 in ./ex2.R m2ex3 <- function(eps = 0) { stopifnot(is.numeric(eps), length(eps) == 1) A <- rbind(c(-1, 1), c(eps^2, -1)) I.e <- 1 - eps^2 / 2 V <- I.e* rbind( c(-1, 1), eps*c( 1, 1)) D <- c(-1-eps, -1+eps) iV <- ## solve(V) rbind(c(-1, 1/eps), c( 1, 1/eps)) / (2 * I.e) ## NOTE: kappa(V) = condition_number(V) == 1/eps exactly useTol <- 2e-16 / eps stopifnot(all.equal(diag(2), V %*% iV, tolerance=useTol), all.equal(A, V %*% diag(D) %*% iV, tolerance=useTol) ) ch.e <- cosh(eps) sh.e <- sinh(eps) list(A = A, expA = exp(-1) * rbind(c( ch.e, sh.e/eps), c(sh.e*eps, ch.e ))) } ###--- rnilMat <- function(n, R_FUN = function(n) rpois(n, lambda=5)) { ## random upper triangular (zero-diagonal) nilpotent n x n matrix m <- matrix(0, n,n) ut <- upper.tri(m) R_FUN <- match.fun(R_FUN) m[ut] <- R_FUN(sum(ut)) m } set.seed(17) m <- rnilMat(10) if(FALSE) Matrix(m) ## 10 x 10 sparse Matrix of class "dtCMatrix" ## ## . 3 10 7 3 4 9 5 9 6 ## . . 5 4 3 . 5 6 3 6 ## . . . 5 7 7 3 7 5 6 ## . . . . 3 7 6 8 2 7 ## . . . . . 9 5 2 7 6 ## . . . . . . 8 5 4 6 ## . . . . . . . 5 5 3 ## . . . . . . . . 3 5 ## . . . . . . . . . 3 ## . . . . . . . . . . ## An interesting example, rounded from above {see ../tests/exact-ex.R} : dN <- 9*7*320 # 20160 EmN <- matrix(c(dN, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3*dN, dN, 0, 0, 0, 0, 0, 0, 0, 0, 352800, 5*dN, dN, 0, 0, 0, 0, 0, 0, 0, 1018080, 332640, 5*dN, dN, 0, 0, 0, 0, 0, 0, 2235240, 786240, 292320, 3*dN, dN, 0, 0, 0, 0, 0, 9368520, 3483480, 1582560, 413280, 181440, dN, 0, 0, 0, 0, 24676176, 9598680, 5073600, 1562400, 826560, 161280, dN, 0,0,0, 43730160, 17451000, 10051440, 3430560, 1955520, 504000, 5*dN, dN, 0, 0, 68438436, 27747480, 16853760, 6036240, 3638880, 1038240, 252000, 3*dN, dN, 0, 119725855, 49165892, 31046760, 11652480, 7198800, 2264640, 614880, 191520, 3*dN, dN), 10, 10) xct10 <- list(m = m, expm = EmN / dN, expmNum = EmN, expmDen = dN) expm/demo/balanceTst.R0000644000176200001440000001100314655414337014361 0ustar liggesusersbalanceTst <- function(A) { ## Purpose: Consistency checking of balance() {was "dgebal()"} ## ---------------------------------------------------------------------- ## Arguments: a square matrix ## ---------------------------------------------------------------------- ## Author: Martin Maechler, 20 Feb 2008 and on n <- dim(A)[1] ## do *the* three calls and look at result P <- balance(A, "P") doPerm <- function(A, pp, i1, i2) { stopifnot(length(pp) == n, dim(A) == c(n,n), 1 <= i1, i1 <= i2, i2 <= n) A. <- A if(i2 < n) { ## The upper part for(i in n:(i2+1)) { # 'p2' in *reverse* order ## swap i <-> pp[i] both rows and columns tt <- A.[,i]; A.[,i] <- A.[,pp[i]]; A.[,pp[i]] <- tt tt <- A.[i,]; A.[i,] <- A.[pp[i],]; A.[pp[i],] <- tt } } if(i1 > 1) { ## The lower part for(i in 1:(i1-1)) { # 'p1' in *forward* order tt <- A.[,i]; A.[,i] <- A.[,pp[i]]; A.[,pp[i]] <- tt tt <- A.[i,]; A.[i,] <- A.[pp[i],]; A.[pp[i],] <- tt } } A. } checkPerm <- function(P, orig.A) { didPerm <- ((leftP <- (i1 <- P$i1) != 1L) | (rightP <- (i2 <- P$i2) != n)) if(didPerm) { ## *had* permutation -- now check my idea about it pp <- as.integer(P$scale) ## Permute A to become P$z : A. <- doPerm(orig.A, pp = pp, i1=i1, i2=i2) stopifnot(isTRUE(all.equal(A., P$z, tolerance = 1e-15))) ## Now the reverse: Use pp[] and permute A. "back to A": if(leftP) { ## The lower part for(i in (i1-1):1) { # 'p1' in *reverse* order tt <- A.[,i]; A.[,i] <- A.[,pp[i]]; A.[,pp[i]] <- tt tt <- A.[i,]; A.[i,] <- A.[pp[i],]; A.[pp[i],] <- tt } } if(rightP) { ## The upper part for(i in (i2+1):n) { # 'p2' in *forward* order ## swap i <-> pp[i] both rows and columns tt <- A.[,i]; A.[,i] <- A.[,pp[i]]; A.[,pp[i]] <- tt tt <- A.[i,]; A.[i,] <- A.[pp[i],]; A.[pp[i],] <- tt } } stopifnot(isTRUE(all.equal(A., orig.A, tolerance = 1e-15))) } } checkPerm(P, orig.A = A) S <- balance(P$z, "S")# "S" starting from result of "P" stopifnot(S$i1 == 1, S$i2 == n) ## Now check the scaling checkScal <- function (d, A1, A2) { stopifnot(length(d) == n, dim(A1) == dim(A2), dim(A2) == c(n,n)) ## A.scaled <- diag(1/d, n) \%*\% A1 \%*\% diag(d, n) ## more efficiently: A.scaled <- A1 * (rep(d, each = n) / d) stopifnot(isTRUE(all.equal(A2, A.scaled, tolerance = 1e-15))) ## Check the reverse: S.rescaled <- A2 * (d * rep(1/d, each = n)) stopifnot(isTRUE(all.equal(A1, S.rescaled, tolerance = 1e-15))) } checkScal(d = S$scale, A1 = P$z, A2 = S$z) B <- balance(A, "B")# "B" : B[oth] stopifnot(P$i1 == B$i1, P$i2 == B$i2) ## now check *both* permutation and scaling A.perm <- doPerm(A, pp = as.integer(B$scale), i1=B$i1, i2=B$i2) ## checkPerm(B, orig.A = A) dB <- B$scale dB[c(if(B$i1 > 1) 1:(B$i1-1), if(B$i2 < n) (B$i2+1):n)] <- 1 checkScal(d = dB, A1 = A.perm, A2 = B$z) ## return list(P = P, S = S, B = B, Sz.eq.Bz = isTRUE(all.equal(S$z, B$z))) } m4. <- rbind(c(-1,-2, 0, 0), c( 0, 0,10,11), c( 0, 0,12, 0), c( 0,13, 0, 0)) op <- options(str = strOptions(vec.len = 12)) str(b4. <- balanceTst(m4.)) with(b4., all.equal(P, B)) # TRUE (everywhere?) ## better (?) example (m <- matrix(c(0,-1,0,-2,10, rep(0,11)), 4,4)) str(ba <- balanceTst(m)) (eq <- with(ba, all.equal(S$z, B$z))) # TRUE now (everywhere?) ba$Sz.eq.Bz # ditto ## a non-empty ``less-balanced'' example --- m4 <- matrix(outer(2^(0:7),c(-1,1)), 4,4) m4[lower.tri(m4)] <- 0 #--> upper triangular ==> will have many permutations ## now permute it; so balance() will find the permutation p <- c(4,2:1,3); m4 <- m4[p,p] m4 str(dm4 <- balanceTst(m4)) # much permutation! i1 = i2 = 1 ! ##----------- Complex examples zba4 <- balanceTst(m4 + 3i * m4) str(zba4) zba <- balanceTst(m*(1 + 1i)) str(zba) stopifnot(exprs = { all.equal(ba$ S$z, Re(zba$ S$z)) all.equal(ba$ S$z, Im(zba$ S$z)) all.equal(dm4$ S$z, Re(zba4$ S$z)) all.equal(dm4$ S$z * 3, Im(zba4$ S$z)) }) options(op) # revert expm/demo/00Index0000644000176200001440000000023711656206117013310 0ustar liggesusersexpm matrix exponential balanceTst Exploring balance(), i.e., LAPACK's dgeBAL matrix balancing exact-fn Functions for examples with exactly known solution expm/demo/expm.R0000644000176200001440000000122414655414337013256 0ustar liggesusersrequire("expm") # diagonalisable matrix T <- rbind(c(-2, 2, 0), c(-3, -2, 2), c( 2, 1,-2)) expm(T) # numerically singular matrix T <- rbind(c(-2, 2, 0), c( 0,-2, 2), c( 0, 0,-2)) expm(T) ## logm(), the inverse of expm() : T - logm(expm(T)) # small ( ~ 1e-13 ) stopifnot(all.equal(T, logm(expm(T)))) # solve shows T is numerically singular try(solve(eigen(T)$vectors)) # singular matrix T <- rbind(c(0, 2, 1), c(0, 0, 2), c(0, 0, 0)) expm(T) stopifnot(all.equal(logm(expm(T)), T)) ## and show how close it is all.equal(logm(expm(T)), T, tolerance=0)# 2.39e-15 {64b ubuntu 12-04} expm/vignettes/0000755000176200001440000000000014660607531013243 5ustar liggesusersexpm/vignettes/expm.Rnw0000644000176200001440000001052212165310624014674 0ustar liggesusers\documentclass{article} \usepackage{amsmath,url} \usepackage[round]{natbib} \usepackage[T1]{fontenc} \usepackage[english]{babel} %\usepackage{lucidabr} \usepackage[noae]{Sweave} %\VignetteIndexEntry{Using expm in packages} %\VignettePackage{expm} \title{Using \pkg{expm} in packages} \author{Christophe Dutang \\ ENSIMAG, Grenoble INP \\[3ex] Vincent Goulet \\ \'Ecole d'actuariat, Universit\'e Laval} \date{Jan. 2008 \ {\footnotesize (added note in June 2010)}} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\proglang}[1]{\textsf{#1}} \newcommand{\pkg}[1]{\textbf{#1}} \newcommand{\mat}[1]{\mathbf{#1}} \bibliographystyle{plainnat} \begin{document} \maketitle \section{Introduction} The \pkg{expm} package provides an \proglang{R} function \code{expm} to compute the matrix exponential of a real, square matrix. The matrix exponential of a matrix $\mat{A}$ is defined as \begin{align*} e^{\mat{A}} &= \mat{I} + \mat{A} + \frac{\mat{A}^2}{2!} + \dots \\ &= \sum_{k = 0}^\infty \frac{\mat{A}^k}{k!}. \end{align*} The actual computations are done in \proglang{C} by a function of the same name that is callable by other packages. Therefore, package authors can use these functions and avoid duplication of efforts. \section{Description of the functions} The \proglang{R} function \texttt{expm} takes as argument a real, square matrix and returns its exponential. Dimension names are preserved: <>= library(expm) m <- matrix(c(4, 1, 1, 2, 4, 1, 0, 1, 4), 3, 3) expm(m) dimnames(m) <- list(letters[1:3], LETTERS[1:3]) m expm(m) @ \bigskip %% manual centerig of "overlapping" box \hspace*{-.12\textwidth}% .08 = .16 / 2 \fbox{\begin{minipage}{1.16\textwidth}%% wider than the text! Note that the remainder of this text \textbf{mainly} relates to \code{expm(., method = "Ward77")}, i.e., the method of \cite{Ward:77} which is no longer the default method, as e.g., \code{method = "Higham08"} has found to be (``uniformly'') superior, see \cite{Higham:2008}. \end{minipage}} \bigskip The actual computational work is done in \proglang{C} by a routine defined as \begin{verbatim} void expm(double *x, int n, double *z) \end{verbatim} where \code{x} is the vector underlying the \proglang{R} matrix and \code{n} is the number of lines (or columns) of the matrix. The matrix exponential is returned in \code{z}. The routine uses the algorithm of \cite{Ward:77} based on diagonal Pad\'e table approximations in conjunction with three step preconditioning. The Pad\'e approximation to $e^{\mat{A}}$ is \begin{displaymath} e^{\mat{A}} \approx R(\mat{A}), \end{displaymath} with \begin{align*} R_{pq} (\mat{A}) &= (D_{pq}(\mat{A}))^{-1} N_{pq}(\mat{A}) \\ \intertext{where} D_{pq}(\mat{A}) &= \sum_{j=1}^p \frac{(p+q-j)! p!}{ (p+q)!j!(p-j)!}\, \mat{A}^j \\ \intertext{and} N_{pq}(\mat{A}) &= \sum_{j=1}^q \frac{(p+q-j)! q!}{ (p+q)!j!(q-j)!}\, \mat{A}^j. \end{align*} See \cite{MolerVanLoan:78} for an exhaustive treatment of the subject. The \proglang{C} routine is based on a translation made by \cite{Matrix} of the implementation of the corresponding Octave function \citep{octave}. \section{Calling the functions from other packages} Package authors can use facilities from \pkg{expm} in two (possibly simultaneous) ways: \begin{enumerate} \item call the \proglang{R} level function \code{expm} in \proglang{R} code; \item if matrix exponential calculations are needed in \proglang{C}, call the routine \code{expm}. \end{enumerate} Using \proglang{R} level function \code{expm} in a package simply requires the following two import directives: \begin{verbatim} Imports: expm \end{verbatim} in file \code{DESCRIPTION} and \begin{verbatim} import(expm) \end{verbatim} in file \code{NAMESPACE}. Accessing the \proglang{C} level routine further requires to prototype \code{expm} and to retrieve its pointer in the package initialization function \code{R\_init\_\textit{pkg}}, where \code{\textit{pkg}} is the name of the package: \begin{verbatim} void (*expm)(double *x, int n, double *z); void R_init_pkg(DllInfo *dll) { expm = (void (*) (double, int, double)) \ R_GetCCallable("expm", "expm"); } \end{verbatim} The definitive reference for these matters remains the \emph{Writing R Extensions} manual. \bibliography{expm} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% coding: utf-8 %%% End: expm/vignettes/expm.bib0000644000176200001440000000352412165310624014666 0ustar liggesusers@Article{Ward:77, author = {Ward, R. C.}, title = {Numerical Computation of the Matrix Exponential With Accuracy Estimate}, journal = {{SIAM} Journal on Numerical Analysis}, year = 1977, volume = 14, pages = {600-610} } @Article{MolerVanLoan:78, author = {Moler, C. and Van~{L}oan, C.}, title = {Nineteen dubious ways to compute the exponential of a matrix}, journal = {{SIAM} Review}, year = 1978, volume = 20, pages = {801-836} } @Manual{Matrix-pkg, title = {Matrix: A Matrix package for R}, author = {Douglas Bates and Martin Maechler}, year = {2010}, note = {R package version 0.999375-38}, language = {english} } @Book{octave, author = {Eaton, J. W.}, title = {{GNU} Octave Manual}, publisher = {Network Theory Limited}, year = 2002, ISBN = {0-9541617-2-6}, url = {http://www.octave.org}, language = {english} } @Book{Higham:2008, author = {Higham, N.~J.}, year = 2008, title = {Functions of Matrices: Theory and Computation}, publisher = {Society for Industrial and Applied Mathematics}, address = {Philadelphia, PA, USA} } @comment{This is *LATER* than Higham(2008) - and *NOT* yet implemented in expm:} @article{Al-mohy_Higham:2009, author = {Awad H. Al-Mohy and Nicholas J. Higham}, year = 2009, title = {A New Scaling and Squaring Algorithm for the Matrix Exponential}, journal = {SIAM Journal on Matrix Analysis and Applications}, volume = 31, number = 3, pages = {970-989}, publisher = {SIAM}, keywords = {matrix exponential; matrix function; scaling and squaring method; Pade approximation; backward error analysis; matrix norm estimation; overscaling; MATLAB; expm}, url = {http://link.aip.org/link/?SML/31/970/1}, doi = {10.1137/09074721X} } expm/data/0000755000176200001440000000000014660607514012145 5ustar liggesusersexpm/data/matStig.R0000644000176200001440000000074010760040026013663 0ustar liggesusersmatStig <- matrix(c( 1.725, -0.765, -15.00, 0, 0, 0, 0, 0, -0.795, 0.765, 0, 0, 0, 0, 0, 0, 0, 0, 0.3949, -0.3949, 0, 0, 343.4851, 0, 0, 0, 0, 0.1456, 0, 0, 0, 0, 0, 0, 0, 0, -1.725, 0.795, 0, 0, 0, 0, 0, 0, 0.765,-0.765, 0, 0, 0, 0, 0, 0, 15.00, 0, -0.3949, 0, 0, 0, 0, 0, 0, 0, 0.3949, -0.1456), nrow=8, byrow=TRUE) expm/src/0000755000176200001440000000000014660607531012022 5ustar liggesusersexpm/src/matrexpO.f0000644000176200001440000002060512470350137013765 0ustar liggesusersc This program computes exp(A) for a given matrix A. c c 2 algorithms are employed: c 1. The Taylor expansion of order "ntaylor," denoted by T(ntaylor). c 2. The Pade diagonal approximation of order c "npade" denoted by P(npade), is used instead, IFF ntaylor = 0 c The algorithm is applied twice to calculate c T(ntaylor) and T(ntaylor+10) [or, when ntaylor=0, c to calculate P(npade) and P(npade+10)]. c An upper bound for the L2 norm of the Cauchy error c T(ntaylor+10)-T(ntaylor) [or, when ntaylor=0, c P(npade+10)-P(npade)] is computed. c The result exp(A) is returned via the first argument. c c This version works with R (i.e., is written as a subroutine) c c To use it, first do c % R SHLIB matrexp.f c to make the shared library matrexp.so c c and then in R, c > dyn.load("matrexp.so") c > .C("matrexp_",as.double(runif(9)), c as.integer(3),as.integer(0),as.integer(8)) c c (This is all done automatically in the R package "expm".) c c -- MM: This is *legacy* code - but we provide the "padeO" ... methods c -- ===> Fix the fortran code enough that it does not give "--as-cran" warnings: c subroutine matrexpO(a, ndim, ntaylor, npade, accuracy) integer ndim, ntaylor, npade double precision a(ndim,ndim), accuracy c "ndim" is the order of the given matrix A c double precision sum(ndim,ndim) double precision solution(ndim,ndim) double precision error(ndim,ndim) double precision dkeep(ndim,ndim) double precision dsqrt, dl1norm, dlinfnorm integer log2 c c use the algorithm to compute T(ntaylor) or P(npade) c npower=log2(dsqrt(dl1norm(ndim,a)*dlinfnorm(ndim,a)))+4 if(ntaylor.gt.0)then call taylorO(ndim,ntaylor,npower,a,sum) else call padeO(ndim,npade,npower,a,sum) endif call powermatrix(ndim,sum,npower,dkeep) call id(ndim,dkeep,sum) c c computing the "solution" T(ntaylor+10) or P(npade+10) c if(ntaylor.gt.0)then call taylorO(ndim,ntaylor+10,npower,a,solution) else call padeO(ndim,npade+10,npower,a,solution) endif call powermatrix(ndim,solution,npower,dkeep) call id(ndim,dkeep,solution) c c copy the result back into a c do i=1,ndim do j=1,ndim a(i,j) = sum(i,j) end do end do c c compute the Cauchy error T(ntaylor+10)-T(ntaylor) c or P(npade+10)-P(npade) c call subtract(ndim,sum,solution,error) accuracy = dsqrt(dl1norm(ndim,error)*dlinfnorm(ndim,error)) return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine taylorO(m,ntaylor,npower,a,sum) c Taylor series for exp(a/2**npower) implicit double precision (a-h,o-z) double precision a(m,m),sum(m,m),dkeep(m,m) nscale=2**npower c print*,'A is scaled by 2**',npower,' =',nscale call initialize(m,sum,0.d0) call addtodiag(m,sum,1.d0) do n=ntaylor,1,-1 call multiplymatrixO(m,sum,a,dkeep) call multiplyscalarO(m,dkeep,1.d0/dble(n*nscale),sum) call addtodiag(m,sum,1.d0) end do return end subroutine padeO(m,npade,npower,a,approx) c Pade approximation for exp(a/2**npower) integer m, npade, npower double precision a(m,m), approx(m,m) c Var double precision aminus(m,m),dkeep(m,m) double precision padenom(m,m),padedenom(m,m) integer nscale,n,i nscale=2**npower c print*,'A is scaled by 2**',npower,' =',nscale call initialize(m,padenom,0.d0) call addtodiag(m,padenom,1.d0) do n=npade,1,-1 call multiplymatrixO(m,padenom,a,dkeep) call multiplyscalarO(m,dkeep, $ dble(npade-n+1)/dble(n*(2*npade-n+1)*nscale),padenom) call addtodiag(m,padenom,1.d0) end do call minus(m,a,aminus) call initialize(m,padedenom,0.d0) call addtodiag(m,padedenom,1.d0) do n=npade,1,-1 call multiplymatrixO(m,padedenom,aminus,dkeep) call multiplyscalarO(m,dkeep, $ dble(npade-n+1)/dble(n*(2*npade-n+1)*nscale),padedenom) call addtodiag(m,padedenom,1.d0) end do do i=1,m call solveO(m,padedenom,padenom(1,i),approx(1,i)) end do return end c MM: FIXME: Use BLAS for the following !!! c ----- (also R internal things --> use C, not Fortran ! c initializing a matrix to a scalar s subroutine initialize(m,x,s) integer m double precision x(m,m), s integer i,j do i=1,m do j=1,m x(i,j)=s end do end do return end subroutine multiplyscalarO(m,x,s,y) c multiplying a matrix x by a scalar s implicit double precision (a-h,o-z) double precision x(m,m),y(m,m) do i=1,m do j=1,m y(i,j)=x(i,j)*s end do end do return end subroutine multiplymatrixO(m,x,y,z) c multiplying 2 matrices implicit double precision (a-h,o-z) double precision x(m,m),y(m,m),z(m,m) do i=1,m do j=1,m z(i,j)=0.d0 do k=1,m z(i,j)=z(i,j)+x(i,k)*y(k,j) end do end do end do return end subroutine id(m,x,y) c assign a matrix x to y implicit double precision (a-h,o-z) double precision x(m,m),y(m,m) do i=1,m do j=1,m y(i,j)=x(i,j) end do end do return end subroutine powermatrix(m,x,ipower,y) c computing the ith power of a matrix x implicit double precision (a-h,o-z) double precision x(m,m),y(m,m),dkeep(m,m) call id(m,x,y) call id(m,x,dkeep) do i=1,ipower call multiplymatrixO(m,dkeep,dkeep,y) call id(m,y,dkeep) end do return end subroutine iden(m,x,y) c assign a vector x to y implicit double precision (a-h,o-z) double precision x(m),y(m) do i=1,m y(i)=x(i) end do return end double precision function dip(m,u,v) c inner product of 2 vectors integer m double precision u(m),v(m) integer i dip=0.d0 do i=1,m dip = dip+u(i)*v(i) end do return end double precision function dl2norm(m,u) c l2 norm of a vector implicit double precision (a-h,o-z) double precision u(m) dl2norm=dsqrt(dip(m,u,u)) return end subroutine solveO(m,A,f,x) c CGS iteration integer m double precision A(m,m), f(m), x(m) c double precision save(m),rcgs(m),r(m) double precision p(m),u(m) double precision rbar(m),v(m),q(m) external dl2norm, dip double precision dl2norm, dip double precision alpha, beta, thresh, eps, omega0,omega1, + omegainit, rho0,rho1, scalar,sigma, tau,vv integer l thresh=1.d-100 eps=1.d-30 call zero(m,x) call iden(m,f,r) call iden(m,r,rcgs) call iden(m,r,p) call iden(m,r,u) omega0= dl2norm(m,rcgs) omegainit=omega0 c print*,'res0=',dabs(omegainit) tau=omega0 vv=0.d0 eta=0.d0 call iden(m,r,rbar) rho0= dip(m,rbar,r) if(dabs(rho0).le.thresh)then c print*,'rho0=',rho0,' MG iteration number=1' return endif do l=1,m call multiplyvector(m,A,p,v) sigma=dip(m,rbar,v) if(dabs(sigma).le.thresh)then c print*,'sigma=',sigma,' iteration number=',2*l+1 return endif alpha=rho0/sigma if(dabs(alpha).le.thresh)then c print*,'alpha=',alpha,' iteration number=',2*l+1 return endif scalar=-alpha call comb(m,u,scalar,v,q) call add(m,u,q,v) call multiplyvector(m,A,v,save) call comb(m,rcgs,scalar,save,rcgs) omega1=dl2norm(m,rcgs) call comb(m,x,alpha,v,x) c print*,'residual=',dabs(omega1),' iteration number=',2*l+1 if(dabs(omega1/omegainit).le.eps)then c print*,'iteration number=',2*l+1 return endif omega0=omega1 rho1=dip(m,rbar,rcgs) if(dabs(rho1).le.thresh)then c print*,'rho1=',rho1,' iteration number=',2*l+1 return endif beta=rho1/rho0 rho0=rho1 call comb(m,rcgs,beta,q,u) call comb(m,q,beta,p,save) call comb(m,u,beta,save,p) end do c print*,'iteration number=',2*l+1 return end expm/src/mexp-common.f0000644000176200001440000000664112470365777014451 0ustar liggesusersC--- Common to "Original" (Old) matrexpO() -- ./matrexpO.f C--- and to new potentially BLAS-based matrexp() -- ./matrexp.f subroutine subtract(m,x,y,z) c subtracting a matrix y from a matrix x integer m double precision x(m,m),y(m,m),z(m,m) integer i,j do i=1,m do j=1,m z(i,j)=x(i,j)-y(i,j) enddo enddo return end subroutine addtodiag(m,x,s) c add a scalar s to the main diagonal elements of a matrix x integer m double precision x(m,m), s integer i do i=1,m x(i,i)=x(i,i)+s enddo return end subroutine minus(m,x,y) c the minus of a matrix integer m double precision x(m,m),y(m,m) integer i,j do i=1,m do j=1,m y(i,j)=-x(i,j) enddo enddo return end double precision function dl1norm(m,x) c L_1 norm of a matrix := max_j sum_i |x_{ij}| integer m double precision x(m,m) double precision sum integer j,i dl1norm=0.d0 do i=1,m sum=0.d0 do j=1,m sum=sum+dabs(x(j,i)) enddo if(sum.gt.dl1norm) dl1norm=sum enddo return end double precision function dlinfnorm(m,x) c L_infty norm of a matrix := max_i sum_j |x_{ij}| integer m double precision x(m,m) double precision sum integer i,j dlinfnorm=0.d0 do i=1,m sum=0.d0 do j=1,m sum=sum+dabs(x(i,j)) enddo if(sum.gt.dlinfnorm) dlinfnorm=sum enddo return end subroutine zero(m,x) c zeroing a vector integer m double precision x(m) integer i do i=1,m x(i)=0.d0 enddo end subroutine add(m,x,y,z) c adding 2 vectors z[] := x[] + y[] integer m double precision x(m),y(m),z(m) integer i do i=1,m z(i)=x(i)+y(i) enddo return end subroutine sub(m,x,y,z) c subtracting a vector y from a vector x integer m double precision x(m),y(m),z(m) integer i do i=1,m z(i)=x(i)-y(i) enddo return end subroutine comb(m,x,a,y,z) c linear combination of 2 vectors z[] := x[] + a* y[] integer m double precision a, x(m),y(m),z(m) integer i do i=1,m z(i)=x(i)+a*y(i) enddo return end subroutine multiplyvector(m,a,x,y) c multiplying matrix times vector y := A . x integer m double precision a(m,m),x(m),y(m) integer i,j do i=1,m y(i) = 0d0 do j=1,m y(i)=y(i)+a(i,j)*x(j) enddo enddo return end integer function log2(x) c the least integer larger than log_2(x) double precision x log2=0 8 log2 = log2+1 if(dble(2**log2).lt.x) goto 8 return end integer function nfact(n) c factorial function integer n integer i nfact=1 do i=1,n nfact=nfact*i enddo return end double precision function c(n,k) c kth coefficient in the nth Pade polynom integer n,k double precision padenom, padedenom integer nfact padenom=dble(nfact(2*n-k)*nfact(n)) padedenom=dble(nfact(2*n)*nfact(k)*nfact(n-k)) c=padenom/padedenom return end expm/src/matrexp.f0000644000176200001440000002206312470350137013646 0ustar liggesuserscccc-*- mode: fortran; kept-old-versions: 12; kept-new-versions: 20; -*- c This program computes exp(A) for a given matrix A. c c 2 algorithms are employed: c 1. The Taylor expansion of order "ntaylor," denoted by T(ntaylor). c 2. The Pade diagonal approximation of order c "npade" denoted by P(npade), is used instead, IFF ntaylor = 0 c The algorithm is applied twice to calculate c T(ntaylor) and T(ntaylor+10) [or, when ntaylor=0, c to calculate P(npade) and P(npade+10)]. c An upper bound for the L2 norm of the Cauchy error c T(ntaylor+10)-T(ntaylor) [or, when ntaylor=0, c P(npade+10)-P(npade)] is computed. c The result exp(A) is returned via the first argument. c c This version works with R (i.e., is written as a subroutine) c c To use it, first do c % R SHLIB matrexp.f c to make the shared library matrexp.so c c and then in R, c > dyn.load("matrexp.so") c > .C("matrexp_",as.double(runif(9)), c as.integer(3),as.integer(0),as.integer(8)) c c (This is all done automatically in the R package 'expm'.) c subroutine matrexp(a, n, ntaylor, npade, accuracy) integer n, ntaylor, npade double precision a(n,n), accuracy c "n" is the order of the given matrix A c double precision sum(n,n), sol10(n,n) double precision dsqrt, dl1norm, dlinfnorm integer log2 integer npower, i,j c FIXME: consider computing c sqrt(dl1norm(n,a) * dlinfnorm(n,a)) c in one function -- no need for the two separate l*norm() functions c npower= log2(dsqrt(dl1norm(n,a)*dlinfnorm(n,a))) + 4 c c Use the algorithm to compute T(ntaylor) or P(npade) c if(ntaylor.gt.0)then call taylor(n,ntaylor,npower,a,sum) else call pade(n,npade,npower,a,sum) endif c c computing the "solution" T(ntaylor+10) or P(npade+10) c if(ntaylor.gt.0) then call taylor(n,ntaylor+10,npower,a,sol10) else call pade(n,npade+10,npower,a,sol10) endif call powMat(n,sum, npower) c copy the result back into a c do i=1,n do j=1,n a(i,j) = sum(i,j) end do end do call powMat(n,sol10, npower) c c compute the Cauchy error T(ntaylor+10)- T(ntaylor) c or P(npade+10) - P(npade) c cc- BLAS: daxpy(m, alpha, x, 1, y, 1) : y := y + alpha*x c call subtract(n,sum,sol10, sum) accuracy = dsqrt(dl1norm(n,sum) * dlinfnorm(n,sum)) return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine taylor(m,ntaylor,npower,a,sum) c Taylor series for exp(a/2**npower) integer m, ntaylor, npower double precision a(m,m),sum(m,m) double precision T(m,m) integer nscale,n nscale=2**npower c print*,'A is scaled by 2**',npower,' =',nscale call identity(m, sum) do n=ntaylor,1,-1 C FIXME: use multScalAdd() instead of these three C ----- add tests for this taylor code !! --> ../tests/ex. call multiplymatrix(m,sum,a,T) call multiplyscalar(m,T,1.d0/dble(n*nscale),sum) call addtodiag(m,sum,1.d0) C --------- 1) multiplymatrix(., A,. B,. C) ; 2) multiplyscalar(., C, s, D) C 3) addtodiag (D, ., 1.0) C ---> D := s (A B) + Id() ---> do this directly via DGEMM : C D := Id() ; D := s * A B + 1 * D C__ almost: call multScalAdd(m, 1.d0/dble(n*nscale), sum,a, T) c NOTE: result must be 'sum' enddo return end subroutine pade(m,npade,npower,a,approx) c Pade approximation for exp(a/2**npower) integer m, npade, npower double precision a(m,m), approx(m,m) c Var double precision aminus(m,m),T(m,m) double precision padenom(m,m),padedenom(m,m) integer nscale,n,i nscale=2**npower c print*,'A is scaled by 2**',npower,' =',nscale call identity(m,padenom) call identity(m,padedenom) do n=npade,1,-1 call multiplymatrix(m,padenom,a,T) call multiplyscalar(m,T, $ dble(npade-n+1)/dble(n*(2*npade-n+1)*nscale),padenom) call addtodiag(m,padenom,1.d0) enddo call minus(m,a,aminus) do n=npade,1,-1 call multiplymatrix(m,padedenom,aminus,T) call multiplyscalar(m,T, $ dble(npade-n+1)/dble(n*(2*npade-n+1)*nscale),padedenom) call addtodiag(m,padedenom,1.d0) enddo do i=1,m call solve(m,padedenom,padenom(1,i),approx(1,i)) end do return end c MM: FIXME: Use BLAS for the following !!! c ----- (also R internal things --> use C, not Fortran ! c initializing an identity matrix subroutine identity(m,x) integer m double precision x(m,m) integer i,j do i=1,m do j=1,m x(i,j)= 0d0 enddo x(i,i)= 1d0 enddo return end C-- NOTA BENE: We also have C --------- 1) multiplymatrix(., A,. B,. C) ; 2) multiplyscalar(., C, s, D) C 3) addtodiag (D, ., 1.0) C ---> D := s (A B) + Id() ---> do this directly via DGEMM : C D := Id() ; D := s * A B + 1 * D subroutine multScalAdd(m,s, x,y,z) integer m double precision x(m,m),y(m,m),z(m,m), s c GEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC ) c C := alpha * AB + beta * C call identity(m, z) call dgemm('N','N', m,m,m, s, x, m, y, m, 1.d0, z, m) return end c DSCAL ( N, ALPHA, X, 1) : x <- alpha * x (x = x[1:n]) c FIXME: replace by using DSCAL : subroutine multiplyscalar(m,x,s,y) c multiplying a matrix x by a scalar s Y := s X integer m double precision x(m,m),y(m,m), s integer i,j do i=1,m do j=1,m y(i,j)=x(i,j)*s enddo enddo return end c DGEMM (TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC ) c C := alpha A B + beta C subroutine multiplymatrix(m,x,y,z) c multiplying two m x m matrices Z := X %*% Y integer m double precision x(m,m),y(m,m),z(m,m) c GEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC ) c C := a * AB + b * C call dgemm('N','N', m,m,m, 1.d0, x, m, y, m, 0.d0, z, m) return end subroutine powMat(m,x,ipower) c Compute x ^ (2^i) -- by simple squaring integer m, ipower double precision x(m,m) double precision xx(m,m) integer i, m2 m2 = m*m call dcopy(m2, x,1, xx,1) do i=1,ipower call multiplymatrix(m,xx,xx,x) if(i .lt. ipower) call dcopy(m2, x,1, xx,1) enddo return end cc-- BLAS: daxpy(m, alpha, x, 1, y, 1) : y := y + alpha*x C this is now in mexp-common.f -- FIXME: use daxpy() or ... c c subroutine comb(m, x,a,y, z) c ---- c linear combination of 2 vectors z[] := x[] + a* y[] C BLAS DDOT ( N, X, INCX, Y, INCY ) --- inner product X' Y subroutine solve(m,A,f,x) c CGS iteration integer m double precision A(m,m), f(m), x(m) c double precision save(m),rcgs(m),r(m) double precision p(m),u(m) double precision rbar(m),v(m),q(m) external dnrm2, ddot double precision dnrm2, ddot double precision alpha, beta, thresh, eps, eta, omega0,omega1, + omegainit, rho0,rho1, scalar,sigma, tau,vv integer l thresh=1.d-100 eps=1.d-30 call zero(m,x) call dcopy(m, f,1, r, 1) call dcopy(m, r,1, rcgs,1) call dcopy(m, r,1, p, 1) call dcopy(m, r,1, u, 1) omega0= dnrm2(m,rcgs, 1) omegainit=omega0 c print*,'res0=',dabs(omegainit) tau=omega0 vv=0.d0 eta=0.d0 call dcopy(m, r,1, rbar,1) rho0= ddot(m, rbar,1, r,1) if(dabs(rho0).le.thresh)then c print*,'rho0=',rho0,' MG iteration number=1' return endif do 10 l=1,m call multiplyvector(m,A,p,v) sigma=ddot(m, rbar,1, v,1) if(dabs(sigma).le.thresh)then c print*,'sigma=',sigma,' iteration number=',2*l+1 return endif alpha=rho0/sigma if(dabs(alpha).le.thresh)then c print*,'alpha=',alpha,' iteration number=',2*l+1 return endif scalar=-alpha call comb(m,u,scalar,v,q) call add(m,u,q,v) call multiplyvector(m,A,v,save) call comb(m,rcgs,scalar,save,rcgs) omega1=dnrm2(m,rcgs, 1) call comb(m,x,alpha,v,x) c print*,'residual=',dabs(omega1),' iteration number=',2*l+1 if(dabs(omega1/omegainit).le.eps)then c print*,'iteration number=',2*l+1 return endif omega0=omega1 rho1=ddot(m, rbar,1, rcgs,1) if(dabs(rho1).le.thresh)then c print*,'rho1=',rho1,' iteration number=',2*l+1 return endif beta=rho1/rho0 rho0=rho1 c u[] := rcgs[] + beta q[] call comb(m,rcgs,beta,q,u) c save[] := q[] + beta p[] call comb(m,q,beta,p,save) c p[] := u[] + beta save[] = (rcgs[] + beta q[]) + beta(q[] + beta p[]) call comb(m,u,beta,save,p) c print*,'iteration number=',2*l+1 10 continue return end expm/src/R_NLS_locale.h0000644000176200001440000000023513444515240014421 0ustar liggesusers/* Localization */ #include #ifdef ENABLE_NLS #include #define _(String) dgettext ("expm", String) #else #define _(String) (String) #endif expm/src/expm.c0000644000176200001440000002144314655443440013144 0ustar liggesusers/* ===== File part of R package expm ===== * * Function to compute the matrix exponential * * exp(M) = sum(n = 0:Inf; M^n / n!), * * where M is an (n x n) matrix. * * The functions therein use LAPACK and BLAS routines. Nicely * formatted man pages for these can be found at * * * * AUTHORS: Vincent Goulet , Christophe * Dutang, based on code in package Matrix. */ #include "expm.h" /* For matrix exponential calculations. Pade constants * * n_{pqj} = [(p + q - j)! p!]/[(p + q)! j! (p - j)!] * * and * * d_{pqj} = [(p + q - j)! q!]/[(p + q)! j! (q - j)!] * * for p = q = 8 and j = 1, ..., 8. */ const static double padec88 [] = { 5.0000000000000000e-1, 1.1666666666666667e-1, 1.6666666666666667e-2, 1.6025641025641026e-3, 1.0683760683760684e-4, 4.8562548562548563e-6, 1.3875013875013875e-7, 1.9270852604185938e-9, }; /* Matrix exponential exp(x), where x is an (n x n) matrix. Result z * is an (n x n) matrix. Mostly lifted from the core of fonction * expm() of package Matrix, which is itself based on the function of * the same name in Octave. */ void expm(double *x, int n, double *z, precond_type precond_kind) { if (n == 1) z[0] = exp(x[0]); /* scalar exponential */ else { /* Constants */ const double one = 1.0, zero = 0.0; const int i1 = 1, nsqr = n * n, np1 = n + 1; const Rboolean do_scale = (precond_kind == Ward_2 || precond_kind == Ward_buggy_octave); /* Variables */ int i, j, is_uppertri = TRUE;; int ilo, ihi, iloscal, ihiscal, info, sqrpowscal; double infnorm, trshift, m1pj = -1; /* Arrays */ int *pivot = (int *) R_alloc(n, sizeof(int)); /* pivot vector */ double *scale = do_scale ? (double *) R_alloc(n, sizeof(double)) : NULL; /* scale array */ double *perm = (double *) R_alloc(n, sizeof(double));/* permutation/sc array */ double *work = (double *) R_alloc(nsqr, sizeof(double)); /* workspace array */ double *npp = (double *) R_alloc(nsqr, sizeof(double)); /* num. power Pade */ double *dpp = (double *) R_alloc(nsqr, sizeof(double)); /* denom. power Pade */ Memcpy(z, x, nsqr); /* Check if matrix x is upper triangular; stop checking as * soon as a non-zero value is found below the diagonal. */ for (i = 0; i < n - 1 && is_uppertri; i++) for (j = i + 1; j < n; j++) if (!(is_uppertri = x[i * n + j] == 0.0)) break; /* Step 1 of preconditioning: shift diagonal by average diagonal. */ trshift = 0.0; for (i = 0; i < n; i++) trshift += x[i * np1]; trshift /= n; /* average diagonal element */ if (trshift > 0.0) for (i = 0; i < n; i++) z[i * np1] -= trshift; /* Step 2 of preconditioning: balancing with dgebal. */ if(do_scale) { if (is_uppertri) { /* no need to permute if x is upper triangular */ ilo = 1; ihi = n; } else { F77_CALL(dgebal)("P", &n, z, &n, &ilo, &ihi, perm, &info FCONE); if (info) error(_("LAPACK routine dgebal returned info code %d when permuting"), info); } F77_CALL(dgebal)("S", &n, z, &n, &iloscal, &ihiscal, scale, &info FCONE); if (info) error(_("LAPACK routine dgebal returned info code %d when scaling"), info); } else if(precond_kind == Ward_1) { F77_CALL(dgebal)("B", &n, z, &n, &ilo, &ihi, perm, &info FCONE); if (info) error(_("LAPACK' dgebal(\"B\",.) returned info code %d"), info); } else { error(_("invalid 'precond_kind: %d"), precond_kind); } /* Step 3 of preconditioning: Scaling according to infinity * norm (a priori always needed). */ infnorm = F77_CALL(dlange)("I", &n, &n, z, &n, work FCONE); sqrpowscal = (infnorm > 0) ? imax2((int) 1 + log(infnorm)/M_LN2, 0) : 0; if (sqrpowscal > 0) { double scalefactor = R_pow_di(2, sqrpowscal); for (i = 0; i < nsqr; i++) z[i] /= scalefactor; } /* Pade approximation (p = q = 8): compute x^8, x^7, x^6, * ..., x^1 */ for (i = 0; i < nsqr; i++) { npp[i] = 0.0; dpp[i] = 0.0; } for (j = 7; j >= 0; j--) { /* npp = z * npp + padec88[j] * z */ F77_CALL(dgemm) ("N", "N", &n, &n, &n, &one, z, &n, npp, &n, &zero, work, &n FCONE FCONE); /* npp <- work + padec88[j] * z */ for (i = 0; i < nsqr; i++) npp[i] = work[i] + padec88[j] * z[i]; /* dpp = z * dpp + (-1)^j * padec88[j] * z */ F77_CALL(dgemm) ("N", "N", &n, &n, &n, &one, z, &n, dpp, &n, &zero, work, &n FCONE FCONE); for (i = 0; i < nsqr; i++) dpp[i] = work[i] + m1pj * padec88[j] * z[i]; m1pj *= -1; /* (-1)^j */ } /* power 0 */ for (i = 0; i < nsqr; i++) dpp[i] *= -1.0; for (j = 0; j < n; j++) { npp[j * np1] += 1.0; dpp[j * np1] += 1.0; } /* Pade approximation is (dpp)^-1 * npp. */ F77_CALL(dgetrf) (&n, &n, dpp, &n, pivot, &info); if (info) error(_("LAPACK routine dgetrf returned info code %d"), info); F77_CALL(dgetrs) ("N", &n, &n, dpp, &n, pivot, npp, &n, &info FCONE); if (info) error(_("LAPACK routine dgetrs returned info code %d"), info); Memcpy(z, npp, nsqr); /* Now undo all of the preconditioning */ /* Preconditioning 3: square the result for every power of 2 */ while (sqrpowscal--) { F77_CALL(dgemm)("N", "N", &n, &n, &n, &one, z, &n, z, &n, &zero, work, &n FCONE FCONE); Memcpy(z, work, nsqr); } /* Preconditioning 2: Inversion of 'dgebal()' : * ------------------ Note that dgebak() seems *not* applicable */ /* Step 2 a) apply inverse scaling */ if(do_scale) { for (j = 0; j < n; j++) for (i = 0; i < n; i++) z[i + j * n] *= scale[i]/scale[j]; } else if(precond_kind == Ward_1) { /* here, perm[ilo:ihi] contains scale[] */ for (j = 0; j < n; j++) { double sj = ((ilo-1 <= j && j < ihi)? perm[j] : 1.); for (i = 0; i < ilo-1; i++) z[i + j * n] /= sj; for (i = ilo-1; i < ihi; i++) z[i + j * n] *= perm[i]/sj; for (i = ihi+1; i < n; i++) z[i + j * n] /= sj; } } /* 2 b) Inverse permutation (if not the identity permutation) */ if (ilo != 1 || ihi != n) { if(precond_kind == Ward_buggy_octave) { /* inverse permutation vector */ int *invP = (int *) R_alloc(n, sizeof(int)); /* balancing permutation vector */ for (i = 0; i < n; i++) invP[i] = i; /* identity permutation */ /* leading permutations applied in forward order */ for (i = 0; i < (ilo - 1); i++) { int p_i = (int) (perm[i]) - 1; int tmp = invP[i]; invP[i] = invP[p_i]; invP[p_i] = tmp; } /* trailing permutations applied in reverse order */ for (i = n - 1; i >= ihi; i--) { int p_i = (int) (perm[i]) - 1; int tmp = invP[i]; invP[i] = invP[p_i]; invP[p_i] = tmp; } /* construct inverse balancing permutation vector */ Memcpy(pivot, invP, n); for (i = 0; i < n; i++) invP[pivot[i]] = i; /* apply inverse permutation */ Memcpy(work, z, nsqr); for (j = 0; j < n; j++) for (i = 0; i < n; i++) z[i + j * n] = work[invP[i] + invP[j] * n]; } else if(precond_kind == Ward_2 || precond_kind == Ward_1) { /* ---- new code by Martin Maechler ----- */ #define SWAP_ROW(I,J) F77_CALL(dswap)(&n, &z[(I)], &n, &z[(J)], &n) #define SWAP_COL(I,J) F77_CALL(dswap)(&n, &z[(I)*n], &i1, &z[(J)*n], &i1) #define RE_PERMUTE(I) \ int p_I = (int) (perm[I]) - 1; \ SWAP_COL(I, p_I); \ SWAP_ROW(I, p_I) /* reversion of "leading permutations" : in reverse order */ for (i = (ilo - 1) - 1; i >= 0; i--) { RE_PERMUTE(i); } /* reversion of "trailing permutations" : applied in forward order */ for (i = (ihi + 1) - 1; i < n; i++) { RE_PERMUTE(i); } } /* else if(precond_kind == Ward_1) { */ /* } */ } /* Preconditioning 1: Trace normalization */ if (trshift > 0) { double mult = exp(trshift); for (i = 0; i < nsqr; i++) z[i] *= mult; } } } /* Main function, the only one used by .External(). */ SEXP do_expm(SEXP x, SEXP kind) { SEXP dims, z; int n, nprot = 0; double *rx, *rz; const char *ch_kind = CHAR(asChar(kind)); precond_type PC_kind = Ward_2 /* -Wall */; if (!isNumeric(x) || !isMatrix(x)) error(_("invalid argument: not a numeric matrix")); if (isInteger(x)) { x = PROTECT(coerceVector(x, REALSXP)); nprot++; } rx = REAL(x); if(!strcmp(ch_kind, "Ward77")) { PC_kind = Ward_2; } else if(!strcmp(ch_kind, "buggy_Ward77")) { PC_kind = Ward_buggy_octave; } else if(!strcmp(ch_kind, "Ward77_1")) { PC_kind = Ward_1; } else error(_("invalid 'kind' argument: %s\n"), ch_kind); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; if (n != INTEGER(dims)[1]) error(_("non-square matrix")); if (n == 0) { UNPROTECT(nprot); return(allocMatrix(REALSXP, 0, 0)); } PROTECT(z = allocMatrix(REALSXP, n, n)); nprot++; rz = REAL(z); expm(rx, n, rz, PC_kind); /* ---- */ setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(nprot); return z; } expm/src/logm-eigen.c0000644000176200001440000001773314655437322014227 0ustar liggesusers/* ===== File part of R package expm ===== * * Function to compute the matrix logarithm * * log(M) = L such that * * M = exp(L) where * * exp(L) = sum(n = 0:Inf; L^n / n!), * * where M and L are an (n x n) matrix. * * The functions therein use LAPACK and BLAS routines. Nicely * formatted man pages for these can be found at * * * * AUTHORS: Christophe Dutang, based on code eigen, * * i.e., function 'modLa_rg' and 'modLa_dgesv' in R's * /src/modules/lapack/lapack.c, used in eigen() */ #include "logm-eigen.h" void logm_eigen(double *x, int n, double *z, double tol) { if (n == 1) z[0] = log(x[0]); /* scalar logarithm */ else { const int nsqr = n * n; const Rcomplex cone = { .r = 1., .i = 0.}, czero = { .r = 0., .i = 0.}; int i, j; int info, lwork, is_conjug, is_diag; double onenorm, rcond, tmp; /* Arrays */ int *ipiv = (int *) R_alloc(n, sizeof(int)); /* permutation vector */ double *left, *right, *workdiag; /* left and right eigenvectors and workspace for diagonalisation */ double *wR = (double *) R_alloc(n, sizeof(double)); /* real part of eigenvalues */ double *wI = (double *) R_alloc(n, sizeof(double)); /* imaginary part of eigenvalues */ double *rworksing = (double *) R_alloc(2*n, sizeof(double)); /* working vector to test the singularity */ Rcomplex *eigvect = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* (right) eigenvectors matrix */ Rcomplex *eigvectinv = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* its inverse */ Rcomplex *logeigval; /* complex matrix diag(log(eigenvalues)) */ Rcomplex *ctmp = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* temp working variable */ Rcomplex *worksing = (Rcomplex *) R_alloc(2*n, sizeof(Rcomplex)); /* workspace to test the singularity */ Memcpy(z, x, nsqr); /* Test if x is diagonalisable by computing its eigenvalues and (right) eigenvectors */ /* code based on modLa_rg in lapack.c, used in eigen.R */ left = (double *) 0; right = (double *) R_alloc(nsqr, sizeof(double)); /* 1 - ask for optimal size of work array */ lwork = -1; F77_CALL(dgeev)("N", "V", &n, z, &n, wR, wI, left, &n, right, &n, &tmp, &lwork, &info FCONE FCONE); if (info != 0) error(_("error code %d from Lapack routine dgeev"), info); lwork = (int) tmp; workdiag = (double *) R_alloc(lwork, sizeof(double)); /* 2 - compute eigenvalues and (right) eigenvectors */ F77_CALL(dgeev)("N", "V", &n, z, &n, wR, wI, left, &n, right, &n, workdiag, &lwork, &info FCONE FCONE); if (info != 0) error(_("error code %d from Lapack routine dgeev"), info); /* try to invert the eigenvectors matrix */ /* 1 - build the Rcomplex matrix with eigenvectors */ for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { is_conjug = 0; if(i < n-1) { /* conjugate eigenvalues */ if(wR[i] == wR[i+1] && wI[i] == -wI[i+1] && wI[i] != 0.0) { is_conjug = 1; eigvect[i * n + j].r = right[i * n + j]; eigvect[i * n + j].i = right[(i+1) * n + j]; } } if(i > 0) { /* conjugate eigenvalues */ if(wR[i] == wR[i-1] && wI[i] == -wI[i-1] && wI[i] != 0.0) { is_conjug = 1; eigvect[i * n + j].r = right[(i-1) * n + j]; eigvect[i * n + j].i = -right[i * n + j]; } } /* real eigenvalues */ if(!is_conjug) { eigvect[i * n + j].r = right[i * n + j]; eigvect[i * n + j].i = 0.0; } /* eigvectinv initialise with the identity matrix */ eigvectinv[i * n +j].r = (i == j) ? 1.0 : 0.0; eigvectinv[i * n +j].i = 0.0; } } /* 2 - store the matrix eigvect (because function zgesv will change it) */ Memcpy(ctmp, eigvect, nsqr); /* 3 - solve a linear complex equation system with eigvectinv equals * to matrix identity. hence, on exit eigvectinv contains the * inverse of complex matrix eigvect. code base on solve.R */ F77_CALL(zgesv)(&n, &n, eigvect, &n, ipiv, eigvectinv, &n, &info); if (info > 0) is_diag = 0; //matrix eigvect is exactly singular. if (info < 0) error(_("argument %d of Lapack routine dgesv had invalid value"), -info); if (info == 0) is_diag = 1; /* check if matrix eigvectinv is numerically singular */ if (is_diag) { /* compute the reciprocal condition number of eigvectinv. */ /* 1 - compute the one norm of the matrix eigvectinv */ onenorm = F77_CALL(zlange)("1", &n, &n, eigvectinv, &n, (double*) NULL FCONE); /* 2 - estimates the reciprocal of the condition number * when the one norm is used. */ F77_CALL(zgecon)("1", &n, eigvectinv, &n, &onenorm, &rcond, worksing, rworksing, &info FCONE); if (rcond < tol) is_diag=0; } if (is_diag) { /* x is diagonalisable so * compute complex matrix operations : * eigvect %*% diag(log(eigenvalues)) %*% eigvectinv */ /* 1 - logeigval is the complex matrix diag(log(eigenvalues)) */ /* code based on z_log in complex.c */ logeigval = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { if(i == j) { logeigval[i * n +j].r = log( sqrt(wR[i] * wR[i] + wI[i] * wI[i]) ) ; logeigval[i * n +j].i = atan2( wI[i], wR[i] ) ; } else { logeigval[i * n +j].r = 0.0; logeigval[i * n +j].i = 0.0; } } } /* 2 - restore the matrix eigvect */ Memcpy(eigvect, ctmp, nsqr); /* 3 - compute (complex) matrix product: ctmp <- eigvect * logeigval */ F77_CALL(zgemm)("N", "N", &n, &n, &n, &cone, eigvect, &n, logeigval, &n, &czero, ctmp, &n FCONE FCONE); /* 4 - compute (complex) matrix product: logeigval <- ctmp * eigvectinv */ F77_CALL(zgemm)("N", "N", &n, &n, &n, &cone, ctmp, &n, eigvectinv, &n, &czero, logeigval, &n FCONE FCONE); //TOCHECK /* store the real part in z */ /* the matrix logarithm is always real, * even if x has complex eigen values. */ for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { z[i * n + j] = logeigval[i * n + j].r; // Rprintf(" %f \t", logeigval[i * n + j].i); } } } else error("non diagonalisable matrix"); } } /* Main function, the only one used by .Call(). */ SEXP do_logm_eigen(SEXP x, SEXP tolin) { SEXP dims, z; int n, m; double *rx = REAL(x), *rz; double tol = asReal(tolin); if (!isNumeric(x) || !isMatrix(x)) error(_("invalid argument")); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; m = INTEGER(dims)[0]; if (n != m) error(_("non-square matrix")); if (n == 0) return(allocVector(REALSXP, 0)); PROTECT(z = allocMatrix(REALSXP, n, n)); rz = REAL(z); logm_eigen(rx, n, rz, tol); setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(1); return z; } expm/src/init.c0000644000176200001440000000267414655414337013146 0ustar liggesusers/* * Native routines registration */ #include #include #include // for NULL #include #include "expm-eigen.h" #include "expm.h" #include "logm-eigen.h" #include "matpow.h" static const R_CallMethodDef CallEntries[] = { {"do_expm", (DL_FUNC) &do_expm, 2}, {"R_matpow", (DL_FUNC) &R_matpow, 2}, {"R_dgebal", (DL_FUNC) &R_dgebal, 2}, {"R_zgebal", (DL_FUNC) &R_zgebal, 2}, {"do_expm_eigen", (DL_FUNC) &do_expm_eigen, 2}, {"do_logm_eigen", (DL_FUNC) &do_logm_eigen, 2}, {"R_matexp_MH09", (DL_FUNC) &R_matexp_MH09, 2}, {NULL, NULL, 0} }; static const R_FortranMethodDef FortEntries[] = { {"matexpRBS", (DL_FUNC) &F77_SUB(matexprbs), 5}, // ./matexp.f {"matrexp", (DL_FUNC) &F77_SUB(matrexp), 5}, // ./matrexp.f {"matrexpO", (DL_FUNC) &F77_SUB(matrexpo), 5}, // ./matrexpO.f {NULL, NULL, 0} }; void R_init_expm(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, FortEntries, NULL); R_useDynamicSymbols(dll, FALSE); /* callable C code from other packages C code :*/ R_RegisterCCallable("expm", "expm", (DL_FUNC) expm); R_RegisterCCallable("matpow", "matpow", (DL_FUNC) matpow); R_RegisterCCallable("expm_eigen", "expm_eigen", (DL_FUNC) expm_eigen); R_RegisterCCallable("logm_eigen", "logm_eigen", (DL_FUNC) logm_eigen); R_RegisterCCallable("matexp_MH09", "matexp_MH09", (DL_FUNC) matexp_MH09); } expm/src/expm.h0000644000176200001440000000202314655414337013145 0ustar liggesusers #ifndef R_PKG_EXPM_H #define R_PKG_EXPM_H #define USE_FC_LEN_T #include #include #ifndef FCONE # define FCONE #endif #include #include #include #include #include "R_NLS_locale.h" typedef enum {Ward_2, Ward_1, Ward_buggy_octave} precond_type; SEXP R_dgebal(SEXP x, SEXP type); SEXP R_zgebal(SEXP x, SEXP type); SEXP do_expm(SEXP x, SEXP kind); void expm(double *x, int n, double *z, precond_type precond_kind); SEXP R_matexp_MH09(SEXP x, SEXP p); void matexp_MH09(double *x, int n, const int p, double *ret); // The legacy code: ----------------------------- // matexp.f: matexpRBS << is what I'd want int F77_NAME(matexprbs)(int *ideg, int *m, double *t, double *H, int *iflag); // matrexp.f: int F77_NAME(matrexp)(double* a, int* n, int* ntaylor, int* npade, double* accuracy); // matrexpO.f: matrexpO << is what I'd want int F77_NAME(matrexpo)(double* a, int* n, int* ntaylor, int* npade, double* accuracy); #endif /* R_PKG_EXPM_H */ expm/src/Makevars0000644000176200001440000000032214655437322013516 0ustar liggesusers# as for a -*- Makefile -*- we use the BLAS and the LAPACK library: PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) # want CMPLX() which needs C11 standard # (ok, not yet:) #CFLAGS = "-std=C11 $(CFLAGS)" expm/src/expm-eigen.c0000644000176200001440000001765314655437322014243 0ustar liggesusers/* ===== File part of R package expm ===== * * Function to compute the matrix exponential * * exp(M) = sum(n = 0:Inf; M^n / n!), * * where M is an (n x n) matrix. * * The functions therein use LAPACK and BLAS routines. Nicely * formatted man pages for these can be found at * * * * AUTHORS: Christophe Dutang, based on code eigen, * * i.e., function 'modLa_rg' and 'modLa_dgesv' in R's * /src/modules/lapack/lapack.c, used in eigen() */ #include "expm-eigen.h" void expm_eigen(double *x, int n, double *z, double tol) { if (n == 1) z[0] = exp(x[0]); /* scalar exponential */ else { const int nsqr = n * n; const Rcomplex cone = { .r = 1., .i = 0.}, czero = { .r = 0., .i = 0.}; int i, j; int info, lwork, is_conjug, is_diag; double onenorm, rcond, tmp; /* Arrays */ int *ipiv = (int *) R_alloc(n, sizeof(int)); /* permutation vector */ double *left, *right, *workdiag; /* left and right eigenvectors and workspace for diagonalisation */ double *wR = (double *) R_alloc(n, sizeof(double)); /* real part of eigenvalues */ double *wI = (double *) R_alloc(n, sizeof(double)); /* imaginary part of eigenvalues */ double *rworksing = (double *) R_alloc(2*n, sizeof(double)); /* working vector to test the singularity */ Rcomplex *eigvect = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* (right) eigenvectors matrix */ Rcomplex *eigvectinv = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* its inverse */ Rcomplex *expeigval; /* complex matrix diag(exp(eigenvalues)) */ Rcomplex *ctmp = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); /* temp working variable */ Rcomplex *worksing = (Rcomplex *) R_alloc(2*n, sizeof(Rcomplex)); /* workspace to test the singularity */ Memcpy(z, x, nsqr); /* Test if x is diagonalisable by computing its eigenvalues and (right) eigenvectors */ /* code based on modLa_rg in lapack.c, used in eigen.R */ left = (double *) 0; right = (double *) R_alloc(nsqr, sizeof(double)); /* 1 - ask for optimal size of work array */ lwork = -1; F77_CALL(dgeev)("N", "V", &n, z, &n, wR, wI, left, &n, right, &n, &tmp, &lwork, &info FCONE FCONE); if (info != 0) error(_("error code %d from Lapack routine dgeev"), info); lwork = (int) tmp; workdiag = (double *) R_alloc(lwork, sizeof(double)); /* 2 - compute eigenvalues and (right) eigenvectors */ F77_CALL(dgeev)("N", "V", &n, z, &n, wR, wI, left, &n, right, &n, workdiag, &lwork, &info FCONE FCONE); if (info != 0) error(_("error code %d from Lapack routine dgeev"), info); /* try to invert the eigenvectors matrix */ /* 1 - build the Rcomplex matrix with eigenvectors */ for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { is_conjug = 0; if(i < n-1) { /* conjugate eigenvalues */ if(wR[i] == wR[i+1] && wI[i] == -wI[i+1] && wI[i] != 0.0) { is_conjug = 1; eigvect[i * n + j].r = right[i * n + j]; eigvect[i * n + j].i = right[(i+1) * n + j]; } } if(i > 0) { /* conjugate eigenvalues */ if(wR[i] == wR[i-1] && wI[i] == -wI[i-1] && wI[i] != 0.0) { is_conjug = 1; eigvect[i * n + j].r = right[(i-1) * n + j]; eigvect[i * n + j].i = -right[i * n + j]; } } /* real eigenvalues */ if(!is_conjug) { eigvect[i * n + j].r = right[i * n + j]; eigvect[i * n + j].i = 0.0; } /* eigvectinv initialise with the identity matrix */ eigvectinv[i * n +j].r = (i == j) ? 1.0 : 0.0; eigvectinv[i * n +j].i = 0.0; } } /* 2 - store the matrix eigvect (because function zgesv will change it) */ Memcpy(ctmp, eigvect, nsqr); /* 3 - solve a linear complex equation system with eigvectinv equals * to matrix identity. hence, on exit eigvectinv contains the * inverse of complex matrix eigvect. code base on solve.R */ F77_CALL(zgesv)(&n, &n, eigvect, &n, ipiv, eigvectinv, &n, &info); if (info > 0) is_diag = 0; //matrix eigvect is exactly singular. if (info < 0) error(_("argument %d of Lapack routine dgesv had invalid value"), -info); if (info == 0) is_diag = 1; /* check if matrix eigvectinv is numerically singular */ if (is_diag) { /* compute the reciprocal condition number of eigvectinv. */ /* 1 - compute the one norm of the matrix eigvectinv */ onenorm = F77_CALL(zlange)("1", &n, &n, eigvectinv, &n, (double*) NULL FCONE); /* 2 - estimates the reciprocal of the condition number * when the one norm is used. */ F77_CALL(zgecon)("1", &n, eigvectinv, &n, &onenorm, &rcond, worksing, rworksing, &info FCONE); if (rcond < tol) is_diag=0; } if (is_diag) { /* x is diagonalisable so * compute complex matrix operations : * eigvect %*% diag(exp(eigenvalues)) %*% eigvectinv */ /* 1 - expeigval is the complex matrix diag(exp(eigenvalues)) */ /* code based on z_exp in complex.c */ expeigval = (Rcomplex *) R_alloc(nsqr, sizeof(Rcomplex)); for (i = 0; i < n; i++) { for (j = 0; j < n; j++) { if(i == j) { expeigval[i * n +j].r = exp(wR[i]) * cos(wI[i]); expeigval[i * n +j].i = exp(wR[i]) * sin(wI[i]); } else { expeigval[i * n +j].r = 0.0; expeigval[i * n +j].i = 0.0; } } } /* 2 - restore the matrix eigvect */ Memcpy(eigvect, ctmp, nsqr); /* 3 - compute (complex) matrix product: ctmp <- eigvect * expeigval */ F77_CALL(zgemm)("N", "N", &n, &n, &n, &cone, eigvect, &n, expeigval, &n, &czero, ctmp, &n FCONE FCONE); /* 4 - compute (complex) matrix product: expeigval <- ctmp * eigvectinv */ F77_CALL(zgemm)("N", "N", &n, &n, &n, &cone, ctmp, &n, eigvectinv, &n, &czero, expeigval, &n FCONE FCONE); /* store the real part in z */ /* the matrix exponential is always real, * even if x has complex eigen values. */ for (i = 0; i < n; i++) for (j = 0; j < n; j++) z[i * n + j] = expeigval[i * n + j].r; } else expm(x, n, z, Ward_2); } } /* Main function, the only one used by .Call(). */ SEXP do_expm_eigen(SEXP x, SEXP tolin) { SEXP dims, z; int n, nprot = 0; double *rx, *rz; double tol = asReal(tolin); if (!isNumeric(x) || !isMatrix(x)) error(_("invalid argument: not a numeric matrix")); if (isInteger(x)) { x = PROTECT(coerceVector(x, REALSXP)); nprot++; } rx = REAL(x); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; if (n != INTEGER(dims)[1]) error(_("non-square matrix")); if (n == 0) { UNPROTECT(nprot); return(allocMatrix(REALSXP, 0, 0)); } PROTECT(z = allocMatrix(REALSXP, n, n)); nprot++; rz = REAL(z); expm_eigen(rx, n, rz, tol); setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(nprot); return z; } expm/src/matexp.f0000644000176200001440000001320411652733737013475 0ustar liggesusers!-----------------------------------------------------------------------! ! ! ! V A R I O U S M A T H E M A T I C A L U T I L I T I E S ! ! ! ! FORTRAN 77 PROCEDURES ! !-----------------------------------------------------------------------! !-----------------------------------------------------------------------! subroutine matexpRBS (ideg, m, t, H, iflag) IMPLICIT NONE INTEGER ideg, m, iflag DOUBLE PRECISION t, H(m,m) !-----PURPOSE-----------------------------------------------------------! ! ! COMPUTES EXP(T*H), THE MATRIX EXPONENTIAL OF A GENERAL MATRIX IN ! FULL, USING THE IRREDUCIBLE RATIONAL PADE APPROXIMATION TO THE ! EXPONENTIAL FUNCTION EXP(X) = R(X) = (+/-)( I + 2*(Q(X)/P(X)) ), ! COMBINED WITH SCALING-AND-SQUARING. ! !-----ARGUMENTS---------------------------------------------------------! ! ! IDEG : (INPUT) THE DEGREE OF THE DIAGONAL PADE TO BE USED. ! A VALUE OF 6 IS GENERALLY SATISFACTORY. ! ! M : (INPUT) ORDER OF H. ! ! T : (INPUT) TIME-SCALE (CAN BE < 0). ! ! H(M,M) : (INPUT) ARGUMENT MATRIX. ! ! IFLAG : (OUTPUT) EXIT FLAG. ! 0 - NO PROBLEM ! <0 - PROBLEM ! !-----------------------------------------------------------------------! ! ROGER B. SIDJE (RBS@MATHS.UQ.EDU.AU) - 'RBS' ! EXPOKIT: SOFTWARE PACKAGE FOR COMPUTING MATRIX EXPONENTIALS. ! ACM - TRANSACTIONS ON MATHEMATICAL SOFTWARE, 24(1):130-156, 1998 !-----------------------------------------------------------------------! ! MODIFIED TO RETURN A FLAG INSTEAD OF TERMINATING, WHEN TRYING ! TO COMPUTE THE EXPONENTIAL OF A MATRIX WITH TOO LARGE ELEMENTS. ! ! 1) NIELS RODE KRISTENSEN, TECHNICAL UNIVERSITY OF DENMARK, 2000 ! 2) ANDREAS S. CHRISTENSEN,TECHNICAL UNIVERSITY OF DENMARK, 2006 ! 3) SREN KLIM, IMM-DTU, 2007 !-----------------------------------------------------------------------! ! INTEGER LWSP, NS, IPIV(M) DOUBLE PRECISION WSP(4*M*M+IDEG+1) INTEGER MM,I,J,K,IH2,IP,IQ,IUSED,IFREE,IODD,ICOEF,IPUT,IGET DOUBLE PRECISION HNORM,SCALE,SCALE2,CP,CQ ! "External" routines: INTRINSIC INT,ABS,DBLE,LOG,MAX !--- CHECK RESTRICTIONS ON INPUT PARAMETERS ... MM = M*M IFLAG = 0 LWSP = 4*M*M + IDEG +1 ! !--- INITIALISE POINTERS ... ! ICOEF = 1 IH2 = ICOEF + (IDEG+1) IP = IH2 + MM IQ = IP + MM IFREE = IQ + MM NS=0 ! !--- INITIALISE ARRAYS ... ! DO I = 1, LWSP WSP(I) = 0.0D0 ENDDO DO I = 1, M IPIV(I) = 0 ENDDO ! !--- SCALING: SEEK NS SUCH THAT ||T*H/2^NS|| < 1/2; ! AND SET SCALE = T/2^NS ... ! DO J = 1,M DO I = 1,M WSP(I) = WSP(I) + ABS( H(I,J) ) ENDDO ENDDO HNORM = 0.0D0 DO I = 1,M HNORM = MAX( HNORM,WSP(I) ) ENDDO HNORM = ABS( T*HNORM ) IF (HNORM .EQ. 0.D0) + CALL RExit('ERROR - NULL H IN INPUT OF DGPADM.') NS = MAX(0, INT(LOG(HNORM)/LOG(2.))+2) SCALE = T / DBLE(2**NS) SCALE2 = SCALE*SCALE ! !--- COMPUTE PADE COEFFICIENTS ... ! I = IDEG+1 J = 2*IDEG+1 WSP(ICOEF) = 1.0D0 DO K = 1,IDEG WSP(ICOEF+K) = (WSP(ICOEF+K-1)*DBLE( I-K ))/DBLE( K*(J-K) ) ENDDO ! !--- H2 = SCALE2*H*H ... ! CALL DGEMM( 'N','N',M,M,M,SCALE2,H,M,H,M,0.0D0,WSP(IH2),M ) ! !--- INITIALIZE P (NUMERATOR) AND Q (DENOMINATOR) ... ! CP = WSP(ICOEF+IDEG-1) CQ = WSP(ICOEF+IDEG) DO J = 1,M DO I = 1,M WSP(IP + (J-1)*M + I-1) = 0.0D0 WSP(IQ + (J-1)*M + I-1) = 0.0D0 ENDDO WSP(IP + (J-1)*(M+1)) = CP WSP(IQ + (J-1)*(M+1)) = CQ ENDDO ! !--- APPLY HORNER RULE ... ! IODD = 1 K = IDEG - 1 100 CONTINUE IUSED = IODD*IQ + (1-IODD)*IP CALL DGEMM( 'N','N',M,M,M, 1.0D0,WSP(IUSED),M, . WSP(IH2),M, 0.0D0,WSP(IFREE),M ) DO J = 1,M WSP(IFREE+(J-1)*(M+1)) = WSP(IFREE+(J-1)*(M+1))+WSP(ICOEF+K-1) ENDDO IP = (1-IODD)*IFREE + IODD*IP IQ = IODD*IFREE + (1-IODD)*IQ IFREE = IUSED IODD = 1-IODD K = K-1 IF ( K.GT.0 ) GOTO 100 ! !--- OBTAIN (+/-)(I + 2*(P\Q)) ... ! IF ( IODD .EQ. 1 ) THEN CALL DGEMM( 'N','N',M,M,M, SCALE,WSP(IQ),M, . H,M, 0.0D0,WSP(IFREE),M ) IQ = IFREE ELSE CALL DGEMM( 'N','N',M,M,M, SCALE,WSP(IP),M, . H,M, 0.0D0,WSP(IFREE),M ) IP = IFREE ENDIF CALL DAXPY( MM, -1.0D0,WSP(IP),1, WSP(IQ),1 ) CALL DGESV( M,M, WSP(IQ),M, IPIV, WSP(IP),M, IFLAG ) IF ( IFLAG.NE.0 ) CALL RWarn ('PROBLEM IN DGESV (WITHIN DGPADM)') CALL DSCAL( MM, 2.0D0, WSP(IP), 1 ) DO J = 1,M WSP(IP+(J-1)*(M+1)) = WSP(IP+(J-1)*(M+1)) + 1.0D0 ENDDO IPUT = IP IF ( NS.EQ.0 .AND. IODD.EQ.1 ) THEN CALL DSCAL( MM, -1.0D0, WSP(IP), 1 ) ELSE !--- SQUARING : EXP(T*H) = (EXP(T*H))^(2^NS) ... ! IODD = 1 DO K = 1,NS IGET = IODD*IP + (1-IODD)*IQ IPUT = (1-IODD)*IP + IODD*IQ CALL DGEMM( 'N','N',M,M,M, 1.0D0,WSP(IGET),M, WSP(IGET),M, . 0.0D0,WSP(IPUT),M ) IODD = 1-IODD ENDDO ENDIF !--- COPY EXP(H*T) into H DO I= 1,M DO J=1,M H(I,J) = WSP(IPUT +(I-1) + (J-1)*M) ENDDO ENDDO !-----------------------------------------------------------------------! END expm/src/R_dgebal.c0000644000176200001440000001156314655437322013676 0ustar liggesusers#include /* strlen(), toupper() .. */ #include "expm.h" static char ebal_type(const char *typstr) { if (strlen(typstr) != 1) error(_("argument type='%s' must be a character string of string length 1"), typstr); char typup = (char)toupper((int)*typstr); /* if (typup == '1') typup = 'O'; /\* alias *\/ */ if (typup != 'N' && typup != 'P' && typup != 'S' && typup != 'B') error(_("argument type='%s' must be one of 'N', 'P', 'S', or 'B'"), typstr); return typup; } SEXP R_dgebal(SEXP x, SEXP type) { SEXP dims, z, Scale, i_1, i_2, ans, nms; char typnm[] = {'\0', '\0'}; // only the first is changed; 2nd = final \0 string terminator int n, info, nprot = 2; if (!isNumeric(x) || !isMatrix(x)) // isNum : integer, logical, or double ("real") error(_("invalid 'x': not a numeric (classical R) matrix")); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; if (n != INTEGER(dims)[1]) error(_("non-square matrix")); typnm[0] = ebal_type(CHAR(asChar(type))); if (isInteger(x) || isLogical(x)) { nprot++; x = PROTECT(coerceVector(x, REALSXP)); } else if(n > 0 && typnm[0] == 'S') { /* FIXME: if 'x' contains +/- Inf dgebal() loops infinitely <==> LAPACK "bug" ----- fix in ..../R/src/modules/lapack/dlapack.f.~dgebal-Inf-patch~ But that does *not* help for external Lapack libraries */ double *dx = REAL(x), aMax = 0.; // aMax := max_{i,j} |x[i,j]| for(int i=0; i < n*n; i++) if(aMax < dx[i]) aMax = dx[i]; if(aMax == R_PosInf) error(_("R_dgebal(*, type=\"S\"): Infinite matrix entry")); } PROTECT(ans = allocVector(VECSXP, 4)); PROTECT(nms = allocVector(STRSXP, 4)); SET_STRING_ELT(nms, 0, mkChar("z")); SET_VECTOR_ELT(ans, 0, (z = duplicate(x))); /* permutation or scale array */ SET_STRING_ELT(nms, 1, mkChar("scale")); SET_VECTOR_ELT(ans, 1, (Scale = allocVector(REALSXP, n))); SET_STRING_ELT(nms, 2, mkChar("i1")); SET_VECTOR_ELT(ans, 2, (i_1 = allocVector(INTSXP, 1))); SET_STRING_ELT(nms, 3, mkChar("i2")); SET_VECTOR_ELT(ans, 3, (i_2 = allocVector(INTSXP, 1))); if(n > 0) { F77_CALL(dgebal)(typnm, &n, REAL(z), &n, INTEGER(i_1), INTEGER(i_2), REAL(Scale), &info FCONE); if (info) error(_("LAPACK's dgebal(%s) returned info code %d"), typnm, info); } setAttrib(ans, R_NamesSymbol, nms); /* now return list(z, scale[], i1, i2) */ UNPROTECT(nprot); return ans; } // R_dgebal() //-------------- Now for complex matrices ---------------------------- #include #include // CMPLX(.) "must be" in with 'C11' and newer, still -- fails on Winbuilder (2024-08-09) /* # ifndef CMPLX */ /* # define CMPLX(x, y) ((double complex)((double)(x) + _Imaginary_I * (double)(y))) */ /* # endif */ // rather for now (need only cabs(.)), this seems safer : #ifdef CMPLX static R_INLINE double R_cabs(Rcomplex z) { return cabs(CMPLX(z.r, z.i)); } #else // currently necessary on Winbuilder static R_INLINE double R_cabs(Rcomplex z) { return hypot(z.r, z.i); } #endif SEXP R_zgebal(SEXP x, SEXP type) { SEXP dims, z, Scale, i_1, i_2, ans, nms; char typnm[] = {'\0', '\0'}; // only the first is changed; 2nd = final \0 string terminator int n, info, nprot = 2; if (!isComplex(x) || !isMatrix(x)) error(_("invalid 'x': not a complex (classical R) matrix")); dims = getAttrib(x, R_DimSymbol); n = INTEGER(dims)[0]; if (n != INTEGER(dims)[1]) error(_("non-square matrix")); typnm[0] = ebal_type(CHAR(asChar(type))); if(n > 0 && typnm[0] == 'S') { /* FIXME: if 'x' contains +/- Inf dgebal() loops infinitely <==> LAPACK "bug" ----- fix in ..../R/src/modules/lapack/dlapack.f.~dgebal-Inf-patch~ But that does *not* help for external Lapack libraries */ Rcomplex *dx = COMPLEX(x); double aMax = 0.; // aMax := max_{i,j} |x[i,j]| for(int i=0; i < n*n; i++) { double ai = R_cabs(dx[i]); if(aMax < ai) aMax = ai; } if(aMax == R_PosInf) error(_("R_zgebal(*, type=\"S\"): Infinite matrix entry")); } PROTECT(ans = allocVector(VECSXP, 4)); PROTECT(nms = allocVector(STRSXP, 4)); SET_STRING_ELT(nms, 0, mkChar("z")); SET_VECTOR_ELT(ans, 0, (z = duplicate(x))); /* permutation or scale array */ SET_STRING_ELT(nms, 1, mkChar("scale")); SET_VECTOR_ELT(ans, 1, (Scale = allocVector(REALSXP, n))); SET_STRING_ELT(nms, 2, mkChar("i1")); SET_VECTOR_ELT(ans, 2, (i_1 = allocVector(INTSXP, 1))); SET_STRING_ELT(nms, 3, mkChar("i2")); SET_VECTOR_ELT(ans, 3, (i_2 = allocVector(INTSXP, 1))); if(n > 0) { F77_CALL(zgebal)(typnm, &n, COMPLEX(z), &n, INTEGER(i_1), INTEGER(i_2), REAL(Scale), &info FCONE); if (info) error(_("LAPACK's zgebal(%s) returned info code %d"), typnm, info); } setAttrib(ans, R_NamesSymbol, nms); /* now return list(z, scale[], i1, i2) */ UNPROTECT(nprot); return ans; } // R_zgebal() expm/src/logm-eigen.h0000644000176200001440000000035713704012703014210 0ustar liggesusers/* ===== File part of R package expm ===== * * logm-eigen.h * * Created by Christophe Dutang on 13/05/08. * */ #include "expm.h" SEXP do_logm_eigen(SEXP x, SEXP tolin); void logm_eigen(double *x, int n, double *z, double tol); expm/src/expm-eigen.h0000644000176200001440000000035713704012703014223 0ustar liggesusers/* ===== File part of R package expm ===== * * expm-eigen.h * * Created by Christophe Dutang on 27/02/08. * */ #include "expm.h" SEXP do_expm_eigen(SEXP x, SEXP tolin); void expm_eigen(double *x, int n, double *z, double tol); expm/src/matpow.h0000644000176200001440000000031214655414337013502 0ustar liggesusers#include "expm.h" /* The C API :*/ void matpow (double *x, int n, int k, double *z); void matpow_z(Rcomplex *x, int n, int k, Rcomplex *z); /* as .Call()ed from R */ SEXP R_matpow(SEXP x, SEXP k); expm/src/matexp_MH09.c0000644000176200001440000001704514655437322014233 0ustar liggesusers/* Copyright (C) 2014-2024 Martin Maechler Copyright (C) 2013-2014 Drew Schmidt This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, see . */ /* Matrix exponentiation algorithm from: "New Scaling and Squaring Algorithm for the Matrix Exponential", by Awad H. Al-Mohy and Nicholas J. Higham, August 2009 */ #include // #include #include "expm.h" #define SGNEXP(x,pow) (x==0?(pow==0?1:0):(x>0?1:(pow%2==0?1:(-1)))) // -------------------------------------------------------- // Utilities // -------------------------------------------------------- // C = A * B for square matrices static void matprod(int n, double *A, double *B, double *C) { const double one = 1.0, zero = 0.0; F77_CALL(dgemm)("N", "N", &n, &n, &n, &one, A, &n, B, &n, &zero, C, &n FCONE FCONE); } // Copy A ONTO B, i.e. B = A static inline void matcopy(int n, double *A, double *B) { F77_CALL(dlacpy)("A", &n, &n, A, &n, B, &n FCONE); // uplo = ^ } /** Identity matrix * * @param n integer >= 1 * @param a n x n pre-allocated to contain the identity matrix */ static inline void mateye(const unsigned int n, double *a) { int i; for (i=0; i norm) norm = tmp; } return norm; } #define NTHETA 5 static int matexp_scale_factor(const double *x, const int n) { const double theta[] = {1.5e-2, 2.5e-1, 9.5e-1, 2.1e0, 5.4e0}; const double x_1 = matnorm_1(x, n); // MM: the following seems logically wrong: the theta[0:3] are *not* really relevant, just need for (int i=0; i < NTHETA; i++) { if (x_1 <= theta[i]) return 0; } int i = (int) ceil(log2(x_1/theta[4])); return 1 << i; } // ___ MM: FIXME we have a matpow() already in ./matpow.c // --- Merge the two, keep the better one // Matrix power by squaring: P = A^b (A is garbage on exit) static void matpow_by_squaring(double *A, int n, int b, double *P) { if (b == 1) { matcopy(n, A, P); return; } mateye(n, P); // P := I if (b == 0) return; // General case: b >= 2 double *TMP = (double *) R_alloc(n*n, sizeof(double)); while (b) { if (b&1) { // P := P A matprod(n, P, A, TMP); matcopy(n, TMP, P); } b >>= 1; // A := A^2 : matprod(n, A, A, TMP); matcopy(n, TMP, A); } } // -------------------------------------------------------- // Matrix Exponentiation via Pade' Approximations // -------------------------------------------------------- const double matexp_pade_coefs[14] = { 1.0, 0.5, 0.12, 1.833333333333333333333e-2, 1.992753623188405797101e-3, 1.630434782608695652174e-4, 1.035196687370600414079e-5, 5.175983436853002070393e-7, 2.043151356652500817261e-8, 6.306022705717595115002e-10, 1.483770048404140027059e-11, 2.529153491597965955215e-13, 2.810170546219962172461e-15, 1.544049750670308885967e-17 }; /* r_m(x) = p_m(x) / q_m(x), where p_m(x) = sum_{j=0}^m (2m-j)!m!/(2m)!/(m-j)!/j! * x^j and q_m(x) = p_m(-x) */ // Workhorse for matexp_pade -- given C, do B := C & update (N, D) void matexp_pade_fillmats(const int m, const int n, const int i, double *N, double *D, double *B, const double *C) { const double tmp = matexp_pade_coefs[i]; const int sgn = SGNEXP(-1, i); /* Performs the following actions: B = C N += pade_coef[i] * C D += (-1)^i * pade_coef[i] * C */ for (int j=0; j < m*n; j++) { double t_j = C[j]; B[j] = t_j; t_j *= tmp; N[j] += t_j; D[j] += sgn*t_j; } } /** * Exponentiation via Pade' expansion * * @param n * @param p * @param A * @param N */ static void matexp_pade(int n, const int p, double *A, double *N) { int i, info = 0, n2 = n*n; // FIXME: check n2 (or n, such that n2 did not overflow !) // Power of A double *B = (double*) R_alloc(n2, sizeof(double)); // Temporary storage for matrix multiplication; matcopy(n, A, C); double *C = Memcpy((double*)R_alloc(n2, sizeof(double)), A, n2); double *D = (double*) R_alloc(n2, sizeof(double)); for (i=0; i 1) matprod(n, A, B, C); // Update matrices matexp_pade_fillmats(n, n, i, N, D, B, C); } // return N := inverse(D) %*% N ------------------- int *ipiv = (int *) R_alloc(n, sizeof(int)); /* assert(ipiv != NULL); */ F77_CALL(dgesv)(&n, &n, D, &n, ipiv, N, &n, &info); } // matexp_pade() /** * Matrix Exponential * * @param x Input (square) matrix. On exit, the values in x are "garbage"! * @param n Number of rows/cols of (square) matrix x. * @param p Order of the Pade' approximation. 0 < p <= 13. * @param ret On exit, ret = expm(x). */ void matexp_MH09(double *x, int n, const int p, double *ret) { int m = matexp_scale_factor(x, n); if (m == 0) { matexp_pade(n, p, x, ret); return; } // else, m >= 1 : int nn = n*n, one = 1; double tmp = 1. / ((double) m); F77_CALL(dscal)(&nn, &tmp, x, &one); matexp_pade(n, p, x, ret); matcopy(n, ret, x); matpow_by_squaring(x, n, m, ret); } #if 0 // >>>>>>>>>>> FIXME: Not yet, does not even compile -- (and hence not yet called) <<<<<<<<< void matexp_MH09_z(Rcomplex *x, int n, const int p, Rcomplex *ret) { int m = matexp_scale_factor(x, n); if (m == 0) { matexp_pade(n, p, x, ret); return; } int nn = n*n, one = 1; Rcomplex tmp = 1. / ((Rcomplex) m); F77_CALL(dscal)(&nn, &tmp, x, &one); matexp_pade(n, p, x, ret); matcopy(n, ret, x); matpow_by_squaring(x, n, m, ret); } #endif // -------------------------------------------------------- // R Wrapper // -------------------------------------------------------- SEXP R_matexp_MH09(SEXP x, SEXP p) { const int n = nrows(x), n2 = n*n; SEXP x_ = duplicate(x); PROTECT_INDEX xpi; PROTECT_WITH_INDEX(x_, &xpi); Rboolean is_C = isComplex(x); if(is_C) { } else if(!isReal(x)) /* coercion to 'Real' numeric */ REPROTECT(x_ = coerceVector(x_, REALSXP), xpi); SEXP R = PROTECT(allocMatrix(TYPEOF(x_), n, n)); if(isComplex(x)) { error(_("matexp_MH09(.) is _not yet_ implemented for complex matrices")); #if 0 // see above // MM{FIXME}: We have already duplicated x to x_ : this should *not* be needed: Rcomplex *x_cp = Memcpy((Rcomplex*)R_alloc(n2, sizeof(Rcomplex)), COMPLEX(x_), n2); matexp_MH09_z(x_cp, n, INTEGER(p)[0], COMPLEX(R)); # endif } else { // isReal(x_) // MM{FIXME}: We have already duplicated x to x_ : this should *not* be needed: double *x_cp = Memcpy((double*)R_alloc(n2, sizeof(double)), REAL(x_), n2); matexp_MH09(x_cp, n, INTEGER(p)[0], REAL(R)); } UNPROTECT(2); return R; } expm/src/matpow.c0000644000176200001440000000764514655414337013515 0ustar liggesusers/* * Power of a matrix x^k := x x ... x, where x in an (n x n) matrix * and k is an *integer*. Based on code originally written by Vincent * Goulet for package actuar (and inspired from Octave in file * .../src/xpow.cc) with slight shortcuts by Martin Maechler: */ #include "matpow.h" /* .Call() this from R : */ SEXP R_matpow(SEXP x, SEXP k) { if(!isMatrix(x)) { error(_("not a matrix")); /*-Wall */ return R_NilValue; } else { SEXP dims = getAttrib(x, R_DimSymbol); int n = INTEGER(dims)[0], k_ = INTEGER(k)[0]; /* need copy, as it is altered in matpow() */ if (n != INTEGER(dims)[1]) error(_("non-square matrix")); if (n == 0) return(allocMatrix(REALSXP, 0, 0)); SEXP z, x_ = duplicate(x); PROTECT_INDEX xpi; PROTECT_WITH_INDEX(x_, &xpi); if(isComplex(x)) { z = PROTECT(allocMatrix(CPLXSXP, n, n)); matpow_z(COMPLEX(x_), n, k_, COMPLEX(z)); } else { // real / double if (!isReal(x)) /* coercion to numeric */ REPROTECT(x_ = coerceVector(x_, REALSXP), xpi); z = PROTECT(allocMatrix(REALSXP, n, n)); matpow(REAL(x_), n, k_, REAL(z)); } setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(2); return z; } } /* Compute z := x %^% k, x an (n x n) square "matrix" in column-order; * NB: x will be altered! The caller must make a copy if needed */ void matpow(double *x, int n, int k, double *z) { if (k == 0) { /* return identity matrix */ int i, j; for (i = 0; i < n; i++) for (j = 0; j < n; j++) z[i * n + j] = (i == j) ? 1.0 : 0.0; return; } else if (k < 0) { error(_("power must be a positive integer; use solve() directly for negative powers")); } else { /* k >= 1 */ static const char *transa = "N"; static const double one = 1.0, zero = 0.0; size_t nSqr = n * ((size_t) n); double /* temporary matrix */ *tmp = (double *) R_alloc(nSqr, sizeof(double)); /* Take powers in multiples of 2 until there is only one * product left to make. That is, if k = 5, compute (x * x), * then ((x * x) * (x * x)) and finally ((x * x) * (x * x)) * x. */ Memcpy(z, x, nSqr); k--; while (k > 0) { if (k & 1) { /* z := z * x */ F77_CALL(dgemm)(transa, transa, &n, &n, &n, &one, z, &n, x, &n, &zero, tmp, &n FCONE FCONE); Memcpy(z, tmp, nSqr); } if(k == 1) break; k >>= 1; /* efficient division by 2; now have k >= 1 */ /* x := x * x */ F77_CALL(dgemm)(transa, transa, &n, &n, &n, &one, x, &n, x, &n, &zero, tmp, &n FCONE FCONE); Memcpy(x, tmp, nSqr); } } } /* Compute z := x %^% k, x an (n x n) square "matrix" in column-order; * NB: x will be altered! The caller must make a copy if needed */ void matpow_z(Rcomplex *x, int n, int k, Rcomplex *z) { if (k == 0) { /* return identity matrix */ for (int i = 0; i < n; i++) for (int j = 0; j < n; j++) { z[i * n + j].r = (i == j) ? 1. : 0.; z[i * n + j].i = 0.; } return; } else if (k < 0) { error(_("power must be a positive integer; use solve() directly for negative powers")); } else { /* k >= 1 */ static const char *transa = "N"; static const Rcomplex zone = { .r = 1., .i = 0.}, zzero = { .r = 0., .i = 0.}; size_t nSqr = n * ((size_t) n); Rcomplex /* temporary matrix */ *tmp = (Rcomplex *) R_alloc(nSqr, sizeof(Rcomplex)); /* Take powers in multiples of 2 until there is only one * product left to make. That is, if k = 5, compute (x * x), * then ((x * x) * (x * x)) and finally ((x * x) * (x * x)) * x. */ Memcpy(z, x, nSqr); k--; while (k > 0) { if (k & 1) { /* z := z * x */ F77_CALL(zgemm)(transa, transa, &n, &n, &n, &zone, z, &n, x, &n, &zzero, tmp, &n FCONE FCONE); Memcpy(z, tmp, nSqr); } if(k == 1) break; k >>= 1; /* efficient division by 2; now have k >= 1 */ /* x := x * x */ F77_CALL(zgemm)(transa, transa, &n, &n, &n, &zone, x, &n, x, &n, &zzero, tmp, &n FCONE FCONE); Memcpy(x, tmp, nSqr); } } } expm/ChangeLog0000644000176200001440000002334114660607502013006 0ustar liggesusers2024-08-19 Martin Maechler * tests/exact-ex.R (osV): ensure valid in filename 2024-08-08 Martin Maechler * inst/test-tools.R (expmAll, allEq): new functions for testing all 'methods'. * R/expm.R: export `.methSparse` and `.methComplex` 2024-08-07 Martin Maechler * DESCRIPTION (Version): 1.0-0 ("it's about time") * R/expm.R (expm): the default and other methods should work with _complex_ matrices. * src/R_dgebal.c (R_zgebal): new: balancing _complex_ matrices * R/balance.R (balance): now works for complex matrices, too. * src/matpow.c (matpow_z): new complex matrix powers \eqn{A^n}. 2024-01-11 Martin Maechler * DESCRIPTION (Version): 0.999-9 * ... Matrix 1.6-5... needs to change a test !! 2023-11-28 Martin Maechler * DESCRIPTION (Version): 0.999-8 * tests/ex.R: ATLAS (Fedora 36, BDR) much less accurate -> using 'tol1' * src/R_dgebal.c (R_dgebal): fixed `error()` thinko. * man/expm.Higham08.Rd: Rd fixes. 2022-12-30 Martin Maechler * DESCRIPTION (Authors@): added, including ORCID for the 3 authors 2022-12-21 Martin Maechler * DESCRIPTION (Version): 0.999-7 * tests/ex.R: needed updates because ATLAS got precision deteriorated (!) 2021-08-19 Martin Maechler * po/*, inst/po/*, R/*.R: more translations and small fixes. 2021-01-12 Martin Maechler * man/*.Rd: updates to \url{}s. 2021-01-11 Martin Maechler * tests/ex.R: raise one tolerance (for "M1 mac"). 2020-07-21 Martin Maechler * DESCRIPTION (Version): 0.999-6 * R/balance.R (balance): now coerces to "matrix". Also, 'dgebal()' is finally deprecated *formally* (the help had: "balance()" is preferred nowadays, where "dgebal" will probably become deprecated since 2011). * demo/balanceTst.R (balanceTst): use balance(), not dgebal() * tests/exact-ex.R: test that more expm(*, method=".") methods work with sparse matrix. 2020-07-16 Martin Maechler * DESCRIPTION (Version): 0.999-5 * src/expm.h: add USE_FC_LEN_T and "FCONE" --> for LTO-compliant BLAS/Lapack * src/*.c: use "expm.h" even more; use FCONE for LTO-compliance 2019-03-20 Martin Mächler * DESCRIPTION (Version): 0.999-4 * src/R_NLS_locale.h renamed from ../locale.h helping wrongly configured compiler|preprocessort setups. * src/expm.h, etc: use "R_NLS_locale.h" 2018-09-15 Martin Mächler * man/logm.Rd: use try(.) [for solaris where needed] 2017-04-06 Martin Maechler * DESCRIPTION (Version): 0.999-3 * src/expm-eigen.c (do_expm_eigen): fix possible PROTECT stack imbalance * src/expm.c (do_expm): ditto; both thanks to T.Kalibera's `expm.so.bcheck` 2017-03-28 Martin Maechler * R/sqrtm.R (sqrtm): simple modification so it works for 1x1 matrix * R/logm.Higham08.R (rootS): (ditto) * src/init.c: "finish" registration 2016-12-13 Martin Maechler * DESCRIPTION (Version): 0.999-1 * src/matpow.c (matpow): use size_t etc, trying to prevent integer overflow when n^2 > .Machine$integer.max, i.e., n >= 46341 2015-10-06 Martin Maechler * DESCRIPTION (Version): 0.999-0 * R/balance.R (balance): also add 'job = "N"' (i.e., 'none') option. * src/R_dgebal.c (R_dgebal): catch +/-Inf in matrix avoiding infinite loop in Lapack's DGEBAL(); thanks to Terry Thernau. 2014-09-11 Martin Maechler * NAMESPACE: no longer export logm.Higham08 * R/expm2.R (expm.AlMoHi09): new expm(x, method = "AlMohy-Hi09") * src/matexp_MH09.c: thanks to Drew Schmidt. 2014-09-03 Martin Maechler * src/matpow.c: need to carefully REPROTECT x_ 2011-11-08 Martin Maechler * man/balance.Rd: use new name balance() instead of dgebal() * R/balance.R: 2011-10-28 Martin Maechler * src/matexp.f (matexpRBS): do not call STOP .. * NAMESPACE: import rowSums from Matrix (because of its sparseMatrix method). * R/expm.R (expm): auto-coerce sparse matrices to dense, when "needed". 2011-10-27 Martin Maechler * R/expm_vec.R (expAtv): finally add the functionality for 'exp(A*t) %*% v' Ravi had translated from EXPOKIT in August. 2011-08-27 Martin Maechler * R/expm.R (expm): add new method "PadeRBS" (Roger B. Sidje), interfacing to the corresponding Fortran code. * src/init.c, src/expm.h: also namespace-ify the Fortran symbols. 2011-08-26 Martin Maechler * NAMESPACE: also import solve() from Matrix, for sparse expm() 2011-03-30 Martin Maechler * DESCRIPTION (Version): 0.98-4 (Suggests): RColorBrewer, sfsmisc -- used in examples * inst/doc/expm.Rnw: replace the few non-ASCII chars by LaTeX. 2010-08-12 Martin Maechler * R/logm.Higham08.R (logm.Higham08): force argument to Schur(.) to be dense for now (working around infelicitous Matrix method). (logm.Higham08): catch case of infinite loop * man/logm.Rd: add example of the above. 2010-07-19 Martin Maechler * DESCRIPTION (Version): 0.98-2 * src/matpow.c (R_matpow): fix modify-argument bug in %^%. Thanks to stackflow-user "gd047" for reporting it. 2010-07-08 Martin Maechler * DESCRIPTION (Version): 0.98-1, for (first!) release to CRAN 2009-06-06 Martin Maechler * DESCRIPTION (Version): 0.96-2 * tests/exact-ex.R: adapt last test, to also pass on 32-bit Mac OSX 2009-06-02 Martin Maechler * tests/exact-ex.R: move print() to see Mac OSX error 2009-03-02 Martin Maechler * R/sqrtm.R (sqrtm): allow negative eigenvalues, with a message iff "verbose"; use sqrt() in that case. * R/logm.Higham08.R (logm.Higham08): allow negative eigenvalues, as in sqrtm. * R/expmCond-all.R (.expmCond.1, .expmFrechet2008.26): and others; cosmetic (speedy!) improvements; dating of Feb.23. 2009-02-28 Martin Maechler * DESCRIPTION (Version, Depends): 0.96-1, Matrix * src/logm-eigen.c (logm_eigen): *do* signal an error, not just print; as the help page has always said. * man/logm.Rd: comment 'order' and 'trySym' out; introduce method = "Higham08" and make it the default (!) * R/logm.R: ditto * R/logm.Higham08.R: new logm.Higham08() from Michael Stadelmann's thesis. * R/sqrtm.R: new sqrtm(), ditto * NAMESPACE: add here. * tests/log+sqrt.R: tests for these; notably small non-diagonalizable cases * R/expm2.R (expm.Higham08): renamed 'expm2' to expm.Higham08 2009-02-19 Martin Maechler * DESCRIPTION (Version): 0.95-1 * R/expmCond-all.R: only public expmCond(*, method=.) function, instead of expmCond1Est() etc. * man/expmCond.Rd: ditto * tests/expm-Cond.R: ditto 2009-02-19 Martin Maechler * DESCRIPTION (Maintainer): myself, for the moment; need to get E-mail feedback from win-builder. * tests/expm-Cond.R: new tests for expmCond*() * tests/exact-ex.R: factor the utilities out into new file; add expm2() * demo/exact-fn.R: containing only (function + data) definitions 2009-02-18 Martin Maechler * R/expmCond-all.R (expmFrechet): method "blockEnlarge", also for testing * man/expmFrechet.Rd: the default method 2009-02-17 Martin Maechler * DESCRIPTION (Version): 0.95-0 * R/expm2.R (expm2): new algorithms from Michael Stadelmann's Master thesis work * R/expmCond-all.R (expmCond, ..): Exponential Condition Number estimation * man/expm2.Rd, man/expmCond.Rd, man/expmFrechet.Rd: docu * NAMESPACE: export new functions 2009-01-30 Martin Maechler * src/R_dgebal.c (R_dgebal): fix to work also for integer matrix() * src/expm.c (do_expm), * src/expm-eigen.c (do_expm_eigen): ditto * tests/bal-ex.R: and test for it. 2008-05-13 Christophe Dutang * Use Lapack function zgecon in "hybrid_Eigen_Ward" to test the singularity. * Start the matrix logarithm logm. 2008-03-20 Vincent Goulet * New function matpow() as alias to operator %^%. * R/matpow.R: miscellaneous fixes and prettyfication of comments 2008-03-01 Martin Maechler * R/expm.R (expm): rename "Eigen" to "R_Eigen" * src/expm.c (expm): get "1bal" case right. * tests/compare-bal-expm.R: minimal testing of "2bal" vs "1bal" 2008-02-29 Martin Maechler * src/expm.c (expm): second argument 'precond_kind' * src/expm.h: update for new second argument * src/expm-eigen.h: implement workaround for Lapack.h's zlange() typo 2008-02-27 Martin Maechler * DESCRIPTION (Version): 0.9-1 -- new version for the occasion * src/expm.c (expm): HOORAY !! --- fixed the octave bug: using simpler __ and correct __ code for back-permuting * R/expm.R (expm): add method = "R_Ward77" which works *correctly* ! 2008-02-25 Martin Maechler * R/matpower.R ("%^%"): add R interface to * src/matpow.c 2008-02-23 Martin Maechler * R/expm.R (expm): add methods from David Firth's "mexp" and my modifications, of Fortran code in * src/mexp-common.f * src/matrexp.f * src/matrexpO.f expm/NAMESPACE0000644000176200001440000000137614655414337012465 0ustar liggesusers### C code useDynLib(expm, .registration = TRUE) importFrom("methods", as, is) importFrom("stats", rnorm) importFrom("Matrix", Schur, norm, solve,# <- for expm.Higham08(*, balancing=FALSE) rowSums, colSums,# e.g. in expm.s.Pade.s Diagonal, Matrix)# <- only in Schur(Matrix(.)) ### Exports export(expm, expAtv) export(.methSparse, .methComplex) export("%^%") export(balance, dgebal)# dgebal() should become deprecated -- see R/dgebal.R and ./TODO export(logm) ## From Michael Stadelmann's (ETH Zurich) Master Thesis : ------------ export(expm.Higham08)## exported, as has own help == man/expm.Higham08.Rd ## For now we want the files to be kept modularly separate from the rest of 'expm' export(expmCond, expmFrechet) export(sqrtm) expm/TODO0000644000176200001440000000111113044611522011703 0ustar liggesusers#-*-org-*- * TODO expm() should work for sparse matrices for more methods * expAtv(A, v, t) ** TODO should work for *vector* t ** TODO should implement the new method by Al-Mohy and Higham (2011), see file:Misc/README and file:Misc/expmv/ * TODO Implement Higham (2009) {we have 2008} : see file:inst/doc/expm.bib * TODO dgebal() -- now renamed to balance() == Matlab name, *but* add the functionality (available in Matlab) to also return the transforming diagonal matrix D --> file:R/balance.R * TODO Rmpfr version possible (s.Pade.s), as soon as solve() for Rmpfr expm/inst/0000755000176200001440000000000014660607514012211 5ustar liggesusersexpm/inst/po/0000755000176200001440000000000014660607514012627 5ustar liggesusersexpm/inst/po/de/0000755000176200001440000000000014660607514013217 5ustar liggesusersexpm/inst/po/de/LC_MESSAGES/0000755000176200001440000000000014660607514015004 5ustar liggesusersexpm/inst/po/de/LC_MESSAGES/R-expm.mo0000644000176200001440000000311714107534174016510 0ustar liggesusers 013N'6;&D2]7 'A:+|@;1%WFqG   '%s' must be a square matrix'A' must be a square matrix of dimension at least 2A and E need to have the same dimensionPade approximation order 'p' must be between 1 and 13.The requested tolerance (tol=%g) is too small for mxrej=%d.Unable to determine matrix exponentialargument is not a matrixcoercing to dense matrix, as required by method %sinvalid 'method'invalid 'preconditioning'matrix not squarereached maxiter = %d iterations; tolerances too small?Project-Id-Version: expm 0.999-6 PO-Revision-Date: 2021-08-19 21:57+0200 Last-Translator: Martin Maechler Language-Team: German Language: de MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit '%s' muss eine quadratische Matrix sein'A' muss eine quadratische Matrix der Dimension mindestens 2 seinA und E müssen die gleiche Dimension habenPadé Approximation der Ordnung 'p' muss zwischen 1 und 13 sein.Die verlangte Toleranz (tol=%g) ist zu klein für mxrej=%d.Das Matrix Exponential kann nicht bestimmt werdenArgument ist keine MatrixUmwandlung in dichte ("dense") Matrix, wie von der Methode %s verlangtungültige 'method'ungültiges 'preconditioning'Matrix ist nicht quadratischhaben maxiter = %d Iterationen erreicht; sind die Toleranzen zu klein?expm/inst/po/fr/0000755000176200001440000000000014660607514013236 5ustar liggesusersexpm/inst/po/fr/LC_MESSAGES/0000755000176200001440000000000014660607514015023 5ustar liggesusersexpm/inst/po/fr/LC_MESSAGES/fr.mo0000644000176200001440000000216310743677313015773 0ustar liggesusersT :8+-+YO7S88M`LAPACK routine dgebal returned info code %d when permutingLAPACK routine dgebal returned info code %d when scalingLAPACK routine dgetrf returned info code %dLAPACK routine dgetrs returned info code %dinvalid argumentnon-square matrixProject-Id-Version: expm 0.0-1 Report-Msgid-Bugs-To: POT-Creation-Date: 2007-11-20 13:46-0500 PO-Revision-Date: 2007-11-20 13:56-0500 Last-Translator: Vincent Goulet Language-Team: Vincent Goulet MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); la procdure LAPACK dgebal a produit le code d'erreur %d lors de la permutationla procdure LAPACK dgebal a produit le code d'erreur %d lors de la mis l'chellela procdure LAPACK dgetrf a produit le code d'erreur %dla procdure LAPACK dgetrs a produit le code d'erreur %dargument incorrectmatrice non carreexpm/inst/po/fr/LC_MESSAGES/expm.mo0000644000176200001440000000213114107534174016323 0ustar liggesusersT :8+-+YtOSm883FLAPACK routine dgebal returned info code %d when permutingLAPACK routine dgebal returned info code %d when scalingLAPACK routine dgetrf returned info code %dLAPACK routine dgetrs returned info code %dinvalid argumentnon-square matrixProject-Id-Version: expm 0.999-0 Report-Msgid-Bugs-To: PO-Revision-Date: 2007-11-20 13:56-0500 Last-Translator: Vincent Goulet Language-Team: Vincent Goulet Language: fr MIME-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n > 1); la procdure LAPACK dgebal a produit le code d'erreur %d lors de la permutationla procdure LAPACK dgebal a produit le code d'erreur %d lors de la mis l'chellela procdure LAPACK dgetrf a produit le code d'erreur %dla procdure LAPACK dgetrs a produit le code d'erreur %dargument incorrectmatrice non carreexpm/inst/po/en@quot/0000755000176200001440000000000014660607514014242 5ustar liggesusersexpm/inst/po/en@quot/LC_MESSAGES/0000755000176200001440000000000014660607514016027 5ustar liggesusersexpm/inst/po/en@quot/LC_MESSAGES/expm.mo0000644000176200001440000000457714107534174017347 0ustar liggesusers\:8 +E+q+),5 @V7'/.^&o J/:08k+++)(,R5DK'F n3& ' J4     LAPACK routine dgebal returned info code %d when permutingLAPACK routine dgebal returned info code %d when scalingLAPACK routine dgetrf returned info code %dLAPACK routine dgetrs returned info code %dLAPACK' dgebal("B",.) returned info code %dLAPACK's dgebal(%s) returned info code %dR_dgebal(*, type="S"): Infinite matrix entryargument %d of Lapack routine dgesv had invalid valueargument type='%s' must be a character string of string length 1argument type='%s' must be one of 'N', 'P', 'S', or 'B'error code %d from Lapack routine dgeevinvalid 'kind' argument: %s invalid 'precond_kind: %dinvalid 'x': not a numeric (classical R) matrixinvalid argumentinvalid argument: not a numeric matrixnon-square matrixnot a matrixpower must be a positive integer; use solve() directly for negative powersProject-Id-Version: expm 0.999-6 Report-Msgid-Bugs-To: PO-Revision-Date: 2021-08-19 21:49+0200 Last-Translator: Automatically generated Language-Team: none Language: en MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Plural-Forms: nplurals=2; plural=(n != 1); LAPACK routine dgebal returned info code %d when permutingLAPACK routine dgebal returned info code %d when scalingLAPACK routine dgetrf returned info code %dLAPACK routine dgetrs returned info code %dLAPACK' dgebal("B",.) returned info code %dLAPACK's dgebal(%s) returned info code %dR_dgebal(*, type="S"): Infinite matrix entryargument %d of Lapack routine dgesv had invalid valueargument type=‘%s’ must be a character string of string length 1argument type=‘%s’ must be one of ‘N’, ‘P’, ‘S’, or ‘B’error code %d from Lapack routine dgeevinvalid ‘kind’ argument: %s invalid 'precond_kind: %dinvalid ‘x’: not a numeric (classical R) matrixinvalid argumentinvalid argument: not a numeric matrixnon-square matrixnot a matrixpower must be a positive integer; use solve() directly for negative powersexpm/inst/po/en@quot/LC_MESSAGES/R-expm.mo0000644000176200001440000000510514107534174017532 0ustar liggesusers &3:1n2'&Z"+}63;/&k2$ .@7U 756H'&Z+):U3;& B 2[   $   7     '%s' must be a square matrix'A' is not a matrix'A' must be a square matrix of dimension at least 2'lucky guess' was better and is used for expmCond'x' has negative real eigenvalues; maybe ok for %sA and E need to have the same dimensionInverse scaling did not work (t = %g).NA/NaN from || Tr - I || after %d step. %sNA/NaN from || Tr - I || after %d steps. %sNaN phi values; probably overflow in expm()Pade approximation order 'p' must be between 1 and 13.Setting m = 3 arbitrarily.The matrix logarithm may not exist for this matrix.The requested tolerance (tol=%g) is too small for mxrej=%d.Unable to determine matrix exponentialargument is not a matrixcoercing to dense matrix, as required by method %sinvalid 'method'invalid 'preconditioning'logm.Higham08() -> (k, m) = (%d, %d)matrix not squarenrow(A) must be >= 1reached maxiter = %d iterations; tolerances too small?Project-Id-Version: expm 0.999-6 PO-Revision-Date: 2021-08-19 21:54 Last-Translator: Automatically generated Language-Team: none MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Language: en Plural-Forms: nplurals=2; plural=(n != 1); ‘%s’ must be a square matrix‘A’ is not a matrix‘A’ must be a square matrix of dimension at least 2‘lucky guess’ was better and is used for expmCond‘x’ has negative real eigenvalues; maybe ok for %sA and E need to have the same dimensionInverse scaling did not work (t = %g).NA/NaN from || Tr - I || after %d step. %sNA/NaN from || Tr - I || after %d steps. %sNaN phi values; probably overflow in expm()Pade approximation order ‘p’ must be between 1 and 13.Setting m = 3 arbitrarily.The matrix logarithm may not exist for this matrix.The requested tolerance (tol=%g) is too small for mxrej=%d.Unable to determine matrix exponentialargument is not a matrixcoercing to dense matrix, as required by method %sinvalid ‘method’invalid ‘preconditioning’logm.Higham08() -> (k, m) = (%d, %d)matrix not squarenrow(A) must be >= 1reached maxiter = %d iterations; tolerances too small?expm/inst/po/expm-de/0000755000176200001440000000000014660607514014166 5ustar liggesusersexpm/inst/po/expm-de/LC_MESSAGES/0000755000176200001440000000000014660607514015753 5ustar liggesusersexpm/inst/po/expm-de/LC_MESSAGES/expm.mo0000644000176200001440000000103514107534174017255 0ustar liggesusers4L`7aBargument type='%s' must be one of 'N', 'P', 'S', or 'B'non-square matrixProject-Id-Version: expm 0.999-6 Report-Msgid-Bugs-To: PO-Revision-Date: 2021-08-19 21:14+0200 Last-Translator: FULL NAME Language-Team: German Language: de MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit Das Argument type='%s' muss eines von 'N', 'P', 'S', oder 'B' seinkeine quadratische Matrixexpm/inst/doc/0000755000176200001440000000000014660607531012755 5ustar liggesusersexpm/inst/doc/expm.Rnw0000644000176200001440000001052212165310624014406 0ustar liggesusers\documentclass{article} \usepackage{amsmath,url} \usepackage[round]{natbib} \usepackage[T1]{fontenc} \usepackage[english]{babel} %\usepackage{lucidabr} \usepackage[noae]{Sweave} %\VignetteIndexEntry{Using expm in packages} %\VignettePackage{expm} \title{Using \pkg{expm} in packages} \author{Christophe Dutang \\ ENSIMAG, Grenoble INP \\[3ex] Vincent Goulet \\ \'Ecole d'actuariat, Universit\'e Laval} \date{Jan. 2008 \ {\footnotesize (added note in June 2010)}} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\proglang}[1]{\textsf{#1}} \newcommand{\pkg}[1]{\textbf{#1}} \newcommand{\mat}[1]{\mathbf{#1}} \bibliographystyle{plainnat} \begin{document} \maketitle \section{Introduction} The \pkg{expm} package provides an \proglang{R} function \code{expm} to compute the matrix exponential of a real, square matrix. The matrix exponential of a matrix $\mat{A}$ is defined as \begin{align*} e^{\mat{A}} &= \mat{I} + \mat{A} + \frac{\mat{A}^2}{2!} + \dots \\ &= \sum_{k = 0}^\infty \frac{\mat{A}^k}{k!}. \end{align*} The actual computations are done in \proglang{C} by a function of the same name that is callable by other packages. Therefore, package authors can use these functions and avoid duplication of efforts. \section{Description of the functions} The \proglang{R} function \texttt{expm} takes as argument a real, square matrix and returns its exponential. Dimension names are preserved: <>= library(expm) m <- matrix(c(4, 1, 1, 2, 4, 1, 0, 1, 4), 3, 3) expm(m) dimnames(m) <- list(letters[1:3], LETTERS[1:3]) m expm(m) @ \bigskip %% manual centerig of "overlapping" box \hspace*{-.12\textwidth}% .08 = .16 / 2 \fbox{\begin{minipage}{1.16\textwidth}%% wider than the text! Note that the remainder of this text \textbf{mainly} relates to \code{expm(., method = "Ward77")}, i.e., the method of \cite{Ward:77} which is no longer the default method, as e.g., \code{method = "Higham08"} has found to be (``uniformly'') superior, see \cite{Higham:2008}. \end{minipage}} \bigskip The actual computational work is done in \proglang{C} by a routine defined as \begin{verbatim} void expm(double *x, int n, double *z) \end{verbatim} where \code{x} is the vector underlying the \proglang{R} matrix and \code{n} is the number of lines (or columns) of the matrix. The matrix exponential is returned in \code{z}. The routine uses the algorithm of \cite{Ward:77} based on diagonal Pad\'e table approximations in conjunction with three step preconditioning. The Pad\'e approximation to $e^{\mat{A}}$ is \begin{displaymath} e^{\mat{A}} \approx R(\mat{A}), \end{displaymath} with \begin{align*} R_{pq} (\mat{A}) &= (D_{pq}(\mat{A}))^{-1} N_{pq}(\mat{A}) \\ \intertext{where} D_{pq}(\mat{A}) &= \sum_{j=1}^p \frac{(p+q-j)! p!}{ (p+q)!j!(p-j)!}\, \mat{A}^j \\ \intertext{and} N_{pq}(\mat{A}) &= \sum_{j=1}^q \frac{(p+q-j)! q!}{ (p+q)!j!(q-j)!}\, \mat{A}^j. \end{align*} See \cite{MolerVanLoan:78} for an exhaustive treatment of the subject. The \proglang{C} routine is based on a translation made by \cite{Matrix} of the implementation of the corresponding Octave function \citep{octave}. \section{Calling the functions from other packages} Package authors can use facilities from \pkg{expm} in two (possibly simultaneous) ways: \begin{enumerate} \item call the \proglang{R} level function \code{expm} in \proglang{R} code; \item if matrix exponential calculations are needed in \proglang{C}, call the routine \code{expm}. \end{enumerate} Using \proglang{R} level function \code{expm} in a package simply requires the following two import directives: \begin{verbatim} Imports: expm \end{verbatim} in file \code{DESCRIPTION} and \begin{verbatim} import(expm) \end{verbatim} in file \code{NAMESPACE}. Accessing the \proglang{C} level routine further requires to prototype \code{expm} and to retrieve its pointer in the package initialization function \code{R\_init\_\textit{pkg}}, where \code{\textit{pkg}} is the name of the package: \begin{verbatim} void (*expm)(double *x, int n, double *z); void R_init_pkg(DllInfo *dll) { expm = (void (*) (double, int, double)) \ R_GetCCallable("expm", "expm"); } \end{verbatim} The definitive reference for these matters remains the \emph{Writing R Extensions} manual. \bibliography{expm} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% coding: utf-8 %%% End: expm/inst/doc/expm.pdf0000644000176200001440000016154314660607531014433 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3308 /Filter /FlateDecode /N 60 /First 482 >> stream x[YoH~_QoZ J9fy`dFQ8MJj6%ӎ b}Y_u]]@Ab Y dAX 4`jƝƀ9*qk` n@0ciR`$3 NA1-3PBQM.A++iÌnH;0h rEARpV:@p Yp b$9(w@hRb8 ΀Ƹ0 -0&`( iiAq`) ,%q%$([a@i>7YP`LrXp$DCHFo@"h@γn.~@z"̮+ߥ7ϳE1g^S.e1.%ۡߔen6@ˇzgw|/zV.Ѽ]R+{n䴸,3(?_.˟'-{NtQe3`?8DZy6ϧGy 8h83l[5>F|'z>zJ{Y|tbgx83-hvYL|,ӲX=8,w|!#2d$Mp\LȔ-|-򹯟,#|KXYdbUO8^`ur\|Mߜ?WPmBUtD]Bm?u(xEy 7(ʸܭFyHo҄#b[ lVxMsr$/B)0VT KI]`q1_&_%oW+Nywc-A=ǔsaDwf6M> y[Prk@Q,%thUROD)$Hnhgέʽc2& ۸e_Ʉܬx`<, 0DDGyĜf@J)~4]f4g6MSkM!?+;6%a?1֏0J[K&VhX0]=bh|kcVƳ }U0^8ts9xp3|5^r3q=ImWY7̚ Ȑ\xҼ̦|zdLc2.ȸn%|J ߥ|)?ZWm(S7oVSaje=N"{&/RRע]S:%btKMQ"_ vHES괲OgSj?IZ W,hwMn|yk)-v2C=dYUa*UU>1CVf+f@l'c8$M?򎌑ՀM24 k ZF+mbH0ĎhJuBON;ËG!d GqCmO~u.m1sj{(Q\+#Bc3+//K6ZNPO~g+4_ _|*ZtoP HOPVݨPìcz7h6+ ۢ_14X ԆUVq)/Z\ɒڶhƿ|qG Uq2MW<"}1oAO ?B4hf+ S &w?{'vzqDyN)Ӎq^ϦⲼ?ڮ@5LSxe7dPɄܛ֫b쀫 FZcl4銽ؤ8ז o٣yxN3?An32eldƺj2mRv58;<9bQ&e٦n;"0Daywss.vűIP+bJ'%:wwJ;FxO6qCRK]eѯs.raZMjY!QG 0!xOG{_yLeX)f9P(@5ݷm3l~<rV%0hC-``>_'deah @|&0PJ6 %1N`7I5^5BQlU7`>ݶ*+`u"iU3u_.}1] Ve)u_5 Bei,)W9ˆztv˖?S~.F3g3{oߝxeMS˶HdsJfKࡣMޝ_Y@wgmA3۝8RN0Nr儴0KI.=(S=8tgxx5hꞫD:~,J KfBfS`8M ~IBᰰh~wѻxaGTɶ1~K& [)+:[*pйFpIֱ:P+•s?z,D~Ӧ<}?0aY$>E)-JuRhesޢMB; lφ3K7 ֶm*TebY[Xzy>E9{Mr/e M!<43 gWyC0i\-[O8 1q8`<ɴ?0,uendstream endobj 62 0 obj << /Subtype /XML /Type /Metadata /Length 1168 >> stream 2024-08-19T11:24:41+02:00 2024-08-19T11:24:41+02:00 TeX Untitled endstream endobj 63 0 obj << /Filter /FlateDecode /Length 2066 >> stream xXrD蝞veSY\rRYJLcApyEg(ۥg,Wۅ.nնrݛP`쁅rq(ť)5h2SҠqwoxuࣵ.j>oƳ VsTˊGV$Zƫ3wj67Ca! Y9΅2b Cx+gϪ}zfj2הz~hlzRuTٱI* 쨨m!_CNʸmv' лHLLaMl3 jv GT/Ǔ]T-C0 -XWj9`j}r^uuvSw)ِ6W:մMY Azݓ!FT2_Kg}T]B( U= eeɥq 8hNi|Y9Q]?E+[[5W]2U9pZ 3k@2Ee58=]IT]j_VcT#dcN Zun  1 moel 1aUi"hmh l1F#0o#FfȀF/7.68 ڢޜA鈱x]HH>7c!Nh$o^*vLԶͧ|fz_V:3ywrĨM}WVFhڿ'riڦSTӰǺmNDGM)9!j0Lȏ$! 8Try anzlM~kbLguGRS[λNzKMՇ.TQ}#h&sk_X@yJ5 |^f>ߋOB sn1|&qgWN#{>=~ekb!G4>!L?L:=Fqy\,~9,0-trA-*C@vA->)ib +(FpSyH-C$ <|VVCi8_b \p\L "A`m 4`؈4D怦w0X#zC.dCvz'2pp̱[xz~yeD! yĪ)@9D*w"A|AJ2qf i&rs(Kx35鋪%璼?ҽj5~~AZϘ/#/HY~ nl?srh䓺fݏ'E4}m5tNpZf:222FMwlw#T.jH.[3VűyNS1wꇁ1װDS솞Y63X5g[3=ֿ3.ͻnJG>TiJTuWJDn>]Օ<*8Nf2ħ6 _{UO1*X]|$2UwF[F`Q!C//Z \FV꯺׈oZ~/z mEQk ]O3Bƅ?}~rTߋ9{65ok匰{F͡o=\37o/KT24<KsB:I,?qCendstream endobj 64 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1455 >> stream xMTPu~_~1Z\ZvO]vYwef?1&D;~ϻln2NdЊ2ʻʺN=Knw}sCS)M۞\Գ~ V-lM dzHyu=K,NIr<*zDeQl*z+)D)/ N]Z]/X;qhbJBѣ}44|s>%b-rgܺy(7HscNލrmKLcUoiP;XH -'_bIv4xVSYh&\ZRI:ye+ gl8G2%$?>c ^;!BW临%~)oLd J,`qX"]e>~d_Q93utA>() /؃ffęsk /CEVT73*%=tɄw544blC[ s=x:% nr,ٜ2a"}#9x<) kV(NnBI^– j&ԚvYs raq^ט{_݅ZJ-S},C0O# *uj+o5 W=`O٬!zAmYVlEϬbe I*`luRJ=Ddju mLf;Y_ =mٱ"$TEa90+AU$*?vo.IK6JiE)dXX|<}Qp .pcekUFW\Puo~XP9\ a\'hpDڢ'O2Q{z۟LP$_@zC]3h\\ZsEcN_*Ε .vO(?e?:8Z[Vh|!5m_i4*nl +mx=g}Y(cDTg>f~2C۶>U^ч_ܨV6oy&$=NL .e5B9?Lj2eS]ޒ,,ԸNRxaCX_gwQw{hYXo@ bB!N3--lTih}7*o3Z#Qe${AgB2zjz4#cRh:ɃSvOX@s'(o5ۊ=VTk8Q)R$.i9r=,IꊠH0C3+@bNZM^ y쎏IٱFhJ?"gP@ןov  #L(W0Kd2)_ñendstream endobj 65 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 606 >> stream xm]HSalXvZNTMJ"N2s,-\EvԽs*bdSIY%Z$^EhPD`ta(be=91;e,H9|(56vP kyjQK[7ܺIχ1C,/4K4Ik mk9f0 WɿCDȪd㫳t MߛFE9``)|WYG.ʹѤQ&&AQ TLm"}js+V,ho~Lv;Qu9^,bPZRSSiR-_ G*J+^Vxe'Aendstream endobj 66 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4509 >> stream xX{Tgb$UlI3@߷Nk{NkSVQQQ  |O@;xTj+Vv;˱a^vqzfw9ϞMINy~|"fF$۰|}9f?DM=|/&aX' # =L5m<}IeVd缥x{Չѻ$۳w߆MsqƝYsZf,3yld~0 bf ,cf2˙J-mU&yd0Ld&1')1AL1eLCh $K҃^A^>N;~{ OM|vkI'Oća [4YL17X bM29PFbeUpZg0QI*Rlԭpe\VMZ,grQ6d[ +* ^g)ylZIb 5z^g.DD5+隷V7䀌`r`z+$.x@WD $9X&EBq+G\zVN҄l$ϲupdl*֭ci+7ddZ:9D.hRq#o_HWd<ߋ} `4, pi@JIp>Jعd"d=FoSwA=fK\Z[MT'tLkia*)~$ kˠ/áÛLA[ U׿c`NzJXJB&&-vRu=%<;g6 `qGٍ M(<|g"K4ڜ\n8FC5l6Z1#GOc2x'7AMHE:fNf#Iϴs9I&~CDd<Ӊe$."RM2ʬ+t|z*x7T.Om4b }0ZҨU ?+_d z/I[ͨ1IAύxЮ4}ZQY99^/_u._B:,YGQgD&RTMTJʒf N.CPʗA4@ Ke`+<(5_Cdр@:NoQa=ab1MNKIiHx~q¶[KiZ\^cC&VHuAv*M9r/%VZk=K$pLhO,Y>I& } RuI4S)y`jd ")LF0&cn]%N `ykTPk ^o޺}v%meWD$f V(ZzH^7\zt^'^27N:|tސiak:Gg"C<E4۵!e??xcF|=qv UEWJr8yMN}aA.8Ab&Q PLkq]~QߚXQppd'_٢ ةې#WSa9 \.<[p2+1Me6Gw?X&`>CSh}73Zc<* w!G ~N ΤIE8xv鍊C5_g PYT ykO N!hj_ ա pC@Gk9 ՒRѰt smU-s"W""y8'!R"Qky GaٮݰT}\ ^r>X%L.n^($n%S G*ܗf6 c62nE` , BTUxc#:|[MU `wC~[?`Β#?__p@Wh(RnޤQn0jsi.3r{#23/&' 9|x *ItPE4,r wq#SX!K{VL{}k¡[8i_zzNnk߽r_ْp guGTB`75_ρ2qqgzŠt4F+nfp4Hxkn;?ˉCrCBrrK9CPnqC9ʩWK̭bI"^DҾV-Mmz?t%|x8 C1_pꃺuW-ذ]o72 um)13R+v_]& #һÐ*ٵDo]D2eHzjigwssܨiD e%rҹ[n<*=4Ĝ#re؇76}j`dL, x3ɾd7 zو)uYOAJePyh.óH[d y}S=gCU%4K\쫸d j<̾Ơ@1VUWVY;2+=Ydbj9 s!h4WTګ-U/I>5/:`|Y~2"@9o~uv߭;0}} N:aHqs`ʍF3lXF+ޝ'IwM')aD4.1ݚmH + ݅v3stGt+'VlU~G DWw<YbjuU*&jBcan\*OK-! vlEc(Q0CáÎ!pd-Fƣ)^jS~X}ۄK%?|yoo+/w(=Pr$:S\V~6՗>{4+~mӧl% dKo-XK5+e] oOFhKԐU\`8GQ ǔ"NL&ECƵٛL& `7*պYg E6s33jK\J$uT5".ꢚ< 6KTPXT:u%G} FNL,jPڴ!g]bѨ׃QfB%k뻪ރSqlZ܆ gY;w>C"Oޕ)<؏3} FVZאSJOk$w)Lf5NI)TU8#xJ}.5ܢB{ZaH鵠 ϐyHR-!kJ *d;]J FE%#ӃOwJcykx}k]s0/q,2؜gwz P"hy䧖O xe}'}Sz d"[ȊkF(F`$ d~HDoݒ 7$'O^?cLzS@mӁtfʎ/0a2endstream endobj 67 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1672 >> stream xUT{LTw3BYPno ޻A]V׮Ub|PEQ*( /Aax 000c`*| ,ֺ YӭInMΰ?7#MNrr|ߑ0RF"K.&_Zj\2pDذ˿ GHVv~}:*w#f`-6&2Ar&P)#a(I>9%ZG2ynL:Dr LPhkWMn(pu[5|o;IQ&\W;t2OpC#~W֓]="M%Ry4i^ǐAqrնˢ E3H@pDg`3Z+Y"ISn>pOzdi27U6)bj7`qBq4\;=qlH<6|6 XHwKTk~pyMڬ6"SL;{@;j(ny9ul]a$U*KކJ5m0 缣~!!}GDUJy'mj]u$+_n磎WOBӞEwy ܙ7l2YL+E }Z# PE'KJh8;noXp46T/Xw_X `as6R[Q]a, .w-rn4ЊJ}9vCPhjnmG[!;cFP]Y] f.I[^ ;&@WTB睪pQ7}x_~yK-s C- 5fHeKU62pF 'Ync.k$ W+p1.֓S!A8'^S̰]}SkJOQF_>S>Gn޴=M*ZRU@D҃*!˘U#e*2, ݛ < ^fF > stream xmyXTWoQpAM%ֵɽ6j& Iz$Y5 M)@b(E\,@B.IhG;ml3A+8:}sy}d2wH3E5^0ES>mSy,!090߮^&[};{d":֠Zŗ$-) -JHL2s% #?Udo[Zg,jk%,%ܴB>9ekFҁ~cXGsm$v]p7ƞ轞߿ͩ9Ρm'E ܐ-aE\̠Ѱ3`UAE-19?V6 (WH T/|#T걇~jmm.拞'q>6@6P{}UQMoti |L#*&dFp'qz]wݛ72r y?%J`| 'EE"ȣ•.ۉpkD=z3K1!ۙ ا컈yq}{=*G@y`Tj$g7֦tpV`X7L;$aN_gC,Ul(@Ӓ[_o_rSrT$֞ZY\ܐܛvA e@* % PJZVSlu:3UL:bOvbFX\?>#\ÅϩS3L1`<SvۢϔzuGPT]4l}8GlǬU]idȹk]=С3fSVA Ř3q8 s㢡t>+h\0JVkmzIǛW._vBg% Gwoup&Nw1BCdQp'87ٮs0zؙ~uS:S~&l?ʲ/j[2IdžNOŭ%9cɽKWJJjlvGGQK CYj.Y>r(e;֯͒bBvۅH\UۋK !nm;l!^k`u'>)}.֘ZrcAyqMр8]zhjyfcH#jW$P\^owl1 }4 Je@sLv5~hQ}J'>[4TPVN**6GFB슾,7c\e/FXqC֍<ݕlV܄ܺQ67, i B(^~.j5PK-eB9"{CDGƱ~ VO4knnt8'NJ2z֨>NF1z"m*ڙep n$M,̈́ HYcQ6|mXܝr@yc r(N$ۙ/5<6b(V~ʗ@AMuAG?,ۥ.CUN ZpޝZ)4QksIKR9~oX77n'ْFoطǺOr.jtANZ.\㮨%+ H.ַU3ZE/1aߍ"x1l[ii`9Bә/Xʕs8`GS3}!~82-oID8.=e,HC a߆z|X`oɯi65MhxõᏭK@ :SUuOTk1BvSL:3R,/4A\ȦF|ۃGPo*\h[*[j,t~Dݏ:p9<=}o5h{]]KĈ $~ípDO%RgN;N66[6T en*Ԙ Yl&ꚚqHg݉/'[&MV]'PY^UcJ+y(Gwp߅Xb.&=ըu=vΒ1QIy|I &(҇B7Rޜyw.{hpjd2_\?jծN6Z\MVib5}TC׮ X*+{ b!:2wᣧ]9y8M;3uFftgwtvċ\ [zC8}6>b׮oT6ЎAWIZ+ ,̬Zo ZA%`c"[m+%}Wj_d zӝ`Z~sx3SE)8g7H˶'wLjb׶:{3D8I޸h7҃endstream endobj 69 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7764 >> stream xzytSIK 6 xPQQyhNitH3om9M:-eRWx}|+-zúϯ++Ymy}yNLF ܳxO3&$Z?n]~}CYO|d?&gLɜ5-UINkҙYuy'-0/y6/JY$mxYq? '8C)gf0f20Gf)3Y<,gdV0SיH f3Yɼʌf3ckLf,3y͌c01sy ̟9$2f(ˤ31Lfs?^F I0Tp)fv̇k=gd'T+{jַ__G7G=`̀K4~\|pp|)%*Kx;wb=pd\"qr(qz֒V_ e~DΖMI,ɮJ6!mk`43\)VLd 22"@aA*9db\"l~!ߐ_Tِ&y"҇|DGq<‘@<95Ax%2U$.GU^֬okɎMO;7 =I$F>om2&(9ՐT@͉{H($'þq&Hϗ' v#AT1]r5oC+88gfx+Uϓ#}H1f3P}v`a;)}ysM WM(2*oL/';*DD1Fc oI<'"}&ℝ&4Ha`ɞ\d Y 7ʕRC.LGY|p;12pȰO݌HUJֵ-^ .t%]Bd| pR[ 7qGO0 f:t5/ǿ2>(cWk]%|~B`5FAw0fyjb(oGD d(@!`"ErBc ;n\|Dk-/^jxΰbCʞV]4l~UeR~!62FmXq=lG;9d$k-`Mc=o OɃRiFOӰgVBLE0Ϊ jYeU5'͕JKeMIQ :&azm~j=ZKh)1Ǩ SOriq3OB[`Z\&ekBJATv.ϒy_%Vˑ~1ۗ5'9VIqL^<ۛDJ90" pZ'Е"a"AW[^XgMUɁM -[᭿DhַH~0%2-DѴA!ɑ@Љ$|xޒ%WZYV dd3N+.f+̎m$JC gC3+\wϖ~뽬qZ)qZ~B.٣+H@YYT,tyC]0TkDi̕|^"C Ȉm z# ?JKYH-N$- ӊN  + iur$H#0N梻 -=YqZlоp ZU'UBI)M\j (m;0jPʅ>q`YS =@4hGc+f{D$luILoi>~MWM PcAM\Ѱj/tΚP]b/M$ƅ(5 ;":N[:Dǿ8vAJܯ1Zlm(9͐P@ʼnɑ0RBU xskiCm6 e\z,2*,'~BW'V$L BT_,oLC'-G81 r"ϘjƫfQk`+SiƓ7<؁5a[ GY@JG$G@mWt+-P, M M|Cm/G!֪k:.ݏmU,jXfErڡC*/m=J&֝abTom,gBfA6pbbNfM(t)|@+DqUh;xbS :֨1ѱcPUk4(: ;o'Z\&7q}-s=< m' d4#P0/ w4>QD_DxrC~ކmum ;ak_@Y4z ɇo9œg/ry`SneGR0ѣ\2˄Mux'r@\ pOX@1HԠe|M$:L]tfk< XLfQ_S/+*|UʪM dTKFP-d]8@MU婻7Nݭ-K[rĪ@E&ܸbWbTch2Ҳ rZ(ӖJ7oJ(x|ބ}2-OK.yT]m&k% Gw(X +f+L~Cҗ$>|dfG6L+7JҒeI6rq=K{ƿӌBV .R{ڟnb <+Ѐ#;Ў+x*vw95B\즱{i]VV X2\+1c.(@RUkJC@Q%-|{ŝk֫[&Vo?zA %JҨ3fdOO ^O1Mq.ZhB[/Y "4 ʶ !gU54W9\z.00:}NY":szNBs9i?eH &HL ]$z[;Y@5Fƶk8h|ZNLa9-uJtE:"P;mlyYv,@+=* iE^"FQMAyfM!M}fDk*qHBa@p02UBl❁`^$I{>00 Za\‘J2?Ng?ɵH!M{uvOzTKFQ@[L y+ݘcQjDx7Sz/I<7q$N#݈^m#x=5eu:oO*A F^am*ϪYPn_jOl6F7-?T*77zB㛽Y;u6Ѣ|'' ҏΌ5B?GEg;;0UQqLdD7R_[BגAX҇(Dd'[tޚCw?O4 `;:lvpMN6p5+3FHjHc> `[k7rN[DwPo)agu/=yFhL'tLVdu2愝F8/D@P$t ޖ!W/6,L@t<Ȥ} r *-UQyta/W@@bƒTe6%Ü؆p+\Taao;{o1x<:pvMA&1=d{=9^#~JC@栿Iw 5%XMQdS ܣ"FPi.Ge`= 6&s4=eB_5]WG,HRy|AdʇߪI:ҮyVi] ՝+MmɀǰivI `'%3*CyJ[юoC 5U[!: ٭ZAJ\+,W4HSٜl2@1ڱg?;ݓ>疌IdF0R@XxK-"rKbKgr&I0^7[!Q4 "Noɺg^l&Z$r;`7;c]aΪ\jzyNT8V1i\̠‡?񭌯5jGGS {!(S쉃9Zbb7*1:uN,/{K}u8JrGt߻p|wzhk1e|Nj g(*^V IZÙpe@2<{̮U(ĨhoAVIg+SESIrj"]h$aIx$ZV'89BS ;📢dA+]73WsT6[R9?2_ƦgٷDҚӖݺ֛`Yr¼ ol$7z>ƻUE1E'Q|.d24[HT@# ^MbSZlA䙊RGgLJLզ`+k)3(C&*vw*vZ!r`;r5D&-o Qr0ɻ SO䴸.MM5Yyit便Dq:A/f%9(hBV\ƞ3{;\.q1:M# (ߘ&$cbh&ՈHkחNzwtGDazB]f'8w'#Ko{H?iSfhlZИK]k2鍠fdt[˸Ў}v}ÍגTq@eWs®@dȋvm=|elf07׬0[L&#h!ȻuvߎM6"6+H 9/0:b񫙩)k 9/T:*,h^ oe1_M6բbpJb369 Nö 텽Syl9'<.MOk(p?8joxC@J}}J^䊠wfE<'I*\ +!t[z,i K"}Zqy+OdSEcQwkEE|JEW t1JF`画OXN z3l<{ҳGJsl{O.q1`\j@So9:kdJ[BIUB( >rZ ܆ڊP1B禆Lz:mfN#J!v<*GVEʺ+u9Eh>vo@@}SZ?= IZۛdsA(T4'V4x!8 [`Q+Wf ^tu݉<~g}9jGU塂[쇫ppC_k;vnOY\1De4E OC)x>`s}cWmkuKv}q~,[c@h #N#ٚ$/"ߋĨ9hCaCA G1Z8is%5Ey:5&c7#q``Mk(vkˣN\4_ڼ gj&(*P#5yW;__8ͰfX3`$ےܙƆg$'?qO2LRA^/6`~kb@Ebx}O D=T~ϑM!MzPU ֏+uvq^x;X8ԅyu&g]3J 5445_1TO~4bF2ADǰŖ\¬"Mrm.xd UEs#Qt*_B0D 7EAqQTmsW=K4C- O3l/Bazu : dXx#*ۿf}J 3[STvIKs\96fޤy!2kA LҔHWNq2} r $ʀsƖNwendstream endobj 70 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1224 >> stream xu{LSwmWD^:.-&*ٜ%{)S6DTdG( JKi1 V( (JEelt8E.s-f[Ӝk:M$sN @ LB,+nA;F_)~K58 c*qI;zNo.Ï-݃g=UCPQPZ`0*Pz |Aa:†w{ AIBrEÑDwO~(jU-燔j4pɡXٻ]hv{3fetwZlJ3ydJ_-U{hZǼ_ Tc%˩ хffGsO:+9[I}Χ϶KZsk 7q%:XS2se *f$q1T,컎Ql/.!mkuL[JAtI0%zY UN+ <'5 Fy ep{rjecJ=,\T1<{Wendstream endobj 71 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 304 >> stream x% SFSS1000va  CR$3qM@~vt|t{rfzac/9;=3¶|rPNLYLNES]vKJ%Au[ы'}}}#ԋ뇰2R`aUxf~dd ? endstream endobj 72 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7645 >> stream xztT?b;(H &k&M､@ H9A@ꀴ,zGc9owZIwygOo^^^^s>9j({LDm<ug0z嚉%uL46N*WH..{{+f\5guܪ5F?ܘ>G肅/x(O)~ǻ777o6AC2\#y{777& oooo$o2o$o UӼgxyxy3xcxw yE!|P^1ϻ777w;E K;y yʻ#zBOg=_ުGPPK$u{ u.]Y'  z 22?πdR-a:I@=nU| " -6nj"E7‹o`5X bc D<$5J\ZH{dvkNq:=7]#'eL!}?TBgRF,,}}-bJ& kS,Z"TB闰 /;N|{1C (F!o,~¾dTp-8!]rsQ `YL!^e5%$M+5`-Zkn{(:N9Yt6g`5JYW|,|*bҿlv,Z<Mb f>.ǷSt7]_JzT^uʔƟĭ|lNahRw!|AB?ՄGDnC)9,NpatK {i/ԟfDzy3ُّBPcqd"#r9"~=N)ajT!hv[x$v?{p35Ac.G,?QI]D$PUL"NxdxGY8 amucA+Mbob귗1 ˥իY evrzSq8.n@o]?B2M BO{ټku{ywq#gP MP&fuڽQ,> ƚh2M`Zv5 WW7I3\ UՕmJ鼞 n9H=hIA* [n1KJԯNӜ'& oGK{T3܉&g9քv1?kFMTJ.A gh2$/@ߜ-x8?Of(РVKm As;>gT!ՍZT.\Y&ް*<qu@Ȓ _NK"jn%Vq ^)^v %Ш,-4- /ZçTç O`^ED5@V O߉+ ՠGj(*T*kSL')'py' "([ RiS`kZ_>iPUX[mA!-4  σ1\ɼdZ_bw @o7z֊iPISye:(2ř|,őZLUFY||hLh`I߬m`4 m,9 ZLP^YLeޓ8yTf@xT.[*}IFZ{DQ]i!dU5׋:vzSkBb(j =^[_c?}P6z,L( ǠF|ˈw< wL(ϴD;ߍGVO{*VԋPڷ O(rv;a$TJ. TsHdd7"^s2ԴJ_PUhûdZwq$uɛ8P f i 8O6c@RZCnͲ{mڬ6Ap"hZA1NYJ j N9XetÁDWW}BG#luRN- kEI`*"Aa*ND}zRo%> w#9RUcleCČJFPTǙm{JNg}l1#3i@lc֘ɂ U9Z ?G{Oh?^1WhDFrb5OMG>.ln^Y>ܺ??Fj47U.V WF#hkѹ**P9$Fnq[Fȵޝr'N~:9CJcY% T i,PҲ"RQYkZ5kmݒݲ}Em [ @F%T)ۊ\76f*|s=3~ؕբ:((ۙl?Oױ6G"Qdff.S."j)M! J]-;ζ>;~+`I l/h""^w:4cl T`X +^`ZsFXЈY[t+F{a:T>\>1gٕ～xAoQN2בx >v0a'LJjDeDU˕+h^9h=ďzstm}QܞǵtN5TrXBYy>6GϠo޲ | o٥QF< AЕzsmXcmAЍ6u5ih6$(4='X)\De6CmcSeMծl>po mfv"cv$H8)6-^P.3tEGv ;~ 1@]4_F hTV6B+ תpuܼ?kvbPar|-Yc oo2YsՔ̣_x0_M4Gԧd&L!VMr\ G9ʋ`qs- )Z6=8.sI2S5cQ6 d;[/歂5k!CMO|8)Y]*$[G{RǕbSur`#=lPU :En/⤸858~&)J#Qz\/Q\/+)uJ' 5 V߅M&y#Bas]KIV3/f\|s v[ҟWD/?%m2ٵ(3p:Ixģ>o`7ɶ7ZLMIFIr Nzm#%uHR >e۞m#g 3.wr (g,kY<$Hfep<|Au\Rà$Q}<qe~;@}Oz(z g&{q ~LYp<4^Ernht ޒCnt{,` " RSE*Vl79Z)Xt:<ɰ/x%U!B'qv c ͭ}3BC.],%Q¨>@ j zA ՍqEbkNNgAF RC |:.:am$#TJ_}8$x8m.ͨl K J󀦅!鄂~5fbA#eJT)o^k(+SHܙ;s\tvZk6mn`uP9vYpF`Fxw5ZmBNZgsC /v;އɨ{RO2W DJ#-l$3}!8';;İIYHү1^M0Mm,/TDl){rG"ՊXdcTK/399r!%$@Z_Ò6JmqEauS]?9eS/̛|YSNR l$Œp߷9z󘋤oRxMoz㱇 v*9[>` ӧx `psRg# ["O&❧J #ϒ'×:Y$Y>=8Cd4N]5LBfu-~Q@:".3I qOI"ӠI#&JeKY[8 ~Sq]!G7*u ޜ Ӹ'];[ϔ*>Q3arg  $gx <ãI?qhKl&ţ҄ ZP󤒥|iX7;~}6 ͱmFdUJ(Ë|ɖB+2=$;0@?5n_=&. `2?ĕ;ZXWi,C;kne׮L M`]v\sb/8ȗu*.'6 HE|&$Wc}f-wSHwm"i* Y:&t3}1@$5aʠ%ీ^#5;㪀Znf.G9JTA ʥ $! .7= ,nԆ A-4gbTLC:6bzOsF8/wZ?@ 'OS"5L̉x H(TThy.,) mJ1pW?;/KZ9ƨgA{8jK.#2 ڼSRAbPyP^FJ]qa<B(å侰ΪE:I!9Qmk׵nD~Qo hUk*Z`3ϛ(ïqU=>ȏܟP (>ƚ|1(@[V1Pj|Ġ =E:*ɨAXh0.:vi!yzJ|;@0Ŭ ᜌai tRYuyYr2t6e+cj AA̰{ak/)J;"(15K z'ZmWTAsA7lka(kNe(?a>т#:G!L=IH^mLњH^cP-o;%zI٪5uUoV)bj/ḏXDfeS7C5j$QhFiM2ԡuEjhN '\߻C@C. *ՂmQ#5¼I|Qfk!}~g;pB GC]mX5o}Ob:{_Ho7^D݀t/nm,=W18p"@'9Z>d5T"D. $SiuH TUܜ`֥؏Hܖ0?Oendstream endobj 73 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 268 >> stream xcd`ab`dddwu041%2Âw 0'3##K;|?v|-?1i"ڰ;wϟw5e1l{v}{C^]&3z}j:1l^uo{X?E^GOv1~W}Oalؒ:4cc5(|g7[ ;wv67;|NZpendstream endobj 74 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1429 >> stream xm{lSu]͢& ͽ1d(р " )q.s:^v޾۵]m]׽tNaEC>!4篓O>_΢hc k?iԒ9@οG}t/4ZYl]6SET1zZGQyYMeSJ[Μraת@cBK ZFpnd$<00| KKlq AЯ'WX'TV5G AIR|LtbzP44񜻅=`g,GMUod w4W5/' ٯ =K?iSlzP k,>u%8<’[DwLlVtNd?si&,!YjJ2m\M%Ҫ""s<=|d7S}㬽@:DD60`fa30Ώvk~'Xug)LGoЉ25Rǻٶu%otXyR\`kj5P1d`~&v.6'765 ɂ\\c`gɂe|-Ό,.qf١@jA  7.[O}e ]hZȉЌ虖67߸oFДx7oϵZp V 4Yqx(} 2 ځv12 #4vFpb}jI(7=sp#$r"P`E!Kr L FުXWT!-"]ZEIz>0 ,I I۟h0u{Cg955 ~mFj3ƾT/hKs(oDendstream endobj 75 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 199 >> stream xcd`ab`dddsu0$i aaa[h RWt gh h*l f޿{{ {ywXtO+;/l~+}d] ~~d6>9.< Lendstream endobj 76 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 586 >> stream xM]HSqggxyR#K"-( 2h#6mKM׶^=~HK9\EZa ^$׋ z?M8BIVsi],> stream xBCMR7w,  H=012Fj?ts~*~ssr)pt|(|trsw~]lM;|CC|||]Nw}Ƌ݋Ջԋך ˠjQUC4AA~Lw0Guc͋oKL0bg͋§j~'eg #e'͋JiuP~>}L讧Ǻɋ !74/XWϡ=:4MFkgo0 7 D/endstream endobj 78 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 268 >> stream xCMSY7M   infinity1*v8|vtz{ssrr ٧2V{eNKT1! Mzp_z‹ 5*Vgf0++=@/.K+9`cJ4&$D?fkKendstream endobj 79 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 237 >> stream xCMEX10k  msummationdisplayX rd#!Gmv)qT钓f}zY{^: btxh yo \Yendstream endobj 80 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 757 >> stream x]ML`[6̋YG 1icDOj,_~&}m压b\!5: cD`R$b³ 8;O0ΝO7?L'2_ fḮ?k |'f ZR%\dZ՞I(Ÿ]8t+)$ЭoE.Qo} @'F%ymC9vr2%Հ`: pd% E7ŭl21=| *ĺ{<Dd큉쥱'jNR3Mu,2S+ME#{endstream endobj 81 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4227 >> stream xytu+"KʆUQ]qleE&!tzR՝G"b\ pQyf_9NxμwuN:U{?V1zQQQ1f咕9sfo,B+с_NDik_!ܤؼLegv\ȣs="zb1XI"V 爅ĽZbXB"jr741K:]`uu o&:&|>qDIdzrOu}kω CWw_RͺY:Ӻ:`AfAFm)0x/Vr^42X:iuDO^;kb*uJk~ZRwx6%C6r^.NJ=;ԡߣZ^RŊXSYn”1Aj##Xa0]~u#O OMJ6ww ;k? \_:*|䪶j#PtJlWFu]-E{|\];4!eMdMd }XVaD&ؙz\KE?D}1qeT!% 4;f`?XXdH6X|T;썠pMFb7ӨAؙfg($6bKPQ @22C!/<Z&Q Gwb +)wQM*~xww}~|K2 Wp쩀G؊ux +VE;=L[^AC˙4.&m m\ػwr ;E3=PoxӐG )P{!WQU.E ?ji{@Ӡp k7g)vSPLv#2BURtW E7rNHN [THiu騰ڳ5<'!g'B-~ YSޞCb"+ Hʛ&ė@6w) z3$ Ogά&Dp.`UD}<'֍| BViT# $-Y޲nOA ,հKPtjcD. dӱKquH Q}@.M 〜o1b+.k~}|R/Pd?ukm]W*RpՇRAN "Dg.VE),BJ=KQz^yǀ+&sdWpVINj|:j؆LLgEկ_W/RH;h;\I@Q{+vY5[y|o6#LCendstream endobj 82 0 obj << /Filter /FlateDecode /Length 2524 >> stream xZݏ$7y^ B A3ӻ3Lf'wvޅøv_]E! w}XvcoևŻϔ.)W\, ,PzPWs* Rj`?-V(X*V@bqY<0 M54ehqsg`C׳C'xόR!n Wwkq^Yln&abbLW:LPF0sc"CZ Y\PZ xO^9FA7J!({H?xPKr\7 dgQ^->YL@x(G`ⰰl߱_|ʃPOb`]uGh+ `7菛Z@v[m=xqT+!0S[ OY& w:-W42@re&-\)~Ć_vePGq3t_ $ﯗGJ#^nwe"qEDp[E e;&mp<,%^ 6vEy93hAkl0SZxo'n˃ OHGy \o``RU4DŽpj cxj[u8QsBbm:u-/EDsgvٸM!MSWx JfB1nݯ^qzڈcsnwÚ(6jә]gsPӶX!)3ڗn"`&Ms|_uAW vu;<=͸Ѭ-|=${%*9MVjKU2]L- $][4 aR_F@GQ/\d3| wm~]T0bf H!u{s7s6 ]oPjQt>f'qFNP8UȢ9  nC}a)FQfCM AJHre%ɱRXboҞBM]K-iQYBɦ1ŋ ѽgb[XPtg ^ɸհ!\TqW&KToKGWfX/mʚ7%IWJ|^MJ4ujͮM^Zץ S͋;6ɻew\z;J#3= ^iH;Cgf,FzkBiAsF. NauSovҮsk2/0$8*nt5BP?ѱK4T88 U@R+3ځqX1!I*h,wyxy3 L8VɜO!7J33(OC=8=i^ b|"਷&2FpƑ6/$FHd`@Ztu+(oU!1rd$1+C;<*ThέR#kWIf+1Is`f=ܿ;A#2Aor;FMM:bvGþ=@)[ cK0̀l8CD8z&rQB@],} xR^򥙖/(d[J.Pu5 c- Jsqt2 Z"Y9Q!"%%:;z5l]IYKF)փR An :$Z>JVyq9x絴sWq00;xH!B9'Av?Vn&u /u9odQ}a of[~$(]8R[8&믜{3dCLa >Oy%G<']8 +u4)^ f)S[b`ߋcƔcd'IFΑ?d,3"·Ҍ MiFaM >e+Yq;B[t,YLy.0̯PƁҜXms:k^ǫfje*We2VPGMzJxTpI&&W|jw:cU*ގK\e:ڡNx/uj[h^{/8zi8naݵ|{_IooS[Pne}w72UR´OU֬ogUBWFwꐯѐh'Esv8xNڟI%X /Lb뻺Aor_liWs\T]%vXY2U("fOIendstream endobj 83 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 244 >> stream xcd`ab`dddw 441%(gaa}E3'@r<E9 L Y49{f{?3T^%:gnU6UUv#swo:|0៺?~D.h^%*|]^z.'N/?ݕvٟq0`nW/=]Dz,C^]XO|>'ozfendstream endobj 84 0 obj << /Filter /FlateDecode /Length 2391 >> stream xXKs["~(L+U-STtЦ\vDX(9 a&;~|( ]ݞzܭ9DHW7۳h.fwD3F) .*0Z6˅VY ]PF '4q8)f>{9.s%Z@I Óݰ]:ejiS)PChri0&6YjS.U?%s(]&J(&px c-ʪvv.f0crEW73_|IB%79cQfimVP P}ZjjqK(u_4=Y2i*g8X<~<r׌8}Yx0Nn3GǨD)dt8eQY.'i`#fח0`9b`"qA 2fAS&pIՌhgw RnXT5qɉ͜/kTq%,Ym=aW]%ޙjKHŤ)M>U HVr}RrP EGQ*lU=V׿X&B mχl I(S!< BK~3Xq%%.371;TS%RKS%0&1& @>#spHZ ol$qoq !%%t71Xu0ɋH0uf{WCm(%:,C,KJs³cLmΗ}m4xd/wϲ\qIc~ : z1!Z'Tۋ77?]-6%V\Ei..(jOMv:($?^=/I`NA9bJ^"z9,yc 91G`a3 e=$ a Ē㴄'%l]绸? A6F3e]۷1l]X-Ek3kHJ9"kG)9|B,T ~& j0b<3)ȡ+,#ڪ1\3e84 }U@}K'("bDTXWߊH GNlK4sB"Yzv  ,PU"|x*qe@̨Ksb7V-6;/g!!)FR$Ƌ6Ykxc 1u,jxtMw[7:CM{ w3*ŀ:*]/..p#<_ͥ'C=$K成Y ^k RpL@ 43(i>L4g:q;/9ʹPsBֻbǢ&iI&n:v©Ӗ.3\:{]Z✃ wQmÇ5QVdf]KhBOe_|Øjx=/UŔm1iʹ^RI„*rcuh0P ݧx)j0JBUߜg46ɜRD_j@dB'#l킂wׯ1w}w &$"EXvJ8cjuڎ]{_M[u{Wm&a(2Ć!jq뾫L 8׌PCTHKvDi. 51l}*U!=1%r,x軱De"!Z}]TZ_}U6Q›xT?7SQ*'Io2Rϧi$0rmZ1d Y.ϣ^u8*\aA׿s)>(5i7Wm`P6\UO lxG^air8 ^H?J0ݡ;cƼ5bjӋĘԋ|>u e1:SPDKQljg >}cNLr3{k/{ .AmH+]U6 Y ]4pBt01>PK93x ![Dh15(筠, /cuT|' V, qnS"`phZLK-[p74hFOmwc׻_@g?@endstream endobj 85 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 627 >> stream x-mHq62̂;^(/0@L" ħrhs-oۼN۝&X,KklBYQڋ^7wqAyϋ/|p,ǀ8w3%[RS[ִ\03ڝ_ݹ Ҏa5XV}L<^m`,۫3,U2~ˬG?$=ZJLqEv'YbAPQ=E҆Vδ)m*]礛ѱ)?$F/ )_Qq 0H*uH7BTYjG͊-~ZgV-Ϩ37g@hXMu=W{읧6YR$>fzn=6Ə m0M@).eAV H/<k\iLMc-ݵzG_ߨ@9!ҊeI-?fpա-XѺ [ͱ{>aU)[A1"nrYpQ5KMIxDYCHfG3Kz >YLF`6UX]\x) n7ȑt^tNsɉ;e]ZEG!S0 ez=IY sendstream endobj 86 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6664 >> stream xyytג]5rMg.ꄐdǻ-KkI3ͪ],ym%kHـ$$m=;r'ygts̙.Wj{-X=.;-OofW쫤\-O慝gl[ۖn_V|[|Suuu5u+tݦ[]nNOukuOݥ{Zwnnnݳtt=[[Zw,]NSEiVլ*\S(g|3|s/=w>o hя׼WM\ƪ~\/_劺1ݜ˳V[[Rr>^yrZq5*X f1vDxX/2LB8)d.l@42L$=%2 ((|R~-VQ,@j&ykk튠s`CqC0 3 Jb<1ILV:`#xFNt˂,e\uQ+V(o8U+Qp<^̈́0P@ EG=M&F=4x&f䎺#bAď+=C^w-hzY6Tb{,@@D{h3{vJ\dK={J`8jբum+VoW*)/3?qݬ 17m>V:rom?-?BiXΜ;s@azm 3PĜ˳ܢ^PC ck 5p+ܶr_z{#I=Ab G1qwWq(,WLG}3ࠝI"L˸E#l,"SM\OFplioUYenyٹyCFՏwHC?5~zzH M `ſ0Q@ 96d @=ձ͵_GܣrQtiX7M Eű"" (i;13R)cΒ?k Z%D!sxp ",29?n NwXzCB_(=U>y|bX&V)PXwZINęɗlp:M 0UiXV};12qF8lk." d$uc9KAl4V{3hAA,T0ZB. GY-$Ѹ}v%eIKz3pW{c=l@$5q$Ѳ3\XC9 Q:pxC^KK"!o0 o<21C ,ä DLH &%@$V<8LL.b#6#Z(.`I3&>ͧ4rPn݁[ L ']lLsðTf3䋽d.GSm?{>!Č=HևnlYs6Xh:+eV {WUM'޾bǺ>/>rM:kIqʷ^򧧍.QY9>eF{./e<$cI!#1Ͱ  ň= a'lhnܹcm- ϔ!nH$UL wGeG? nYj93kPŕ8xR4*k%^rVbSIYkP֔o6Z-dV!SVopK9>"&##A ur9Bҳ99L\ I@`R⒘$ %<GX@B^{W=7?Bd)@1/MHX2ߍݧ*s; x R/iYx}ӿӾh' K/%4 UiOFZ,$Pp֭Z U!l+(+;H#Ӓ?o7:)w5bI9,A/0#R616A@Yj孋`1z঳GG4>Ygx\C^O?f 'Rq+ 2NvKnxM; ½E" g$ C>p3f`3=APfYnx"B<ka-`m&w|yJm ]iw`Kvb:n@/^=_zMB.H(DDböע> &z''N4HN5s.ϚΪ,-wy\Qe[F8;oе[%+*&y$,.I`ՆX +)7 GlbEM i&_ҙԫo}``hR3Z឴msN3,_wR_穣 7v-fG*k Zv룍MR(!^ώ/Q6ޤvgBOU`nX1Vvn݁1'! Fj*PtHS02%C)ON;(teV2 'dz %*ݹJ7p ayN9!]OM N b^ȿM\qƜn-%Rg-]ka,/:bL=1tBoK6Qnn29m6@uXt,:~=sjK\_nEvoY1rŹ׿4Ş,oamЎ6<826'N #CT[]ѵp"~(y(q(u2( d t ׌xi}vǖ:;,vM.'a3K`(9K94v픓wzjpSm:usB2]4v=X^{'t@[ҿ@0¶w758r請HI*"2(@ojѳn@U{ĺ7oЄujՓRH.PŴ8(#-F_;ѹy,D Ԟۻ'׏Ii&c[ՖrF 'Yޠ^ާӽ$!R$)W׻ys*(<$/^< za-hJoY i4P|=#qizKF:GJ(d.֋X{csݗ2:_ڌt2x45l*ɦ*0_ D1C 0Bu4*6^"z% z+S&qO^:" 2"V Hۦ&<#Q#&S]y*$;0ru@/c<$(=m#!zu&aH0D$Y}3@fyc\h+$$=BVL\JHGR"fPh X 5_W _!z,d +Pb2Ax3B7.C lS7"# vrVkF v,:ݔrXi$+6+oMW=_097=w w Meh @$ $KCIęDuL1?%ܘF>HC*6EǢ㱱\mz-ވ%E# :'CY0iJȦv' QRtL (AUf茘YY֋'頺z`a DAVeF}þodIR!Ym 1juQݞE" =t& SZ }mWBc *_k9ݷkʬ~6yv4!A/7[i@+l>;Ë p[W֗!&\ޤ _6{'nR,:7R w|^Fӫͬ>@7W2!Q=9|7PL.(_ܬ>/VQicz**uyHLS#?U b.V:"&fw%E,T(_ְ!hAkjU+M]o3&pA ^ghoi2alT1] *PP$MN7'h`b~6A,vX>?$ _41_gjH8bqEeSo gT6R\Ђ4\1cq kM]ZJa3)>'&sЋroeϟ$vZ<]{,W4:Bxn0AuYzwnk>rípzbOo)}FP^׾kkg8#8z=wLU4C|JQˉ9!wLi6EbBH JЭt7b1`w-7\zӲܒw(?(Ǖg>yXlBo}ue knD鷼4'S8l"H d-jD}~(0 mm۩iًO()G ʫe/b῔s'F;UV:)᫻נ9a+81u4Z"-@޸P=^ u,y؏zp /K(WG8^CXo/t׸R Yмxd:J^C0XK?a,mlFȬ@R~~J,oϾ:f l Wzz޲ض7m 4lDP^f|++ \C<uuZ}־hz-8.a=$ĔԛL%c~Hpϑx)UEIu)Wn0]f+ ud Cַc@_+7*ל[1HE/Ι^H5?O.y8~&SL AҳHK2S$ r7`m.l^{z_ۻh;dL ]~ߦV6H=C#\iĄiJSlBύL-RM?dCaf` ] '_LM{vh &V $φPՉyȀ/e8S3i@"X :8={LrtCTQh0 Q|P+#*^>RZ3}[vOh$bl0p^qiy*@_oz7;7ƪ[߹E՟އ'Œ<eS|* %dTH1),pyw7V cM\!c}t)ɑGMmqfУMOMiO||=Tɚ!yzC4]vm|R^l\|6B1<P?s,*v=(%żOYkDr$tͤgwr{R}/5@&~wޑQ12}tj@al,jj +`} SLFyA?

oQrR_Kw34^j0v@Fr XN;{/͆Lz 9x i@, :yfS;֘PAX*?yO+ߙgte9dd1;zg\STDHW6ϥ/J܋CH^уC,bNpN$v@H$}mo z,׺DŖk^e z4 _kd߄ ę8b &Bt{0n|tEf zD }6!P0wlpݡ>n *&S?0Q&Q$#CBEYL2(^O5N@h#a jTȇBzwI1E`2Յ0.d;vxph&3 +7+YSf83fY)-'fX—46;Z \}=mђ V/?ni P3*_lt 1v|endstream endobj 87 0 obj << /Type /XRef /Length 125 /Filter /FlateDecode /DecodeParms << /Columns 4 /Predictor 12 >> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 88 /ID [<855e304dcc005125de8421f6b4765874>] >> stream x˽ AFs\\"B:PVYAcFI ,9=y(Ogs4HBjgFrGse5$b ݑ,DC |i endstream endobj startxref 57814 %%EOF expm/inst/doc/expm.R0000644000176200001440000000047614660607531014060 0ustar liggesusers### R code from vignette source 'expm.Rnw' ################################################### ### code chunk number 1: expm.Rnw:49-55 ################################################### library(expm) m <- matrix(c(4, 1, 1, 2, 4, 1, 0, 1, 4), 3, 3) expm(m) dimnames(m) <- list(letters[1:3], LETTERS[1:3]) m expm(m) expm/inst/test-tools.R0000644000176200001440000001233214655414132014446 0ustar liggesusers#### Will be sourced by several R scripts in ../tests/ source(system.file("test-tools-1.R", package="Matrix"), keep.source=FALSE) expm.t.identity <- function(x, method, tol = .Machine$double.eps^0.5, check.attributes = FALSE, ...) { ## Purpose: Test the identity expm(A') = (expm(A))' ## ---------------------------------------------------------------------- ## Arguments: method, ... : arguments to expm() ## tol, check.attributes: arguments to all.equal() ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 23 Feb 2008, 17:26 ex <- expm::expm(x , method=method, ...) et <- expm::expm(t(x), method=method, ...) all.equal(t(ex), et, tolerance = tol, check.attributes = check.attributes) } ### This is similar to Matrix' example(spMatrix) : ##' @title random sparse matrix ##' @param nrow,ncol dimension ##' @param ncol ##' @param nnz number of non-zero entries ##' @param density ##' @param rand.x random number generator for 'x' slot ##' @return an nrow x ncol matrix ##' @author Martin Maechler, 14.-16. May 2007 rSpMatrix <- function(nrow, ncol = nrow, density, nnz = density*nrow*ncol, sparse = FALSE, rand.x = function(n) round(100 * rnorm(n))) { stopifnot((nnz <- as.integer(nnz)) >= 0, nrow >= 0, ncol >= 0, nnz <= nrow * ncol) xx <- rand.x(nnz) ## unfortunately, the two resulting matrices might *not* be identical: ## because the x's of repeated (i,j)'s will be *added* for sparse, but not dense: ## set.seed(11); m <- rSpMatrix(12, density = 1/10) ## set.seed(11); M <- rSpMatrix(12, density = 1/10, sparse=TRUE) if(sparse) spMatrix(nrow, ncol, i = sample(nrow, nnz, replace = TRUE), j = sample(ncol, nnz, replace = TRUE), x = xx) else { m <- matrix(0, nrow, ncol) m[cbind(i = sample(nrow, nnz, replace = TRUE), j = sample(ncol, nnz, replace = TRUE))] <- xx m } } zeroTrace <- function(m) { ## Make the {average} trace to 0 -- as it is inside expm(. "Ward77") ## This version also works for 'Matrices' stopifnot(length(dim(m)) == 2, is.numeric(dd <- diag(m))) diag(m) <- dd - mean(dd) m } uniqEntries <- function(m, diagS = FALSE) { ## Purpose: make the non-zero entries of matrix 'm' ``unique'' ## ---------------------------------------------------------------------- ## Arguments: ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 26 Feb 2008, 14:40 m[m > 0] <- seq_len(sum(m > 0)) m[m < 0] <- -seq_len(sum(m < 0)) if(diagS) diag(m) <- 10 * sign(diag(m)) m } ## This needs "Matrix" package rMat <- function(n, R_FUN = rnorm, rcondMin = 1.4 * n ^ -1.6226, iterMax = 100) { ## Purpose: random square matrix "not close to singular" ## ---------------------------------------------------------------------- ## Arguments: ## NOTE: needs Matrix::rcond() -- 2023-11: WHY? {it has more norm = "", but..} ## ---------------------------------------------------------------------- ## Author: Martin Maechler, Date: 19 Jan 2008 ## ##--> /u/maechler/R/MM/Pkg-ex/Matrix/rcondition-numb.R researches rcond( ) ## Result : ## -log[rcond] = log(Kappa) = 1.051 + 1.6226 * log(n) ## ================================================== ## 1/rcond = Kappa = exp(1.051 + 1.6226 * log(n)) ## = 2.8605 * n ^ 1.6226 ## ================================================== ## since we *search* a bit, take a factor ~ 4 higher rcond: ## 4 / 2.8605 ~ 1.4 --> default of rcondMin above stopifnot(require("Matrix")) # needs also as(*, ..) etc it <- 1 rcOpt <- 0 repeat { M <- matrix(R_FUN(n^2), n,n) if((rc <- Matrix::rcond(M)) >= rcondMin) break if(rc > rcOpt) { rcOpt <- rc M.Opt <- M } if((it <- it+1) > iterMax) { warning("No Matrix found with rcond() >= ",format(rcondMin), "\n Achieved rcond() = ", format(rcOpt),"\n") M <- M.Opt break } } M } ##' call expm(A, ) for (all possible) methods and do catch errors expmAll <- function(A, meths = eval(formals(expm)$method), errFUN = conditionMessage) { if(!missing(meths)) stopifnot(meths %in% eval(formals(expm)$method)) sapply(meths, simplify = FALSE, function(mtd) tryCatch(expm(A, method = mtd), error = errFUN)) } ##' Are they "equal" -- typically applied to result of expmAll() allEq <- function(Lst, iBest = 1L, check.attributes=FALSE, tol = 1e-10, ...) { stopifnot(!is.na(iB <- as.integer(iBest)), length(iB) == 1L, 1L <= iB, iB <= length(Lst), is.list(Lst)) sapply(Lst[-iB], simplify=FALSE, # not vapply() : result TRUE or "..." function(R) all.equal(Lst[[iB]], R, check.attributes=check.attributes, tolerance=tol, ...)) } doExtras <- interactive() || nzchar(Sys.getenv("R_EXPM_CHECK_EXTRA")) || identical("true", unname(Sys.getenv("R_PKG_CHECKING_doExtras"))) expm/build/0000755000176200001440000000000014660607531012332 5ustar liggesusersexpm/build/vignette.rds0000644000176200001440000000031314660607531014666 0ustar liggesusersmP @R_W.!]]EUTn}yz{o(%0L p@@aG]5xmsy«Y|goWuj5E+j6 mk.D)NWͤqCüӻ-9ǑDz,T?uث~RJh\V/$c~ڰ1expm/build/partial.rdb0000644000176200001440000000010114660607517014453 0ustar liggesusersb```b`aad`b15/17A"he7expm/man/0000755000176200001440000000000014660607514012007 5ustar liggesusersexpm/man/expAtv.Rd0000644000176200001440000000573314655414337013560 0ustar liggesusers\name{expAtv} \title{Compute Matrix Exponential exp(A t) * v directly} \alias{expAtv} \alias{expmv}% - the MATLAB name "mv" = Matrix-Vector (in Stats/R mv:= multivariate) \description{ Compute \eqn{\exp(A t) * v} directly, without evaluating \eqn{\exp(A)}. } \usage{ expAtv(A, v, t = 1, method = "Sidje98", rescaleBelow = 1e-6, tol = 1e-07, btol = 1e-07, m.max = 30, mxrej = 10, verbose = getOption("verbose")) } \arguments{ \item{A}{n x n matrix} \item{v}{n - vector} \item{t}{number (scalar);}% ___ FIXME allow vector ? ___} \item{method}{a string indicating the method to be used; there's only one currently; we would like to add newer ones.} \item{rescaleBelow}{if \code{\link{norm}(A,"I")} is smaller than \code{rescaleBelow}, rescale \code{A} to norm 1 and \code{t} such that \eqn{A t} remains unchanged. This step is in addition to Sidje's original algorithm and easily seen to be necessary even in simple cases (e.g., \eqn{n = 3}).} \item{tol, btol}{tolerances; these are tuning constants of the "Sidje1998" method which the user should typically \emph{not} change.} \item{m.max, mxrej}{integer constants you should only change if you know what you're doing} \item{verbose}{flag indicating if the algorithm should be verbose..} } \value{a list with components \item{eAtv}{.....fixme...} } % \details{ % } \references{ Roger B. Sidje (1998) EXPOKIT: Software Package for Computing Matrix Exponentials. \emph{ACM - Transactions On Mathematical Software} \bold{24}(1), 130--156. (\bold{Not} yet available in our \pkg{expm} package!)\cr%% but see ../Misc/README and ../Misc/expmv/ Al-Mohy, A. and Higham, N. (2011). Computing the Action of the Matrix Exponential, with an Application to Exponential Integrators. \emph{SIAM Journal on Scientific Computing}, \bold{33}(2), 488--511. \doi{10.1137/100788860} %% @article{doi:10.1137/100788860, %% author = {Al-Mohy, A. and Higham, N.}, %% title = {Computing the Action of the Matrix Exponential, with an %% Application to Exponential Integrators}, %% journal = {SIAM Journal on Scientific Computing}, %% volume = 33, %% number = 2, %% pages = {488-511}, %% year = 2011, %% doi = {10.1137/100788860}, %% URL = {http://epubs.siam.org/doi/abs/10.1137/100788860}, %% } } \author{Ravi Varadhan, Johns Hopkins University; Martin Maechler (cosmetic, generalization to sparse matrices; rescaling (see \code{rescaleBelow}). } % \note{ % } \seealso{ \code{\link{expm}}%,.... } \examples{%% tests are at end of ../tests/ex2.R source(system.file("demo", "exact-fn.R", package = "expm")) ##-> rnilMat() ; xct10 set.seed(1) (s5 <- Matrix(m5 <- rnilMat(5))); v <- c(1,6:9) (em5 <- expm(m5)) r5 <- expAtv(m5, v) r5. <- expAtv(s5, v) stopifnot(all.equal(r5, r5., tolerance = 1e-14), all.equal(c(em5 \%*\% v), r5$eAtv)) v <- 10:1 with(xct10, all.equal(expm(m), expm)) all.equal(c(xct10$expm \%*\% v), expAtv(xct10$m, v)$eAtv) } \keyword{algebra} \keyword{math} expm/man/balance.Rd0000644000176200001440000000660514655414337013675 0ustar liggesusers\name{balance} \alias{balance} \alias{dgebal} \title{Balance a Square Matrix via LAPACK's DGEBAL} \description{ Balance a square matrix via LAPACK's \code{DGEBAL}. This is an \R interface, mainly used for experimentation. This LAPACK routine is used internally for Eigenvalue decompositions, but also, in Ward(1977)'s algorithm for the matrix exponential. The name \code{balance()} is preferred nowadays, and \dQuote{dgebal()} has been deprecated (finally, after 9 years ...). } \usage{ balance(A, job = c("B", "N", "P", "S")) ## Deprecated now: ## dgebal(A, job = c("B", "N", "P", "S")) } \arguments{ \item{A}{a square (\eqn{n\times n}{n x n}) numeric, logical or complex matrix.} \item{job}{a one-letter string specifying the \sQuote{job} for DGEBAL / ZGEBAL. \describe{ \item{P}{\bold{P}ermutation} \item{S}{\bold{S}caling} \item{B}{\bold{B}oth permutation and scaling} \item{N}{\bold{N}one} } } } \value{ A list with components \item{z}{the transformation of matrix \code{A}, after permutation and or scaling.} \item{scale}{numeric vector of length \eqn{n}, containing the permutation and/or scale vectors applied.} \item{i1,i2}{integers (length 1) in \eqn{\{1,2,\dots,n\}}, denoted by \code{ILO} and \code{IHI} respectively in the LAPACK documentation. Only relevant for \code{"P"} or \code{"B"}, they describe where permutations and where scaling took place; see the \sQuote{Details} section. } } \details{ An excerpt of the LAPACK documentation about \code{DGEBAL()} or \code{ZGEBAL()}, respectively, describing the result \describe{ \item{i1 ("ILO")}{(output) integer} \item{i2 ("IHI")}{(output) integer\cr \code{i1} and \code{i2} are set to integers such that on exit \code{z[i,j] = 0} if \eqn{i > j} and \eqn{j = 1,...,i1-1} or \eqn{i = i2+1,...,n}. If \code{job = 'N'} or \code{'S'}, \code{i1 = 1} and \code{i2 = n}.} \item{scale}{(output) numeric vector of length \code{n}. Details of the permutations and scaling factors applied to \code{A}. If \code{P[j]} is the index of the row and column interchanged with row and column \code{j} and \code{D[j]} is the scaling factor applied to row and column j, then \code{scale[j] = P[j]} for \eqn{j = 1,...,i1-1}\cr \code{ = D[j]} for \eqn{j = i1,...,i2},\cr \code{ = P[j]} for \eqn{j = i2+1,...,n}. The order in which the interchanges are made is \code{n} to \code{i2+1}, then \code{1} to \code{i1-1}.} } Look at the LAPACK documentation for more details. } \references{ LAPACK Reference Manual, \url{https://netlib.org/lapack/}, balancing \sQuote{gebal}, currently at \url{https://www.netlib.org/lapack/explore-html/df/df3/group__gebal.html}. } \author{Martin Maechler} \seealso{\code{\link{eigen}}, \code{\link{expm}}. } \examples{ m4 <- rbind(c(-1,-1, 0, 0), c( 0, 0,10,10), c( 0, 0,10, 0), c( 0,10, 0, 0)) (b4 <- balance(m4)) ## --- for testing and didactical reasons : ---- if(expm:::doExtras()) withAutoprint({ sessionInfo() packageDescription("Matrix") "expm installed at" dirname(attr(packageDescription("expm"), "file")) }) demo(balanceTst) # also defines the balanceTst() function # which in its tests ``defines'' what # the return value means, notably (i1,i2,scale) } \keyword{array} \keyword{arith} expm/man/expm.Rd0000644000176200001440000002643514655414337013264 0ustar liggesusers\name{expm} \alias{expm} \alias{mexp}% for now \alias{.methComplex} \alias{.methSparse} \title{Matrix Exponential} \description{ This function computes the exponential of a square matrix \eqn{A}, defined as the sum from \eqn{r=0} to infinity of \eqn{A^r/r!}. Several methods are provided. The Taylor series and Pad\enc{é}{e'} approximation are very importantly combined with scaling and squaring. } \usage{ expm(x, method = c("Higham08.b", "Higham08", "AlMohy-Hi09", "Ward77", "PadeRBS", "Pade", "Taylor", "PadeO", "TaylorO", "R_Eigen", "R_Pade", "R_Ward77", "hybrid_Eigen_Ward"), order = 8, trySym = TRUE, tol = .Machine$double.eps, do.sparseMsg = TRUE, preconditioning = c("2bal", "1bal", "buggy")) .methComplex # those 'method' s which also work for complex (number) matrices .methSparse # those 'method' s which work with _sparseMatrix_ w/o coercion to dense } \arguments{ \item{x}{a square matrix.} \item{method}{\code{"Higham08.b"}, \code{"Ward77"}, \code{"Pade"} or \code{"Taylor"}, etc; The default is now \code{"Higham08.b"} which uses Higham's 2008 algorithm with \emph{additional} balancing preconditioning, see \code{\link{expm.Higham08}}. The versions with "*O" call the original Fortran code, whereas the first ones call the BLAS-using and partly simplified newer code.\cr \code{"R_Pade"} uses an \R-code version of \code{"Pade"} for didactical reasons, and\cr \code{"R_Ward77"} uses an \R version of \code{"Ward77"}, still based on LAPACK's \code{dgebal}, see \R interface \code{\link{dgebal}}. This has enabled us to diagnose and fix the bug in the original octave implementation of \code{"Ward77"}. \code{"R_Eigen"} tries to diagonalise the matrix \code{x}, if not possible, \code{"R_Eigen"} raises an error. \code{"hybrid_Eigen_Ward"} method also tries to diagonalise the matrix \code{x}, if not possible, it uses \code{"Ward77"} algorithm. } \item{order}{an integer, the order of approximation to be used, for the \code{"Pade"}, incl \code{"R_Ward77"}, and \code{"Taylor"} methods. The best value for this depends on machine precision (and slightly on \code{x}) but for the current double precision arithmetic, one recommendation (and the Matlab implementations) uses \code{order = 6} unconditionally;\cr our default, \code{8}, is from Ward(1977, p.606)'s recommendation, but also used for \code{"AlMohy-Hi09"} where a high order \code{order=12} may be more appropriate (and slightly more expensive).} \item{trySym}{logical indicating if \code{method = "R_Eigen"} should use \code{\link{isSymmetric}(x)} and take advantage for (almost) symmetric matrices.} \item{tol}{a given tolerance used to check if \code{x} is computationally singular when \code{method = "hybrid_Eigen_Ward"}.} \item{do.sparseMsg}{logical allowing a message about sparse to dense coercion; setting it \code{FALSE} suppresses that message.} \item{preconditioning}{a string specifying which implementation of Ward(1977) should be used when \code{method = "Ward77"}. %%% FIXME explain more } } \details{ The exponential of a matrix is defined as the infinite Taylor series \deqn{e^M = \sum_{k = 1}^\infty \frac{M^k}{k!}.}{% exp(M) = I + M + M^2/2! + M^3/3! + \dots} For the "Pade" and "Taylor" methods, there is an \code{"accuracy"} attribute of the result. It is an upper bound for the L2 norm of the Cauchy error \code{expm(x, *, order + 10) - expm(x, *, order)}. Currently, mostly algorithms which are \emph{\dQuote{\R-code only}} accept \emph{sparse} matrices (see the \code{"\link[Matrix:sparseMatrix-class]{sparseMatrix}"} class in package \CRANpkg{Matrix}). Their \code{method} names are available from \code{.methSparse}. Similarly only some of the algorithms are available for \code{\link{complex}} (number) matrices; the corresponding \code{method}s are in \code{.methComplex}. } \value{ The matrix exponential of \code{x}. } \seealso{ The package vignette for details on the algorithms and calling the function from external packages. \code{\link{expm.Higham08}} for \code{"Higham08"}. \code{\link{expAtv}(A,v,t)} computes \eqn{e^{At} v} (for scalar \eqn{t} and \eqn{n}-vector \eqn{v}) \emph{directly} and more efficiently than computing \eqn{e^{At}}. } \author{ The \code{"Ward77"} method:\cr Vincent Goulet \email{vincent.goulet@act.ulaval.ca}, and Christophe Dutang, based on code translated by Doug Bates and Martin Maechler from the implementation of the corresponding Octave function contributed by A. Scottedward Hodel \email{A.S.Hodel@eng.auburn.edu}. The \code{"PadeRBS"} method:\cr Roger B. Sidje, see the EXPOKIT reference. The \code{"PadeO"} and \code{"TaylorO"} methods:\cr Marina Shapira (U Oxford, UK) and David Firth (U Warwick, UK); The \code{"Pade"} and \code{"Taylor"} methods are slight modifications of the "*O" ([O]riginal versions) methods, by Martin Maechler, using BLAS and LINPACK where possible. The \code{"hybrid_Eigen_Ward"} method by Christophe Dutang is a C translation of \code{"R_Eigen"} method by Martin Maechler. The \code{"Higham08"} and \code{"Higham08.b"} (current default) were written by Michael Stadelmann, see \code{\link{expm.Higham08}}. The \code{"AlMohy-Hi09"} implementation (\R code interfacing to stand-alone C) was provided and donated by Drew Schmidt, U. Tennesse. } \references{ Ward, R. C. (1977). Numerical computation of the matrix exponential with accuracy estimate. \emph{SIAM J. Num. Anal.} \bold{14}, 600--610. Roger B. Sidje (1998). EXPOKIT: Software package for computing matrix exponentials. ACM - Transactions on Mathematical Software \bold{24}(1), 130--156. Moler, C and van Loan, C (2003). Nineteen dubious ways to compute the exponential of a matrix, twenty-five years later. \emph{SIAM Review} \bold{45}, 3--49. At \doi{10.1137/S00361445024180} Awad H. Al-Mohy and Nicholas J. Higham (2009) A New Scaling and Squaring Algorithm for the Matrix Exponential. \emph{SIAM. J. Matrix Anal. & Appl.}, \bold{31}(3), 970--989. \doi{10.1137/S00361445024180} } \note{ For a good general discussion of the matrix exponential problem, see Moler and van Loan (2003). } \examples{ x <- matrix(c(-49, -64, 24, 31), 2, 2) expm(x) expm(x, method = "AlMohy-Hi09") ## ---------------------------- ## Test case 1 from Ward (1977) ## ---------------------------- test1 <- t(matrix(c( 4, 2, 0, 1, 4, 1, 1, 1, 4), 3, 3)) expm(test1, method="Pade") ## Results on Power Mac G3 under Mac OS 10.2.8 ## [,1] [,2] [,3] ## [1,] 147.86662244637000 183.76513864636857 71.79703239999643 ## [2,] 127.78108552318250 183.76513864636877 91.88256932318409 ## [3,] 127.78108552318204 163.67960172318047 111.96810624637124 ## -- these agree with ward (1977, p608) ## Compare with the naive "R_Eigen" method: try( expm(test1, method="R_Eigen") ) ## platform depently, sometimes gives an error from solve ## or is accurate or one older result was ## [,1] [,2] [,3] ##[1,] 147.86662244637003 88.500223574029647 103.39983337000028 ##[2,] 127.78108552318220 117.345806155250600 90.70416537273444 ##[3,] 127.78108552318226 90.384173332156763 117.66579819582827 ## -- hopelessly inaccurate in all but the first column. ## ## ---------------------------- ## Test case 2 from Ward (1977) ## ---------------------------- test2 <- t(matrix(c( 29.87942128909879, .7815750847907159, -2.289519314033932, .7815750847907159, 25.72656945571064, 8.680737820540137, -2.289519314033932, 8.680737820540137, 34.39400925519054), 3, 3)) expm(test2, method="Pade") ## [,1] [,2] [,3] ##[1,] 5496313853692357 -18231880972009844 -30475770808580828 ##[2,] -18231880972009852 60605228702227024 101291842930256144 ##[3,] -30475770808580840 101291842930256144 169294411240859072 ## -- which agrees with Ward (1977) to 13 significant figures expm(test2, method="R_Eigen") ## [,1] [,2] [,3] ##[1,] 5496313853692405 -18231880972009100 -30475770808580196 ##[2,] -18231880972009160 60605228702221760 101291842930249376 ##[3,] -30475770808580244 101291842930249200 169294411240850880 ## -- in this case a very similar degree of accuracy. ## ## ---------------------------- ## Test case 3 from Ward (1977) ## ---------------------------- test3 <- t(matrix(c( -131, 19, 18, -390, 56, 54, -387, 57, 52), 3, 3)) expm(test3, method="Pade") ## [,1] [,2] [,3] ##[1,] -1.5096441587713636 0.36787943910439874 0.13533528117301735 ##[2,] -5.6325707997970271 1.47151775847745725 0.40600584351567010 ##[3,] -4.9349383260294299 1.10363831731417195 0.54134112675653534 ## -- agrees to 10dp with Ward (1977), p608. expm(test3, method="R_Eigen") ## [,1] [,2] [,3] ##[1,] -1.509644158796182 0.3678794391103086 0.13533528117547022 ##[2,] -5.632570799902948 1.4715177585023838 0.40600584352641989 ##[3,] -4.934938326098410 1.1036383173309319 0.54134112676302582 ## -- in this case, a similar level of agreement with Ward (1977). ## ## ---------------------------- ## Test case 4 from Ward (1977) ## ---------------------------- test4 <- structure(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 1e-10, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0), .Dim = c(10, 10)) attributes(expm(test4, method="Pade")) max(abs(expm(test4, method="Pade") - expm(test4, method="R_Eigen"))) ##[1] 8.746826694186494e-08 ## -- here mexp2 is accurate only to 7 d.p., whereas mexp ## is correct to at least 14 d.p. ## ## Note that these results are achieved with the default ## settings order=8, method="Pade" -- accuracy could ## presumably be improved still further by some tuning ## of these settings. ## ## example of computationally singular matrix -> is nil-potent -> expm(m) = polynomial(m) ## m <- matrix(c(0,1,0,0), 2,2) try( expm(m, method="R_Eigen") ) ## error since m is computationally singular (em <- expm(m, method="hybrid")) ## hybrid use the Ward77 method I2 <- diag(2) stopifnot(all.equal(I2 + m, expm(m))) ## Try all methods -------------------------------------- (meths <- eval(formals(expm)$method)) # >= 13 .. all3 <- sapply(meths, simplify = FALSE, function(mtd) tryCatch(expm(test3, method = mtd), error = conditionMessage)) ## are all "equal" : stopifnot( vapply(all3[-1], function(R) all.equal(all3[[1]], R, check.attributes=FALSE), NA)) all4 <- sapply(meths, simplify = FALSE, function(mtd) tryCatch(expm(test4, method = mtd), error = conditionMessage)) ### Try complex matrices --c--c--c--c--c--c--c--c--c--c--c--c--c--c--c .methComplex zm <- m*(1+1i) # is also nilpotent : stopifnot(zm \%*\% zm == 0, # is nilpotent already for ^2 ==> expm() is linear % all.equal(I2 + zm, expm(zm))) ## --->> more tests in ../tests/{ex,ex2,exact-ex}.R } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/expm.Higham08.Rd0000644000176200001440000001147514655414337014626 0ustar liggesusers\name{expm.Higham08} \Rdversion{1.1} \alias{expm.Higham08} \title{Matrix Exponential [Higham 2008]} \description{ Calculation of matrix exponential \eqn{e^A} with the \sQuote{Scaling & Squaring} method with balancing. Implementation of Higham's Algorithm from his book (see references), Chapter 10, Algorithm 10.20. The balancing option is an extra from Michael Stadelmann's Masters thesis. } \usage{ expm.Higham08(A, balancing = TRUE) } \arguments{ \item{A}{square matrix, may be a \code{"\link[Matrix:sparseMatrix-class]{sparseMatrix}"}, currently only if \code{balancing} is false.} \item{balancing}{logical indicating if balancing should happen (before and after scaling and squaring).} } \details{ The algorithm comprises the following steps \describe{ \item{0.}{Balancing} \item{1.}{Scaling} \item{2.}{Padé-Approximation} \item{3.}{Squaring} \item{4.}{Reverse Balancing} } } \value{ a matrix of the same dimension as \code{A}, the matrix exponential of \code{A}. } \references{ Higham, Nicholas J. (2008). \emph{Functions of Matrices: Theory and Computation}; SIAM (Society for Industrial and Applied Mathematics), Philadelphia, USA; \doi{10.1137/1.9780898717778} Michael Stadelmann (2009). \emph{Matrixfunktionen; Analyse und Implementierung}. [in German] Master's thesis and Research Report 2009-12, SAM, ETH Zurich; \url{https://math.ethz.ch/sam/research/reports.html?year=2009}, or the pdf directly at \url{https://www.sam.math.ethz.ch/sam_reports/reports_final/reports2009/2009-12.pdf}. } \author{ Michael Stadelmann (final polish by Martin Maechler). } \note{ \code{expm.Higham8()} no longer needs to be called directly; rather \code{expm(A, "Higham8b")} and \code{expm(A, "Higham8")} correspond to the two options of \code{balancing = TRUE || FALSE}. } \seealso{ The other algorithms \code{\link{expm}(x, method = *)}. \code{\link{expmCond}}, to compute the exponential-\emph{condition} number. } \examples{ ## The *same* examples as in ../expm.Rd {FIXME} -- x <- matrix(c(-49, -64, 24, 31), 2, 2) expm.Higham08(x) ## ---------------------------- ## Test case 1 from Ward (1977) ## ---------------------------- test1 <- t(matrix(c( 4, 2, 0, 1, 4, 1, 1, 1, 4), 3, 3)) expm.Higham08(test1) ## [,1] [,2] [,3] ## [1,] 147.86662244637000 183.76513864636857 71.79703239999643 ## [2,] 127.78108552318250 183.76513864636877 91.88256932318409 ## [3,] 127.78108552318204 163.67960172318047 111.96810624637124 ## -- these agree with ward (1977, p608) ## ---------------------------- ## Test case 2 from Ward (1977) ## ---------------------------- test2 <- t(matrix(c( 29.87942128909879, .7815750847907159, -2.289519314033932, .7815750847907159, 25.72656945571064, 8.680737820540137, -2.289519314033932, 8.680737820540137, 34.39400925519054), 3, 3)) expm.Higham08(test2) expm.Higham08(test2, balancing = FALSE) ## [,1] [,2] [,3] ##[1,] 5496313853692405 -18231880972009100 -30475770808580196 ##[2,] -18231880972009160 60605228702221760 101291842930249376 ##[3,] -30475770808580244 101291842930249200 169294411240850880 ## -- in this case a very similar degree of accuracy. ## ---------------------------- ## Test case 3 from Ward (1977) ## ---------------------------- test3 <- t(matrix(c( -131, 19, 18, -390, 56, 54, -387, 57, 52), 3, 3)) expm.Higham08(test3) expm.Higham08(test3, balancing = FALSE) ## [,1] [,2] [,3] ##[1,] -1.5096441587713636 0.36787943910439874 0.13533528117301735 ##[2,] -5.6325707997970271 1.47151775847745725 0.40600584351567010 ##[3,] -4.9349383260294299 1.10363831731417195 0.54134112675653534 ## -- agrees to 10dp with Ward (1977), p608. ??? (FIXME) ## ---------------------------- ## Test case 4 from Ward (1977) ## ---------------------------- test4 <- structure(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 1e-10, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0), .Dim = c(10, 10)) E4 <- expm.Higham08(test4) Matrix(zapsmall(E4)) S4 <- as(test4, "sparseMatrix") # some R based expm() methods work for sparse: ES4 <- expm.Higham08(S4, bal=FALSE) stopifnot(all.equal(E4, unname(as.matrix(ES4)))) ## NOTE: Need much larger sparse matrices for sparse arith to be faster! ## ## example of computationally singular matrix ## m <- matrix(c(0,1,0,0), 2,2) eS <- expm.Higham08(m) # "works" (hmm ...) } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/logm.Rd0000644000176200001440000000626613777326364013257 0ustar liggesusers\name{logm} \alias{logm} \title{Matrix Logarithm} \description{ This function computes the (principal) matrix logarithm of a square matrix. A logarithm of a matrix \eqn{A} is \eqn{L} such that \eqn{A= e^L} (meaning \code{A == expm(L)}), see the documentation for the matrix exponential, \code{\link{expm}}, which can be defined as \deqn{e^L := \sum_{r=0}^\infty L^r/r! .}{sum[r = 0,..,Inf; L^r/r!] .} } \usage{ logm(x, method = c("Higham08", "Eigen"), % order = 8, trySym = TRUE, tol = .Machine$double.eps) } \arguments{ \item{x}{a square matrix.} \item{method}{a string specifying the algorithmic method to be used. The default uses the algorithm by Higham(2008). The simple \code{"Eigen"} method tries to diagonalise the matrix \code{x}; if that is not possible, it raises an error. } % \item{order}{only for \code{method = "Eigen"} .. FIXME} % \item{trySym}{only for \code{method = "Eigen"} .. FIXME} \item{tol}{a given tolerance used to check if \code{x} is computationally singular when \code{method = "Eigen"}.} } \details{ The exponential of a matrix is defined as the infinite Taylor series \deqn{e^M = \sum_{k = 1}^\infty \frac{M^k}{k!}.}{% exp(M) = I + M + M^2/2! + M^3/3! + \dots.} The matrix logarithm of \eqn{A} is a matrix \eqn{M} such that \eqn{exp(M) = A}. Note that there typically are an infinite number number of such matrices, and we compute the \emph{prinicipal} matrix logarithm, see the references. Method \code{"Higham08"} works via \dQuote{\emph{inverse} scaling and squaring}, and from the Schur decomposition, applying a matrix square root computation. It is somewhat slow but also works for non-diagonalizable matrices. } \references{ Higham, N.~J. (2008). \emph{Functions of Matrices: Theory and Computation}; Society for Industrial and Applied Mathematics, Philadelphia, PA, USA. The Matrix Logarithm is very nicely defined by Wikipedia, \url{https://en.wikipedia.org/wiki/Matrix_logarithm}. } \value{ A matrix \sQuote{as \code{x}} with the matrix logarithm of \code{x}, i.e., \code{all.equal( expm(logm(x)), x, tol)} is typically true for quite small tolerance \code{tol}. } \seealso{ \code{\link{expm}} } \author{ Method \code{"Higham08"} was implemented by Michael Stadelmann as part of his master thesis in mathematics, at ETH Zurich; the \code{"Eigen"} method by Christophe Dutang. } \examples{ m <- diag(2) logm(m) expm(logm(m)) ## Here, logm() is barely defined, and Higham08 has needed an amendment ## in order for not to loop forever: D0 <- diag(x=c(1, 0.)) (L. <- logm(D0)) stopifnot( all.equal(D0, expm(L.)) ) ## A matrix for which clearly no logm(.) exists: (m <- cbind(1:2, 1)) (l.m <- try(logm(m))) ## all NA {Warning in sqrt(S[ij, ij]) : NaNs produced} ## on r-patched-solaris-x86, additionally gives ## Error in solve.default(X[ii, ii] + X[ij, ij], S[ii, ij] - sumU) : ## system is computationally singular: reciprocal condition number = 0 ## Calls: logm ... logm.Higham08 -> rootS -> solve -> solve -> solve.default if(!inherits(l.m, "try-error")) stopifnot(is.na(l.m)) ## The "Eigen" method ``works'' but wrongly : expm(logm(m, "Eigen")) } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/matpow.Rd0000644000176200001440000000234714655414337013616 0ustar liggesusers\name{matpow} \alias{\%^\%} \alias{matpow} \title{Matrix Power} \description{ Compute the \eqn{k}-th power of a matrix. Whereas \code{x^k} computes \emph{element wise} powers, \code{x \%^\% k} corresponds to \eqn{k - 1} matrix multiplications, \code{x \%*\% x \%*\% ... \%*\% x}. } \usage{ x \%^\% k } \arguments{ \item{x}{a square \code{\link{matrix}}, \code{numeric} or \code{complex}.} \item{k}{an integer, \eqn{k \ge 0}{k >= 0}.} } \details{ Argument \eqn{k} is coerced to integer using \code{\link{as.integer}}. The algorithm uses \eqn{O(log_2(k))}{O(log2(k))} matrix multiplications. } \value{ A matrix of the same dimension as \code{x}. } \author{ Based on an R-help posting of Vicente Canto Casasola, and Vincent Goulet's C implementation in \pkg{actuar}. } \note{ If you think you need \code{x^k} for \eqn{k < 0}, then consider instead \code{solve(x \%^\% (-k))}. } \seealso{ \code{\link{\%*\%}} for matrix multiplication. } \examples{ A <- cbind(1, 2 * diag(3)[,-1]) A A \%^\% 2 stopifnot(identical(A, A \%^\% 1), A \%^\% 2 == A \%*\% A) ## also for complex number matrix Z : Z <- A + 2i*A Z \%^\% 2 stopifnot(identical(Z, Z \%^\% 1), Z \%^\% 2 == Z \%*\% Z) } \keyword{array} \keyword{arith} expm/man/expmCond.Rd0000644000176200001440000000631614531337476014065 0ustar liggesusers\name{expmCond} \title{Exponential Condition Number of a Matrix} \Rdversion{1.1} \alias{expmCond} \description{ Compute the exponential condition number of a matrix, either with approximation methods, or exactly and very slowly. } \usage{ expmCond(A, method = c("1.est", "F.est", "exact"), expm = TRUE, abstol = 0.1, reltol = 1e-6, give.exact = c("both", "1.norm", "F.norm")) } \arguments{ \item{A}{a square matrix} \item{method}{a string; either compute 1-norm or F-norm \emph{approximations}, or compte these \emph{exactly}.} \item{expm}{logical indicating if the matrix exponential itself, which is computed anyway, should be returned as well.} \item{abstol, reltol}{for \code{method = "F.est"}, numerical \eqn{\ge 0}{>= 0}, as \emph{absolute} and \emph{relative} error tolerance.} \item{give.exact}{for \code{method = "exact"}, specify if only the 1-norm, the Frobenius norm, or both are to be computed.} } \details{ \code{method = "exact"}, aka Kronecker-Sylvester algorithm, computes a Kronecker matrix of dimension \eqn{n^2 \times n^2}{n^2 x n^2} and hence, with \eqn{O(n^5)} complexity, is prohibitely slow for non-small \eqn{n}. It computes the \emph{exact} exponential-condition numbers for both the Frobenius and/or the 1-norm, depending on \code{give.exact}. The two other methods compute approximations, to these norms, i.e., \bold{est}imate them, using algorithms from Higham, chapt.~3.4, both with complexity \eqn{O(n^3)}. %% FIXME: Say more } \value{ when \code{expm = TRUE}, for \code{method = "exact"}, a \code{\link{list}} with components \item{expm}{containing the matrix exponential, \code{\link{expm.Higham08}(A)}.} \item{expmCond(F|1)}{numeric scalar, (an approximation to) the (matrix exponential) condition number, for either the 1-norm (\code{expmCond1}) or the Frobenius-norm (\code{expmCondF}).} When \code{expm} is false and \code{method} one of the approximations (\code{"*.est"}), the condition number is returned directly (i.e., \code{\link{numeric}} of length one). } \references{ Awad H. Al-Mohy and Nicholas J. Higham (2009). \emph{Computing Fréchet Derivative of the Matrix Exponential, with an application to Condition Number Estimation}; MIMS EPrint 2008.26; Manchester Institute for Mathematical Sciences, U. Manchester, UK. \url{https://eprints.maths.manchester.ac.uk/1218/01/covered/MIMS_ep2008_26.pdf} Higham, N.~J. (2008). \emph{Functions of Matrices: Theory and Computation}; Society for Industrial and Applied Mathematics, Philadelphia, PA, USA. Michael Stadelmann (2009) \emph{Matrixfunktionen} ... Master's thesis; see reference in \code{\link{expm.Higham08}}. } \author{ Michael Stadelmann (final polish by Martin Maechler). } \seealso{ \code{\link{expm.Higham08}} for the matrix exponential. } \examples{ set.seed(101) (A <- matrix(round(rnorm(3^2),1), 3,3)) eA <- expm.Higham08(A) stopifnot(all.equal(eA, expm::expm(A), tolerance= 1e-15)) C1 <- expmCond(A, "exact") C2 <- expmCond(A, "1.est") C3 <- expmCond(A, "F.est") all.equal(C1$expmCond1, C2$expmCond, tolerance= 1e-15)# TRUE all.equal(C1$expmCondF, C3$expmCond)# relative difference of 0.001... } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/matStig.Rd0000644000176200001440000000277611406622454013715 0ustar liggesusers\name{matStig} \alias{matStig} \docType{data} \title{Stig's "infamous" Example Matrix} \description{ Stig Mortensen wrote on Oct 22, 2007 to the authors of the \pkg{Matrix} package with subject \dQuote{Strange result from expm}. There, he presented the following \eqn{8 \times 8}{8 * 8} matrix for which the Matrix \code{expm()} gave a \dQuote{strange} result. As we later researched, the result indeed was wrong: the correct entries were wrongly permuted. The reason has been in the underlying source code in Octave from which it had been ported to \pkg{Matrix}. } \usage{data(matStig)} \author{Martin Maechler} \examples{ data(matStig) as(matStig, "sparseMatrix") # since that prints more nicely. ## For more compact printing: op <- options(digits = 4) E1 <- expm(matStig, "Ward77", preconditioning="buggy") # the wrong result as(E1, "sparseMatrix") str(E2 <- expm(matStig, "Pade"))# the correct one (has "accuracy" attribute) as(E2, "sparseMatrix") attr(E2,"accuracy") <- NULL # don't want it below E3 <- expm(matStig, "R_Eigen") # even that is fine here all.equal(E1,E2) # not at all equal (rel.difference >~= 1.) stopifnot(all.equal(E3,E2)) # == ##________ The "proof" that "Ward77" is wrong _________ M <- matStig Et1 <- expm(t(M), "Ward77", precond= "buggy") Et2 <- expm(t(M), "Pade"); attr(Et2,"accuracy") <- NULL all.equal(Et1, t(E1)) # completely different (rel.diff ~ 1.7 (platform dep.)) stopifnot(all.equal(Et2, t(E2))) # the same (up to tolerance) options(op) } \keyword{array} \keyword{datasets} expm/man/expmFrechet.Rd0000644000176200001440000000447113044611522014543 0ustar liggesusers\name{expmFrechet} \title{Frechet Derivative of the Matrix Exponential} \alias{expmFrechet} \encoding{UTF-8} \description{ Compute the Frechet (actually \sQuote{Fréchet}) derivative of the matrix exponential operator. } \usage{ expmFrechet(A, E, method = c("SPS", "blockEnlarge"), expm = TRUE) } \arguments{ \item{A}{square matrix (\eqn{n \times n}{n x n}).} \item{E}{the \dQuote{small Error} matrix, used in \eqn{L(A,E) = f(A + E, A)}}%% FIXME \item{method}{string specifying the method / algorithm; the default \code{"SPS"} is \dQuote{Scaling + Pade + Squaring} as in the algorithm 6.4 below; otherwise see the \sQuote{Details} section.} \item{expm}{logical indicating if the matrix exponential itself, which is computed anyway, should be returned as well.} } \details{ Calculation of \eqn{e^A} and the Exponential Frechet-Derivative \eqn{L(A,E)}. When \code{method = "SPS"} (by default), the with the Scaling - Padé - Squaring Method is used, in an R-Implementation of Al-Mohy and Higham (2009)'s Algorithm 6.4. \describe{ \item{Step 1:}{Scaling (of A and E)} \item{Step 2:}{Padé-Approximation of \eqn{e^A} and \eqn{L(A,E)}} \item{Step 3:}{Squaring (reversing step 1)} } \code{method = "blockEnlarge"} uses the matrix identity of %% FIXME use nice LaTeX \deqn{f(\left{ .... \right} ) } \deqn{f([A E ; 0 A ]) = [f(A) Df(A); 0 f(A)]} for the \eqn{2n \times 2n}{(2n) x (2n)} block matrices where \eqn{f(A) := expm(A)} and \eqn{Df(A) := L(A,E)}. Note that \code{"blockEnlarge"} is much simpler to implement but slower (CPU time is doubled for \eqn{n = 100}). } \value{ a list with components \item{expm}{if \code{expm} is true, the matrix exponential (\eqn{n \times n}{n x n} matrix).} \item{Lexpm}{the Exponential-Frechet-Derivative \eqn{L(A,E)}, a matrix of the same dimension.} } \references{see \code{\link{expmCond}}.} \author{Michael Stadelmann (final polish by Martin Maechler).} \seealso{ \code{\link{expm.Higham08}} for the matrix exponential. \code{\link{expmCond}} for exponential condition number computations which are based on \code{expmFrechet}. } \examples{ (A <- cbind(1, 2:3, 5:8, c(9,1,5,3))) E <- matrix(1e-3, 4,4) (L.AE <- expmFrechet(A, E)) all.equal(L.AE, expmFrechet(A, E, "block"), tolerance = 1e-14) ## TRUE } \keyword{algebra} \keyword{math} expm/man/sqrtm.Rd0000644000176200001440000000212711406665466013453 0ustar liggesusers\name{sqrtm} \alias{sqrtm} \title{Matrix Square Root} \description{ This function computes the matrix square root of a square matrix. The sqrt of a matrix \eqn{A} is \eqn{S} such that \eqn{A = S S}. } \usage{ sqrtm(x) } \arguments{ \item{x}{a square matrix.} } \details{ The matrix square root \eqn{S} of \eqn{M}, \eqn{S = sqrtm(M)} is defined as one (the \dQuote{principal}) \eqn{S} such that \eqn{S S = S^2 = M}, (in \R, \code{all.equal( S \%*\% S , M )}). The method works from the Schur decomposition. } \value{ A matrix \sQuote{as \code{x}} with the matrix sqrt of \code{x}. } \references{ Higham, N.~J. (2008). \emph{Functions of Matrices: Theory and Computation}; Society for Industrial and Applied Mathematics, Philadelphia, PA, USA. } \seealso{ \code{\link{expm}}, \code{\link{logm}} } \author{ Michael Stadelmann wrote the first version. } \examples{ m <- diag(2) sqrtm(m) == m # TRUE (m <- rbind(cbind(1, diag(1:3)),2)) sm <- sqrtm(m) sm zapsmall(sm \%*\% sm) # Zap entries ~= 2e-16 stopifnot(all.equal(m, sm \%*\% sm)) } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/DESCRIPTION0000644000176200001440000000363614660661247012755 0ustar liggesusersPackage: expm Type: Package Title: Matrix Exponential, Log, 'etc' Version: 1.0-0 Date: 2024-08-19 Authors@R: c(person("Martin", "Maechler", role=c("aut","cre"), email="maechler@stat.math.ethz.ch", comment = c(ORCID = "0000-0002-8685-9910")) , person("Christophe","Dutang", role = "aut", comment = c(ORCID = "0000-0001-6732-1501")) , person("Vincent", "Goulet", role = "aut", comment = c(ORCID = "0000-0002-9315-5719")) , person("Douglas", "Bates", role = "ctb", comment = "cosmetic clean up, in svn r42") , person("David", "Firth", role = "ctb", comment = "expm(method= \"PadeO\" and \"TaylorO\")") , person("Marina", "Shapira", role = "ctb", comment = "expm(method= \"PadeO\" and \"TaylorO\")") , person("Michael", "Stadelmann", role = "ctb", comment = "\"Higham08*\" methods, see ?expm.Higham08...") ) Contact: expm-developers@lists.R-forge.R-project.org Description: Computation of the matrix exponential, logarithm, sqrt, and related quantities, using traditional and modern methods. Depends: Matrix Imports: methods Suggests: RColorBrewer, sfsmisc, Rmpfr BuildResaveData: no License: GPL (>= 2) URL: https://R-Forge.R-project.org/projects/expm/ BugReports: https://R-forge.R-project.org/tracker/?atid=472&group_id=107 Encoding: UTF-8 NeedsCompilation: yes Packaged: 2024-08-19 09:24:41 UTC; maechler Author: Martin Maechler [aut, cre] (), Christophe Dutang [aut] (), Vincent Goulet [aut] (), Douglas Bates [ctb] (cosmetic clean up, in svn r42), David Firth [ctb] (expm(method= "PadeO" and "TaylorO")), Marina Shapira [ctb] (expm(method= "PadeO" and "TaylorO")), Michael Stadelmann [ctb] ("Higham08*" methods, see ?expm.Higham08...) Maintainer: Martin Maechler Repository: CRAN Date/Publication: 2024-08-19 15:20:07 UTC