module Math.HiddenMarkovModel.CSV where

import Math.HiddenMarkovModel.Utility (vectorDim)

import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape
import qualified Numeric.LAPACK.Matrix as Matrix
import qualified Numeric.LAPACK.Vector as Vector
import Numeric.LAPACK.Matrix (ShapeInt)
import Numeric.LAPACK.Vector (Vector)

import qualified Numeric.Netlib.Class as Class

import qualified Data.Array.Comfort.Shape as Shape

import qualified Text.CSV.Lazy.String as CSV
import Text.Read.HT (maybeRead)
import Text.Printf (printf)

import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import Control.Monad.Exception.Synchronous (Exceptional)
import Control.Monad (liftM2, replicateM, unless)

import qualified Data.List.Reverse.StrictElement as Rev
import qualified Data.List.HT as ListHT


cellsFromVector ::
   (Shape.C sh, Show a, Class.Real a) => Vector sh a -> [String]
cellsFromVector :: Vector sh a -> [String]
cellsFromVector = (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show ([a] -> [String])
-> (Vector sh a -> [a]) -> Vector sh a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector sh a -> [a]
forall sh a. (C sh, Storable a) => Vector sh a -> [a]
Vector.toList

cellsFromSquare ::
   (Shape.Indexed sh, Show a, Class.Real a) => Matrix.Square sh a -> [[String]]
cellsFromSquare :: Square sh a -> [[String]]
cellsFromSquare = (Vector sh a -> [String]) -> [Vector sh a] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show ([a] -> [String])
-> (Vector sh a -> [a]) -> Vector sh a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector sh a -> [a]
forall sh a. (C sh, Storable a) => Vector sh a -> [a]
Vector.toList) ([Vector sh a] -> [[String]])
-> (Square sh a -> [Vector sh a]) -> Square sh a -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Square sh a -> [Vector sh a]
forall meas vert horiz height width a.
(Measure meas, C vert, C horiz, C height, C width, Floating a) =>
Full meas vert horiz height width a -> [Vector width a]
Matrix.toRows

padTable :: a -> [[a]] -> [[a]]
padTable :: a -> [[a]] -> [[a]]
padTable a
x [[a]]
xs =
   let width :: Int
width = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (([a] -> Int) -> [[a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
xs)
   in  ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Int -> [a] -> [a]
forall a. a -> Int -> [a] -> [a]
ListHT.padRight a
x Int
width) [[a]]
xs


type CSVParser = MS.StateT CSV.CSVResult (Exceptional String)

assert :: Bool -> String -> CSVParser ()
assert :: Bool -> String -> CSVParser ()
assert Bool
cond String
msg =
   Bool -> CSVParser () -> CSVParser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cond (CSVParser () -> CSVParser ()) -> CSVParser () -> CSVParser ()
forall a b. (a -> b) -> a -> b
$ Exceptional String () -> CSVParser ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String () -> CSVParser ())
-> Exceptional String () -> CSVParser ()
forall a b. (a -> b) -> a -> b
$ String -> Exceptional String ()
forall e a. e -> Exceptional e a
ME.throw String
msg

retrieveShortRow :: CSV.CSVError -> Maybe CSV.CSVRow
retrieveShortRow :: CSVError -> Maybe CSVRow
retrieveShortRow CSVError
err =
   case CSVError
err of
      CSV.IncorrectRow {csvFields :: CSVError -> CSVRow
CSV.csvFields = CSVRow
row} -> CSVRow -> Maybe CSVRow
forall a. a -> Maybe a
Just CSVRow
row
      CSVError
_ -> Maybe CSVRow
forall a. Maybe a
Nothing

fixShortRow ::
   Either [CSV.CSVError] CSV.CSVRow -> Either [CSV.CSVError] CSV.CSVRow
fixShortRow :: Either [CSVError] CSVRow -> Either [CSVError] CSVRow
fixShortRow Either [CSVError] CSVRow
erow =
   case Either [CSVError] CSVRow
erow of
      Left [CSVError]
errs ->
         case (CSVError -> Maybe CSVRow) -> [CSVError] -> ([CSVRow], [CSVError])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
ListHT.partitionMaybe CSVError -> Maybe CSVRow
retrieveShortRow [CSVError]
errs of
            ([CSVRow
row], []) -> CSVRow -> Either [CSVError] CSVRow
forall a b. b -> Either a b
Right CSVRow
row
            ([CSVRow], [CSVError])
_ -> [CSVError] -> Either [CSVError] CSVRow
forall a b. a -> Either a b
Left [CSVError]
errs
      Either [CSVError] CSVRow
_ -> Either [CSVError] CSVRow
erow

maybeGetRow :: CSVParser (Maybe CSV.CSVRow)
maybeGetRow :: CSVParser (Maybe CSVRow)
maybeGetRow = do
   CSVResult
csv0 <- StateT CSVResult (Exceptional String) CSVResult
forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
   case CSVResult
csv0 of
      [] -> Maybe CSVRow -> CSVParser (Maybe CSVRow)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CSVRow
forall a. Maybe a
Nothing
      Either [CSVError] CSVRow
item : CSVResult
csv1 -> do
         CSVResult -> CSVParser ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put CSVResult
csv1
         case Either [CSVError] CSVRow
item of
            Right CSVRow
row -> Maybe CSVRow -> CSVParser (Maybe CSVRow)
forall (m :: * -> *) a. Monad m => a -> m a
return (CSVRow -> Maybe CSVRow
forall a. a -> Maybe a
Just CSVRow
row)
            Left [CSVError]
errors ->
               Exceptional String (Maybe CSVRow) -> CSVParser (Maybe CSVRow)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String (Maybe CSVRow) -> CSVParser (Maybe CSVRow))
-> Exceptional String (Maybe CSVRow) -> CSVParser (Maybe CSVRow)
forall a b. (a -> b) -> a -> b
$ String -> Exceptional String (Maybe CSVRow)
forall e a. e -> Exceptional e a
ME.throw (String -> Exceptional String (Maybe CSVRow))
-> String -> Exceptional String (Maybe CSVRow)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (CSVError -> String) -> [CSVError] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CSVError -> String
CSV.ppCSVError [CSVError]
errors

getRow :: CSVParser CSV.CSVRow
getRow :: CSVParser CSVRow
getRow =
   Exceptional String CSVRow -> CSVParser CSVRow
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String CSVRow -> CSVParser CSVRow)
-> (Maybe CSVRow -> Exceptional String CSVRow)
-> Maybe CSVRow
-> CSVParser CSVRow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe CSVRow -> Exceptional String CSVRow
forall e a. e -> Maybe a -> Exceptional e a
ME.fromMaybe String
"unexpected end of file" (Maybe CSVRow -> CSVParser CSVRow)
-> CSVParser (Maybe CSVRow) -> CSVParser CSVRow
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CSVParser (Maybe CSVRow)
maybeGetRow

checkEmptyRow :: CSV.CSVRow -> Exceptional String ()
checkEmptyRow :: CSVRow -> Exceptional String ()
checkEmptyRow CSVRow
row =
   case (CSVField -> Bool) -> CSVRow -> CSVRow
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CSVField -> Bool) -> CSVField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (CSVField -> String) -> CSVField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSVField -> String
CSV.csvFieldContent) CSVRow
row of
      [] -> () -> Exceptional String ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      CSVField
cell:CSVRow
_ -> String -> Exceptional String ()
forall e a. e -> Exceptional e a
ME.throw (String -> Exceptional String ())
-> String -> Exceptional String ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%d: expected empty row" (CSVField -> Int
CSV.csvRowNum CSVField
cell)

skipEmptyRow :: CSVParser ()
skipEmptyRow :: CSVParser ()
skipEmptyRow  =  Exceptional String () -> CSVParser ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String () -> CSVParser ())
-> (CSVRow -> Exceptional String ()) -> CSVRow -> CSVParser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSVRow -> Exceptional String ()
checkEmptyRow (CSVRow -> CSVParser ()) -> CSVParser CSVRow -> CSVParser ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CSVParser CSVRow
getRow

manySepUntilEnd :: CSVParser a -> CSVParser [a]
manySepUntilEnd :: CSVParser a -> CSVParser [a]
manySepUntilEnd CSVParser a
p =
   let go :: CSVParser [a]
go = (a -> [a] -> [a]) -> CSVParser a -> CSVParser [a] -> CSVParser [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) CSVParser a
p (CSVParser [a] -> CSVParser [a]) -> CSVParser [a] -> CSVParser [a]
forall a b. (a -> b) -> a -> b
$ do
          Maybe CSVRow
mrow <- CSVParser (Maybe CSVRow)
maybeGetRow
          case Maybe CSVRow
mrow of
             Maybe CSVRow
Nothing -> [a] -> CSVParser [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
             Just CSVRow
row -> do
                Exceptional String () -> CSVParser ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String () -> CSVParser ())
-> Exceptional String () -> CSVParser ()
forall a b. (a -> b) -> a -> b
$ CSVRow -> Exceptional String ()
checkEmptyRow CSVRow
row
                CSVParser [a]
go
   in  CSVParser [a]
go

manyRowsUntilEnd :: (CSV.CSVRow -> CSVParser a) -> CSVParser [a]
manyRowsUntilEnd :: (CSVRow -> CSVParser a) -> CSVParser [a]
manyRowsUntilEnd CSVRow -> CSVParser a
p =
   let go :: CSVParser [a]
go = do
          Maybe CSVRow
mrow <- CSVParser (Maybe CSVRow)
maybeGetRow
          case Maybe CSVRow
mrow of
             Maybe CSVRow
Nothing -> [a] -> CSVParser [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
             Just CSVRow
row -> (a -> [a] -> [a]) -> CSVParser a -> CSVParser [a] -> CSVParser [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) (CSVRow -> CSVParser a
p CSVRow
row) CSVParser [a]
go
   in  CSVParser [a]
go

parseVectorCells ::
   (Read a, Class.Real a) =>
   CSVParser (Vector ShapeInt a)
parseVectorCells :: CSVParser (Vector ShapeInt a)
parseVectorCells =
   CSVRow -> CSVParser (Vector ShapeInt a)
forall a.
(Read a, Real a) =>
CSVRow -> CSVParser (Vector ShapeInt a)
parseVectorFields (CSVRow -> CSVParser (Vector ShapeInt a))
-> CSVParser CSVRow -> CSVParser (Vector ShapeInt a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CSVParser CSVRow
getRow

-- ToDo: Maybe check row consistency already here?
parseVectorFields ::
   (Read a, Class.Real a) =>
   CSV.CSVRow -> CSVParser (Vector ShapeInt a)
parseVectorFields :: CSVRow -> CSVParser (Vector ShapeInt a)
parseVectorFields =
   Exceptional String (Vector ShapeInt a)
-> CSVParser (Vector ShapeInt a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String (Vector ShapeInt a)
 -> CSVParser (Vector ShapeInt a))
-> (CSVRow -> Exceptional String (Vector ShapeInt a))
-> CSVRow
-> CSVParser (Vector ShapeInt a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Vector ShapeInt a)
-> Exceptional String [a] -> Exceptional String (Vector ShapeInt a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Vector ShapeInt a
forall a. Storable a => [a] -> Vector ShapeInt a
Vector.autoFromList (Exceptional String [a] -> Exceptional String (Vector ShapeInt a))
-> (CSVRow -> Exceptional String [a])
-> CSVRow
-> Exceptional String (Vector ShapeInt a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CSVField -> Exceptional String a)
-> CSVRow -> Exceptional String [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CSVField -> Exceptional String a
forall a. Read a => CSVField -> Exceptional String a
parseNumberCell (CSVRow -> Exceptional String [a])
-> (CSVRow -> CSVRow) -> CSVRow -> Exceptional String [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (CSVField -> Bool) -> CSVRow -> CSVRow
forall a. (a -> Bool) -> [a] -> [a]
Rev.dropWhile (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (CSVField -> String) -> CSVField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSVField -> String
CSV.csvFieldContent)

parseNonEmptyVectorCells ::
   (Read a, Class.Real a) =>
   CSVParser (Vector ShapeInt a)
parseNonEmptyVectorCells :: CSVParser (Vector ShapeInt a)
parseNonEmptyVectorCells = do
   Vector ShapeInt a
v <- CSVParser (Vector ShapeInt a)
forall a. (Read a, Real a) => CSVParser (Vector ShapeInt a)
parseVectorCells
   Bool -> String -> CSVParser ()
assert (Vector ShapeInt a -> Int
forall sh a. C sh => Vector sh a -> Int
vectorDim Vector ShapeInt a
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) String
"no data for vector"
   Vector ShapeInt a -> CSVParser (Vector ShapeInt a)
forall (m :: * -> *) a. Monad m => a -> m a
return Vector ShapeInt a
v

cellContent :: CSV.CSVField -> Exceptional String String
cellContent :: CSVField -> Exceptional String String
cellContent CSVField
field =
   case CSVField
field of
      CSV.CSVFieldError {} -> String -> Exceptional String String
forall e a. e -> Exceptional e a
ME.throw (String -> Exceptional String String)
-> String -> Exceptional String String
forall a b. (a -> b) -> a -> b
$ CSVField -> String
CSV.ppCSVField CSVField
field
      CSV.CSVField { csvFieldContent :: CSVField -> String
CSV.csvFieldContent = String
str } -> String -> Exceptional String String
forall (m :: * -> *) a. Monad m => a -> m a
return String
str

parseNumberCell :: (Read a) => CSV.CSVField -> Exceptional String a
parseNumberCell :: CSVField -> Exceptional String a
parseNumberCell CSVField
field = do
   String
str <- CSVField -> Exceptional String String
cellContent CSVField
field
   String -> Maybe a -> Exceptional String a
forall e a. e -> Maybe a -> Exceptional e a
ME.fromMaybe (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"field content \"%s\" is not a number" String
str) (Maybe a -> Exceptional String a)
-> Maybe a -> Exceptional String a
forall a b. (a -> b) -> a -> b
$
      String -> Maybe a
forall a. Read a => String -> Maybe a
maybeRead String
str

parseSquareMatrixCells ::
   (Shape.C sh, Read a, Class.Real a) =>
   sh -> CSVParser (Matrix.Square sh a)
parseSquareMatrixCells :: sh -> CSVParser (Square sh a)
parseSquareMatrixCells sh
sh = do
   let n :: Int
n = sh -> Int
forall sh. C sh => sh -> Int
Shape.size sh
sh
   [Vector ShapeInt a]
rows <- Int
-> StateT CSVResult (Exceptional String) (Vector ShapeInt a)
-> StateT CSVResult (Exceptional String) [Vector ShapeInt a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n StateT CSVResult (Exceptional String) (Vector ShapeInt a)
forall a. (Read a, Real a) => CSVParser (Vector ShapeInt a)
parseVectorCells
   Bool -> String -> CSVParser ()
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Vector ShapeInt a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vector ShapeInt a]
rows) String
"no rows"
   Bool -> String -> CSVParser ()
assert ((Vector ShapeInt a -> Bool) -> [Vector ShapeInt a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==) (Int -> Bool)
-> (Vector ShapeInt a -> Int) -> Vector ShapeInt a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector ShapeInt a -> Int
forall sh a. C sh => Vector sh a -> Int
vectorDim) [Vector ShapeInt a]
rows) String
"inconsistent matrix dimensions"
   Square sh a -> CSVParser (Square sh a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Square sh a -> CSVParser (Square sh a))
-> Square sh a -> CSVParser (Square sh a)
forall a b. (a -> b) -> a -> b
$
      Omni Unpacked Arbitrary Filled Filled Shape Small Small sh sh
-> ArrayMatrix
     Unpacked Arbitrary Filled Filled Size Big Big ShapeInt ShapeInt a
-> Square sh a
forall measA vertA horizA measB vertB horizB heightA widthA heightB
       widthB packB propB lowerB upperB packA propA lowerA upperA a.
(Measure measA, C vertA, C horizA, Measure measB, C vertB,
 C horizB, C heightA, C widthA, C heightB, C widthB) =>
Omni packB propB lowerB upperB measB vertB horizB heightB widthB
-> ArrayMatrix
     packA propA lowerA upperA measA vertA horizA heightA widthA a
-> ArrayMatrix
     packB propB lowerB upperB measB vertB horizB heightB widthB a
Matrix.reshape (Order
-> sh
-> Omni Unpacked Arbitrary Filled Filled Shape Small Small sh sh
forall sh. C sh => Order -> sh -> Square sh
MatrixShape.square Order
MatrixShape.RowMajor sh
sh) (ArrayMatrix
   Unpacked Arbitrary Filled Filled Size Big Big ShapeInt ShapeInt a
 -> Square sh a)
-> ArrayMatrix
     Unpacked Arbitrary Filled Filled Size Big Big ShapeInt ShapeInt a
-> Square sh a
forall a b. (a -> b) -> a -> b
$
      ShapeInt
-> [Vector ShapeInt a]
-> ArrayMatrix
     Unpacked Arbitrary Filled Filled Size Big Big ShapeInt ShapeInt a
forall width a.
(C width, Eq width, Storable a) =>
width -> [Vector width a] -> General ShapeInt width a
Matrix.fromRows (Int -> ShapeInt
forall n. n -> ZeroBased n
Shape.ZeroBased Int
n) [Vector ShapeInt a]
rows

parseStringList :: CSV.CSVRow -> CSVParser [String]
parseStringList :: CSVRow -> CSVParser [String]
parseStringList =
   Exceptional String [String] -> CSVParser [String]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Exceptional String [String] -> CSVParser [String])
-> (CSVRow -> Exceptional String [String])
-> CSVRow
-> CSVParser [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CSVField -> Exceptional String String)
-> CSVRow -> Exceptional String [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CSVField -> Exceptional String String
cellContent (CSVRow -> Exceptional String [String])
-> (CSVRow -> CSVRow) -> CSVRow -> Exceptional String [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (CSVField -> Bool) -> CSVRow -> CSVRow
forall a. (a -> Bool) -> [a] -> [a]
Rev.dropWhile (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (CSVField -> String) -> CSVField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSVField -> String
CSV.csvFieldContent)