expm/0000755000176200001440000000000013444661372011235 5ustar liggesusersexpm/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/po/0000755000176200001440000000000013444641430011644 5ustar liggesusersexpm/po/R-expm.pot0000644000176200001440000000360012412743604013537 0ustar liggesusersmsgid "" msgstr "" "Project-Id-Version: expm 0.999-0\n" "POT-Creation-Date: 2014-10-01 11:20\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" msgstr "" msgid "invalid 'preconditioning'" msgstr "" msgid "Unable to determine matrix exponential" msgstr "" msgid "'A' must be a square matrix" msgstr "" msgid "'x' 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" 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 "logm()" msgstr "" msgid "NA/NaN from %s after %d step." msgstr "" msgid "NA/NaN from %s after %d steps." msgstr "" msgid "|| Tr - I ||" 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 "'x' must be a quadratic matrix" msgstr "" msgid "sqrtm()" msgstr "" msgid "NA/NaN from %s after %d step.\n" msgid_plural "NA/NaN from %s after %d steps.\n" msgstr[0] "" msgstr[1] "" expm/po/expm.pot0000644000176200001440000000433212412731331013335 0ustar liggesusers# SOME DESCRIPTIVE TITLE. # Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER # This file is distributed under the same license as the PACKAGE package. # FIRST AUTHOR , YEAR. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: expm 0.999-0\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2014-10-01 09:33+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:36 expm-eigen.c:214 expm.c:307 logm-eigen.c:219 matpow.c:23 msgid "non-square matrix" msgstr "" #: R_dgebal.c:60 #, c-format msgid "LAPACK's dgebal(%s) returned info code %d" msgstr "" #: expm-eigen.c:64 expm-eigen.c:72 logm-eigen.c:68 logm-eigen.c:76 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:122 logm-eigen.c:126 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:203 logm-eigen.c:213 msgid "invalid argument" 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:164 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "" #: expm.c:167 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "" #: expm.c:288 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:302 #, c-format msgid "invalid 'kind' argument: %s\n" 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.po0000644000176200001440000000553312412743604012621 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: 2014-10-01 09:33+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:36 expm-eigen.c:214 expm.c:307 logm-eigen.c:219 matpow.c:23 msgid "non-square matrix" msgstr "matrice non carre" #: R_dgebal.c:60 #, 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:64 expm-eigen.c:72 logm-eigen.c:68 logm-eigen.c:76 #, c-format msgid "error code %d from Lapack routine dgeev" msgstr "" #: expm-eigen.c:122 logm-eigen.c:126 #, c-format msgid "argument %d of Lapack routine dgesv had invalid value" msgstr "" #: expm-eigen.c:203 logm-eigen.c:213 msgid "invalid argument" msgstr "argument incorrect" #: 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:164 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "la procdure LAPACK dgetrf a produit le code d'erreur %d" #: expm.c:167 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "la procdure LAPACK dgetrs a produit le code d'erreur %d" #: expm.c:288 msgid "invalid argument: not a numeric matrix" msgstr "" #: expm.c:302 #, fuzzy, c-format msgid "invalid 'kind' argument: %s\n" 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/inst/0000755000176200001440000000000013444641430012203 5ustar liggesusersexpm/inst/po/0000755000176200001440000000000013444641430012621 5ustar liggesusersexpm/inst/po/en@quot/0000755000176200001440000000000013444641430014234 5ustar liggesusersexpm/inst/po/en@quot/LC_MESSAGES/0000755000176200001440000000000013444641430016021 5ustar liggesusersexpm/inst/po/en@quot/LC_MESSAGES/R-expm.mo0000644000176200001440000000567712412743604017545 0ustar liggesusers )32Qp'&>8+W63; &El/$ 73k s77(6E"|'& >, k + :  3 ;@ &|  /    $& K ] 7r      'A' is not a matrix'A' must be a square matrix'A' must be a square matrix of dimension at least 2'lucky guess' was better'x' has negative real eigenvalues; maybe ok for %s'x' must be a quadratic matrix'x' must be a square matrixA and E need to have the same dimensionInverse scaling did not work (t = %g).NA/NaN from %s after %d step.NA/NaN from %s after %d step. NA/NaN from %s after %d steps. NA/NaN from %s after %d steps.NaN 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 methodinvalid 'method'invalid 'preconditioning'logm()logm.Higham08() -> (k, m) = (%d, %d)matrix not squarenrow(A) must be >= 1reached maxiter = %d iterations; tolerances too small?sqrtm()|| Tr - I ||Project-Id-Version: expm 0.999-0 POT-Creation-Date: 2014-10-01 11:20 PO-Revision-Date: 2014-10-01 11:20 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); ‘A’ is not a matrix‘A’ must be a square matrix‘A’ must be a square matrix of dimension at least 2‘lucky guess’ was better‘x’ has negative real eigenvalues; maybe ok for %s‘x’ must be a quadratic matrix‘x’ must be a square matrixA and E need to have the same dimensionInverse scaling did not work (t = %g).NA/NaN from %s after %d step.NA/NaN from %s after %d step. NA/NaN from %s after %d steps. NA/NaN from %s after %d steps.NaN 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 methodinvalid ‘method’invalid ‘preconditioning’logm()logm.Higham08() -> (k, m) = (%d, %d)matrix not squarenrow(A) must be >= 1reached maxiter = %d iterations; tolerances too small?sqrtm()|| Tr - I ||expm/inst/po/en@quot/LC_MESSAGES/expm.mo0000644000176200001440000000447612412743604017342 0ustar liggesusersL:8+5+a+)5@7Z'/!&2Y kJxX:8W+++)5>DtK' -N3h& J     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 %dargument %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-0 Report-Msgid-Bugs-To: POT-Creation-Date: 2014-10-01 09:33+0200 PO-Revision-Date: 2014-10-01 09:33+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 %dargument %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/fr/0000755000176200001440000000000013444641430013230 5ustar liggesusersexpm/inst/po/fr/LC_MESSAGES/0000755000176200001440000000000013444641430015015 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.mo0000644000176200001440000000220212412743604016317 0ustar liggesusersT :8+-+YOFS88#\oLAPACK 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: POT-Creation-Date: 2014-10-01 09:33+0200 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/test-tools.R0000644000176200001440000001054412311702321014434 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() ## ---------------------------------------------------------------------- ## 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 } doExtras <- interactive() || nzchar(Sys.getenv("R_EXPM_CHECK_EXTRA")) || identical("true", unname(Sys.getenv("R_PKG_CHECKING_doExtras"))) expm/inst/doc/0000755000176200001440000000000013444641456012760 5ustar liggesusersexpm/inst/doc/expm.pdf0000644000176200001440000016655013444641457014442 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3381 /Filter /FlateDecode /N 61 /First 490 >> stream xkSv:; <6n~'-_ϑIJ`X>tDz%I}' D1" 3 Q C4FH iC2%a a 0!aL 0IFƘ0Ĺ&,%B%4DrCQf:1B2QsIt+D)љ2D$$X0xDp$F!&2OI4d'` ʄdi‰d$=03) `F)h g# dkłD!N ОD" \i(#<* *,L`2aI$`M#ozχ7htz6K}yvٙy19q'?cBOӳc ow|t7MoWdkR{ŬgNx7w7ê /s;q#_7{D~HB_fV (bܶR 3eSv[Ir]4q$lWAͭ9fͅunx:Y䓛ay Vc{'8T4;JU2 u*MQ)TFTE7&K_deAH;Nب2ej]@);{N&+-"ȼ}-he]mRI{'X|fw[4DRx?cχ[rLcC#l T 62Y1WDg}%Ɯь 1dG$"\5ך1Dyhm:M-8IY%lKGA0޾..^@!crD8T#k{}꭭]ܦK溾I'Hu"sn@ 'NX+/rvl8ʭA%gͰ5/?CU^gtX hsk[VVuAubrtWžbjR \-n CMDj*.W0iח~9F UƉތ2Ӯ1M}1o0|3!okH6O&iB6 @F2 <օOa~y%tn.sx?(U ߒ|z%輦l1:aHɻ fPܺ֫b5N.89fH.M4]i/Κg{v(jA3d mAwirx3;l>nAg-'xB4F5h 0ޘCk,vqț!oY?Ç5Fq(B6R֧`!QT|DMLW^~xwkRt=;*F1B1CEeL1b7H6 CDo ۺ-¼mw:]Ԉ7DDӍE77"Dx lwe%Em1)C1Y' Xn[@ IC\w%nSwQoBPhsuEN DM֖ t])0Lud+In`# ttUg%\{)2g,Pb?cn# sJcf|S4sJϹe,~tۦO^hMYFY6m֭{oZ?~ ے!gSA<У﫴_Lp9ǶˉDHDI*Ĉϼz^W ^?<ںʒ8WYe]pbsˑ!b9d;tu֥# V :JDXOc—'Ë&/ JKZR8]](56Y(L17O7[qɔc> stream 2019-03-21T08:54:23+01:00 2019-03-21T08:54:23+01:00 TeX Untitled endstream endobj 64 0 obj << /Filter /FlateDecode /Length 2091 >> stream xXَ}/$)&M c 'ؚ @w?ۭXK&3O_ܪ"EmÀȪP ^ӿw+>g8<qspFY( )|u(0 of5W gcYIK(HҦ^kț/gaS}PZ\RBЌTE)-TYsn 1v_f\HRY[J{I֭C|\F{-`I[s!#i ZiGBF8l` `TQ TIdCKjn뫬]=}!]g|LH?"$H d7 <[T,`X`htf>V]kE.a3tfqiUsƺO[#D_PڰC^Vy6gQp'/u5%僪3 f.+L4Y>t J*㣌7Y.%y5k 9n/M+\Ji+B!b׆D -8x FSrzGsL)mG/2_JZB Ebvm-%Y'2 '{G=4fFX@\>K,J6b(nϨ VK7 K%K9RD-Ln.4"XwmB<(6mRFqv [|-vcLK- LTlկq?RRIak UlkV%Ta$%vwGk'ARjum"ɳcӵ=DX"D(UNx7"Xbn߃7D9v kq=V.3|'Rq!HlOUI=%/ב&{ƚ}NhBP8۷X|H`/)`mUе%_kFtŀ3OW^g?ͨ?z=Sk$O㡩̔M߬gdQS2BS(!'%Z Fu@ѮSC@ZW;U\B˩ 4 ;Gx"yyH]RFa B+cBiI4j /. wB,q5X\NOtCg܅pgO#}O8[xMCtWcljl"vDkv]K2hRVA{<ﺈ%B_1HE@=Nƾp ZFXDXl̞i6|~Q V:r.u=m>8XJ\[sv^SȚqigBP -U35̡ 357@IñH[W`A񕟋-όT8ZE{^6#޷TLJ}ߧO=,)wdKk/ry̎![RVF֫]vCϊjtzsZu X Rzoް W`tvu">>ßo >V5tlϙR>{'iK ?ί-56C'uﵸA 8䭵 O7579YP_}IK'{|ʜ/|.QC(Q^,WɭxM=Ijlm/1޾_{]B?v" /}^YLekLl`:,4?ohendstream endobj 65 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1519 >> stream x]}LSWo)\QU^u[en%:s"Ƞȇʇ).+R-RЊ*D\Fn&:5d8O5q%99'Y9(\\di -۲ FaT8@ޙfDYX7 EJE|QbQN\(pEJKv͗aXb뱍X ϰ!; xa_^0-l ol,:xa(ޫ׉dn;Mr@BW2Ė0ųd3IQM!dri5Ȼd9 fTpil{@)F}ȘIUx^qpebG2(-cL1BQwP8 r?W[pL*7#6pA~sDLjnҥUPgl jk :&TA!-ɧK,ٸlI+HXڕ2iClԓ*`mQGmV;rv V ~NŜ<h<'=47`xԎՕ«@]ϲQc8#`vwx@qQ7dy5#$Jv ӊbm@-.wk ^s!m_ cR5k[[lf,".A.BZ VPkdLP3mY9bHA!_+fvjDBWwUJ ZO=qB ou.EI`^9z2֐d5Vi=ΔlRXT ~8${|ބ]k,B'f*<OŰ2sCh@"(itkp3ء΄;ehξ;w Yf"ϑDŽ$I]q-d7I}td`APm8l$sS@I$*9a2FX KvoV廳JRrn=sx$<ԮY0qˇ7*I3o ~lzz:Xi@@?qMa'#)> stream xm[Haws4FI`ݨtaΜ]tPSܖf"}6d1(KH+ EF Lyn~<F!1=HX7ZqD.%4'OɢQP}\IR[7AxÑc6ZV^i3VlIیO )@H#bI*>ۇlA7$G"!)v<#a5j~JT(dJ_"sḙGd|4.+^rF=R mP9بtኒG5 ޑi}索4'q5D3rD& iV > stream xXyXW0sܰ%UkkiujEZ".,aOX'd!@ BKܰ U[U2;mqNÝp̝< y7~o ×Xo\"qcwcf>oڭڠ@4f7>Njgac?__ _oOM'_2 p$u]Z7ߔo[:|dGDr%X"lcff3 N&dev11:y&Y¬g2FM-E%&yb03f^%~)s4yw ? p <3uTUޝx}Ɠ3i}{֢Y1~|lcix$ !X g [=c87JwU(_aLU>卦Z_ ƒ"k5ӚeTJJvsib x@2VUiGx GnZ]!J_-ɖ7{w!N vak %uӢÒ6p0GBdY t~GU۶I8,ѥ&OK7XPw4%owuFrĔQ~L˻ɂ<7pl).% aq!*bx&#j8m0yXG`3ƔhmJH>Vϕcdv< AT0!E(.]t6?5%(SzDȖȓhZ1a~z|9G@RYgAdH[:HYO6]pc=GncQQŇ˂\vyq[D8_,/)p.=ZEl98-ۋG؍Cഇp0Ir}{jBdg F'd neI @ɆC i2a"$,Uɟ )JlU%@@At\qV_^[H<Ƨ{E9,x7HHV'N&y$zAOC[Kֻ ^Tj{x$2?Rכt, _ lΌb9|=׌sBnM`zi<ڏܙ*@ U>Oq*T>cPy 1U{4ʅ&KT`(_*4Sppjn˯s :7ʨs58ko-oDfH4]ο~Gl SB O*8aA/ h (9-:ŧa$ρ (a{&^ɕ oHF˰atA_J] SnHKd-,u$!:sZI/wsݨz@Qs[e%*&ab*cS ?5_ƟK]<(4>^\ȥ.ey]ω>$+.lجGpx'8!Ne[JDՔcBmaNh7Đ'!A|MJ&~i ~u ~E$jz]hd}ZAۑ->^USIzP14;+zӰGqTJnFF+B<:tBV2`+"7e7gu 8J $ W Qc,G2Oq]Vk59EyIœ9ǞtRoؑ?DHrDd^ abo-r/Ε$M4?5"|g>QF-!ϳkZ]+}dFX#5|H}{w:/˫燾yn4K)͜V*p4H 9iQwǡT$ѧR^?ssg-z.PPjf邊TGEȚ=}9t o_ 9~eHwѐ7r?]S=ʫ*l2X .|`B^z~b/$QBW'3CC&Ȇ> stream x]{LW0s ʯVT]QTb|PEQ*T :s^gf׀Cy Cbqkؐ5n&]ݚ{IAv7ޜ|?WDQ"(`_luQQs5b?aUvD ٴ4Q$ %hk(Z,^HDآrse/ۭXbYR~TE+9;~u,=WϨ=TubmT,ZDR @R!(DՉĢ/Ei'5 J/E)Q/ޤ;uyB;MbdQa3Qp'-(%˜19m29wC<ޅ&=|v>3h QwojPzykx:!3rw%*ܢ'ۄx u@ޤx'aL0.A9Y4WAܰB{k|~Sܱ/xE5>2:[G{s~%;iLC_3?EPkqB-W?Jlu:]mMl;jvbo;E犁+G{⶿-΍jQG3،tʹ')xaAIDcnw!o$ۮFϚ:'{.'[SlzRFJ\|p[qzs~e"/NiE8bY:3z?ޛt.ѧ@"}Jzxe[lRGI1SWeM: ѝu-qhK;[}zVǹ{#@BtVݜ;ކv03Ϣ#O6Y dC*RZ+"ԮzkCSm f1} HWܹǓHLf0`KJk]$9ph( }s_endstream endobj 69 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2977 >> stream xm{\ }j׵jKmrjHE 7[ᖜ("(ҢZkm:?[ў}uv[y99#aD{B,'R >e63gI_7qn0E S;xL掛Sq4I"MNLHN:9*:5iOrB褨y0Iɾ)~i+"Q1qHH\ Yc3@& f62O3>0˙7 JMf5qgxfIs`X&#NNJp.Uy2drA܈J˓&t})$I&6d6T{.yc>쳯+YRG[yHMjm2?FȮ˝S+Rw?6УL _++ou!Rg7Li]XQId)^+<oq2r0pGba/kL%Maџ>]暥,}dsi,i7$F%ƨb ӭn8\vs'|)dǥ3ƝaˁPnݪ^4/>?  |6>-YIW&+*V5bMx u~үid5fWVsM6a#;a˷ jzRj2HX(וB)WTQ\[P]#TW) GL&00>_%*!忺JZehHܣD~+箈hTzq MA;q.˿m#s1}ZjGK ڴ Ԅ)Ћe 57ֿ8*ehp:h)O-ys"Fnhc$8K;(qR_mĉdc+F ÁB\eİKΒdFIƹgD,?w7ũ%F牧ygβX[wD UV ᖡ7QMArCY=JwU%7'u UMM2C#jeaꭘ)a9GO/u UPÙ4bX ₌[6[j-V2˳$tHFfl>G/IJ]{0FBB?I>0P/: [FuR>a^nD)N>r0g{PYVY/H1 %PRV-,9 !Z0j02`vI:iH83xVPY]Q 8(/~L< ^ JCTr"cavRB36C a c=i[>!:΁c82_@'zsxtO?[Sә܂T"Ǝtkg{[׉`Ei>): RA=`[?]`AgAԏ wkx"aԂx݉Ëb # {[\ЌO;JdP+nK\XuUup7Fm?ʳ(b[m[]X Go=ĸA-jE5cac|Lu̬>qAt[=tˡBg ؿ׼ꁻ-;,ްbKj8yOvc^_Ԕ'lҵr/jK1?{y Y֔Wku8:P.^ZmoE9q>r(a?Eя~o0Z-rS^ 5lyGٱ0K)ה[`l04?j=w7+̾?reO)h)0px'M|n.!3q#cF_C}l˾d\P}!> Jv8sajH鎤^8+v=,G%A˧.3:R/0?nQX, CzAyS6Y>ݘDcW Uj[o:Jʵkf*wgN>g}(KK?v?~G, LzB$qSMRc z)kMֿ7ˏM'$aE9XV@՜N敏[,h&IDGw4cprOf+mds*tUZSז}G;$'q:Yrc-o &%.{u Cj4R(2X3ƸDJ7FAZyёlxp퓇/ q8xos ٙݗ#<y8Ey>_ۿ[,8ћn:?UZ&r%ZltiI0Dx<7?$&ٞ6J!tev9l2)8į;8{s,;|DL\G=i[a} Tedsä$i) /9wendstream endobj 70 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7793 >> stream xyyxSUmKs/;6fETKRU@RmitI'64iڦ @dG}U#*=fs,?I&9|YN~DTTT%3122:2*&[1t'|R=l [=1È訨?-KNښ*^YO/1wpv֜9orϗ,n߲ %pۖl߱,myUGU /N~ic/i {vHC,&"$cerbG"#VkZb1xKL$oyDH@E'& $b xH&^!`bE %.qx D<'#("O @GDcԨIlT3#ǒ5:h߀ aP8dЄa=tܔffdz6<75G#ZGi5tԞ'>f2ѯ'$z*+JI {W K G6Hy(`K VwYKi^@A)X6o!4:H(jJ' a!'(ʕ*]8n |nWp4s)0Htd2d1_W+(.ݡCl<ބf,x?FO \o *Ȗ&z5[i<$veD^oyh!ӄF]~Bα20-֢}k7E`fb{#;qI%EO{!۹{&O@zRQLMץ2j;?Ca8k{mSBr>t}q'$zPܽR9KL|sl֫/&%-*"f:GRg~M^\{`a t%o,~(ҢԐG F&ՙq ax~8'({Ep8)47͆h(*#] coHK@`vZ6\Sʛ&|6?Wtf=;C;) >q71IpS=Nqu/"GOJGXzZ+'p0 R:* .8苜 _R5kmMZnÊk1gyMdZE9CJLrQvE`8'  0>+#Uⶸp`AR D oU* $l&;g2ዝGc KAg°%G݃ocZj5Z^X+Ϡ,6Ì=ΑK%:5r%(UVW*6-A>ބ&N iptjJr,(4epROԃK Wч9 PlV*#ێig8yYFINS.@5Tw/Yj1a^K>i\˻ n<{vaV(ʕ & @QVdb6NˠIjN%l/R D>mT O?uW1UcAqb߻-RnHatiT"\h3G< @jͺx,0L(GqGyBXZLr?8 $RO9XPT~yi@f"jje+icH0>aj°GaTN K2EdJa;ξwIɎfGcet{C RPEn[œ^6Q";X{ŧG|dh4921񪀒BHnT CN)`OmY,[&زذLϴg0#D*c]i>9+u˅އY_cԽƾu{-XṃV25C.Ydc2H+jox͠^&L Gra`gB3\h S擀 ),̕rF87MF^mRQfNY ]pQ6^ѢN.Hq{` |.+Doxno;>hyk.C"35)p\h+ul mh;[5d~ CkdO#yoEk4wЗ_P4Ue0 =MyV,0P;ƶݵ)&~Ä*v'jNx%u¯PҰz mLx P&U oyS^Q^pݎ`//mzh"c{s,QT۱/}o*1q8V[x_Ն:*' k.&_aFNaV-`mu2qÎ T]K/`qc)zX};&Ă ;2P -֝=xא!9FWom+<<:mTI v!7z*c8p(1fBvo.RM6ȟfQ 5B=,Df!*ܽRVjnX|ƪ(z9lfD%UKo  Hkmh_V-.E :Atu~ݝ Wo? uuE"NW0Ĝy= eڟsAp1>;#㐨wWby-p(r՘y!rL"Ee䇚* Tx9Ga(3āv^ 1%7Soԩr-uK; gT9TRiFu;ú;膈+`n t(XJ/9Up16Q?yUI |wCrk:[Ū1[J-dXʘѶ|3:I4x'h=, X IA &ѝG^ >px@myP^MY(&g4j*g&z56\R^1yAKW{fTCdjC_xAPM!yTOTNlZ#CQ"*gRD'/w:d|,-R_P+ 3}p?N 2);.CC'(4pґ0u.(+ uY8X)PѢ넫60^QkןvηjSY /#$ݯLBk Sři:h \}LQ˱xJ8g&׫7S3nC /m*a5fNZYkq @Aޛ,B@F Rw z1(Z9ek,|>K{ްAMb<Ռɵ632(qDF8{0E,{h2G$ܝuRν s]03LSy`#׾3Ufyv30t2Kur -{7qc0>}Χ?)?YcYf+){hm6r&APue92]g-(̥ |qΟD/ èr/D4^>c^ 8@RRtXU84F9[Sm{8XeE9)cpum5-W ='ֱ6Dv8)b!P.ʊ CU 50*քY \y@O&ڙӶ(&ϳ~k(3gfaNei phAQ418 !FH-Z &ʡJ@;ˠ/gV`%)l7(ٍ _rs/Dd\\[MMH_.W^;N?EϞ@cϠv]S!;.?\x&_I{kwd˱]@6uogLYcИ4,x,$w(ҊŻ50m7v` h51?Anh&gi?2_̶1PBvSKnkN&w XVf/ͿNpHR$~1U5MXz-=EVNlsGx*qckj-sG>@;oڴ./{SpY\Ƿ*[m +n:֤S/[,U&UKٖmA2-kN *Aܪy82aӧ7ONJӰșerD|^3E6EClQ* !`K1~kMz&7ʱb ~JYT R{,DL$XtI ª<*G\[UKyeNx2fU3v?ToxTwW`b Dot:dF`ٽ]~9RW;̴PEf$y&*&Xs G ~wXa`C&< DpziC=f4om-\-lF˂&~Ui TMAM>m22+k|Zfan{ŽO6ݓxhe)80хjN=]pD+tRA΢+wG.5ıXn C]K[].zd[ B"E꼎0ey{lF:!{zTCnMm-,&K"@`nnSY\Q+5MǑcQ_܋y#G꫽SޘsAby@eQqhŦMVxGN~gM9]yno;)T4]No9Ὼ?+aF0jPy op+M;}kLɗJC5խ7ËkRPG # d a]ݺpU٪Y|Yl}m|d_{]?>O}*_G _;V!\)pS<~U$p36ZQ=_ARցu8m bm[|4[j^@PhZ47ϠvCauʲ}JG84 Nm08(eO~M`6#o,ł1g8Ɉ@QWX kfGz)( BZ g ]-Z_y9qt>.Ii8 ]2Ą$Ͻ6Ty]oλ0˞ 5r`S_^U%-S^Cz{ZS\trJ1gT%PQ[_^>yN m䂂҂j5D̮BVb7O 0endstream endobj 71 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1295 >> stream xu{LSWmW@^-&*쒽)hZA)ByDPZ+< eA^TƖM8t1˜#l1{9et-'%7(*OL&x"y|Ǎi +|x ,æ#AHbVj59:unTV͎JfV*&B(4;'zo&(%hu(m@Q(, QH P^#k-!KCn=&,Cy B?^1*:pץ?,H)(+,VVެՓ֕֓n5֔{>**r4zx+KXG0$P)q1aXo',UIk 7.ĔǒO97He3ݞq>h=ܶy1}eեPFWRP^a0볖Wsfr>=pb͟9~Lf_lrr˕d`8 87C"^/ (o`M6:%']`+?}ppѷpohu4@(CeAiqNہV™_C/rx'xL`( nq;g'6r@4s269QsD5IG]5i| ̦g㑅BФ,;RtS̵VigAGr^~͌'W̌3>Gye[/t}zs>um抛endstream endobj 72 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 384 >> stream xcd`ab`dd v 6400qt~H3a.g",,ݹr|<<,˿/;#s~nAiIjo~JjQBpb^BpjQf s 13##{ |v34'?n}-).jHJHow[mVSW~Rۤ3J,T[o߮=u`cL(ٽmAMk}xÌ~uOoѿ^_>KY~KNfoڞZmʿ/~J FA iu))|e ;cɄ sbf#endstream endobj 73 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7653 >> stream xy| (qM :"v "D!((HKHd{n6{^H Ho7H .E{U{;;٥˜9o9EAdee.8gγÇOch*GlZM oku1=o6۳!r{~OJP?hZH77b|eA5oE%%KIߝl+V^U4luO/hpٳ)aċ/|x˯y' b01xE !%9ě[ē\b1x( ^' 0b"1($%&oTb1I!&^%{D}%D61' X7qчMlj#(bwج=Fؔ=%{W=e'>~>{]}} t_~?r=L}}ub^ s[g;/ ?9}p߲_8U:y|Gω{2]%Br2(EOuUbO]%*o1 tu&g~_ ά c>e#lt:͎d}:B5D<7+o4; uJ髗gаez^ ag5œ^lCz : 9/6eN×S%Te]Oza_$OHzG\0 9_uCi;8߾Ju+)TW#8&׀5VoWc#pj/ͤ>h`߿pp(@fGE@߶JZ.U2@,wSL3Y]Rj+U! $MМC} ZCP֥Gao@Hs7;a]FyH6O>΂]zmSϳk'DLY[SRV/h5ҌFz/WSzE~ 3,s8u"@Ht8 |Kq>Nw~}HOPqmHWI 73pXsoq\T,aG"i](jV\s%M]? KWqІt{Ѕ>ׄ~K;-4zv/,\a;/dK#qtCIFŷʇûh8234CI\#q0;VH)`N'C=ܟ-I(sx=W3RV1JQH7}ϡ3?Œ+B2p穄W+*f0Q `.:#H$X^Ü^&vH%}CEpƙdymsT>\^OZA79ka5YfݤX Qrɼ[RI>yc= Lc" R䗻ax4LśpKIJsb:{'uJH2 Cr?\4 L rΒh;OZms)tT;M6[4ʝbjX֪ @sG^'ыܧ`ge8[cKɬݰTv6-ᨽT6J"ezǠKתW' |Ǿ:Kڂm(69Ӷ:ez<3\-kZ_ h#F($qr[Ol9DYn,ƗSdJ%}s .r>UbTZVG-,(B%EE֨'m2X,U1KpkY͢p%n3]AJ E5N$#S"1GV`]at ->7{zLov - -_^/ʤ[ ЦkC 0 Kjw`w} ͈E>pDO̓Ȅ>XʾJJ 2E%$sߵ'YH %Z& L)YPK&TV8E&aXe0+țyZGԶAF@ͻ?vh@7Ѱ@<&5?Fj)8Z᬴Wy`{;`-d ô []Q} ۜkmt݉ԅ>7.@8w!dP1,+몔%po!2Fo4}is~|$g7ઋT^a<|v4 t+K?qg1[,V@[H;5 M`R-X3El6NO8[#*hɊiYދs8%S~d;nɆ .e_/Y& Q>h&NK9=#ީs [-VaƯ zoγ1@I#q[kT3{fwgcz_dPD~^.9Uk__+~+f-()puXL8cyͧ>IK|6uǔJ7 ?Qkd7Ik FQc EYWWWr OCnLħL8f tPLwq/˜V\Z hK¦zјu-wjbNjd(ut% y@3Q ~!kJn..iky[qwzL;xyl8 i'=G5/.ʺ>(!sj'{=ZN1F\#NȘ&\3ϟDJZ!~8xn;} c,v.Q@mV]0cҔ1ΟUȮLǕؑqjߐ>_$!w ?q^ r7,ۭrQiĤQ=C2 E` ]%>WiY / W^7إ;9>p2ɬ!2 ?X[؛8?9-eG}~COBt\└R +,[X^ /#]i}m_̑c3dlhm]F.Lˌܖџo;n^giMM{:): eRP|]< {A`}ն.hlbYh?֩`P`xBrqkEqYѲ~#}9ǧ(` yӪ("AD~EɗȴOMMMƼpL髭ӥ]HyddָNr.E.Py_tMMBc'w Q9X8ɵ\) {N\_c=1"AH~AF4¾añb:_hJ]*o1?qrҚi\W5,D&VzKStk8K`6&<2 ^fW/Ν7p0NGl3޹(/;43ʢ%xY٢iku±o[tͪFb7:#V/( NmZY|L$bẆ& ^x=d|cpXQRS.U_ 厕j直q-m7޹:joFrM=Cx8FI0\qܭ $,M p:zNF1H_h'},Ӫߐ[*Stsםwj:$5)X0k[ϨkhfuGi'>x{5(c7_Jy4}b*>ԁ:Řd5Z/pQ\uK$Oa)VY:zYʜhHb=AJU`]K-TM4w ɚr͈ >O2r[?e>x{WP_F4?68gŔ02VoL`/ aiD|m2g/kM-FCS}\Aܼ ,'LY2mcV h%(iYo6aK[an˚/{]13eW\L!w\" jǕd?FV$b%:TkؿN7Rq8f#=E5M{d6Es¾hƹP62[3lvdj.+EhR k+v4Z v̥f \v Եx [H0)k2"";~LمET9cfrR& btq+"Ad Vq J̔L`”>]E&1^E`N|`]>dUD{ҀYE 'N&$nэR|WnqVsH$i}S7bxcO+Yw@K%,Z''嗂RYٹ8]=soFzFFWKmlM`;I_ҟ7bvU^VlͶƶa_s}^t_ۤ |V֭WI_5k'O,B٘?bF1'ku=]x-Ffg&F(ܫt(}U*h4*z%wJ&:MC\w[pùɐxP J} ؁z aXG{6\PU-jL >3+iUW*M; t,7s? O൒Lx۠= FSBUc%?aL[I<󵥔ѭ+-J0L2́DsLاދ#\eC ^R]7T.y3YD3Ӭ]p,S CAYry^'8_imohƫ_[6MTt `1쭼\|@a^㍛ Aç(B"bBIW6?= D/+Ҡ?jßO{(l(y GH)Iꐎk7)d- TFVtJ5ıѵ(XtR&%TIk(A@mvl6 vOGCaN*X U{`Z4*?*NŖWK`߇RXo PJ1'[Q;k:1fCn_Bq5UTM~0"39*}B75 _H~>]ޱ}{0(=endstream endobj 74 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 446 >> stream xcd`ab`dddwu041H3a!O?VY~'YskyyX6-={3#c~is~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWqr-(-I-ROI-c```rd`Pb9fߏ?w}Wk>㖟˘4mXZ]՝R;֚fn={Wuo>ܽc/.N=}S{z~eo5V¾Wۺ7w?^VllW`ѽǓ]տ+1S(-C;5by-}K@{ شl| ~L`4߱wq}gb1ùyw<=<| endstream endobj 75 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1611 >> stream xm}l\Y' -ܹBBG F!kS PYĊg;v {ZαŎ9 ɖPh1ԖM@;1!JM&c.M<}`8_u[%=K fYeOce{Y_|+ݥRNS/~ F2d&q{tZ̴ҰQWcMmݺC6]6Z2xUWo7XLtLӎ[\vgӏ6nҹ,YWgj39}v{Qbҭ ݼ[ɩMNaŎg[_4YwİCXVmaOcc/`ʰX!v T+l)zH(<$JO YYX+@RYȅ&aN3Vd=X l@ =׺+44c'(t8q#dZfi԰D3`[f'#\4¸ADY~`mbP,x_> ='RT`BȈ&dGOlCcu:3$5FpCc~ E r]z\\gx4pJzY0`uoGr\)WlT5[ sD\xi )a bLuSgGμ;d;zY>5!F6 $?C!=~p0H%C;0lȅ˭Ҙ/4S:o=RcN{ ];7_1n!Q>Jri| l؃wʣ]!6 W)T\m}? D/@VW8C$LEDڎ uMEjb=pڎ7ڗ޽ s Q}W?{ND;csb8ԯF[#I5{WwkWHssI(Yq> ~tH,!ñ7Pmd4sgM\0\ʎJ$'&{p^t_V\j(5/%K- A' Dw#{*'O3!-&ChД8/+shu9LLrh 'C@<׻|jnU $&y=D*}}z66nlmxԴRM"1ZDO_/! gJbؿCendstream endobj 76 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 389 >> stream xcd`ab`dddsu0~H3a!Kg,,ݹu|=<<<,!={3#c^qs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWvt-(-I-ROI-c```td`Pb`bdd+w?\3XBny}wnwNw}w]IwuuTt6vWusw_ѽE<ʇ;,'O?QSX >}I.B ?\?JD{2_Sϝ>w$\߅Xp]x1o1ܐIendstream endobj 77 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 761 >> stream xMmHSqw^-7FIyw:0{EQ`oJ֬vks-#] ,(W>TB(箿ZEЗyx90$MG76f=P%)&9\4'MgiWB=HN/閅ܚtGמí 6/,J mҹ X#ps* /^-Zލb>!m+;ٻMli7 ݆! %)@oJ`0 3_$@U!bE!Ln:aG.׉M4PO6@ciZvz|Xf:cN*-E+uQ=.#nu':+'웨efV"sGD%1Td]NPC)u1[C {^/;*z-2N/ D0?bL). 8oӜ(uuqt[,R|FZjwh|3 brendstream endobj 78 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 633 >> stream x_HSq?n6Cۍ!n0l`PNʈzȇ9/ka k=Ƙ3R.(Đ|0J$ !B/nB᜗s>#UgM֌1KGt,K*@"wlQf@KVL*$%Gޛmcr0UURbb,q:|!YCH Bc:,b(xWmI)#z7Xs>itxY&Yw ,عV!T P!: (;  I:iULt/nmJ u=Py) (m6Pb$H@bF%蛡qF^M؀-4Zx `-zy *B |$&#)%g9P .MVa)AѴAaw9)z=d5~j̔ {;IqR=rAQt\ BwAgg.~~cEa%ZiXɣd5O@^׷J ,j_Lrf%L2T bK>AI!lԉ1!јZq<$sR 9*kL{ @Mksendstream endobj 79 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 442 >> stream xcd`ab`ddds 4H3a!k_VY~'YsyyyX^(={ #c^qSs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWvt-(-I-ROI-K,d```b0d`XȢG/e{3`YLtKJ`...Z=GOq72Zea'.='㷀oߜ3|.;ہ|gWm,8P7w_|4[oti<𝯛%mm[}=9-DL~eT\~}s+^~ o{pļ Xendstream endobj 80 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 405 >> stream xcd`ab`dddwu041M~H3a!-C5UA nne?x ~^!Ș_29(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMU8VB9)槤悌K,.Id`````b`bdd'úG2,w3ʰ|E~ZĖ=MwH7ǟl?&x9iro_~ J]Y΃͏nE.>֊c okYe~'twuuvutWt7X7CϬ?ۺ$tϕ+&r>.]r\,<'1/֗endstream endobj 81 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 936 >> stream x]{L[ue^t&޻ D,*X'̰1ii;(q郎B_i{[(F[179?Ǫ̏?~]M99|0Ǐopoc{|"i_(r q2}ڹ-߮C'8QnwTtvBjmIGVk%k-9I*'`ؿ(&endstream endobj 82 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4272 >> stream xXytTU!e"9ba,b, =U}R˭}߷T(؂T(p`=gԞnᙹtϜ3̩S9{~~M 5v URR2fyMg.r_rLR1+)|syE jJբ?K'h؞oVeSԩԘ[,iou5nY^ hV (eK[WC?\AQo: ][[Wȶ76Q:l_{g _Mr퓼L/OY<囩N=1?&(Tn _*`DAB%H! /F* k ^p"H 5 O"N+nf #b+B*=2YHy giwڙN|nO Wߣ[HlgߟK ϕbea9q]X@] X4Hs߫݇n/?*M{iͷ,~]<Üu'iCǩ7Ǒdgܡ?+t\mV1>Ǜ*+@Vn,^SYnW:.{~Y[D[" 0EeF`[tHx=pҡ!W*lI_:AinV2-v"2lQD÷9i?f8(PT@a)v%LI _{/<{Ea#ivu0!.íSiv{Jp1[rwڳ3h*]]]>מ஽~|Kےt.N'=7ZMw~^Va#4(ZSe1جzT" s$ɒCyGʕE/?RnԍtVM vrM?dGlLR}DdZʮv"m' w%KC:fk5/d”*粳yz:a{Kj6k",7dx_p QOm).)q)xv FT!R1rҽbrݭ)seN1F!hP o_B{ADZ1^ 6@N,R̞<" ȥiy@JsL&RQ(S^y/#ťyEK4m_6O` -:p>[7)uPr}21x [uO^'C)sߙ8,\W^q(9h*;(&c(S-[|qFY !<ʒf(ۤR'k5+[GMYPP 2`*v)hTrqL<<_v6#t [ķ jVLtnl{jwQr벒lEPq7O'gdW KH|Ͼ{?_v-@VK1mQ$96 ׌;׺t-ҡ')c;{Q, ^Ĝ~*ch١CItųJ9^{.Ӹ|D*ʀRmٱ 7I̜~׍A+DzpqW,G>&'uwNnә5HS! k=)ϵS`) X $ De$#ɩfݰtkHBb}(˻]ɬop ''%2qehC&E]ƷľFozg•p$M"];7Ly1 bxՑNeDžJs"feUP-nIao)LK$Gs\簎IC  oh8I"!j8}#KF>㇆Rx%nRbt/do7 LVAňAâAC$v?'4.Fqg]4$Hݐ>">f6ZB[5veia%%yR6mmܡSuH!e ]/lb,-q#h^2B.O%Z.JNA3NG,vZe\^:G zh4b4Q@ZT>2rᅴx& IP(1D"n$Ns~_'˥cUcxYw={O+m%["#Jfҽ~#ɴ;rExruL'7V ZĤ9s>3̱+kwZǎSxcb*'{>YEʹYg"-H*T2砉@|IG8WWFӸtQiCPfS'W{{ۘnއp؃R0'um6uކ9_c%0tzmjJiL 3 /XlQ1l:z̹C/9! yӐJuC?&#Qb 琔32NQr&”ҥwwul|aɛ/vIvؙy?԰FlPER|dnoEWO{Aݜ\3}lnk#Gνq@yt-y3-^ 8~1ULVZzEۖW,ڢ1VE:rOk/&` #XBWeGx#4_/Uy(*w?ݲIQTDqB?}<4^:$ȠƯo_p7jjjBGMC micft)"佗yUl~=O{3bǽʂzR{(?;F#|\(? bbE6hV/'MYIPYFʰ>hɁhb{7;1_Ӛ :@E?x`ce0=JYfK.Z#Pם|];j."Ȃ_V@TcxUgFaN U~(X&.mCendstream endobj 83 0 obj << /Filter /FlateDecode /Length 2560 >> stream xZ]GYOH/5(CB a"ʬ4kio==]ۘTR~QO{nO_y!WG0뙈/v:H=Egi )WHeg HSp?4[ ^hK!`1Q<|:;{}տDE]W]GGϵRb>t{W7ۗlrюa]eNhB%aTEn=Z4J&A%*5XN.80DHW8/ ^A^Kvhɺ`sod;l ` Ӆ s#)ogFPjus/@܂^06ɈAL{T$&V7i\ qe8fmoĶ>#n T7%@5B[ɚ!>aپfqy Gn/UTL5w'9zm^o eO=ܯ{Q 2`m~B/U@oUtST4`j .t~J5Pٲ/^C}K&s.pٛjm1H,zwAqLވkxմVMճu^p/= t" ʺB)c0/rϷG\\[MZI{I(85=IL%FVQ+9/珏y߂*iO)(v8^04z$PU|9S$Af Fw~ '\ m;2>X^Ǧl6.5Ȗ7mll ]}btɀ EȎmfi12Z:c^֫06踍=(p7jpR VX SDVq;D0!fQf|Il ߖ B&H: p(ڜr" ;ȲlToӚE!VM nƭIe_5}أ|svD=GڑsۉX앃ʡ %ӝK5!!7=Fx ܥ1 8i.W~\nIE*ȱIʏAjh}%WZޥgH^Wk5e&׉]ưaEl6{)<-G;b [c߸[qb"!G9y١۱(aPnU[oh&H‹̌5W NaTvvƼ#&8lRg ?:) }l`\I&t؃;iHI9>r St=ػ.;Y(o/Gc~JcR 0ƈNS_lvGCvբ̗,"h!'oDj0zތmlٟX֨"m_n"}6 Z'*CDur= `5TrMCKHQ% ~]=bQլpy.Z%A(&hh^z#,`Rc4ne'TYB$K6Z|J.W׷9B{ |ЅddpCBUD*QU-ޏ' OȊ=ظ`퇛! /ףּ/H (g6kYiϨNq3%Q?w;*_]5 EjVZ;LM`Jc> ?J1nN;o͢P=Ou%eִ&- @! nߩ+P`ߋ9r=-2ZIjU $흄29fRDeF,HPeKUaaP=2ֻ2a-M:`~uVTTdaiUw5؟xҬU`nT񷅧[,/_\}Z_:%ev >Ѡщey<4to5lU<`ktnp55g#K{Ut%PhcTO4\xy͏ 6]sho+nmzVnmnpyHݖ*xrKhmN^#47\ڶB֌ `AD[}uhO%&މzUS b݂򓲩wO򭞥L/2EC\x'+E >֗endstream endobj 84 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 413 >> stream xcd`ab`dddw 441H3a!3G9,,ݹL|<<,+8 }/^=O19(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMUSB9)槤%W&00001H20,cb`fdd{ڽ7gg9^\\wˊR yucy?ƾk3XZ=<<@W!endstream endobj 85 0 obj << /Filter /FlateDecode /Length 2415 >> stream xXKs뾷=|Pe˜ZF.[Hr|R.$dI&AT{ʰJ b==_=&y'9ѳ ;ۣOGONjp3*ʈQ'\71fB=y圝Ngt+˺R9g4ΤY„*VфɊB]J5UnQ^!fJ*d*SO`r>iiS/ V?^eF2իT8aִTLq`宻k7[0Yje>hv 즜˺~7 | 6RQW#V}YW|旼gu*M-c+V6M[vMF+o_0^c]Tn{=ZD2( y8?*l=\Xs/[W@ .#$gP2S)e*I \F.F,TdVK.g:+/_ ̔pΫMQ&4R LPTE\%ÄݻmQ9x"і:S7lUvKtn`/>R4/$@ ۦj1úLfnYYQNnX`MU-* s"]7cBfҙxӑLilӈLJGP۴n1Y9H/3UpYOg5D`LBFAuV"$ZٛǀgN剹f47s.ӹ;l2ԿJz~囓#%KN'/!Nȏy|S;e(c,,[ .GuRt(@!Fn=6a94zvm-puI 4jmlf{#>J$P=豙)3fBr&uAX?Ls3I!(Xyה@k,0nLK=kS$E*s 8nj+eO8L!QaId2׭_qY,*21:.YFkOnS֔>k ޤr әVHʾLeցG s[/"85[6jJhiǺGt]iKhEC`kYs* rޢؿ 9ڊ$I8`18 ծrӽLL>:Xy`^W6PxŇ_eKI_XBAzdpǓdaL 㰦PՏvg S yb=7ީ_n*xZsF9 z}@psw練E(k 3"UvU#)z&oQzU+]փ6bM۽N氷3z΃~x>~wYtKwwQvm~=o!]߈DUNҼم$ ,Yc* = Uhi y! ZR@ nT6^ի7aEZ]t@8E`>8 4 L|oSj4{{j ]׭?{vބYD- <,͍>γu}_f]u;^ej-і`19ہ SYH&3sOgi"7T*AbjA2~eY>q!/A%a:!L yb ~UΚn SIʄB('ۀo{sW/>o.ɴZi:7SG?ݓ~Ա/Iuk3o #Ɛ߁_K_g'Ty#ޯ(ܜޒҖ &W~9:ڮdǺm#/+6RG̽^d(;dz}̱ư%5yO/}85˳FԎ"B V~ XЌȑ?w9I$p2R='仩-7 kSW% 6P|kq'ĉ&{AKD֨+aЇ;j*ݦ}K3p0@Ol'Wwc/ݦD꯭ H+=;o)OV [,uC~^~֣#Gs?m)[ѳ݌XnI?endstream endobj 86 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 704 >> stream x][HSql05w, }(|TBII3yɩm-67mei R E7"zS| ߇ID $cΞ**GO[T">Dj^1 !.j=89'cnB@2m򖴒+򖦴\RM.+;!T6D)QHH"b,mUܭ+|%gK.RjNiEMaXMpŘ*|- I8#.SVUJufCr_jnxF&\tߤ8 Gg0ۻڬjRd_VUo!K̹> stream xywtuhl+"cvfi!B. HHwz1N8N&|uɲnʼnk )$!$@].s#8oߞ;9SSn-yx3HOU\ >y,Y3뻝 f[.^wbFA/47i۪Z~qGUK/Uo =74Rˢm%;VVڹzo|JSJQ[Z1WVqbbbbbb~&Bfŋ/)R,R,P,VXxTTq(sJ r3fZxKחa K%7|u&f}Cz~ngU5/^[漮a}rxpw+Uی:#}v>᳟x>!FvlVw`v+et^TuY8u\5~0qǻd yWMu[\u)3>63W PXkMӺtBh]t1!T0Hx S `qb5$@*D/zkˆ ,ܝS+ŏGףc>Vس3b7}vt-<-h/<xM̸S 5gmLj@+n YRC\O#N͝cQ'lZTllk&t_#H`(yWЩ6z 5[&D:WwЋ_:n҆MĬ{g\ ?W_IcED0 >,}U]]U_~QA~0yܱ vkeF!QޮPrS(*P½k-z챕An~_S|ZԈDt8`h͸@ P4|:\wUKrX(?> = ܸ]B8 k5L4 DqFxaGIs u29(+/QQpX>{?KBnom&NLT VDZ{Q½Bڟ1Dx"uiN^g4mwTK|eSwbfe7h!̱'CؓE3ሃqI_݅Y^;ir :[GKJʫl[ȎnX(d^Xf gOe9Ͱ 7]qukNBuݶ U_0!@YF" (3lC/ Yo܆2ßVdu!tv96GxYR{nUqīVq-;y  )J\].;~G3ol!*DX0le#%Ug,[M[GlT~6`C cI:A'xsE|W1t))BłP09.> &q&Tps&Ɲ('54ʉtrbg°_.g\PfL݆k>{ß \N\PzLn\d c05jm)jM $άoW="ie—v޹9߆:d){ U8 Idaa/dЙ# X IrC5fx\V apFұ]S_kMKK o=Pcy  29?NWx񣏖HWDOu6=~ |($!^~bMN^ n߭48\ۥ'5n[Gpr@+~v`~7ip.Jw> x'&y? v& brSGx.q-. .r9&EBcaxM0v6:go7C܈e5^e)м\34OeЙcخqx2g4g!BrmTZF.]k=#/=SFLM.E,z-U֠_*{FBsh?l(ޑј{Z-"?a@y(7x.CC|*:!STk5UKam珎 |dMc٪zVNpv!zlm4:Ru`\jPdT ~55ApU9t[D;ъi[PE33E=X$H [`oԡJYZh&.@]tjm6H8KkC1zn]ۯwHsᑋKoBGG_pT>`لjpG$G&<[Qxj 6EwZ+#BxSWЍ&kPfTW٪wAAwԗul~tŹ?|tf.0Z#wx<T2<5wOŪ5R> V;!Z(ދoւ qtrN١ *<ra^=>[\pV| [NX51'jzO>Xm[&ȶ69]ͺgjOxA$WwLܪIb&EX_lzb] 5z5{K #K:GV0ăDl! ukV/2>7)] *.߿NgE~922$΀Daf]] 2,a3on ?macE#9@Zmilþ0Cpr8;Sj/5> et[]j64CS{UGhh44x3yftwϏ4uH\xǒ>uLAiNhZ}C}Dtd~=:D66^kړC@$ȑؑ'gC8%!ڵH!oEī[R;+􄱿cb%^nYN(p"RT$#ナqޫGlmb)xL`xUB*s_Dt|@!ƃXo6ۛp& vWi8ݕO?KGk9ˠmpZF};@M[XƿWY_#=oAm̚, Z{3ٶ~,,w8CI&083uS[{c{ܒ9~htt/|?>yk$!D %Żxdo_[ Ǒk P+]|BAsE֢`nDZ"~?3$ zvCB'*ݓ}mHGOG4t,yaqCWӨ*\R܊( %KUbW1X,T 8 *aBlz؋&6疼O gx =`@K_\5. iX)ć4ҘǍo~M}3; b m$}JݥK_ݬVvVY`[\ 9n6 Ċϣ}ʠ8'" X3g4m&Ţ%b2 g8Qڧ>d^ ͱ%_êk_sG\ zH5qxz_UOY?t'JıTsPJ1GSW!8wXuF†7I?BH'[~LBI-ymV)Hpw֭6\-W=0Q40h^; (i*CG#t8,#h#-х|0>A4M&J;KKw.tk h.ʳY@V&*0n?ƪWhjJH0 >WU浣X2'>vqVrF}6hӨJb>`,V=X9>5pX2T S43X^#n';gG3>r>9Wp\^b5/: xOHT}wbKn롽]RZ_\'r/ .F!BM<9v^؆,l& x174WN|9"jAO7x A f?n(I~'O`axpm)&CӟꯐfKvǏDw D_PymԵvSVh qt\, ]xKXthCYln^~24M$!:iͨ0_nk' ֔ͅǟh ح,^R#i,wooN|ld"2#o:Ld݀IwEgp?S(0i.ͦO@!㽬I4"4i̔@=ZG[{է5*y^5cbcs}E~l\n|qv9i77@ SV쫛pqpɺ:6T4/-s؟?x%f]Bx<+ޯ[ ~ 3R}^u/VwKme{V}j  RźZur먱,'n )UD oy4Kc_(W:F59 "y9 Gm7x8$"c& ~<"z`oU'.u]L]аYةmO.&++K,맽=k)3 GoMY*RB'񐽣h#[-C T㕙ʓ]?IML]<&W< G;Er=lXG\kmv$qS'K.͉BJX74@x$7~j@&xxi}31಴xU@B>PNWO{ix|JCaq%iIPrRh}Y p;%妮MǛɄ3Kz5ormH>GmI4}=0 ݡ tӼ+BPC;(FJC##+6L ĵ)?r"34{-J8:vcI 'e EfV2WPԆY]Nq 4y2g~ |8f nytcP$Ⱦe [Է4ފYo,'W Bd}۰OFܮ/X[ao0CTw'|Xwnl_)@7=/•5Qn0ABnPs||Hex'WY,A@BPIaF0QFIX*eoz5hmRе~m Ncp/Zts?xD C>/XhB̴, ,~P%nw$vvvwNM͚E]]mt3}T[hB9e`` a=„@y<QTr%1դہyHP["tc6qyAZKCb 5F%ɡxҠP2S?IV~EBuj֬1774LJUۧOhI OI7-ef T?x&ȳ3oP(7qZeendstream endobj 88 0 obj << /Type /XRef /Length 114 /Filter /FlateDecode /DecodeParms << /Columns 4 /Predictor 12 >> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 89 /ID [<62f304cee9ec6ddb12b042c156c0efdd><10c2506da806b9737bdf565047dc94d3>] >> stream xcb&F~ c%#: 5 $2`>= 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.R0000644000176200001440000000052213444641456014053 0ustar liggesusers### R code from vignette source 'expm.Rnw' ### Encoding: UTF-8 ################################################### ### 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/tests/0000755000176200001440000000000013444641430012370 5ustar liggesusersexpm/tests/ex.R0000644000176200001440000001744113044611306013131 0ustar liggesuserslibrary(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. ## ---------------------------- ## 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 = 1e-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). ## ---------------------------- ## 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")) 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=5e-15), all.equal(m4, m4T, check.attributes=FALSE, tolerance=5e-15), all.equal(m4, m4TO,check.attributes=FALSE, tolerance=5e-15), 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/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/tests/exact-ex.R0000644000176200001440000003047613066656622014254 0ustar liggesusers#### Examples where we know the result "exactly" library(expm) options(digits = 4, width = 90, 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") 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), gc = 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 ## ^^^^^^^^^^^^ ## 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: expm.Matr.dge <- function(x) getDataPart(getMethod("expm", "dgeMatrix"))(Matrix::..2dge(x)) expmList <- list(Matr = Matrix::expm, Matr.d = expm.Matr.dge, Ward = function(x) expm::expm(x, "Ward77"), s.P.s = function(x) expm::expm(x, "Pade"), s.P.sO= function(x) expm::expm(x, "PadeO"), s.P.sRBS= function(x) expm::expm(x, "PadeRBS"), 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.08= function(x) expm:::expm.AlMoHi09(x, p = 8), AmHi09.10= function(x) expm:::expm.AlMoHi09(x, p = 10), AmHi09.12= function(x) expm:::expm.AlMoHi09(x, p = 12), AmHi09.13= function(x) expm:::expm.AlMoHi09(x, p = 13), s.T.s = function(x) expm::expm(x, "Taylor"), s.T.sO= function(x) expm::expm(x, "TaylorO"), Eigen = expm.safe.Eigen, hybrid= function(x) expm::expm(x, "hybrid") ) set.seed(12) fRE <- replicate(if(doExtras) 100 else 20, re.facMat(20, expmList)) cat("Number of correct decimal digits for facMat(20, rnorm):\n") summary(-log10(t(fRE["relErr",,]))) ## Now look at that: boxplot(t(fRE["relErr",,]), log="y", notch=TRUE, ylim = c(8e-16, 1e-8), main = "relative errors for 'random' eigen-ok 20 x 20 matrix") showProc.time() if(doExtras) { str(rf100 <- replicate(20, re.facMat(100, expmList))) print(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.P.sO 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.T.sO 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 ##--> take out the real slow ones for the subsequent tests: `%w/o%` <- function(x, y) x[!x %in% y] #-- x without y print(nms.swift <- names(expmList) %w/o% c("s.P.s", "s.P.sO", "s.T.s", "s.T.sO")) expmL.swift <- expmList[nms.swift] set.seed(18) ## 12 replicates is too small .. but then it's too slow otherwise: rf400 <- replicate(12, re.facMat(400, expmL.swift)) print(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 showProc.time() }## if(doExtras) only ## Now try an example with badly conditioned "random" M matrix... ## ... ## ... (not yet) ### 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.T.sO 8.33 ## s.P.s 9.11 ## s.P.sO 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(require("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.P.sO s.T.s s.T.sO 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)] ###--- 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 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)) (re.x <- re.x[!is.na(re.x)]) ## Pentium-M 32-bit ubuntu gave ## Ward s.P.s s.P.sO sPs.H08. sPs.H08b s.T.s s.T.sO 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.P.sO sPs.H08. sPs.H08b s.T.s s.T.sO 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.P.sO sPs.H08. sPs.H08b s.T.s s.T.sO 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.P.sO sPs.H08. sPs.H08b s.T.s s.T.sO 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.s", "s.T.sO")] < 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, class="error") meths[ok] # only two, for now ## "Higham08" "R_Pade" showProc.time() 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/matpow-ex.R0000644000176200001440000000273313044611522014434 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) 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/ex2.R0000644000176200001440000001267413044611522013216 0ustar liggesusers #### Example matrices from the Matlab demos // expAtv() examples library(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE) ## -> assertError()... 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} ## --- 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")) 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 ## --- 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))) stopifnot(all.equal(V %*% IV, diag(2))) em.true <- V %*% (exp(d) * IV) stopifnot(all.equal(em.true, expm::expm(m)), all.equal(em.true, expm::expm(m,"Pade"), check.attributes=FALSE)) ###----------- 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, diag = 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), ] ), tolerance=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/bal-ex.R0000644000176200001440000000715412605211701013662 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"))# 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 <- dgebalTst(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 <- dgebalTst(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/src/0000755000176200001440000000000013444641457012026 5ustar liggesusersexpm/src/logm-eigen.h0000644000176200001440000000057313444515240014215 0ustar liggesusers/* ===== File part of R package expm ===== * * logm-eigen.h * * Created by Christophe Dutang on 13/05/08. * */ #include #include #include #include #include #include "R_NLS_locale.h" //#include "logm.h" SEXP do_logm_eigen(SEXP x, SEXP tolin); void logm_eigen(double *x, int n, double *z, double tol); expm/src/Makevars0000644000176200001440000000016610760034000013477 0ustar liggesusers# as for a -*- Makefile -*- we use the BLAS and the LAPACK library: PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) expm/src/expm-eigen.h0000644000176200001440000000057113444515240014226 0ustar liggesusers/* ===== File part of R package expm ===== * * expm-eigen.h * * Created by Christophe Dutang on 27/02/08. * */ #include #include #include #include #include #include "R_NLS_locale.h" #include "expm.h" SEXP do_expm_eigen(SEXP x, SEXP tolin); void expm_eigen(double *x, int n, double *z, double tol); expm/src/matexp_MH09.c0000644000176200001440000001504213044611522014211 0ustar liggesusers/* Copyright (C) 2013-2014 Drew Schmidt. Copyright (C) 2014 Martin Maechler 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 #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; const char trans = 'N'; F77_CALL(dgemm)(&trans, &trans, &n, &n, &n, &one, A, &n, B, &n, &zero, C, &n); } // Copy A ONTO B, i.e. B = A static inline void matcopy(int n, double *A, double *B) { const char uplo = 'A'; F77_CALL(dlacpy)(&uplo, &n, &n, A, &n, B, &n); } /** 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); 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 void matexp_pade_fillmats(const int m, const int n, const int i, double *N, double *D, double *B, 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)^j * 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); } // R <- 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; } 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); } // -------------------------------------------------------- // R Wrapper // -------------------------------------------------------- SEXP R_matexp_MH09(SEXP x, SEXP p) { const int n = nrows(x), n2 = n*n; SEXP R = PROTECT(allocMatrix(REALSXP, n, n)); SEXP x_ = duplicate(x); PROTECT_INDEX xpi; PROTECT_WITH_INDEX(x_, &xpi); if (!isReal(x)) /* coercion to numeric */ REPROTECT(x_ = coerceVector(x_, REALSXP), xpi); // 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.c0000644000176200001440000000453113044611522013466 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 x_ = duplicate(x); PROTECT_INDEX xpi; PROTECT_WITH_INDEX(x_, &xpi); if (!isReal(x)) /* coercion to numeric */ REPROTECT(x_ = coerceVector(x_, REALSXP), xpi); SEXP z = PROTECT(allocMatrix(REALSXP, n, n)); setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); matpow(REAL(x_), n, k_, REAL(z)); 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); 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); Memcpy(x, tmp, nSqr); } } } expm/src/matpow.h0000644000176200001440000000033013444515240013470 0ustar liggesusers#include #include #include #include "R_NLS_locale.h" /* The C API :*/ void matpow(double *x, int n, int k, double *z); /* as .Call()ed from R */ SEXP R_matpow(SEXP x, SEXP k); expm/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/logm-eigen.c0000644000176200001440000002005711556553404014215 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 char *transa = "N"; const int nsqr = n * n; const Rcomplex cone = {1., 0.}, czero = {0., 0.}; int i, j; int info, lwork, is_conjug, is_diag; double onenorm, rcond, tmp; char jobVL[1], jobVR[1]; /* 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 */ jobVL[0] = 'N'; left = (double *) 0; jobVR[0] = 'V'; right = (double *) R_alloc(nsqr, sizeof(double)); /* 1 - ask for optimal size of work array */ lwork = -1; F77_CALL(dgeev)(jobVL, jobVR, &n, z, &n, wR, wI, left, &n, right, &n, &tmp, &lwork, &info); 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)(jobVL, jobVR, &n, z, &n, wR, wI, left, &n, right, &n, workdiag, &lwork, &info); 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); /* 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); 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)(transa, transa, &n, &n, &n, &cone, eigvect, &n, logeigval, &n, &czero, ctmp, &n); /* 4 - compute (complex) matrix product: logeigval <- ctmp * eigvectinv */ F77_CALL(zgemm)(transa, transa, &n, &n, &n, &cone, ctmp, &n, eigvectinv, &n, &czero, logeigval, &n); //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/expm.h0000644000176200001440000000164213444515240013141 0ustar liggesusers #ifndef R_PKG_EXPM_H #define R_PKG_EXPM_H #include #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 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/expm.c0000644000176200001440000002134013071464011013124 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; /* 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; /* 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(precond_kind == Ward_2 || precond_kind == Ward_buggy_octave) { 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); if (info) error(_("LAPACK routine dgebal returned info code %d when permuting"), info); } scale = (double *) R_alloc(n, sizeof(double)); F77_CALL(dgebal)("S", &n, z, &n, &iloscal, &ihiscal, scale, &info); 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); 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); 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); /* 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); 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); 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); Memcpy(z, work, nsqr); } /* Preconditioning 2: Inversion of 'dgebal()' : * ------------------ Note that dgebak() seems *not* applicable */ /* Step 2 a) apply inverse scaling */ if(precond_kind == Ward_2 || precond_kind == Ward_buggy_octave) { 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/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/init.c0000644000176200001440000000262213066656526013142 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}, {"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/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/expm-eigen.c0000644000176200001440000001773013071464011014221 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 char *transa = "N"; const int nsqr = n * n; const Rcomplex cone = {1., 0.}, czero = {0., 0.}; int i, j; int info, lwork, is_conjug, is_diag; double onenorm, rcond, tmp; char jobVL[1], jobVR[1]; /* 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 */ jobVL[0] = 'N'; left = (double *) 0; jobVR[0] = 'V'; right = (double *) R_alloc(nsqr, sizeof(double)); /* 1 - ask for optimal size of work array */ lwork = -1; F77_CALL(dgeev)(jobVL, jobVR, &n, z, &n, wR, wI, left, &n, right, &n, &tmp, &lwork, &info); 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)(jobVL, jobVR, &n, z, &n, wR, wI, left, &n, right, &n, workdiag, &lwork, &info); 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); /* 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); 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)(transa, transa, &n, &n, &n, &cone, eigvect, &n, expeigval, &n, &czero, ctmp, &n); /* 4 - compute (complex) matrix product: expeigval <- ctmp * eigvectinv */ F77_CALL(zgemm)(transa, transa, &n, &n, &n, &cone, ctmp, &n, eigvectinv, &n, &czero, expeigval, &n); /* 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/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/R_NLS_locale.h0000644000176200001440000000023513444515240014421 0ustar liggesusers/* Localization */ #include #ifdef ENABLE_NLS #include #define _(String) dgettext ("expm", String) #else #define _(String) (String) #endif expm/src/R_dgebal.c0000644000176200001440000000444712605211701013661 0ustar liggesusers#include /* strlen(), toupper() .. */ #include "expm.h" static char ebal_type(const char *typstr) { char typup; if (strlen(typstr) != 1) error(_("argument type='%s' must be a character string of string length 1"), typstr); typup = toupper(*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'}; int n, info, nprot = 2; if (!isNumeric(x) || !isMatrix(x)) 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)) { 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); if (info) error(_("LAPACK's dgebal(%s) returned info code %d"), typnm[0], info); } setAttrib(ans, R_NamesSymbol, nms); /* now return list(z, scale[], i1, i2) */ UNPROTECT(nprot); return ans; } expm/NAMESPACE0000644000176200001440000000133412605211701012436 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("%^%") 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/demo/0000755000176200001440000000000013444641430012152 5ustar liggesusersexpm/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/balanceTst.R0000644000176200001440000001013012311702321014335 0ustar liggesusersdgebalTst <- function(A) { ## Purpose: Consistency checking of 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 <- dgebal(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 <- dgebal(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 <- dgebal(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)) str(b4. <- dgebalTst(m4.)) ## better (?) example (m <- matrix(c(0,-1,0,-2,10, rep(0,11)), 4,4)) str(ba <- dgebalTst(m)) ## Hmm: here S$z *differs* from B$z ## --- but at least, the scale[] and z[] returned seem ok ## 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 dgebal() will find the permutation p <- c(4,2:1,3); m4 <- m4[p,p] m4 str(dm4 <- dgebalTst(m4)) # much permutation! i1 = i2 = 1 ! expm/demo/exact-fn.R0000644000176200001440000001057012311702321013772 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))) } ## Note that relErr() is copy-pasted from ../inst/test-tools.R : ## ## The relative error typically returned by all.equal: 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 R_FUN <- match.fun(R_FUN) stopifnot(n > 0, is.numeric(ev), length(ev) == n, dim(M) == c(n,n), is.numeric(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/expm.R0000644000176200001440000000072712311702321013241 0ustar liggesusersrequire("expm") #diagonalisable matrix T <- cbind(c(-2, -3, 2), c(2, -2, 1), c(0, 2, -2)) expm(T) # numerically singular matrix T <- cbind(c(-2, 0, 0), c(2, -2, 0), c(0, 2, -2)) expm(T) #solve shows T is numerically singular try(solve(eigen(T)$vectors)) #singular matrix T <- cbind(c(0, 0, 0), c(2, 0, 0), c(1, 2, 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/data/0000755000176200001440000000000013444641430012137 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/R/0000755000176200001440000000000013444641430011427 5ustar liggesusersexpm/R/balance.R0000644000176200001440000000047612605211701013136 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")) .Call("R_dgebal", A, match.arg(job)) dgebal <- balance expm/R/expmCond-all.R0000644000176200001440000003311212470351210014065 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") 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(sprintf("reached maxiter = %d iterations; tolerances too small?", maxiter)) ##-------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("'A' must be a square matrix") 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/logm.Higham08.R0000644000176200001440000002364713066656622014101 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(sprintf("'x' has negative real eigenvalues; maybe ok for %s", "logm()")) 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 %s after %d step.\n", "NA/NaN from %s after %d steps.\n"), " || Tr - I || ", 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(sprintf("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(sprintf("logm.Higham08() -> (k, m) = (%d, %d)", k,m)) ##------ 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(sprintf("R.index[n-k = %d]] is NULL, set to n=%d", n-k,n)) 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_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/expm2.R0000644000176200001440000001047212412724123012604 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("'A' must be a square matrix") 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("'x' must be a square matrix") stopifnot(length(p <- as.integer(p)) == 1) if (p < 1 || p > 13) stop("Pade approximation order 'p' must be between 1 and 13.") .Call(R_matexp_MH09, x, p) } expm/R/sqrtm.R0000644000176200001440000001223113066656622012730 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("'x' must be a quadratic matrix") ##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(sprintf("'x' has negative real eigenvalues; maybe ok for %s", "sqrtm()")) 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(sprintf("R.index[n-k = %d]] is NULL, set to n=%d", n-k,n)) 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/R/logm.R0000644000176200001440000000130512407501461012504 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("'x' must be a quadratic matrix") 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/expm.R0000644000176200001440000001556412603316123012530 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)) { ## no checking here; this is not to be called by the user e <- ceiling(log2(max(rowSums(abs(x))))) s <- max(0, e+1) ## 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 * (order-k+1) / (k*(2*order-k+1)) 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 } expm.methSparse <- c("Higham08", "R_Eigen", "R_Pade") ## "FIXME" -- keep this list up-to-date - test by setting R_EXPM_NO_DENSE_COERCION 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: stopifnot(is.numeric(x) || (isM <- inherits(x, "dMatrix")) || inherits(x, "mpfrMatrix")) 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")) isM <- !is.numeric(x) && isM if(isM && checkSparse) { # i.e., a "dMatrix" if(!(method %in% expm.methSparse) && is(x, "sparseMatrix")) { if(do.sparseMsg) message("coercing to dense matrix, as required by method ", dQuote(method)) 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 stopifnot(is.matrix(x)) 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() isSym <- if(trySym) isSymmetric.matrix(x) else FALSE z <- eigen(x, symmetric = isSym) V <- z$vectors Vi <- if(isSym) t(V) else solve(V) 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 stopifnot(is.matrix(x)) .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 ! stopifnot(order >= 2) 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 like 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(is.matrix(x), (order <- as.integer(order)) >= 1) 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 by ## AUTHORS: Marina Shapira and David Firth -------------- stopifnot(is.matrix(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/vignettes/0000755000176200001440000000000013444641456013246 5ustar liggesusersexpm/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/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/MD50000644000176200001440000000637613444661372011561 0ustar liggesusers21111a7a01bc26f8614c9bd7a5672471 *ChangeLog cc822bf4a114f7d7e748cea36f1ee315 *DESCRIPTION 126f13f1117be0fcb55ba5ca4e6ffc97 *NAMESPACE 962be9a004c63dba7ff7f5f1f057c8e6 *R/balance.R 2b28d5a44256ed57fcb049143f0176bf *R/expm.R 5c43235770b7e3d9abc406bd05c929f2 *R/expm2.R 77c50b87a3afd971fb795811e125019b *R/expmCond-all.R dbc522a7c2b2a50ce050493daba661e0 *R/expm_vec.R 6fde0acfeb30cef0efca9224283b2e20 *R/logm.Higham08.R e101cde2867ae010ca104d0cf5d9fbc3 *R/logm.R 45e07bacddb49c9238b3e9d1767992f7 *R/matpow.R 2edda55f39f40755078b08f674a0da43 *R/sqrtm.R 62dbcce738cc4dafde0cbb7a5b92aabc *TODO 38388d272431c382ea6d58b161119fc1 *build/vignette.rds d31374f27f2d6e5c5b459e0b1541cbbd *data/matStig.R b544e04306e3002383308b520878ea59 *demo/00Index c8ef86c54bac18a08945970a36bb770b *demo/balanceTst.R 84bfbe96d9fa970b3dffd244766bed24 *demo/exact-fn.R fa79ca82d01fb70f9267f5a9d0237041 *demo/expm.R 349f822d69fe5e3d3926c99bee9e386e *inst/doc/expm.R 61655a9c17ec4f2e874bc1ee2af64e96 *inst/doc/expm.Rnw c5ba04310b73c9e96ee40ecae463940e *inst/doc/expm.pdf 7a1b16cbc14582bd11282774a27c87f5 *inst/po/en@quot/LC_MESSAGES/R-expm.mo 501af6d6e25e337a5e502dac988a6bb6 *inst/po/en@quot/LC_MESSAGES/expm.mo 090f57b6ef84c46ab9fdd0b82699a60a *inst/po/fr/LC_MESSAGES/expm.mo 274e76f34f3671b5db44d6a1dbc701a9 *inst/po/fr/LC_MESSAGES/fr.mo 9a400ff096d03cebf5409130ec553ab6 *inst/test-tools.R 0492621589ed70a47a9731941af08cf9 *man/balance.Rd 2681415ac9d47fdf5223de806c84042d *man/expAtv.Rd 74637b35252323211f4cc7e008f5b6b0 *man/expm.Higham08.Rd dcda40d80d307a5ed5bdc8d09806a428 *man/expm.Rd 40f63f9ffea19d1ce6c3dae3f9277caa *man/expmCond.Rd 697d7311ef6c64384bedb7a9c345b41c *man/expmFrechet.Rd 271d34c380b2ca6e04fdaf414cd541f7 *man/logm.Rd 0835f0173e75dabe7a9b97ee7a540fd5 *man/matStig.Rd 25ffdff79449fea67c0f0ae69506fd33 *man/matpow.Rd 915ff3260a6359ff21eef5bc62c204da *man/sqrtm.Rd c988f5ca518069c3895e0dca17b5f91d *po/R-expm.pot c2180f601b2d26af619ae1c0b4fc9e33 *po/expm.pot beec477f1bec3d42eb1ca8d265354e30 *po/fr.po 3d90f59b3248da1e70798e94456b5c99 *src/Makevars d962e154a1fa708ec850fb4c0726843c *src/R_NLS_locale.h 995d411673095b10a9305f61a919db55 *src/R_dgebal.c a530ccc106b9648ad28df7fa23a75c22 *src/expm-eigen.c 22bf7cf17e13a0243f889b2b9e73042e *src/expm-eigen.h 472f04b49e6bc51d7e2060759468f6ac *src/expm.c 8987d515590c319424877467e8005321 *src/expm.h c0dd474c3e359526645e51a11f5b299f *src/init.c 8021937be917255ec167fdcfba3e66ff *src/logm-eigen.c 7c135254a9b68c6a1ca4754d493b7419 *src/logm-eigen.h 8685b3faef183159c5044570e81b31b1 *src/matexp.f 1adb9242b9bed0f47858193dcb3d07ec *src/matexp_MH09.c 115d4f13a45395eb775dfe75447ce083 *src/matpow.c b16149a6a56e3d03521c01dee1ca6a8b *src/matpow.h b85b0dbcc9fed3def6ff8231525935e3 *src/matrexp.f d4cda3837efeafa9bdf66bf5b51a4c1f *src/matrexpO.f 1a8c861e1c2c64ab0af2c7742aac4acc *src/mexp-common.f a22fd1e243d0d2e96802f551a4ff7f28 *tests/Frechet-test.R 5dab626b71fbd97f5aec2f5afda51432 *tests/bal-ex.R 25b4a3563784582c94650c95dd0ba71c *tests/ex.R bc2c371adf98d0a651f016dd92d468cf *tests/ex2.R adeb5ceafd44f9219524df173f66169f *tests/exact-ex.R a43d9bcf58d286dd0745b058b5b003ca *tests/expm-Cond.R ed2a4e750c0f271b198982795a272892 *tests/log+sqrt.R 041ae27011d67be12b0bf4cfadb27dc2 *tests/matpow-ex.R 61655a9c17ec4f2e874bc1ee2af64e96 *vignettes/expm.Rnw e1d639c199dadb136a99c08a9aed0dd7 *vignettes/expm.bib expm/build/0000755000176200001440000000000013444641456012335 5ustar liggesusersexpm/build/vignette.rds0000644000176200001440000000031413444641456014672 0ustar liggesusersb```b`fef`b2 1# 'H( +G -KW*d)$&g'c]&1h0X" ,LHXs1dwI-HK î?+S+`zP԰Aհe ,s\ܠL t7`~΢r=xA$Gs=ʕXVr7expm/DESCRIPTION0000644000176200001440000000131413444661372012742 0ustar liggesusersPackage: expm Type: Package Title: Matrix Exponential, Log, 'etc' Version: 0.999-4 Date: 2019-03-20 Author: Vincent Goulet, Christophe Dutang, Martin Maechler, David Firth, Marina Shapira, Michael Stadelmann Contact: expm-developers@lists.R-forge.R-project.org Maintainer: Martin Maechler Description: Computation of the matrix exponential, logarithm, sqrt, and related quantities. Depends: Matrix Imports: methods Suggests: RColorBrewer, sfsmisc, Rmpfr BuildResaveData: no License: GPL (>= 2) URL: http://R-Forge.R-project.org/projects/expm/ Encoding: UTF-8 NeedsCompilation: yes Packaged: 2019-03-21 07:54:23 UTC; maechler Repository: CRAN Date/Publication: 2019-03-21 10:10:02 UTC expm/ChangeLog0000644000176200001440000001653113444515240013005 0ustar liggesusers2019-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/man/0000755000176200001440000000000013444641430012001 5ustar liggesusersexpm/man/expAtv.Rd0000644000176200001440000000567212407501461013546 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. ((NOT yet available!))\cr%% i.e., in expm package, 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. %% @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/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/logm.Rd0000644000176200001440000000563513347257614013250 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{http://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 or even error {on Solaris} \dontshow{ 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/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/man/expm.Higham08.Rd0000644000176200001440000001115312705240621014602 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{"\linkS4class{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 \enumerate{ \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, N.~J. (2008). \emph{Functions of Matrices: Theory and Computation}; Society for Industrial and Applied Mathematics, Philadelphia, PA, USA. Michael Stadelmann (2009). \emph{Matrixfunktionen; Analyse und Implementierung}. [in German] Master's thesis and Research Report 2009-12, SAM, ETH Zurich; \url{http://www.sam.math.ethz.ch/reports/2009}, or \url{ftp://ftp.sam.math.ethz.ch/pub/sam-reports/reports/reports2009/2009-12.pdf}. } \author{ Michael Stadelmann (final polish by Martin Maechler). } \seealso{ For now, the other algorithms \code{\link{expm}}. \bold{This will change there will be one function with optional arguments to chose the 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/expmCond.Rd0000644000176200001440000000630312407501461014044 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{http://eprints.ma.man.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/expm.Rd0000644000176200001440000002376712470351155013260 0ustar liggesusers\name{expm} \alias{expm} \alias{mexp}% for now \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é 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")) } \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 "Pade" and "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, only algorithms which are \emph{\dQuote{\R-code only}} accept \emph{sparse} matrices (see the \code{\link[Matrix:sparseMatrix-class]{sparseMatrix}} class in package \pkg{Matrix}), i.e., currently only \code{"R_Eigen"} and \code{"Higham08"}. } \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 \url{http://epubs.siam.org/doi/pdf/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. } \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 ## m <- matrix(c(0,1,0,0), 2,2) try( expm(m, m="R_Eigen") ) ## error since m is computationally singular expm(m, m="hybrid") ## hybrid use the Ward77 method } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/balance.Rd0000644000176200001440000000571412605211701013654 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, where \dQuote{dgebal} will probably become deprecated. } \usage{ balance(A, job = c("B", "N", "P", "S")) dgebal(A, job = c("B", "N", "P", "S")) } \arguments{ \item{A}{a square (\eqn{n\times n}{n x n}) numeric matrix.} \item{job}{a one-letter string specifying the \sQuote{job} for DGEBAL. \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 Details section. } } \details{ An excerpt of the LAPACK documentation about DGEBAL(), 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 } \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 : ---- 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/matpow.Rd0000644000176200001440000000207712016223562013601 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}}.} \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) } \keyword{array} \keyword{arith}