{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module HLearn.DataContainers
where
import Control.Monad
import Control.Monad.Random
-- import Data.Binary
import Data.Functor
-- import Data.Hashable
import Data.List
import Data.List.Split
import Debug.Trace
import Test.QuickCheck
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import HLearn.Algebra
-------------------------------------------------------------------------------
-- Idioms
type Labeled var label = (label,var)
type Weighted var = (var,Double)
-- | I only ever expect labels of type Bool, Int, and String, but it may be convenient to use other types as well for something. This class and instance exist so that we have some reasonable assumptions about what properties labels should have for our other classes to work with. It also keeps us from writing so many constraints.
class (Hashable label, Binary label, Ord label, Eq label, Show label, Read label) => Label label
instance (Hashable label, Binary label, Ord label, Eq label, Show label, Read label) => Label label
-------------------------------------------------------------------------------
-- DataItem
data DataItem = Missing
| Continuous !Double
| Discrete !String
deriving (Read,Show,Eq,Ord)
fromContinuous :: DataItem -> Double
fromContinuous (Continuous x) = x
-- instance Hashable DataItem where
-- hash Missing = 0
-- hash (Discrete x) = 1 `combine` (hash x)
-- hash (Continuous x) = 2 `combine` (hash x)
--
instance NFData DataItem where
rnf Missing = ()
rnf (Discrete x) = rnf x
rnf (Continuous x) = rnf x
--
-- instance Binary DataItem where
-- put x = case x of
-- Missing -> put (0::Word8)
-- Discrete y -> put (1::Word8) >> put y
-- Continuous y -> put (2::Word8) >> put y
-- get = do
-- i <- get
-- case i::Word8 of
-- 0 -> return Missing
-- 1 -> liftM Discrete get
-- 2 -> liftM Continuous get
--
-- instance Arbitrary DataItem where
-- arbitrary = do
-- choice <- choose (0,3)
-- x <- choose (-10,10)
-- return $ case (choice::Int) of
-- 0 -> Missing
-- 1 -> Discrete $ show x
-- 2 -> Continuous x
-------------------------------------------------------------------------------
-- DataDesc
data DataDesc label = DataDesc
{ numLabels :: Int
, labelL :: [label]
, numAttr :: Int
}
deriving (Eq,Read,Show)
-- attrL :: DataDesc label -> [Int]
-- attrL desc = [0..numAttr desc-1]
-- instance (Binary label) => Binary (DataDesc label) where
-- put desc = do
-- put $ numLabels desc
-- put $ labelL desc
-- put $ numAttr desc
-- get = liftM3 DataDesc get get get
instance (NFData label) => NFData (DataDesc label) where
rnf desc = deepseq (deepseq (labelL desc) (rnf $ numLabels desc)) (rnf $ numAttr desc)
instance Arbitrary (DataDesc Int) where
arbitrary = do
labels <- choose (2,50)
attrs <- choose (1,50)
return $ DataDesc labels [0..labels-1] attrs
-------------------------------------------------------------------------------
-- DataLoaderCSV
class DataLoaderCSV dl where
loadDataCSV :: DatafileDesc -> IO ({-Either String -}dl)
data AttrIndex = FirstC | LastC | IndexC Int
deriving (Read,Show)
-- | Describes the data file to be loaded
data DatafileDesc = DatafileDesc
{ datafilePath :: String -- ^ The path of the file to open
, datafileLabelColumn :: AttrIndex
-- , datafileTrueClass :: Maybe String -- ^ Currently, in order to use the binary classification algorithms you must specify which class label should be considered as True, and all the rest are considered False.
, datafileMissingStr :: Maybe String -- ^ This field specifies what symbol is used to represent missing data if present. "?" is very common.
-- , datafileForce :: Maybe [String -> DataItem]-- ^ If this is set to Nothing, then text fields will automatically be Discrete and numeric fields automatically be Continuous. Occasionally, however, you want numeric fields to be discrete, so you would have to set this.
}
deriving Show
datafileName = last . splitOn "/" . datafilePath
instance Show (String->DataItem) where
show xs = ""
-------------------------------------------------------------------------------
-- DataContainers
type DPF = [DataItem]
type DPS = [(Int,DataItem)] -- ^ DPS = DataPointSparse
type UDPS label = DPS -- ^ UDPS = Unabeled DataPointSparse
type LDPS label = Labeled DPS label -- ^ LDPS = Labeled DataPointSparse
type WLDPS label = (Weighted (LDPS label)) -- ^ WDPS = Weighted labeled DataPointSparse
type WUDPS label = (Weighted (UDPS label)) -- ^ WDPS = Weighted labeled DataPointSparse
fetchAttr :: Int -> DPS -> DataItem
fetchAttr attrI dps =
case lookup attrI dps of
Nothing -> Missing
Just x -> x
dps2dpf :: Int -> DPS -> DPF
dps2dpf len dps = go 0 dps []
where
go itr [] dpf
| itr >= len = reverse dpf
| otherwise = go (itr+1) [] (Missing:dpf)
go itr dps dpf
| itr >= len = reverse dpf
| otherwise = if (fst $ head dps) == itr
then go (itr+1) (tail dps) ((snd $ head dps):dpf)
else go (itr+1) dps (Missing:dpf)
dpf2dps :: DPF -> DPS
dpf2dps xs = filter (\x -> (snd x)/=Missing) $ zip [0..] xs
-------------------------------------------------------------------------------
-- DataSparse
class
( F.Foldable ds
, Functor ds
, T.Traversable ds
, Show label
, Show dataType
, Show (ds dataType)
, Ord label
, Ord dataType
, Semigroup (ds dataType)
) =>
DataSparse label ds dataType | ds -> label
where
emptyds :: DataDesc label -> ds dataType
getDataDesc :: ds dataType -> DataDesc label
getNumObs :: ds dataType -> Int
getObsL :: ds dataType -> [Int]
getDataL :: ds dataType -> [dataType]
-- getNumLabels :: ds dataType -> Int
-- getNumLabels = length . getLabelL
-- getLabelL :: ds dataType -> [label]
-- randomize :: ds dataType -> HLearn (ds dataType)
filterds :: (dataType -> Bool) -> ds (dataType) -> ds (dataType)
splitdtree :: dataType -> ds (dataType) -> (ds dataType, ds dataType)
-- sample :: Int -> ds (Weighted dataType) -> HLearn (ds dataType)
-- zipds :: ds dataType -> ds dataType2 -> ds (dataType,dataType2)
zipdsL :: ds dataType -> [w] -> ds (dataType,w)
zip3dsL :: ds dataType -> [a] -> [b] -> ds (dataType,a,b)
-- randSplit :: (RandomGen g) => Double -> ds dataType -> Rand g (ds dataType, ds dataType)
takeFirst :: Int -> ds dataType -> ds dataType
dropFirst :: Int -> ds dataType -> ds dataType
-- newtype LDPS_Compare label = LDPS_Compare (LDPS label)
--
-- splitdsLDPS :: (DataSparse label ds (LDPS label)) => (Int,DataItem) -> ds (LDPS label) -> (ds (LDPS label),ds(LDPS label))
-- splitdsLDPS = undefined
splitds :: (DataSparse label ds dataType) => Int -> ds dataType -> [ds dataType]
splitds numsplits ds = go 1 ds
where
splitlen = ceiling $ (fromIntegral $ getNumObs ds)/(fromIntegral numsplits)
go itr ds = (takeFirst splitlen ds):nextL
where
nextL=if itr>=numsplits -- (getNumObs ds' == 0 && itr>numsplits)
then {-trace "hit0" -}[]
else {-trace "not0" $ -}go (itr+1) ds'
ds'=dropFirst splitlen ds
splitdsRedundantSimple :: (DataSparse label ds dataType) => Int -> Int -> ds dataType -> [ds dataType]
splitdsRedundantSimple numsplits redun ds
| redun == numsplits = replicate numsplits ds
| redun == 1 = splitds numsplits ds
| redun > 1 && redun<numsplits = [ (splits !! i) <> (extrads i) | i<-[0..numsplits-1]]
where
extrads i = foldl1' (<>) [splits !! i' | i'<-redunL i]
redunL i = [i' `mod` numsplits | i' <- [i+1..i+redun-1]]
splits = splitds numsplits ds
getTransposeL :: (DataSparse label ds (LDPS label)) => ds (LDPS label) -> [[(label,DataItem)]]
getTransposeL ds = map (zip (map fst dsL)) . map (map snd) . transpose . map (fillL (numAttr $ getDataDesc ds)) $ map snd dsL
where
dsL = getDataL ds
fillL :: Int -> DPS -> DPS
fillL limit = go 0
where
go itr []
| itr < limit = (itr,Missing):(go (itr+1) [])
| otherwise = []
go itr (x:xs)
| fst x==itr = x:(go (itr+1) xs)
| otherwise = (itr,Missing):(go (itr+1) (x:xs))
lds2uds ::
( DataSparse label ds (LDPS label)
, DataSparse label ds (UDPS label)
) => ds (LDPS label) -> ds (UDPS label)
lds2uds lds = fmap snd lds
-- class LabeledDataSparse lds label | lds -> label where
-- trainOnline :: {-(Monoid model) => -}(model -> LabeledDataPointSparse label -> model) -> model -> lds -> model
-- trainOnlineM :: (Monad m) => (model -> LabeledDataPointSparse label -> m model) -> model -> lds -> m model
-- -- trainOnline :: (Monoid model) => (LabeledDataPointSparse label -> model) -> lds -> model
--
-- class UnlabeledDataSparse uds label | uds -> label where