expm/0000755000176000001440000000000012276627706011272 5ustar ripleyusersexpm/TODO0000644000176000001440000000111412251553550011743 0ustar ripleyusers#-*-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/0000755000176000001440000000000012251554325011675 5ustar ripleyusersexpm/po/expm.pot0000644000176000001440000000203410743677313013400 0ustar ripleyusers# 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: PACKAGE VERSION\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2007-11-20 13:46-0500\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" #: expm.c:106 #, c-format msgid "LAPACK routine dgebal returned info code %d when permuting" msgstr "" #: expm.c:110 #, c-format msgid "LAPACK routine dgebal returned info code %d when scaling" msgstr "" #: expm.c:157 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "" #: expm.c:160 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "" #: expm.c:232 msgid "invalid argument" msgstr "" #: expm.c:238 msgid "non-square matrix" msgstr "" expm/po/fr.po0000644000176000001440000000274110743677313012657 0ustar ripleyusers# 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. # #, fuzzy msgid "" msgstr "" "Project-Id-Version: expm 0.0-1\n" "Report-Msgid-Bugs-To: \n" "POT-Creation-Date: 2007-11-20 13:46-0500\n" "PO-Revision-Date: 2007-11-20 13:56-0500\n" "Last-Translator: Vincent Goulet \n" "Language-Team: Vincent Goulet \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" #: expm.c:106 #, 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:110 #, 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:157 #, c-format msgid "LAPACK routine dgetrf returned info code %d" msgstr "la procdure LAPACK dgetrf a produit le code d'erreur %d" #: expm.c:160 #, c-format msgid "LAPACK routine dgetrs returned info code %d" msgstr "la procdure LAPACK dgetrs a produit le code d'erreur %d" #: expm.c:232 msgid "invalid argument" msgstr "argument incorrect" #: expm.c:238 msgid "non-square matrix" msgstr "matrice non carre" expm/inst/0000755000176000001440000000000012251554325012234 5ustar ripleyusersexpm/inst/po/0000755000176000001440000000000012251554325012652 5ustar ripleyusersexpm/inst/po/fr/0000755000176000001440000000000012251554325013261 5ustar ripleyusersexpm/inst/po/fr/LC_MESSAGES/0000755000176000001440000000000012251554325015046 5ustar ripleyusersexpm/inst/po/fr/LC_MESSAGES/fr.mo0000644000176000001440000000216310743677313016023 0ustar ripleyusersT :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/test-tools.R0000644000176000001440000001053612153610406014473 0ustar ripleyusers#### 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, tol = 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/0000755000176000001440000000000012251554350012777 5ustar ripleyusersexpm/inst/doc/expm.pdf0000644000176000001440000016615012251554351014455 0ustar ripleyusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3382 /Filter /FlateDecode /N 61 /First 490 >> stream x[SNշ, ߰Xv۹`wCBв9X ;ƱlG/ ADsh"%HIF4%9YN8#.$\kDL0X0gDjWKPe=Un%NpDyc qaYF&Fc{CLkhoI&I2E$#ƒ2KbЕXe9 ƃc}FrnI.$|~ 9UjݛgЫr5Ճr^-vFsB[xF֏dT70a㧅2?cʱ.=Pկ{ iZigwnUc&6aQ-2A"tDǴ> $ ? Idms ~;*r!rRH-+XOGE`NtPVٱ ڢɷ{ `Gn YZбU>bHm]ASZ5K z`=56k@Ap`R1` XE zO;nml{535+$0LBʞ0L,aeAL!)qg`s2YlfVdٷmtޡ?liFl .Cg7?Gdh7]N-Cw=G-=zJ9$?G^:r;@{N@{`J>rvMx-sZ]5Ow1*VYLX hF6@',8~aŠu*6.|FstV/oˬRۀgq :'/{9Z7D5qXY["3T[ԋYdj6-SfK^P%"͆hpYq\ٶ\%o6*~sۤ2vwr:Bd c# L<.ҎS-6j'`^% ݑWedBYԣoS+3Z8I`$ϗxH g,]yK^@ sl(q7UXC𐘪!Aj0ؕ0Y{Etux D2T2q=#8" dr5 s cMU1Zv$87#$9S󽓣pH‘BoPwdלA{}ꮫ]ڦKƺY&HM" m@ 'N,Yls5A;i>ΠfX\,+:l7<&hs#k[VuAWټ-l}`P[VZ\AǓV'm26MZ-*}&-7^~<5x_}&E;ִ).iƲymҟE>Bh1f# Sa]po'( VvomS~+-;ۆˊܲez[gV Ya.irgd]P5Z'ε^e\qrqrW}Jӂ/rlLA_:I^?e5}-hnL;-?\OYbfxr2'dk4}ÉֺsqMY. yYhei<ݯ1 m\4FD]}N(vcپ>jRv={ckBv fLJC/td30#㒤#6l"o&.&(K4v#0mύE'kivh9) /юκmsU"$W/Lˋë]:j7Hj;)ئ+HU`㺬&8աNc%+emN8ѓբ6;>08:)I誶3ĕ<8-MŰE>kv[馟&K3b)=GG]`%ɍU^^l%4jvݺnz)w+y6{N;`9|IQU~o}I ['j4 `]"|=vfo: mV[!塬lpn]No7en!"ĭ, k&û.ޅ]6%YӖ;6mMwl6*R^cs[ΈF6 Zʥwx9;mh]fn1)$IҴ8Btb%]nYFu#AſFַOvN/ށb;zU, ubVy5\rbxa.]uit frDbN! c 6]Nq:(s 36YhL13S-zd&0=O!O;!Kx}ɷ:~ u3*oaԭ m^M{tmWU–+!{1mIaSRؐ\t 9D$rؼ-[*ZNv-JZ+| PS:<AղI%77(FԄ-O͝$ޚכBPӛ8?,ɾo 7" 9{Fqoj7"'5/0R6ݴKendstream endobj 63 0 obj << /Subtype /XML /Type /Metadata /Length 1329 >> stream 2013-12-10T10:03:36+01:00 2013-12-10T10:03:36+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 1506 >> stream x]}LSWo)\QUͽd\K6uN1AaA+Rhi{ -\V=P[h*ȥ)T׉ u3ѩq&[yʮ+,$眜90E%Xɪ°">2Nm0*]$b"?`a<6)9I9rm{;0,RZTg_N$? Ò,ۀmX} YVͫ *na3doxb .xh_\/EzJ%d(-rųK3IaudrQi5ȻdlņT46 |L>l _gXTJ;(?`Tשj&JE\O::L:a~.f" O\vw8oYS9yBu2Knjn+ePclujk :"9OT9CZ1OWXp#ؒ൫D)x٨'hvv_+f<vzDLWw  XOw^M> stream xmQ[HamEf[ Ŷ. !{IA6{tSBDf6sW]Tt-W4(KH|'EFK9΁@"¸3VaH"F'NRH*FRI^N؀%%KMmP:f̪lIR۬ޠHjmhq@!ϋbL$Dz@ xϰFpV2b̭yr }lV 2܊ڀ5.Ǫ_BsepbD#4b$]Wh:a@Z#V"ކ؊CJ34by9\NjLpG:8jH]d] r4;Zy.qME\ƥ_\c%nY:%lG&I^>ҽ#~"/\5\V, * E].;(y03[l qFR2.YC286U{fR gnSFw}ґSG42 v6*kZ, gow4?> stream xWyTTWԽ b0Bc-;FEcQA(RZR,W[BEAUQ,(DM$F1H'I&19[e:s 윞3s3g x}m_4 uK-/loN " GihZP0O̼3) sWs2M=E[OdfJxuzĚ̬7sޒ{φȽ6?ppkTj%K~ylffa20[m(&y<ǬbV3/0f Y,f1o1o3/1/3+̣ @d.11 `4{RS`dୠA]e񎃗&ϚlɩOO{lӭ̜?3nOH{dȔ+'[?v3I78닑jp'V,6Sk+OyA,U!CQjͶfY*)h.a7dlCQUqƩqD਷q:KP1R%ʜHq():6\( 5|a\[}:mdI+ؗBKljL],^;~ᣪ͛҄gY,;TМݻ:ŢyŪbm!w?t/w$[!ked8m@-hifRTHBENրl=Ӈf<mً@.uem>qkgkUq6T?޹:HZ5Rsj!-:Ь>B',~&86;{iTBN' . \}$"|DI1@I' ?1MR|'Z e**P5¯xe% 9Wi)~ yq7];܁ D@!~501U,Ly<8WQ*!~5Mtޏ,nQN\c (w9@1\}E0yB@e,JYD ?M̯@E^PbSfJ9ki(832T NgIrZN@?{Sv$}qE>zKϱ Ec}DȭyׇzάBPWXhJUVGQT)4fE$mU#xF׏NosQ2U3:OJ}YaPU ?YK-e,~ueꢂ,ATI^ګo^ e끾*- Wda #5@ݦFG5G$KQEh`—Catu4rh3?΂`ߑ6vP#)l̵5G[n>CW 'GEi) !Ǎw B)qHx+Dpq_͑گ $3Ȑ &(mR2/'$G -U";?2.UK%qRjw @\}а$\ T%$$?"͚@ri}r:H_")<~&.檍p@/p_aOUjsxzRQ?r>ዘ! Y ,1NݡIH+ID{P'CeSV}‡I2c )9TF'tthk{j-5k|r"!'YXqit88T5qソn;c$ tHo!Yw4XܺL= &h4xa/[j1c3iKHL'ύIڊ`<_zPѪݔ^3"k1[-ϒwgdr$Tok|{B::;lm2cY0v&) I~Mɩ2YXXZl6K^:i3=n|c?c;i6SH)= *p3iہ7RҌ'X1$Y>mq#ާ"TĒW+._Q *:1{ogb=ۤc^6Fkvm/½Iu=SOQm0rpzv,GO)f2/ ?bP^UM}Oi/_<_UFgcc YmkҋT(OjЇP'v䇛_{&xx,M4f`_3$t0\.7yrGAcEesޭ*A1{`;h'$p-76*!^֌?W}/!zK/H%3YάAQZX~ T'y hYEx[{x&Quޮ eVM/[bOWgQPƍƳ/ШʪJk*l5B3KYh?/JD?V(xZ5;xT*"\i݂+r!Te7س!rr6gϿ/"~cf']?ZHwC`_V,̙X6Hk>]Fv(r_f!3g/u 5Z=nB ,mg}SAk sJjćy!Yr,,愚J̪*0}G~7|#kzk|,Q"Bu*̢׭+RircCw~ͻ$D])P/oįmįCnF`n<fjs1'k dKG9Ho&8Bh-X~9"h9My|I|] JyFP#*%ŷy7'^Y>wիVI%YjRf#AP+_N\gܑHSY;u/}w ggNQP_X'6t C*"M3B;=t[o 8fH{n`9履/9'|[aya șsX.r0__ :cfdCެP+VE5h%b'_MXeg\HkOwB]p%(ZW *vSvtBNj 5f&tO>[|a(7;#%i, I_쯤#A㸽jT[Q-)3@=O$pmF!ZYU}x/dĽV`#lNLj5jLz#MܞʺItv?Isk**sKƥ@Lnlw6 Ɯ !N?.#?H $W WjUeZ밗jr󋊄3.ߪ,*{x$ 7U8%rŴ Ս*endstream endobj 68 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1725 >> stream x]{PTe]rs ^5J4db5(D!>Eey.ZP` eyT21Xc:L4vgR3&m]c.v7g~~4G4?&nOԺrqD*~=S" -ABE<_HWnU)2ssg/ݣxriJqLE+U9;}y<-VOTMuuTVUՔX~߮zRU> NLEݝ6ݸ䑪z`|iwXvRUxiSc c8(5fh,g +w#SK`坹l8:xtou/1-|=EwV])m8:VN>u ΂UL( lK!>9s|duMȎa0ҧ3 }<A O+}ِjt5隲in`jMmKC(a}ҡoQǛ9M.8q >QQ;tvDp7|O?P%Dztu%XlؘRGI1CWgK: !u=qK;W}zv{#@|VtVݜ[ގYv03ϡi7r^?X+\HmD|d`-0΂l&YU{zsT%S03$hvg1ʑf`kv@$_)_-;k?TC RXHKGcA%C2?ʴ1P *CN]tH')^ÿܿIǀy:Dl޴#fp\.A;r^iHhK2di4H-[998,bͶ7 |)r=WsiwEyVMrO:S I';ld$* `vÙPT+?$!p4AGVPeiy f`=}d4t-+K? @6Y dC 'LWEL]_[eֆa6!k#ї `23ju-2|&:(\endstream endobj 69 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2964 >> stream xm{\ea`5L^g15Զ-3-lV7oyDn"20f 0\ rI)Tfffn Y umwky<9=w$#H\|B{{sidT $Sָ$)LrntqǕSpddf$Ĕ+Sf$'DNN <◚4Rvք=0,f 3 d`f1LY,eg1o2+;3SO82- 8MuwVZ/Eg3":,;g^ m}˓ox<Բ_A.ţM|J4ZFLVT5:(?6.vSʴ"l㇥_xVs7չM1kvg5TTՉfMUjUvJ%ҏ VnNJd=N m,E/b^/ۗd: ᫶-} 0ȡ?Ȝ-!ڝ^^5"`S[ꁲ*_5A~i"S@DuZv96掏CvO{#^ 峛uӿw;]?O <ޚaȄ y#8;9{G!B9K Y;&+7ԃ?yw\G3{, |' |]sĊԅ#׽ Fot;w-=q(IY\bTTw'j"4 ղzqW验YS('/B>d5fWVsc6agC`5Ɵ7 jSj2HX(וB)WTQ\[P]#TW) nGL&00^|ǃ  n32iA!qm.$ڢYPU)K׫,@kVkYd.nh28RSvXBϗSptR4\8g!±5.fgQZֺv}YV.cjϞ;ɭqqyY)V[Rj+8znݜ]ougz% *`nޚO+{ҹ;.ţH컦ӗ>#huy~JӮ^]ÑiątRКm>+ڨ̠Nދxy~6/C -/~,ԿU{j֖ḃEgˎYL܊cQ˙p .i^j57\6{ >/ oJ1DVlLQi7hc3qӞ;[ 5[%jU7sVΟ/V*xƙRCnonn_JW$2'x^Y=~I=(5Z>5-ajU})eQʌ ʋTJbƜ]d>jpp[`Pfmc\KܽrsHwcsš7 ϵ.M?$51{ʙ~ogo>!os,ʁ 6gt27o4-{,eF3NM*%ҿؿ)^>F?gR_Mי5yYL!8uUjztMr`I+78Bڠb[̢V,Z&0tF-B.>5cKd~]Aʆ>~O(f>Ki]]ɭ1½ {~aKNt>|bNıUt֛ +a u@պGdS7oNs!"s!Q0AvWR 3#idI1g$~EdžZ?sr-_!Ҩړo3Nk M\/#؟& N&HNre)7endstream endobj 70 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7779 >> stream xyyxSUmKs/`ce^AEY *T(e_ehm$]IM&M @";ZQqT\<{Y~>Mr9{>rA$"""/4xQɨtݚh0( W7r=z=P"2"cfgfdsR2fflӋA̙)9;kN;BQλy͹[%'o]h;.K[2cU˯Lzu򓯽Ɣo}aqyAEijbb xXF,'Vcċ*%b51XC&s Zb"1'wy$b>*HL&IB I"O<%apb1H% b0I !.E #H!bdO6g~6Zϙc*{j-uo8zgD!<\&f274sqm2|#f$Gt `Z83>9董'l4xo_!,!&^/hj!?D-eVPlw[%͞&zR`QԾqٕ)@BHhY(և *R*K pjJ86s)0Hte$RdQ.OWX#ڡKC<ހF4Kx8 ;d@sw~v౔jg>y"Str(i>Držjo/0-:)":{{@>(^Ԝ;5&p;:WX@3#w2D?XDF_DA.)_Lq;yvtyۋ^J("zPkҘ[V,wTP|3Q"08a _Fsf4:In'H"11M*r,&6@B8sTN7S+=-+V -G)h-Zǡ=8b6`JNu}@K{y suGϿ nKΫ nDX<Eb:I٭{Kk{V8xl0UǢll0۳ :ł!d,pf͖0 &<@mΜ'a2WS:&5 ک)/"nj@tԏ(vzvh7PwTc|NZ~7?3'se{-/GOJG(dZZɳ'p0a b.8 +cK_oP5kmRR5߂eWC,()zд))|¬DU 03O?%<<`P|WB?5|emq`%z۪Tf%H,xUvXa;dN`s( F5wժmɽ$Zȑ+G|mz#52kKR ⵯPlZ5\@MGAS:h_٘l_XK9Pi 쥞{AqЬTz0v5}o62]NYAj No_r c¼PJ}Ҙa^@~,:{vaV I SA:}3O_}N!mrxXAe+Eo5TZ) >mT ?c*1\>Xj*q??w]р†?ȓZsGptzn5<81" Xplo=9OH+J+w2mB,2P@mTM[T}y p4=Ba'Ll6]顃TrsV^V#LN5l.]3hx̠roi3TT[l;MpNր^/YL L*ZYM'>:,v[K-萌L˰c0#/^PFs~g/]I6Ra?ݻ"9+m#H[;708Ze=͕GV{^Qh/lWzu*Ҧ?Z$Ws{SdК 2dHTbWA79ENc_̀Zɯ$ہ[I-@cVUFR4)N(j5 :YGA#pap'Uf,G6櫃=70c_I^0mGaIDXFC}'= -xMu0f>p5O׷M݉j^I4$fpiX=hEs7? (>LJou)-+-nGI0˗T lzhc{s(+ϭRuLTƙL,pNW/C{z =;?GI6u~NP.1 Cs=Uǂ >(TFqkOa--$@HNU[w0 ϰV9c0=E ]v ʨ؅D-yGY= W=*G"`>#-AMio.)67Ceo?rL`~cE~ىHƩj`6Y+QIR{$ RZ])U(~Ap>¹v}qZ?y4D+>8Q; GT؝%!P8/U.(+ XqұRNơ.M Vm ݗUx|@Y|=~F9߫/bؿvQÛ2&W^,~g`"f,;j8&lKD#| ެR= $0(nWY}46ͺ容` @q|&.4LsXc/=t#`(6; غP:Ȣ(ѸRc 0LpIԷ|ZVm ocXaʕ&vkȶZZQ -f,C&-=/de5.3c? 1?<aϿ 74 2U8um']buuV)r{@sAۮsl\sV:Ac`us/bPr6}ӻcwzwCa=yEx!)-61R(qF8k (L{h2G$_q|. Rξ su]o63 M+9/|9mp, &F̔kh\j˞u j}%O_OOfe f/6f7$vʤ(i]e%p;m}ڏ+_r4q9n ϒe lkjh''W,ZvFtܙ{LXA.R`i ?wwO"1HPKKI~~]=He3UrnK Pgkm* g?8ilJα·a礠:65ۆ p2]=v*YIA -Os]rFk|A+S( [;[*6 ?}d9oeeaƺ,1-RaQ_ƀ=^f+4laESabT-rd)}M>#|%.JieyEoͽ~I#!D"[;MMH_.W^: N?A/GcNW B`wK]pt&}-v>Q1fAcSd)[e)#a|b,M^k ] c߃q&씕 F4j3p`EOG73_}{9o= S-GFK8YVJHfjd7or'`eJ֒ܫsA"X,IWլ< lhi Zj/ q*&N8 YVW$ǑѝُhwVUkӺLؿTk= NEg`R߮+lqVܺLZN-_,w"Tei2 [Tp68x d,Ѳvǐב[U3cPS&lT´Ti4u*9SPx'NWGn o-bEZ\ǎsFeDZo@J0Lp3Rv\8ꪻl\ߨ ge=uE`nڥGx,:HumZӎi =YȠSFh<{PYG}KU8hoQȭ)l =NNea~FIojC,6Ez7~u7oN~{b.L\2O6qPIgq} ~H2G` R+|!!хoE>C/5JXX'c}ˑԇp1Nc{a?7MlwZ+;Su,LyW;3T):ͽ}ٌ4'fN wkYcTSM0T[ictLh H<޺J9=҇E^<.=[WWSW<bܘ}-c=ʃU-|*!7`gru?Bx9 l{7.EI h"O!@gUqAc~DNZ釱XQ;tm38g79@5| 9Y9lp_~ Z!oGW]@4Z]9]H`) |l%V2qB=>"Vmqin;: gAi)&CgYd% “%p$ ,j2..ߴ`i*ح='Ž"P-e?Wh?LF*-~:wqfyubF@eJuU-BЛzm l \??bRr #աx5O 4(%[qCϾE^JFµtP) `fXY9{٬o7aPUSk8O[ s88i$h,v;}>Ž ._L93JI:^낿[ȹt(\J܁3]w:eBҨWفǽk3lCǏڊ6;^icN]Z5oΞ %0صS`1Xa&d0d ݫ:mSnpX/Ñ cdWN=U6k2s$"#&__3o0>!Io͟*̬qp;~6C.o;iU@=qW/n^Ŕ*lzPF/3~Ix&ۥwr/,v9@H z_JieG>tIwd#UXnLY K65#e޺]~9PVQ29uevY;V!\!pЗXp`;:l6 )'kdV,{{&k1q,|__yBEO7{ B)`)WռB}T@CА5h@o4ZGF강dpH:| pQ̞ rzl2G},żSQg8Ɉ@Q_ mbGzi( BZ ;N]-Ңj_i)14,Xsp(&Se2= `.F=GODl+dޯ_2A_]!q3 Ve"~ _>t4&erj|"A^Z 7tf}F%JU O- Di7oԟ -'endstream endobj 71 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1282 >> stream xu{LSgƿC9GD;0-d*ʒݔ)je"*2U +RrHR.m BAR*c˦y[ǜ#l1yˎ+41[||<ϓ{ EMKoy-&&f/<7W؉d1 85W\09$3IEIWh9ڌ܈$*#7;"^XUVeiBsҋgR$xl#r$u$Lg! ђ?(s@P@iDKoў/ q@d᮴9{d>5xD AtgLtøyc>/MylHKyʧϲKs6˯cOհDS}Lt^Y3*p IG8e$T:{X"/-nu`/yUhvމ슌fΗr#Y=vخ?'}jqVϠӥAi~5endstream endobj 72 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 371 >> stream xcd`ab`dd v 6400qH3a.g"k7s7O3 ~ (土[PZZZWZ&`^x? e|;x [_DKjJҪ;9~[~.]wƇ핟6mr̻DwcO){{'Jv/h[еhSe/>0oa~[{Rl|0璓[3f?>h g|gc}Q}o}w}wPBbhEZ]JwJ7_sgX2w4\{帘p20gendstream endobj 73 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7646 >> stream xy| (qM :`/D"=((HKHd{n6{^lHB*D *xx-rwウK{{'dΜʷ!#rrrN[`رc3.엾'׀䕙\0=_ɃEC~J)|Vа?bV[#HjWoKSjk_ʯ/i.xE(*X9KUsV]v{Ryvȉ=?G]񥣗!b1G<@Q@ #rD!qۈA$b2q;1xJL"(boNQ~m}5wO5`'ǒ>~>>pmу2ۋoxg!o;4r羼)L]]2^?/|1lɰ A#^#hSDmׂo4 rUZV'*јU&^,a{ky,d {p=Lp>/9 Kx^* ֱOZ$ iq'E$CTJAMȖ+SxB<=/EŔP-5Dt1?Y"艇~<% MqZf,K}}o~*ûR]اn堚6۽m3O{i&^{ ӇGH@ iv*xPyTDLFe}` 4n2x;Ť{Ru%k֋*qXkARTӰ/3yhxAk(ʹ h y~T ШIxf{e^\Slc7ѤҮT􇼵KoZM4$Ft|LO~;'TUz._^ hnw ǀoߎ uNֶޯp* JzQ] Ia>-.0%$R$ml5_ڎ TUА믐%HeeuYׄJ d +$y`7 FĒFLj~eev;x$h{ >8 *ϡդPoݗq+`^z+wSpY*rÝ}.g72c o.Cga%#WdS A"6``g(| M@GWEHرD9CJ$*=2sɪ!DS:+l;_KR`TfMcX /Pj<ɼՠRI>yc BQ{;ǘ#jEȿ,0m+LɞUU,.n l8 ;T>\7oKn :hj vuuYm.ιf&Ywa-Q1_PkUv]ʹ xc03R$c,   $L1d2E썱OTΖ>r&7=pԞdT?-C91 *DUŹwI't4"߄WGrXGLsε6GpYxW^c+[ƗHQϠh,*<^4rr۸wl9CD9>8bX^Bxs? {>|T&T ZZ&XS*ڴJ8$QO2X,U2KpGY͢K}p-n]MJ E5昝NK$#S"᧝1GVc]at 7zLoN - #_Y/d \fk4C6 +k`wSf"L8"w'dB`_ Wr=i~oS,lH5,@_(%eP|R*w+B%@8cI+C@J|73aL:3D<3SzC$e W80mdVu䵂:wy: # l]nźh؍Q pM "JƔscvث;QQwt/nX` B0m&,_"o=<;aQùAxНHH]x"qbsGEh?B0A JдVY,,_!>oZCߕa >'A NNE1 ƣ&qh0*FzG=rl,f h i߰AtpVVk&mvJ|}~zuBZ1[98 =C1gz|fG;ٍn!_dqR/W4d,a(x _]dgӑJԹaR.LjK)p6l4h7t$nkj|L2x'2)À #cOH"69x&Pca\-K]2s!y?_ReIfDU j5ICNklR(4B~~!x'O oͱgSL\,ʐ>NY&MȎ!F i_eӷSh;T?h2#]*K"tmi7YjeXF{OJ~ZV7p[jH!0JYJ9VON?.onь޴7l=ۗJջ}REoV/Uz}t}bXkםQ c3m(q,AՆ *@'|HDo@,[&)-Lk(5FIC7ƤzCc|xtPlR dvOp8q5;A }'YB"ɦј;K]bB'5 P|o: y@Q=I+5B ]< L|:2\N,zl[]GP~Z̩=`Wi9T  2q%r{# cs Δp:)j)Z_`>cOs j 9_iE)CPx(,)vg7dIB%/lYyc;z;u˷,;vwPĤ=A2,E^c,u\m >WiY銿(76b BoK+r$dR9{B.}da.5ki<) W*@%0efsv]vH}ed7]֙`Q`xFvqgEqIŲi }y_Qu^T]%3nx{=c7f_}*x"sbU|Egit0#|:_EqQeNs.oSh(XgfLVeg){5b#Y)6 X,AI RѕhMw Ɇ*ň w5;>g>6=> dzOq3Zd~|5YgnK{Q8K& kDFtCя+*ݥ߮m16՛mJz+fN*E;ɘfm43\L,$gcp 59$s:b$|6sWYmgPc4rn`; K~)mN"7)=OFchD1ّe$t\I&aȻ]kvU6Z v̥f ,6RbX*h$)k2"!;~lDم=aޖ}sHB)Tk8J ܈'2du@wFdvR&0bʿy^LC0/gއDzo.jq*R"5=guԍ}D+Ȫql'q8:[f;)aF-X s6ee* ˄6JUB >za`p~>sz/N B u :[z+ f`ʗa;&]bgfgׁ5;V`mmw7>|g]:vp̖#fʕBl2$+i /HmU>P+k / E d"!WB2[G,9tC1~<'}Zn=`Ų= +E% ]9qE^X`>wt_Pk-|tiG7tnE =&)WUXayX*?kPszR'(/ c cHg #M][Ufdab4SIT.Pj z5PӵV:FS}Zog=d Ky"NJn@/  d.ܹ*pռm"ՉOP|:u̖`,D[ύNqm@XohjYz] Jh'՞ v(Js<}?| "}PN)ʩ[c֠ʍ[Bp>[>_:[_[YFy\!҂&beMmn*Ԉ?d+<[Vo}vIkMRĦ*k>9Jr| |MC‚ڄcwxƖ[r0-^/t*E<`8 ,ἫL[ܼ}+p/'<3m,iOϝhFn i#e @o#]Z=K_u1n,TRWjRvW#+qx[->>SŽo?:C=c%-u"n[T^g3G"SO2Iͺcvc)d_IWg]{FFUj4e|T 4RiU5خǰ])8>elŃaAF" n *2h@3ustL76qN$_aSp P?O/_PxK/؛LyaF _?}HloRhu@նhǙmB~ҿN/Z 1Xg~rvIGzy%/>fp4MB$q뜆dFICɨHBH*f+N(KbMDt(+lPh뱿θh͇Tޮ>WqOM~o9};Kic; <6Fk1_9준c9 M๩O^pZůLNIn)9yбs\>i]cÂ? px~RmWy70Yo]\`YaYa[aWoty{sQ̗CCfȈ'eBG3@ 6uֲ愵Rn-7n]vrv0VƁm7E]Ry`3W$0v>7XVÙGG~<I;"8LMffUnZb&_wSI>[[=0\*!LOpH.taZ( zMv'EMok_΢#ݟ[8K0vfZmP%K5&P dyD'{kfVլH tffkE٩{-%z<,~̨U-ZX&g^]%!O,H- jQW ;`||iSk;^LM2l)Ս'_A6 @`XTy΃y (d`G^tXandf (8 j~| ( fE h_vԮs]߃1ދ^RxA1~ߟV^PUQPhR,!.oUʒaT^VtJ5ıѮpgMrl3+(5 a6H[NqS4@P Cua> stream xcd`ab`dddwu041U~H3a!O?nnM?T'~.Ș__PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@ܦs JKR|SR=@b]vϸ2y?MDwWuw7TNپ,mcUݛwoˣӤ{FOԞyY/`;[UUݏׁj~#[;U+~xtdwJ߷JbKB>lfa{'67;_ôS-:w$]\ٸXpnm9o9)endstream endobj 75 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1600 >> stream xm}l\IIB\tc h6:֦@ҡ-}v\p~w%/v̑8vH֤@iVUP[6ĄZJխR+T=vimy}}pq|UMm["UoJLe봅5|ร_hrZ͌ʸAuǎ?޲e~vZiQ/F t髪 Ӻsf˵`kp6|F˜ut;d<9A !SW3s@F|4ún]4Js ʪ.ľ""$U/y|Gt[U=q "j@ȁچG(cmtf8Ij ϲ.6+NOR*u)?ݦQ mp<+@ rjg F{7iEݻZYT).־{z~bnʃy. U/qiҳdlUKYEtJַKA#\k-sƟ]˫ RSpEM\eA %B{"e.Aͽ wxE(*g${9#{t3@X|>rn@#|k\EY1H䐄1 Z*эcsfOdI:w7Cz+6Ue1x~ٸбx/&OpF"MlCeR]vLƇKg/H:hXvR'%t G[lF1Fx7]E!YRyב[d^ ƒ2{F&O>Cp ٱK q/>ǒǘg/?1<>8F `Γm|P8>x?@$; \#5ѓ̞Isþ]56^M+=~qG$ z^]vΛ.56ɐ(1Z)[}K 'n\G)puW˵OvD{.71#;$&F6I򫯕gaؿ3@endstream endobj 76 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 375 >> stream xcd`ab`dddsu0T~H3a!Kgk7s7˦wG ~"ȘW_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*&s JKR|SRY~t>]?[^ߝ۝]]{w]]EUlwto~>{/a={z~e~oV`7t~1 P׏"7W?GsOg;0wan9.<;|^Ňendstream endobj 77 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 752 >> stream xMmHSqw^ͩ}Rf(7-ZvsZ[۵JSsv얒j&ZVTPЫ_XD *z!s"<<{# p ,mMi3@8ʂQƔ+3d ܘI #:<ޠ% 9BaIIn/E_uSʜKt;'{*E9(,rɲwAAA w_Ւ9BZv D; Vx$YXtŸLEP-$BW4sqNlB,DGx2#IMB$ձZĤE%}0|X4@;[6r u5z/jl³מí% ,( ZS_϶i%,e}1wӎPS* /n-ߍbam;=7XOlm 5F!Sm]aj{%^oo?oJa% A6 A s6duB\TY2_-m'v,4yױ30lNbhQ WR:~3z(ghCʎҌw;~R/%obW^Z̘ --hm_rӹ@EK4I14li|-OQkyxЊ\;!.@<CĘT\T1Tۣ9P:]ԁb8B5 O_endstream endobj 78 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 621 >> stream xoHqeڋv" - 90('iZfnng0Gj^Ƙԙ )EbH0J̤ A!Bo]yl_=z5larߋUk.V{{`CK`zY 4FOSd c{'PDXH1Md,TP)0DU>}#QJw7&Y[01&o Nendstream endobj 79 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 431 >> stream xcd`ab`ddds 4T~H3a!k_nn? ~O+ȘW_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*ݦ&s JKR|SR222K* 1v1032hmK{ ?-|/{*?/تuϑa)j{#忌3}h9{ -`7 ˿v`U Nğ:]<9M3--,]~u3>|t@[A_wmyd/@g_߼i_[~:={1/gendstream endobj 80 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 391 >> stream xcd`ab`dddwu041~H3a!-C5eB ``ad/m_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@s JKR|SRKsAd$V2000F00v1012ta]#eX>٢y_a-bKQVt͞[֦Y;{4{dwow_?i?%~`.vJGU"T[kű72J:Z:+~,!g֟ύm] Sg]9}.n9.|͓xx[Pendstream endobj 81 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 925 >> stream x]_L[ue^fSu&޻XCD@0u”-  PRZ: Gqi{?T6`HT}pdFfĽjbss|>Ǥ5Gڔ7ZS \xFxN‰woւL2ǐ)t ޓǍcm&f¬ 􋭭-KͭkY;2JeXcPY`j,t s֤25Ci2Lwk4q0-*~ բ1JZc6b&eFGtօuc[XmUb\߫L wŞuT_.HEgb@80NT|`*s\VRxR[/RHNT՝t({T&\H@ cM;y3L(R&qNO;w*U 6׌XO(soK@OIxB?$BLhVP D,8;Qiu6ғ xR|X_x,hwqJp9zT6VpGsE;I} o-P-9Os*^/~%?}_"t*rΏ#cb&SRqDwtNp|!5{ ĵ+i~i6{{nWу\8_m%"xT( b®s.PSB[2%4?ݗp$ !"LlxY3 ~vOm`X`O t~!FOQ;۱E@M/P 3Wi.sP&2҇\vW̬7)šZ\^*mt_DGvBn md 1#bգG-yY*/aؿnendstream endobj 82 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4259 >> stream xXytTU~!e!ei{N.8 mZY$@"!{R[׫J-,Q"PA[E{Ψ=-Σ̭$gzc;UR޽}wSFC]R[̙3KZS\Ɋ\^V&c{oT)qdj mŽNIw [2Ѷ7ڻEsHܽIybKC3jZf>0k?wgýZEMj:j5zZHKQ%lzC-VPSJO@ jjP#uc$Vţ^.{z crp{AW; WnooWnuLZ=}K'2mcϕRW3sj𻳀/aUJ:kOirW329MJUnkM2\4:<1x>HG>&c@`7>yËYfZe-bw@*]/l"Mi" f=p^fxwo}<;@C7Ñh?,ן+4r;] U8mɐhg_G7ٺOyU?0Ҫo9j&EW#YNRS3^+˹(Jx# qXZR|7*xe5W4\U0NEDK~x 6wꠢGlm]  |#pmdiKɦtWE*GZT.dR[&tHRX&5Kd]ncΐ;BUiuPJ_TvawʒPS|88^_Is ݿca2zUD|szZ'Ꝭo{J0|T?;|;;<;|/lO|nޑ]55-??MOa^V*֞3 2q5ft)f5fp6·qAFÆ4#ݙ{t H2BnS m**t+]JPʍggX6v통3Gt4dU &>"tdʄ. ЯJ~'VBBΦs蠞>ߒmiW6DBmmʦ궖@›rřBBHe=ڰެ;9 ^OeRmnQC@BڣՐ'q/Ⱥ2zސqdzM6vpOCA&vر P&fL8.m47Re&޳{1nqF";#LFڴҼء7?=htΝ6蔕g< 7ɂN3h4rIҜbp%Clԣ`w꼪W7q}:y`0 [Ћu$pLk#Wa J 3g|$"r+ i~BO@.7%Icp"AyQ0ٕ W[yzz]s$6֡js 꿂t2faٵ|X`Ja7m2/2YH8EkߝϺH\W^09' c Sȭ:[BF9~eD#aٲꀢͪne6 LBQS.V0" i҄*R9b(f5s3>WD^JPk"k}'_[խ?'|r~O>o<'yBX >2L]YO^ VD%)Ҙ1GNnP{!c6<jƏ e? /N6NRǷ{Nq#X Fȕ_|SCCNOLrFWbZ0u #KeXNuG Syv&jҖNnNۮ󨊛2nyhAߓ_s,Dw9Zy|ī/L2#"g6Ww?*n[hϨ "Riñ󣭤>7"X2t?~@eFQ+dwؑROb~!l9x~<~7rUU\ϼˌ? B]<{FSNdSh]-[\Xs 8)=s9:PcrJKL䧳Krss7_‹GQĤ򄮄_2ҟ@0 de#ه+8#$cZMg2=n&MOyw7j$"pW:UpW9M[B9H~*~hn hryB_" gs͂o#uK fg* ~a.S2 E| KI̠Rk@&v̥NNΗLG&(Q 6$W&E8;opyw=hl=QeO! {PJ+ow:ESd+i bJXd*L0dc2f0u{FRD;=震B`r*7/'4qehGM_,tDF $z]wʓr~bQCvnm#k6ؒy5MЏG%n5nG2eM g8CCT @0Jeqbc>k}7ѿj6MkȖτ w W݋ۭ"K]T5"а$,.ͨ YoΓe1_%F|aUvc u;8|X/ 95nc>xA+Ax:n3Wsܶh3#؏)O2>nlM8z~URb`ɕ*$XOWߕEZ;R^f#$)-ILL\k;B0*&HmlhZm"VxNuԐ@0 ŷg!FCѝ?py0~"'i$%bV;Y ۗefi/qL 3-\EkK׬5LzX^ ]BowY_#W+]Bequh-GNBËx34[hGzؙVtE!_ʥpZi ݣˁڠ<ѧ/O6,@/3=^c]Ѩe`^ުo Z<nrdkM򂴨'+>$P"3a2DY$Z5-jXeQCM:lWUYy$šOkC!`2OAMY|מ< êV PzgZW6+"#ꆪ:I{@ǟދc~W;J肺=yys.EPUIcȜ0І>aF\&!ٕ \#h2xv{YME͈"d&ѓ#xRG5w?ƅ8@F6;rF\z9US51WgqBc7ư铥3 ,n\AoAj kIǂx7?y/)Wl{N`g6}T.cӨ=(˷V @^Us^UFk@h7;LD\Ľ8(Xd֟'bƨ}(8I M977m3hzV$E:n.Ň706vx^P *&[$J9Wɣ?ˋFm%h=TDI͢RQpx:v6il$*4UWK-d0d>LǗ8 {kendstream 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 401 >> stream xcd`ab`dddw 441U~H3a!3G9k7s7BsO``ad/mw/,L(QHT04Q020TpM-LNSM,HM,rr3SK*4l2JJ s4u3K2RSRSJsS ӃP%E )EyE9 L Y49{f{?3T^%:gnU6UUv#TtÛO]f#DLiioj/kwsM\.t}zn=G뗟pG8~0L7NjcYQVJ!._},WB7smbK<y3endstream 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 690 >> stream x][HSq6=kce2;BA=(J>)DXؼM.g˳mnSũ ,)Ȋz)ZO/||)|㥝=U^|v8IJ (e籽xwF`ߢK:ڔjygNeyg{N^)vl7ˊ ʦV"ʈeBH*ٿ B*Ze_BERc6a P05hs<Wů! +h\P߬R]X I/50|0(7l.NV&uFMDb+njGߖ{f3Ԡ7 5gխ$~i!& n}CꐶCRYwB'Ḫ z|ai?#(fi=sɺn6EqYG|.b  q-[N|TƇ}s! Gӌފh،a ;/qҽNK&[ ^`JACd-70RUG2/sIl@Ea,t aSZy҇lB00`7٭N3&˦iGDmn'>\66.Yzae N@꺝mt4ÃO鋻dbQAAT:{endstream endobj 87 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6698 >> stream xywtuhl+"cB, \bq8M{J)e݊R HB.I`daK\.wyܑwrxw4G[߷|w P\f.X@p{xF/kaf!̼Vbl&w7*f̙|c}WW4jq[EݮVPlCM/,l]Ԧ][^ѡ\}E;WZv]]'+%;skw+*))++6(UlT<ؤجxAqEE+(Q@Pu =H1Lu0aeW` (HRH{կ , tpwN-?J^ZaN=jx Z^ yB#VxHqjl52ilV,G;=G WѴŤMxކF>9$ ,PSe֝ͫ#Lvy#uf{?ed% Y?O{g\ ?W6) G`ĻAT}rqI*R\;;۟^#Q2 `l٣2Ax׊J/2BPU~+^8U9Un{}a ̅W/\#+_t.t $G谟 pѼqi15߾Ĺo+ED #(#I{(q@ p@8.jh02HN!ĥrPfW:(n>c걶w$YL:.器gAc;C {?cD8Pi"3 nSˠ 4nxB6>> ObrOL'AOR@ǀ>'ޤ &EةrrԘK*ʌ֎f˴gr? #aO;7kRT/cwEG]kӉsSQM1ulLl5M0vv38;}u_[ ͤG}Bc#ON' gU T+:fw KtfWڶpMOBQ ɼSw;v̾san'p蝄vSڭ56+a6?,C~<+@EP!{Wfk)xX bv3 %jjEϡ_G:@"PW߫ˢkl'+9hQ#=Oq]t"$wǯ"sk8vyZ( j(0E znuѨI{9Nz6"/9K:wsݯ4|$^AcrnNxȀo0 (?8O VJLu;-VT}m Q!B`()p>+e؊l:`{9]V"`|K : x4$E3;%4K QKIv"X,dqM03 Ԥs4q7@9QNXt;;3T8㼺7eu2?nxl'tҳuOerKBg{ a1ThMQkj wzUߦ'~!I#."{ql( C@&rW,5C DMLO ?:p9o/ _9T.peu109 Qk$5;wlhT ``cd; Ҁ ÝZ__Կ ny%=p4kyUIg㇈Bew!čjOոMz\ֹu( ʧǺ &{7tÀyiW`91a&7 xWr"aXd,4Qw.wm~A9v3y_Y^3Ue1CC\.:o!s:O~($WwHkt/ ۟ 9 =E kj]"RZv5uR`>#i5/@cr\ui@S;]k" F]xw?!\wV ceR'% DB7L#GAFp("l[ p+A2lMэ0!G-ll}6@04T-7mM!JJw; $A'ÚH:w~̼̰ܸ+hTlm.)n\Dž*b?^,a}SC!6X=AFACsSާ3<%/.ŚjiN\zC iLFz1_& n̝EL6>%yڥklX+LWzq,-.օ7b>ePxS,DSp 6b|@;(r};#c<ۏ*UA+Zl/.|y(,̉OME\>h 4#Un)fal "LA'ƬD7 zF>ɲ6y87A0bpv86زiu勀j GC~-#UߜH>zhotTV}~WO!K/3WB?>y |LԉjUzRT wpqNMʛu—šso~տxRNqBu#X|Pfo$Ɗ2 4cx"q^׾A.q4UҌ'`2<?Docy2686ؐ"(:T阧v[|{$a2F։/FD41()^$ g~1>%1,|D89,Aΰͣ#d{3UҌviv)h6y(jRset-u]Zm4KC6tD#C]00v;s< }e: ANZy3*Lסm;`{{esA8938H-v)HE˦]-v8m33'D7l] @>OD-LKb&fcx/t:(pM)3e.N4vI}J|7u zXؘ@_j\]F P{&>T?w%,KJ7\l04@&%&~a_έ^je/e!'ˊf,9ϋticW]zKU_+{ yN/Dfa@ 1# ɟ%k'[eՉ]R5lGv#K˺iozj kdT,CQ;ƫ TwGD᭛#D{k7 Cw(4 ʱAȊӣquJ\L={=^Kx-]XGrCQeFc5aVfM3i><YvَTNuJ!G\NO~þD-ga;aڈ['"hQPuĕ~d*ӷvCDe.i#s!#mg]=XW7etX[GD0{&2&.$EBlj b, j4`);J X7s.prIMxFS*3'e'??s wwa36#][EMk/Bqbjz 4N&bXz6-v7 PZ(?){ڃlpthQ.ytLO?;wnƻE Pse`I5Q*F’RwBɔj kE=jH{QQ7 \~ $R[QhB)(7AG(ߠhTTanFJW7 @f =Ņ S'>xW jhJs=Nep{~ԛ6 Ʃil^Q*A u, :NtO{~ϕzadžVy(UtSF*Qq{"\^ d.Ti>'w)Tx{qtM8p0 )ĭ%qfeU!b]{a3 Z֦[&a+$ ]jV 4G~EG9GNd0ȡ-.L[1[U2vxxLbkg=~7AԬY.\()eqZO7GuEZ!!S)LcHվ@%!ZSM~o(ǎ%BLj0hCWE($-0OPXct/0P29Jw) z; %#)>dugY?4@-ޚ5f䆆 Vt <鑁 &_72Yl~#AAGo /<=:Ҫendstream endobj 88 0 obj << /Type /XRef /Length 116 /Filter /FlateDecode /DecodeParms << /Columns 4 /Predictor 12 >> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 89 /ID [<34ec6c9d94f30f93b3e1cb4ecf42d30a>] >> stream xcb&F~ c%#> 5 f$ !Q .$x  xĵL< Y 6Oq 7 !Hpd^X;@긁T  endstream endobj startxref 60132 %%EOF expm/inst/doc/expm.Rnw0000644000176000001440000001052212251554350014440 0ustar ripleyusers\documentclass{article} \usepackage{amsmath,url} \usepackage[round]{natbib} \usepackage[T1]{fontenc} \usepackage[english]{babel} %\usepackage{lucidabr} \usepackage[noae]{Sweave} %\VignetteIndexEntry{Using expm in packages} %\VignettePackage{expm} \title{Using \pkg{expm} in packages} \author{Christophe Dutang \\ ENSIMAG, Grenoble INP \\[3ex] Vincent Goulet \\ \'Ecole d'actuariat, Universit\'e Laval} \date{Jan. 2008 \ {\footnotesize (added note in June 2010)}} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\proglang}[1]{\textsf{#1}} \newcommand{\pkg}[1]{\textbf{#1}} \newcommand{\mat}[1]{\mathbf{#1}} \bibliographystyle{plainnat} \begin{document} \maketitle \section{Introduction} The \pkg{expm} package provides an \proglang{R} function \code{expm} to compute the matrix exponential of a real, square matrix. The matrix exponential of a matrix $\mat{A}$ is defined as \begin{align*} e^{\mat{A}} &= \mat{I} + \mat{A} + \frac{\mat{A}^2}{2!} + \dots \\ &= \sum_{k = 0}^\infty \frac{\mat{A}^k}{k!}. \end{align*} The actual computations are done in \proglang{C} by a function of the same name that is callable by other packages. Therefore, package authors can use these functions and avoid duplication of efforts. \section{Description of the functions} The \proglang{R} function \texttt{expm} takes as argument a real, square matrix and returns its exponential. Dimension names are preserved: <>= library(expm) m <- matrix(c(4, 1, 1, 2, 4, 1, 0, 1, 4), 3, 3) expm(m) dimnames(m) <- list(letters[1:3], LETTERS[1:3]) m expm(m) @ \bigskip %% manual centerig of "overlapping" box \hspace*{-.12\textwidth}% .08 = .16 / 2 \fbox{\begin{minipage}{1.16\textwidth}%% wider than the text! Note that the remainder of this text \textbf{mainly} relates to \code{expm(., method = "Ward77")}, i.e., the method of \cite{Ward:77} which is no longer the default method, as e.g., \code{method = "Higham08"} has found to be (``uniformly'') superior, see \cite{Higham:2008}. \end{minipage}} \bigskip The actual computational work is done in \proglang{C} by a routine defined as \begin{verbatim} void expm(double *x, int n, double *z) \end{verbatim} where \code{x} is the vector underlying the \proglang{R} matrix and \code{n} is the number of lines (or columns) of the matrix. The matrix exponential is returned in \code{z}. The routine uses the algorithm of \cite{Ward:77} based on diagonal Pad\'e table approximations in conjunction with three step preconditioning. The Pad\'e approximation to $e^{\mat{A}}$ is \begin{displaymath} e^{\mat{A}} \approx R(\mat{A}), \end{displaymath} with \begin{align*} R_{pq} (\mat{A}) &= (D_{pq}(\mat{A}))^{-1} N_{pq}(\mat{A}) \\ \intertext{where} D_{pq}(\mat{A}) &= \sum_{j=1}^p \frac{(p+q-j)! p!}{ (p+q)!j!(p-j)!}\, \mat{A}^j \\ \intertext{and} N_{pq}(\mat{A}) &= \sum_{j=1}^q \frac{(p+q-j)! q!}{ (p+q)!j!(q-j)!}\, \mat{A}^j. \end{align*} See \cite{MolerVanLoan:78} for an exhaustive treatment of the subject. The \proglang{C} routine is based on a translation made by \cite{Matrix} of the implementation of the corresponding Octave function \citep{octave}. \section{Calling the functions from other packages} Package authors can use facilities from \pkg{expm} in two (possibly simultaneous) ways: \begin{enumerate} \item call the \proglang{R} level function \code{expm} in \proglang{R} code; \item if matrix exponential calculations are needed in \proglang{C}, call the routine \code{expm}. \end{enumerate} Using \proglang{R} level function \code{expm} in a package simply requires the following two import directives: \begin{verbatim} Imports: expm \end{verbatim} in file \code{DESCRIPTION} and \begin{verbatim} import(expm) \end{verbatim} in file \code{NAMESPACE}. Accessing the \proglang{C} level routine further requires to prototype \code{expm} and to retrieve its pointer in the package initialization function \code{R\_init\_\textit{pkg}}, where \code{\textit{pkg}} is the name of the package: \begin{verbatim} void (*expm)(double *x, int n, double *z); void R_init_pkg(DllInfo *dll) { expm = (void (*) (double, int, double)) \ R_GetCCallable("expm", "expm"); } \end{verbatim} The definitive reference for these matters remains the \emph{Writing R Extensions} manual. \bibliography{expm} \end{document} %%% Local Variables: %%% mode: latex %%% TeX-master: t %%% coding: utf-8 %%% End: expm/inst/doc/expm.R0000644000176000001440000000047612251554350014102 0ustar ripleyusers### R code from vignette source 'expm.Rnw' ################################################### ### code chunk number 1: expm.Rnw:49-55 ################################################### library(expm) m <- matrix(c(4, 1, 1, 2, 4, 1, 0, 1, 4), 3, 3) expm(m) dimnames(m) <- list(letters[1:3], LETTERS[1:3]) m expm(m) expm/tests/0000755000176000001440000000000012276625722012430 5ustar ripleyusersexpm/tests/ex.R0000644000176000001440000001676112276625711013200 0ustar ripleyuserslibrary(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, tol=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, tol = 1e-13), all.equal(m1.t, m1O, check.attributes=FALSE, tol = 1e-13), all.equal(m1.t,m1T, check.attributes=FALSE, tol = 1e-13), all.equal(m1.t,m1TO, check.attributes=FALSE, tol = 1e-13), all.equal(m1.t, expm(T1,"Ward77"), tol = 1e-13), all.equal(m1.t, expm(T1,"R_Pade"), tol = 1e-13), all.equal(m1.t, expm(T1,"R_Ward77"), tol = 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, tol= 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, tol = 1e-12), all.equal(m2.t, m2O,check.attributes=FALSE, tol = 1e-12), all.equal(m2.t,m2T, check.attributes=FALSE, tol = 1e-12), all.equal(m2.t,m2TO,check.attributes=FALSE, tol = 1e-12), all.equal(m2.t, expm(T2,"Ward77"), tol = 1e-12), all.equal(m2.t, expm(T2,"R_Ward77"), tol = 1e-12), all.equal(m2.t, expm(T2,"R_Pade"), tol = 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, tol = 3e-11), # ^^^^^ # 1.2455e-11 for libatlas (above) all.equal(m3.t, m3T, check.attributes=FALSE, tol = 1e-11), all.equal(m3.t, m3O, check.attributes=FALSE, tol = 1e-11), all.equal(m3.t, m3TO, check.attributes=FALSE, tol = 1e-11), all.equal(m3.t, expm(T3,"R_Eigen"), tol = 1e-11), all.equal(m3.t, expm(T3,"Ward77"), tol = 1e-11), all.equal(m3.t, expm(T3,"R_Ward"), tol = 1e-11), all.equal(m3.t, expm(T3,"R_Pade"), tol = 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), tol=1e-14), all.equal(m4O [,10], 1/gamma(10:1), tol=1e-14), all.equal(m4T [,10], 1/gamma(10:1), tol=1e-14), all.equal(m4TO[,10], 1/gamma(10:1), tol=1e-14), all.equal(m4, m4O, check.attributes=FALSE, tol=5e-15), all.equal(m4, m4T, check.attributes=FALSE, tol=5e-15), all.equal(m4, m4TO,check.attributes=FALSE, tol=5e-15), all.equal(m4, expm(T4,"Ward77"), check.attributes=FALSE, tol = 1e-14), all.equal(m4, expm(T4,"R_Ward"), check.attributes=FALSE, tol = 1e-14), all.equal(m4, expm(T4,"R_Pade"), check.attributes=FALSE, tol = 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)) stopifnot(all.equal(diag(x = c(1,2,2)), solve(W4) %*% A4 %*% W4 )) expm/tests/log+sqrt.R0000644000176000001440000000521312021132600014272 0ustar ripleyuserslibrary(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, tol=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")) l.L2 <- logm.Higham08(L2) l.L3 <- logm.Higham08(L3) all.equal(l.L2, lL2, tol=0)# 5.64 e-14 (32-bit *and* 64-bit) all.equal(l.L3, lL3, tol=0)# 2.40 e-15 (ditto) stopifnot(all.equal(l.L2, lL2, tol= 1000e-16), all.equal(l.L3, lL3, tol= 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)), tol=0) ## "Mean relative difference: 1.020137e-13" stopifnot(all.equal(EA, expm.Higham08(logm.Higham08(EA)), tol=1e-12)) S <- crossprod(A) all.equal(S, sqrtm(S) %*% sqrtm(S), tol=0) ## "Mean relative difference: 2.26885e-15" stopifnot(all.equal(S, sqrtm(S) %*% sqrtm(S), tol=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)), tol=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), tol=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.R0000644000176000001440000000123712021132600015063 0ustar ripleyuserslibrary(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.R0000644000176000001440000002464312021132600014252 0ustar ripleyusers#### 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(), .. 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))) } 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 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 } expmList <- list(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), 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") ) expmL.wo.E <- expmList[names(expmList) != "R_Eigen"] 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, 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] ## 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)) ## sPs.H08. 2.08 ## sPs.H08b 2.08 ## Ward 2.25 ## s.T.s 5.44 ## s.T.sO 5.44 ## s.P.s 6.06 ## s.P.sO 6.06 ## hybrid 7.25 ## Eigen 8.33 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 if(require(RColorBrewer)) { ## Bcol <- brewer.pal(ncol(t.m2),"Dark2") Bcol <- brewer.pal(ncol(t.m2),"Set1") } else { ## 7 from Dark2 ## Bcol <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A", ## "#66A61E", "#E6AB02", "#A6761D") ## Rather: those from "Set1" Bcol <- c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999") } matplot(eps, t.m2, type = "b", log = "xy", col=Bcol, lty = 1:9, pch=1:9, 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:7, pch=1:7, inset = 0.02) if(require("sfsmisc")) { sfsmisc::eaxis(1, labels=FALSE) sfsmisc::eaxis(1, at = eps[c(TRUE,FALSE)]) 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)), tol = 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, tol= 1e-13)) re.x <- sapply(expmL.wo.E, 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 stopifnot(re.x[c("Ward", "s.T.s", "s.T.sO")] < 3e-16, re.x < 1e-13)# <- 32-bit needed 0.451e-14 ##--- Now look at the *sparse* methods: (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 showProc.time() expm/tests/expm-Cond.R0000644000176000001440000000215512021132600014360 0ustar ripleyusers#### 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, tol = 1e-14), all.equal(C2 , eC$expmCond1, tol = 1e-14), all.equal(C3. , eC$expmCondF, tol = 1e-14, check.attributes = FALSE), all.equal(C3.1, eC$expmCondF, tol = 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/ex2.R0000644000176000001440000001241412276625722013253 0ustar ripleyusers #### Example matrices from the Matlab demos // expAtv() examples library(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE) ## -> assertError()... ## --- 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]], tol = 1e-12)) for(k in seq_len(length(ml1) - 1)) { print(all.equal(ml1[[k]], ml1[[k + 1]], tol = 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, tol = 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, tol = 1e-11)) mA2.T <- expm(A2, method = "Taylor") stopifnot(all.equal(mA2, mA2.T, tol=1e-10)) all.equal(mA2, mA2.T, tol=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, tol = 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() ---------------- 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), ] ), tol=1e-14) # 64-bit lynne: 2.7e-16 !! sc.Atv <- function(A,v, s) { vapply(s, function(l) expAtv(l*A, v, t=1/l)$eAtv, v) } chk.sc.Atv <- function(A,v, s, tol=1e-15) { r <- vapply(s, function(l) expAtv(l*A, v, t=1/l)$eAtv, v) I <- expAtv(A,v)$eAtv if (!isTRUE(eq <- all.equal(as.vector(r), rep(I, length(s)), tol = 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.R0000644000176000001440000000625312153561755013730 0ustar ripleyuserslibrary(expm) source(system.file("test-tools.R", package= "expm"), keep.source=FALSE)## -> assertError()... ## 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/0000755000176000001440000000000012251554351012045 5ustar ripleyusersexpm/src/locale.h0000644000176000001440000000023512276626047013466 0ustar ripleyusers/* Localization */ #include #ifdef ENABLE_NLS #include #define _(String) dgettext ("expm", String) #else #define _(String) (String) #endif expm/src/logm-eigen.h0000644000176000001440000000056512276626047014260 0ustar ripleyusers/* ===== File part of R package expm ===== * * logm-eigen.h * * Created by Christophe Dutang on 13/05/08. * */ #include #include #include #include #include #include "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/Makevars0000644000176000001440000000016610760034000013527 0ustar ripleyusers# as for a -*- Makefile -*- we use the BLAS and the LAPACK library: PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) expm/src/expm-eigen.h0000644000176000001440000000056312276626047014271 0ustar ripleyusers/* ===== File part of R package expm ===== * * expm-eigen.h * * Created by Christophe Dutang on 27/02/08. * */ #include #include #include #include #include #include "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/matpow.c0000644000176000001440000000445412276626047013540 0ustar ripleyusers/* * 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), z, x_; int n = INTEGER(dims)[0], ktmp = 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)); PROTECT(x_= duplicate(x)); if (!isReal(x)) /* coercion to numeric */ x_= coerceVector(x_, REALSXP); PROTECT(z = allocMatrix(REALSXP, n, n)); setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); matpow(REAL(x_), n, ktmp, 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; int nSqr = n * 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, (size_t) 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, (size_t) 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, (size_t) nSqr); } } } expm/src/matpow.h0000644000176000001440000000032212276626047013533 0ustar ripleyusers#include #include #include #include "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.f0000644000176000001440000001615112276626047014030 0ustar ripleyusersc 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 "mexp".) 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 10 i=1,ndim do 10 j=1,ndim 10 a(i,j) = sum(i,j) 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 10 n=ntaylor,1,-1 call multiplymatrixO(m,sum,a,dkeep) call multiplyscalarO(m,dkeep,1.d0/dble(n*nscale),sum) 10 call addtodiag(m,sum,1.d0) 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 10 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) 10 call addtodiag(m,padenom,1.d0) call minus(m,a,aminus) call initialize(m,padedenom,0.d0) call addtodiag(m,padedenom,1.d0) do 20 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) 20 call addtodiag(m,padedenom,1.d0) do 30 i=1,m 30 call solveO(m,padedenom,padenom(1,i),approx(1,i)) 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 10 i=1,m do 10 j=1,m 10 x(i,j)=s 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 10 i=1,m do 10 j=1,m 10 y(i,j)=x(i,j)*s 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 10 i=1,m do 10 j=1,m z(i,j)=0.d0 do 10 k=1,m 10 z(i,j)=z(i,j)+x(i,k)*y(k,j) 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 10 i=1,m do 10 j=1,m 10 y(i,j)=x(i,j) 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 10 i=1,ipower call multiplymatrixO(m,dkeep,dkeep,y) 10 call id(m,y,dkeep) 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 10 i=1,m 10 y(i)=x(i) 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 10 i=1,m 10 dip = dip+u(i)*v(i) 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 10 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) 10 call comb(m,u,beta,save,p) c print*,'iteration number=',2*l+1 return end expm/src/logm-eigen.c0000644000176000001440000002005712276626047014251 0ustar ripleyusers/* ===== 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.h0000644000176000001440000000142612276626047013203 0ustar ripleyusers #ifndef R_PKG_EXPM_H #define R_PKG_EXPM_H #include #include #include #include #include #include "locale.h" typedef enum {Ward_2, Ward_1, Ward_buggy_octave} precond_type; SEXP do_expm(SEXP x, SEXP kind); void expm(double *x, int n, double *z, precond_type precond_kind); // 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.c0000644000176000001440000002127412276626047013201 0ustar ripleyusers/* ===== 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 = 1; 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)) { nprot++; x = PROTECT(coerceVector(x, REALSXP)); } 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) return(allocMatrix(REALSXP, 0, 0)); PROTECT(z = allocMatrix(REALSXP, n, n)); rz = REAL(z); expm(rx, n, rz, PC_kind); /* ---- */ setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(nprot); return z; } expm/src/matexp.f0000644000176000001440000001320412276626047013523 0ustar ripleyusers!-----------------------------------------------------------------------! ! ! ! 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.c0000644000176000001440000000216012276626047013164 0ustar ripleyusers/* * Native routines registration */ #include #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}, {"do_expm_eigen", (DL_FUNC) &do_expm_eigen, 2}, {"do_logm_eigen", (DL_FUNC) &do_logm_eigen, 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); /* 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); } expm/src/matrexp.f0000644000176000001440000002204112276626047013704 0ustar ripleyuserscccc-*- 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 10 i=1,n do 10 j=1,n a(i,j) = sum(i,j) 10 continue 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 30 i=1,m 30 call solve(m,padedenom,padenom(1,i),approx(1,i)) 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.c0000644000176000001440000001767712276626047014302 0ustar ripleyusers/* ===== 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, m, nprot = 1; double *rx, *rz; double tol = asReal(tolin); if (!isNumeric(x) || !isMatrix(x)) error(_("invalid argument")); if (isInteger(x)) { nprot++; x = PROTECT(coerceVector(x, REALSXP)); } rx = REAL(x); 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); expm_eigen(rx, n, rz, tol); setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(nprot); return z; } expm/src/mexp-common.f0000644000176000001440000000655612276626047014500 0ustar ripleyusersC--- 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 10 i=1,m do 10 j=1,m 10 y(i,j)=-x(i,j) 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 10 i=1,m 10 z(i)=x(i)+y(i) 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 10 i=1,m 10 z(i)=x(i)+a*y(i) 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 10 i=1,n 10 nfact=nfact*i 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_dgebal.c0000644000176000001440000000351612276626047013726 0ustar ripleyusers#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")); if (isInteger(x)) { nprot++; x = PROTECT(coerceVector(x, REALSXP)); } 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))); 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/NAMESPACE0000644000176000001440000000132311656206117012476 0ustar ripleyusers### C code useDynLib(expm, .registration = TRUE) importFrom("Matrix", Schur, norm, solve,# <- for expm.Higham08(*, balancing=FALSE) rowSums, colSums,# e.g. in expm.s.Pade.s 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 for now; later -> expm(method = ".") ## For now we want the files to be kept modularly separate from the rest of 'expm' export(expmCond, expmFrechet) export(logm.Higham08) ## for now: merge into logm() with 'method = "."' export(sqrtm) expm/demo/0000755000176000001440000000000012251554325012203 5ustar ripleyusersexpm/demo/00Index0000644000176000001440000000023711656206117013340 0ustar ripleyusersexpm matrix exponential balanceTst Exploring balance(), i.e., LAPACK's dgeBAL matrix balancing exact-fn Functions for examples with exactly known solution expm/demo/balanceTst.R0000644000176000001440000001010011656206117014377 0ustar ripleyusersdgebalTst <- 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, tol = 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, tol = 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, tol = 1e-15))) ## Check the reverse: S.rescaled <- A2 * (d * rep(1/d, each = n)) stopifnot(isTRUE(all.equal(A1, S.rescaled, tol = 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.R0000644000176000001440000001057011626636744014051 0ustar ripleyusers#### "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, tol=useTol), all.equal(A, V %*% diag(D) %*% iV, tol=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.R0000644000176000001440000000072112014530757013277 0ustar ripleyusersrequire("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, tol=0)# 2.39e-15 {64b ubuntu 12-04} expm/data/0000755000176000001440000000000012251554325012170 5ustar ripleyusersexpm/data/matStig.R0000644000176000001440000000074010760040026013713 0ustar ripleyusersmatStig <- 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/0000755000176000001440000000000012251554325011460 5ustar ripleyusersexpm/R/balance.R0000644000176000001440000000047111656206117013173 0ustar ripleyusers## 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","P","S")) .Call("R_dgebal", A, match.arg(job)) dgebal <- balance expm/R/expmCond-all.R0000644000176000001440000003311512251554220014123 0ustar ripleyusers#### -------------------*- 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 and n > 1") n <- d[1] 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 and n > 1") n <- d[1] ##---------STEP 1: Calculate Kroneckermatrix of L(A)------------------------ K <- matrix(0, n^2, n^2) v <- numeric(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 and n > 1") 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 and n>1") 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 j <- l*2+1 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.R0000644000176000001440000002230611431063176014106 0ustar ripleyusers##------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("logm.H..(): 'x' has negative real eigenvalues; probably ok") 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 (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("Inverse scaling did not work (t =", format(t), ");\n", "maybe logm(x) is not defined for this 'x'.\n", "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("logm.Higham08() -> (k, m) = (", 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 rootS <- function(UT) { ## Generate Basic informations of Matrix UT stopifnot(length(d <- dim(UT)) == 2, is.numeric(d), (n <- d[1]) == d[2], n >= 1) ## FIXME : should work for "Matrix" too: not S <- as.matrix(UT) S <- UT ##------- STEP 0: Analyse block structure ---------------------------------- ## 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 ## Generate Blockstructure and save it as R.index R.index <- vector("list",n-k) l <- 1 i <- 1 while(i < n) { ## i advances by 1 or 2, depending on 1- or 2- Jordan Block if (S[i+1,i] == 0) { R.index[[l]] <- i } else { R.index[[l]] <- (i:(i+1)) i <- i+1 } i <- i+1 l <- l+1 } 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) == 1) { ## FIXME(?) : in sqrtm(), we take *complex* sqrt() if needed : 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 > 1) for (j in 2:(n-k)) { ij <- R.index[[j]] for (i in (j-1):1) { ii <- R.index[[i]] sumU <- 0 ## Calculation for 1x1 Blocks if (length(ij) == 1 & length(ii) == 1 ) { if (j-i > 1) for (l in (i+1):(j-1)) { 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) == 1 ) { if (j-i > 1) for (l in(i+1):(j-1)) { 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) == 1 & length(ii) == 2 ) { if (j-i > 1) for (l in(i+1):(j-1)) { 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 > 1) for (l in(i+1):(j-1)) { 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])[1,1]*I tUjj[3:4,3:4] <- t(X[ij,ij])[2,2]*I tUjj[1:2,3:4] <- t(X[ij,ij])[1,2]*I tUjj[3:4,1:2] <- t(X[ij,ij])[2,1]*I X[ii,ij] <- solve(tUii+tUjj,as.vector(S[ii,ij]-sumU)) } } } X } expm/R/expm_vec.R0000644000176000001440000001057512153610406013413 0ustar ripleyusers#### 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 || 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.R0000644000176000001440000000016610772074007013115 0ustar ripleyusers### M^k for a matrix M and non-negative integer 'k' "%^%" <- function(x, k) .Call(R_matpow, x, as.integer(k)) expm/R/expm2.R0000644000176000001440000000771512016223562012643 0ustar ripleyusers##------OVERVIEW---------------------------------------------------------------- #Input: A; nxn Matrix #Output: e^A Matrixeponential; nxn Matrix #Function for Calculation of e^A with the Scaling&Squaring Method with Balancing # Step 0: Balancing # Step 1: Scaling # Step 2: Pad-Approximation # Step 3: Squaring # Step 4: Reverse Balancing #R-Implementation of Higham's Algorithm from the Book #"Functions of Matrices - Theory and Computation", Chapter 10, Algorithm 10.20 ##-------CODE------------------------------------------------------------------- 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 designated, Balance the Matrix A ## This Balancing Code is adapted from the R-Foge expm Package, ## which is needed for the balance function 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 } expm/R/sqrtm.R0000644000176000001440000001145711153020032012740 0ustar ripleyusers#### 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 sqrtm <- function(x) { ## Generate Basic informations of matrix x ## x <- 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("'x' has negative real eigenvalues; probably ok") S <- as.matrix(Sch.x@T) Q <- as.matrix(Sch.x@Q) ##---------STEP 1: Analyse block structure----------------------------------- ## 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 ## Generate Blockstructure and save it as R.index R.index <- vector("list",n-k) l <- 1 i <- 1 while(i < n) { ## i advances by 1 or 2, depending on 1- or 2- Jordan Block if (S[i+1,i] == 0) { R.index[[l]] <- i } else { R.index[[l]] <- (i:(i+1)) i <- i+1 } i <- i+1 l <- l+1 } 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) == 1) { X[ij,ij] <- if((.s <- S[ij,ij]) < 0) sqrt(.s + 0i) else sqrt(.s) } else { ev1 <- Sch.x@EValues[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 > 1) for (j in 2:(n-k)) { ij <- R.index[[j]] for (i in (j-1):1) { ii <- R.index[[i]] sumU <- 0 ## Calculation for 1x1 Blocks if (length(ij) == 1 & length(ii) == 1) { if (j-i > 1) for (l in (i+1):(j-1)) { 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) == 1 ) { if (j-i > 1) for (l in(i+1):(j-1)) { 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) == 1 & length(ii) == 2 ) { if (j-i > 1) for (l in(i+1):(j-1)) { 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 > 1) for (l in(i+1):(j-1)) { 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])[1,1]*I tUjj[3:4,3:4] <- t(X[ij,ij])[2,2]*I tUjj[1:2,3:4] <- t(X[ij,ij])[1,2]*I tUjj[3:4,1:2] <- t(X[ij,ij])[2,1]*I X[ii,ij] <- solve(tUii+tUjj, as.vector(S[ii,ij]-sumU)) } } } ##------- STEP 4: Reverse the Schur Decomposition -------------------------- ## Reverse the Schur Decomposition Q %*% X %*% solve(Q) } expm/R/logm.R0000644000176000001440000000130711152312077012535 0ustar ripleyusers### ===== 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.R0000644000176000001440000001512412165277426012567 0ustar ripleyusers### ===== 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 if(getRversion() < "3.1.0") dontCheck <- identity expm <- function(x, method = c("Higham08.b", "Higham08", "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" or "Matrix" matrices: stopifnot(is.numeric(x) || is(x, "dMatrix")) 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")) if(!is.numeric(x) && 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, "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 <- .Fortran(dontCheck(if(identical(grep("O$", method), 1L)) matrexpO else matrexp), X = x, size = d[1], ntaylor, npade, accuracy = double(1))[c("X", "accuracy")] structure(res$X, accuracy = res$accuracy) })## end{switch} } expm/vignettes/0000755000176000001440000000000012251554350013265 5ustar ripleyusersexpm/vignettes/expm.bib0000644000176000001440000000352412165310624014716 0ustar ripleyusers@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.Rnw0000644000176000001440000001052212165310624014724 0ustar ripleyusers\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/MD50000644000176000001440000000562112276627706011606 0ustar ripleyuserse75d696dd9406db6356bab0812ca6b7f *ChangeLog 51a9ae69a30dd0009078343b2f3a6520 *DESCRIPTION 1391979426cf683092dcfc8737756a47 *NAMESPACE 9e93611ffa0c58d5d96919ff20dfb32c *R/balance.R 7eeb8306997c7e731b68b39b025fda99 *R/expm.R 94ff7164a2d6f0e6d194fa1a0b97f31f *R/expm2.R b0dccc778789fdadc05ee8ab459c2af2 *R/expmCond-all.R 7952a43d2fb2cc75367e1a021ff2aca9 *R/expm_vec.R 96bffd70183f67f21ead98e52eb00c4a *R/logm.Higham08.R 058e850322e2118168b63d7c0c425a3c *R/logm.R 45e07bacddb49c9238b3e9d1767992f7 *R/matpow.R 7455ed1d8c2d09448e5ef6d4efb5309f *R/sqrtm.R ed44e91930808a849b7887296c3482eb *TODO 224247323e3b4efc51dfc0b3d52a061d *build/vignette.rds d31374f27f2d6e5c5b459e0b1541cbbd *data/matStig.R b544e04306e3002383308b520878ea59 *demo/00Index c9bd8c07f4aaa1d496d084208af13712 *demo/balanceTst.R 0c5782f0638c277a2127a100a649cae9 *demo/exact-fn.R fd861847b8625d350e018c425d8e3207 *demo/expm.R 07ac2c2c3add1d02cb9ecfbdfb2ac077 *inst/doc/expm.R 61655a9c17ec4f2e874bc1ee2af64e96 *inst/doc/expm.Rnw 4cebbee8b1cc0584f5086fce617ad52a *inst/doc/expm.pdf 274e76f34f3671b5db44d6a1dbc701a9 *inst/po/fr/LC_MESSAGES/fr.mo 55267be85c0958628079a05fb3e821f4 *inst/test-tools.R 359a118639bcc8c25fc30a676087d140 *man/balance.Rd f3ceb89a739a22c88ceb05ca381439e3 *man/expAtv.Rd d52ea4ee1214621852707585a2b7b731 *man/expm.Higham08.Rd 6a2029a5b6d6b43574069346c4936b2e *man/expm.Rd 5b3cfb3e32292a75bdb6a7936ea4538c *man/expmCond.Rd dbaa4d554ba366c6d1c47ad0874bd65c *man/expmFrechet.Rd d8364f4ec512381448f82989d05f9e1a *man/logm.Rd 0835f0173e75dabe7a9b97ee7a540fd5 *man/matStig.Rd 25ffdff79449fea67c0f0ae69506fd33 *man/matpow.Rd 915ff3260a6359ff21eef5bc62c204da *man/sqrtm.Rd a811fa0cd9a523bf2022a3282126cb7d *po/expm.pot 05e28b52cdfb97fa0602d8a874144984 *po/fr.po 3d90f59b3248da1e70798e94456b5c99 *src/Makevars 62cb61d1eac18847a0c1641c6fa4f91d *src/R_dgebal.c 9a62dad490c3987ee3263e280ddaf916 *src/expm-eigen.c f0e9baca5fdd17d8ed2d5d7e2d8c1c91 *src/expm-eigen.h 23597a7e42f35fa89c61a38bd43daff8 *src/expm.c 340f5fc3a1ba7acd3738c0581afe5472 *src/expm.h 6a8978704970c7598ad15dfd09c7cedf *src/init.c d962e154a1fa708ec850fb4c0726843c *src/locale.h 8021937be917255ec167fdcfba3e66ff *src/logm-eigen.c 951196042588902a6f918cf884085190 *src/logm-eigen.h 8685b3faef183159c5044570e81b31b1 *src/matexp.f f9fd8eaa12f12fb5370dab1a62a23c23 *src/matpow.c 5ea5953e7dbebb781213725a8460897c *src/matpow.h 916843de605e677b868425d4a09c040d *src/matrexp.f 5f2c00231dbba3bb6a25ffbbb56d81a3 *src/matrexpO.f 3fd6e0d41e853aad802336acece3ec34 *src/mexp-common.f a22fd1e243d0d2e96802f551a4ff7f28 *tests/Frechet-test.R 334a7196ca6f67f83acf2f324bd0de79 *tests/bal-ex.R 0ca55007131d09f7a8b1efd2f7067a10 *tests/ex.R 24e05ad1b6669ad1b3615704d15858da *tests/ex2.R cdb18d26b1e9263c330a705eddea0179 *tests/exact-ex.R 775de117ad4099c44d16522f2725877f *tests/expm-Cond.R cf1b42132932b087c822514863892f0b *tests/log+sqrt.R 61655a9c17ec4f2e874bc1ee2af64e96 *vignettes/expm.Rnw e1d639c199dadb136a99c08a9aed0dd7 *vignettes/expm.bib expm/build/0000755000176000001440000000000012251554350012354 5ustar ripleyusersexpm/build/vignette.rds0000644000176000001440000000031312251554350014710 0ustar ripleyusersb```b`b&f YH320piԊ\r4q̼tBfBAbrvbzj1V)ihlS E!@„5/1HvԂԼ?;<E T [fN*ސ89 d Bw(,/׃ @?{49'ݣ\)%ziE@ w;v6expm/DESCRIPTION0000644000176000001440000000117012276627706012777 0ustar ripleyusersPackage: expm Type: Package Title: Matrix exponential Version: 0.99-1.1 Date: 2013-07-04 Author: Vincent Goulet, Christophe Dutang, Martin Maechler, David Firth, Marina Shapira, Michael Stadelmann, expm-developers@lists.R-forge.R-project.org Maintainer: Martin Maechler Description: Computation of the matrix exponential and related quantities. Depends: Matrix Suggests: RColorBrewer, sfsmisc BuildResaveData: no License: GPL (>= 2) URL: http://R-Forge.R-project.org/projects/expm/ Packaged: 2014-02-12 08:09:11 UTC; ripley NeedsCompilation: yes Repository: CRAN Date/Publication: 2014-02-12 09:24:38 expm/ChangeLog0000644000176000001440000001335612016223562013034 0ustar ripleyusers2011-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/0000755000176000001440000000000012251554325012032 5ustar ripleyusersexpm/man/expAtv.Rd0000644000176000001440000000566412251553550013602 0ustar ripleyusers\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., tol = 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.Rd0000644000176000001440000000277611406622454013745 0ustar ripleyusers\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.Rd0000644000176000001440000000533111431063176013257 0ustar ripleyusers\name{logm} \alias{logm} \alias{logm.Higham08} \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) %% FIXME? drop this eventually: logm.Higham08(x) } \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.)) ) } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/expmFrechet.Rd0000644000176000001440000000444211152312077014572 0ustar ripleyusers\name{expmFrechet} \Rdversion{1.1} \alias{expmFrechet} \title{Frechet Derivative of the Matrix Exponential} \description{ Compute the Frechet 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"), tol = 1e-14) ## TRUE } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/sqrtm.Rd0000644000176000001440000000212711406665466013503 0ustar ripleyusers\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.Rd0000644000176000001440000001043511166347652014650 0ustar ripleyusers\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} \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)) ## ## 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.Rd0000644000176000001440000000626711166347652014120 0ustar ripleyusers\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), tol= 1e-15)) C1 <- expmCond(A, "exact") C2 <- expmCond(A, "1.est") C3 <- expmCond(A, "F.est") all.equal(C1$expmCond1, C2$expmCond, tol= 1e-15)# TRUE all.equal(C1$expmCondF, C3$expmCond)# relative difference of 0.001... } \keyword{algebra} \keyword{math} \encoding{UTF-8} expm/man/expm.Rd0000644000176000001440000002274512016223562013277 0ustar ripleyusers\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", "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 %% NOTA BENE: Matlab uses order = 6 !!! our default, \code{8}, is from Ward(1977, p.606)'s recommendation. } \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{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}}. } \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/sam-bin/dbq/article/41801} } \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) ## ---------------------------- ## 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.Rd0000644000176000001440000000564612016223562013714 0ustar ripleyusers\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", "P", "S")) dgebal(A, job = c("B", "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} } } } \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.Rd0000644000176000001440000000207712016223562013631 0ustar ripleyusers\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}