diff options
-rw-r--r-- | packages/base/src/Internal/Algorithms.hs | 18 | ||||
-rw-r--r-- | packages/base/src/Internal/Modular.hs | 2 | ||||
-rw-r--r-- | packages/base/src/Numeric/LinearAlgebra.hs | 1 | ||||
-rw-r--r-- | packages/tests/src/Numeric/LinearAlgebra/Tests.hs | 6 |
4 files changed, 19 insertions, 8 deletions
diff --git a/packages/base/src/Internal/Algorithms.hs b/packages/base/src/Internal/Algorithms.hs index d2f17f4..ee3ddff 100644 --- a/packages/base/src/Internal/Algorithms.hs +++ b/packages/base/src/Internal/Algorithms.hs | |||
@@ -470,17 +470,25 @@ eigenvaluesSH (Her m) = eigenvaluesSH' m | |||
470 | 470 | ||
471 | -------------------------------------------------------------- | 471 | -------------------------------------------------------------- |
472 | 472 | ||
473 | -- | QR decomposition of a matrix in compact form. (The orthogonal matrix is not explicitly formed.) | ||
474 | data QR t = QR (Matrix t) (Vector t) | ||
475 | |||
473 | -- | QR factorization. | 476 | -- | QR factorization. |
474 | -- | 477 | -- |
475 | -- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular. | 478 | -- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular. |
476 | qr :: Field t => Matrix t -> (Matrix t, Matrix t) | 479 | qr :: Field t => Matrix t -> (Matrix t, Matrix t) |
477 | qr = {-# SCC "qr" #-} unpackQR . qr' | 480 | qr = {-# SCC "qr" #-} unpackQR . qr' |
478 | 481 | ||
479 | qrRaw m = qr' m | 482 | -- | Compute the QR decomposition of a matrix in compact form. |
483 | qrRaw :: Field t => Matrix t -> QR t | ||
484 | qrRaw m = QR x v | ||
485 | where | ||
486 | (x,v) = qr' m | ||
480 | 487 | ||
481 | {- | generate a matrix with k orthogonal columns from the output of qrRaw | 488 | -- | generate a matrix with k orthogonal columns from the compact QR decomposition obtained by 'qrRaw'. |
482 | -} | 489 | -- |
483 | qrgr n (a,t) | 490 | qrgr :: Field t => Int -> QR t -> Matrix t |
491 | qrgr n (QR a t) | ||
484 | | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)" | 492 | | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)" |
485 | | otherwise = qrgr' n (a,t) | 493 | | otherwise = qrgr' n (a,t) |
486 | 494 | ||
@@ -870,6 +878,8 @@ fixPerm' s = res $ mutable f s0 | |||
870 | triang r c h v = (r><c) [el s t | s<-[0..r-1], t<-[0..c-1]] | 878 | triang r c h v = (r><c) [el s t | s<-[0..r-1], t<-[0..c-1]] |
871 | where el p q = if q-p>=h then v else 1 - v | 879 | where el p q = if q-p>=h then v else 1 - v |
872 | 880 | ||
881 | -- | Compute the explicit LU decomposition from the compact one obtained by 'luPacked'. | ||
882 | luFact :: Numeric t => LU t -> (Matrix t, Matrix t, Matrix t, t) | ||
873 | luFact (LU l_u perm) | 883 | luFact (LU l_u perm) |
874 | | r <= c = (l ,u ,p, s) | 884 | | r <= c = (l ,u ,p, s) |
875 | | otherwise = (l',u',p, s) | 885 | | otherwise = (l',u',p, s) |
diff --git a/packages/base/src/Internal/Modular.hs b/packages/base/src/Internal/Modular.hs index a3421a8..239c742 100644 --- a/packages/base/src/Internal/Modular.hs +++ b/packages/base/src/Internal/Modular.hs | |||
@@ -371,7 +371,7 @@ test = (ok, info) | |||
371 | 371 | ||
372 | checkLU okf t = norm_Inf $ flatten (l <> u <> p - t) | 372 | checkLU okf t = norm_Inf $ flatten (l <> u <> p - t) |
373 | where | 373 | where |
374 | (l,u,p,_ :: Int) = luFact (LU x' p') | 374 | (l,u,p,_) = luFact (LU x' p') |
375 | where | 375 | where |
376 | (x',p') = mutable (luST okf) t | 376 | (x',p') = mutable (luST okf) t |
377 | 377 | ||
diff --git a/packages/base/src/Numeric/LinearAlgebra.hs b/packages/base/src/Numeric/LinearAlgebra.hs index 7be2600..a1c0158 100644 --- a/packages/base/src/Numeric/LinearAlgebra.hs +++ b/packages/base/src/Numeric/LinearAlgebra.hs | |||
@@ -162,6 +162,7 @@ module Numeric.LinearAlgebra ( | |||
162 | Transposable, | 162 | Transposable, |
163 | LU(..), | 163 | LU(..), |
164 | LDL(..), | 164 | LDL(..), |
165 | QR(..), | ||
165 | CGState(..), | 166 | CGState(..), |
166 | Testable(..) | 167 | Testable(..) |
167 | ) where | 168 | ) where |
diff --git a/packages/tests/src/Numeric/LinearAlgebra/Tests.hs b/packages/tests/src/Numeric/LinearAlgebra/Tests.hs index 30480d7..ecda6c1 100644 --- a/packages/tests/src/Numeric/LinearAlgebra/Tests.hs +++ b/packages/tests/src/Numeric/LinearAlgebra/Tests.hs | |||
@@ -500,10 +500,10 @@ sliceTest = utest "slice test" $ and | |||
500 | , testSlice (test_qrgr 4 tau2) qrr2 | 500 | , testSlice (test_qrgr 4 tau2) qrr2 |
501 | ] | 501 | ] |
502 | where | 502 | where |
503 | (qrr1,tau1) = qrRaw (rec :: Matrix R) | 503 | QR qrr1 tau1 = qrRaw (rec :: Matrix R) |
504 | (qrr2,tau2) = qrRaw (rec :: Matrix C) | 504 | QR qrr2 tau2 = qrRaw (rec :: Matrix C) |
505 | 505 | ||
506 | test_qrgr n t x = qrgr n (x,t) | 506 | test_qrgr n t x = qrgr n (QR x t) |
507 | 507 | ||
508 | ok_qrgr x = simeq 1E-15 q q' | 508 | ok_qrgr x = simeq 1E-15 q q' |
509 | where | 509 | where |