module Data.Sparse.Common
( module X,
insertRowWith, insertRow, insertColWith, insertCol,
diagonalSM,
outerProdSV, (><), toSV, svToSM,
lookupRowSM,
extractCol, extractRow,
extractVectorDenseWith, extractRowDense, extractColDense,
extractDiagDense,
extractSubRow, extractSubCol,
extractSubRow_RK, extractSubCol_RK,
fromRowsL, fromRowsV, fromColsV, fromColsL, toRowsL, toColsL) where
import Data.Sparse.Utils as X
import Data.Sparse.PPrint as X
import Data.Sparse.Types as X
import Data.Sparse.Internal.IntMap2
import qualified Data.Sparse.Internal.IntM as I
import Data.Sparse.Internal.IntM (IntM(..))
import Data.Sparse.SpMatrix as X
import Data.Sparse.SpVector as X
import Numeric.Eps as X
import Numeric.LinearAlgebra.Class as X
import qualified Data.IntMap as IM
import GHC.Exts
import Data.Complex
import Data.Maybe (fromMaybe, maybe)
import qualified Data.Vector as V
import Data.VectorSpace
resizeSV :: Int -> SpVector a -> SpVector a
resizeSV d2 (SV _ sv) = SV d2 sv
mapKeysSV :: (IM.Key -> IM.Key) -> SpVector a -> SpVector a
mapKeysSV fk (SV d sv) = SV d $ I.mapKeys fk sv
insertRowWith :: (IxCol -> IxCol) -> SpMatrix a -> SpVector a -> IM.Key -> SpMatrix a
insertRowWith fj (SM (m,n) im) (SV d sv) i
| not (inBounds0 m i) = error "insertRowSM : index out of bounds"
| n >= d = SM (m,n) $ I.insert i (insertOrUnion i sv' im) im
| otherwise = error $ "insertRowSM : incompatible dimensions " ++ show (n, d)
where sv' = I.mapKeys fj sv
insertOrUnion i' sv' im' = maybe sv' (I.union sv') (I.lookup i' im')
insertRow :: SpMatrix a -> SpVector a -> IM.Key -> SpMatrix a
insertRow = insertRowWith id
insertColWith :: (IxRow -> IxRow) -> SpMatrix a -> SpVector a -> IxCol -> SpMatrix a
insertColWith fi smm sv j
| not (inBounds0 n j) = error "insertColSM : index out of bounds"
| m >= mv = insIM2 smm vl j
| otherwise = error $ "insertColSM : incompatible dimensions " ++ show (m,mv) where
(m, n) = dim smm
mv = dim sv
vl = toListSV sv
insIM2 im2 ((i,x):xs) j' = insIM2 (insertSpMatrix (fi i) j' x im2) xs j'
insIM2 im2 [] _ = im2
insertCol :: SpMatrix a -> SpVector a -> IxCol -> SpMatrix a
insertCol = insertColWith id
outerProdSV, (><) :: Num a => SpVector a -> SpVector a -> SpMatrix a
outerProdSV v1 v2 = fromListSM (m, n) ixy where
m = dim v1
n = dim v2
ixy = [(i,j, x * y) | (i,x) <- toListSV v1 , (j, y) <- toListSV v2]
(><) = outerProdSV
diagonalSM :: SpVector a -> SpMatrix a
diagonalSM sv = ifoldSV iins (zeroSM n n) sv where
n = dim sv
iins i = insertSpMatrix i i
svToSM :: SpVector a -> SpMatrix a
svToSM (SV n d) = SM (n, 1) $ I.singleton 0 d
toSV :: SpMatrix a -> SpVector a
toSV (SM (m, n) im) = SV d im' where
im' | m < n = snd . head . toList $ im
| otherwise = fmap g im
g = snd . head . toList
d | m==1 && n==1 = 1
| m==1 && n>1 = n
| n==1 && m>1 = m
| otherwise = error $ "toSV : incompatible matrix dimension " ++ show (m,n)
lookupRowSM :: SpMatrix a -> IxRow -> Maybe (SpVector a)
lookupRowSM sm i = SV (ncols sm) <$> I.lookup i (dat sm)
extractRow :: SpMatrix a -> IxRow -> SpVector a
extractRow m i
| inBounds0 (nrows m) i = fromMaybe (zeroSV (ncols m)) (lookupRowSM m i)
| otherwise = error $ unwords ["extractRow : index",show i,"out of bounds"]
extractCol :: SpMatrix a -> IxCol -> SpVector a
extractCol m j = toSV $ extractColSM m j
extractVectorDenseWith ::
Num a => (Int -> (IxRow, IxCol)) -> SpMatrix a -> SpVector a
extractVectorDenseWith f mm = fromListDenseSV n $ foldr ins [] ll where
ll = [0 .. n 1]
(_, n) = dim mm
ins i acc = mm @@ f i : acc
extractRowDense :: Num a => SpMatrix a -> IxRow -> SpVector a
extractRowDense mm iref = extractVectorDenseWith (\j -> (iref, j)) mm
extractColDense :: Num a => SpMatrix a -> IxCol -> SpVector a
extractColDense mm jref = extractVectorDenseWith (\i -> (i, jref)) mm
extractDiagDense :: Num a => SpMatrix a -> SpVector a
extractDiagDense = extractVectorDenseWith (\i -> (i, i))
extractSubRow :: SpMatrix a -> IxRow -> (Int, Int) -> SpVector a
extractSubRow m i (j1, j2) = fromMaybe (zeroSV deltaj) vfilt where
deltaj = j2 j1 + 1
vfilt = resizeSV deltaj .
ifilterSV (\j _ -> j >= j1 && j <= j2) <$> lookupRowSM m i
extractSubRow_RK :: SpMatrix a -> IxRow -> (IxCol, IxCol) -> SpVector a
extractSubRow_RK m i (j1, j2) = mapKeysSV (subtract j1) $ extractSubRow m i (j1, j2)
extractSubCol :: SpMatrix a -> IxCol -> (IxRow, IxRow) -> SpVector a
extractSubCol m j (i1, i2) = toSV $ extractSubColSM m j (i1, i2)
extractSubCol_RK :: SpMatrix a -> IxCol -> (IxRow, IxRow) -> SpVector a
extractSubCol_RK m j (i1, i2) = toSV $ extractSubColSM_RK m j (i1, i2)
instance LinearVectorSpace (SpVector Double) where
type MatrixType (SpVector Double) = SpMatrix Double
(#>) = matVecSD
(<#) = vecMatSD
instance LinearVectorSpace (SpVector (Complex Double)) where
type MatrixType (SpVector (Complex Double)) = SpMatrix (Complex Double)
(#>) = matVecSD
(<#) = vecMatSD
matVecSD :: InnerSpace (IntM t) =>
SpMatrix t -> SpVector t -> SpVector (Scalar (IntM t))
matVecSD (SM (nr, nc) mdata) (SV n sv)
| nc == n = SV nr $ fmap (`dot` sv) mdata
| otherwise = error $ "matVec : mismatched dimensions " ++ show (nc, n)
vecMatSD :: InnerSpace (IntM t) =>
SpVector t -> SpMatrix t -> SpVector (Scalar (IntM t))
vecMatSD (SV n sv) (SM (nr, nc) mdata)
| n == nr = SV nc $ fmap (`dot` sv) (transposeIM2 mdata)
| otherwise = error $ "vecMat : mismatching dimensions " ++ show (n, nr)
fromRowsL :: [SpVector a] -> SpMatrix a
fromRowsL = fromRowsV . V.fromList
fromColsL :: [SpVector a] -> SpMatrix a
fromColsL = fromColsV . V.fromList
toRowsL :: SpMatrix a -> [SpVector a]
toRowsL aa = map (extractRow aa) [0 .. m1] where
(m,n) = dim aa
toColsL :: SpMatrix a -> [SpVector a]
toColsL aa = map (extractCol aa) [0 .. n1] where
(m,n) = dim aa
fromColsV :: V.Vector (SpVector a) -> SpMatrix a
fromColsV qv = V.ifoldl' ins (zeroSM m n) qv where
n = V.length qv
m = dim $ V.head qv
ins mm i c = insertCol mm c i
fromRowsV :: V.Vector (SpVector a) -> SpMatrix a
fromRowsV qv = V.ifoldl' ins (zeroSM m n) qv where
n = V.length qv
m = svDim $ V.head qv
ins mm i c = insertRow mm c i
showNz :: (Epsilon a, Show a) => a -> String
showNz x | nearZero x = " _ "
| otherwise = show x
toDenseRow :: Num a => SpMatrix a -> IM.Key -> [a]
toDenseRow sm irow =
fmap (\icol -> sm @@ (irow,icol)) [0..ncol1] where (_, ncol) = (nrows sm, ncols sm)
toDenseRowClip :: (Show a, Num a, Epsilon a) => SpMatrix a -> IM.Key -> Int -> String
toDenseRowClip sm irow ncomax
| nco > ncomax = unwords (map showNz h) ++ " ... " ++ showNz t
| otherwise = unwords $ showNz <$> dr
where dr = toDenseRow sm irow
h = take (ncomax 2) dr
t = last dr
(_, nco) = dim sm
printDenseSM sm = do
newline
putStrLn $ sizeStr sm
newline
printDenseSM0 sm
printDenseSM0 sm = do
putStrLn $ sizeStr sm
newline
printDenseSM' sm 5 5
newline
where
printDenseSM' sm' nromax ncomax = mapM_ putStrLn rr_' where
(nr, _) = (nrows sm, ncols sm)
rr_ = map (\i -> toDenseRowClip sm' i ncomax) [0..nr 1]
rr_' | nr > nromax = take (nromax 2) rr_ ++ [" ... "] ++[last rr_]
| otherwise = rr_
toDenseListClip :: (Show a, Epsilon a) => SpVector a -> Int -> String
toDenseListClip sv ncomax
| dim sv > ncomax = unwords (map showNz h) ++ " ... " ++ showNz t
| otherwise = unwords $ showNz <$> dr
where dr = toDenseListSV sv
h = take (ncomax 2) dr
t = last dr
printDenseSV :: (Show t, Epsilon t) => SpVector t -> IO ()
printDenseSV sv = do
newline
putStrLn $ sizeStrSV sv
newline
printDenseSV0 sv
printDenseSV0 :: (Show t, Epsilon t) => SpVector t -> IO ()
printDenseSV0 sv = do
printDenseSV' sv 5
newline where
printDenseSV' v nco = putStrLn rr_' where
rr_ = toDenseListClip v nco :: String
rr_' | dim sv > nco = unwords [take (nco 2) rr_ , " ... " , [last rr_]]
| otherwise = rr_
instance (Show a, Num a, Epsilon a) => PrintDense (SpVector a) where
prd = printDenseSV
prd0 = printDenseSV0
instance (Show a, Num a, Epsilon a) => PrintDense (SpMatrix a) where
prd = printDenseSM
prd0 = printDenseSM0