HLearn-classification (empty) → 0.0.1
raw patch · 10 files changed
+1666/−0 lines, 10 filesdep +ConstraintKindsdep +HLearn-algebradep +HLearn-classificationsetup-changed
Dependencies added: ConstraintKinds, HLearn-algebra, HLearn-classification, HLearn-distributions, MonadRandom, QuickCheck, Safe, base, bytestring, containers, criterion, dlist, list-extras, logfloat, math-functions, normaldistribution, parsec, primitive, split, statistics, vector, vector-th-unbox
Files
- HLearn-classification.cabal +77/−0
- Setup.hs +2/−0
- src/HLearn/DataContainers.hs +254/−0
- src/HLearn/DataContainers/CSVParser.hs +63/−0
- src/HLearn/DataContainers/DS_List.hs +302/−0
- src/HLearn/Evaluation/CrossValidation.hs +261/−0
- src/HLearn/Models/Classification.hs +57/−0
- src/HLearn/Models/Classifiers/NBayes.hs +164/−0
- src/HLearn/Models/DistributionContainer.hs +264/−0
- src/examples/demo.lhs +222/−0
+ HLearn-classification.cabal view
@@ -0,0 +1,77 @@+Name: HLearn-classification+Version: 0.0.1+Description: This module is for unsupervised, supervised, and semi-supervised classification tasks. It is in desperate need of documentation and refactoring.+Category: Data Mining, Machine Learning+License: GPL+--License-file: LICENSE+Author: Mike izbicki+Maintainer: mike@izbicki.me+Build-Type: Simple+Cabal-Version: >=1.8++Executable HLearn-Classification-Demo+ Main-is: src/examples/demo.lhs+ Build-Depends: + HLearn-algebra >= 0.0.1,+ ConstraintKinds >= 0.0.1,+ HLearn-distributions >= 0.0.1,+ HLearn-classification >= 0.0.1,+ + base >= 3 && < 5,+ criterion >= 0.6.1.1+ ghc-options: + -threaded+ -rtsopts + -O2+ -- -prof+ -funbox-strict-fields+ -- -prof+ -- -fllvm++Library+ Build-Depends: + base >= 3 && < 5,+ HLearn-algebra >= 0.0.1,+ HLearn-distributions >= 0.0.1,+ ConstraintKinds >= 0.0.1,++ -- are these really necessary?+ + dlist >= 0.5,+ + parsec >= 3.1.3,+ Safe >= 0.1,+ bytestring >= 0.10.0.0,+ primitive >= 0.4.1,+ split >= 0.2.1.1,+ list-extras >= 0.4.1,+ containers >= 0.5,+ statistics >= 0.10.2,+ + QuickCheck >= 2.5.1,+ vector >= 0.9,+ vector-th-unbox >= 0.1,+ + MonadRandom >= 0.1.6,+ logfloat >= 0.12.0,+ math-functions >= 0.1.1,+ normaldistribution >= 1.1.0++ + hs-source-dirs: src+ ghc-options: + -rtsopts + -- -auto-all + -- -caf-all + -funbox-strict-fields+ -O2 + -- -fllvm+ Exposed-modules:+ HLearn.Models.Classification+ HLearn.Models.Classifiers.NBayes+ HLearn.Models.DistributionContainer+ HLearn.DataContainers+ HLearn.DataContainers.CSVParser+ HLearn.DataContainers.DS_List+ HLearn.Evaluation.CrossValidation+ --HLearn.Evaluation.Metrics
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/HLearn/DataContainers.hs view
@@ -0,0 +1,254 @@+{-# 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+
+ src/HLearn/DataContainers/CSVParser.hs view
@@ -0,0 +1,63 @@+module HLearn.DataContainers.CSVParser+ ( loadCSV+ , list2csv+ , module Text.ParserCombinators.Parsec+ )+ where+ +import System.IO+import Text.ParserCombinators.Parsec+ +-- | Loads a CSV file. Algorithms store debugging info in CSV files, and this function is used by the plotting routines+loadCSV :: String -> IO (Either ParseError [[String]])+loadCSV filename = do+ hin <- openFile filename ReadMode+ str <- hGetContents hin+ let ds = parseCSV str+ return ds+ +-- | Converts a list into CSV format for writing to a file+list2csv :: [String] -> String+list2csv xs = foldl addcommas "" $ map addquotes xs+ where+ addcommas x y = + if x==""+ then y+ else x++","++y+ addquotes x = show x+-- list2csv xs = init $ tail $ show xs++-- CSV parser from "Real World Haskell," p. 391+-- modified to allow multiple spaces between cells+ +parseCSV :: String -> Either ParseError [[String]]+parseCSV input = parse csvFile "(unknown)" input+ +csvFile = endBy line eol+line = sepBy cell (char ',' <|> char ' ')+cell = do+ spaces+ quotedCell <|> many (noneOf " ,\n\r")++quotedCell = do+ char '"'+ content <- many quotedChar+ char '"' <?> "Quote at end of cell"+ return content+ +quotedChar = noneOf "\"" <|> try (string "\"\"" >> return '"')++eol = try (string "\n\r")+ <|> try (string "\r\n")+ <|> try (string "\n")+ <|> try (string "\r")+ <?> "end of line"+ +-- test csv parsing+{-+csv_test = do+ dm <- loadData $ defDatafileDesc {datafileName="../testdata/ringnorm.data"}+ putStrLn $ func dm+ where+ func (Left x) = show x+ func (Right x) = show $ take 10 x-}
+ src/HLearn/DataContainers/DS_List.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HLearn.DataContainers.DS_List+ where++import Control.Applicative+import Control.Monad+import Control.Monad.Random+import Data.List+import Debug.Trace+import Safe+import Test.QuickCheck++import qualified Data.Foldable as F+import qualified Data.Traversable as T++import HLearn.Algebra+import HLearn.DataContainers+import HLearn.DataContainers.CSVParser+-- import HLearn.Misc.LazyDecodeList+-- import HLearn.RandUtils++import qualified Control.ConstraintKinds as CK++-------------------------------------------------------------------------------+-- DS_List++data DS_List label dataType = DS_List+ { dsDesc :: DataDesc label+ , dsL :: [dataType]+ , dsLen :: Int+ }+ deriving (Read,Show)+ + +instance (Eq label) => Semigroup (DS_List label dataType) where+ (<>) (DS_List dsDesc1 dsL1 dsLen1) (DS_List dsDesc2 dsL2 dsLen2) = + if (dsDesc1 /= dsDesc2)+ then error "DS_List.(<>): adding two elements of different dimensions"+ else DS_List dsDesc1 (dsL1++dsL2) (dsLen1+dsLen2)+ +-- instance (Eq label) => Monoid (DS_List label datatype) where+-- mappend = (<>)+-- mempty = DS_List undefined mempty 0++-- arbitraryDS_List :: DataDesc -> Gen (DS_List Int (LDPS Int))+-- arbitraryDS_List desc = do+-- dsLen <- choose (100,200)+-- dsL <- vector dsLen+-- return $ DS_List +-- { dsDesc = desc+-- , dsL = dsL+-- , dsLen = dsLen+-- , dsLabelL = [0..numLabels desc]+-- }++instance CK.Partitionable (DS_List label) where+ partition k ds = [ ds {dsL = dsL'} | dsL' <- CK.partition k (dsL ds)]++instance F.Foldable (DS_List label) where+ foldr f model0 ds = foldr f model0 (dsL ds)++instance CK.Foldable (DS_List label) where+ foldr f model0 ds = F.foldr f model0 (dsL ds)+ foldl f model0 ds = F.foldl f model0 (dsL ds)+ foldl' f model0 ds = F.foldl' f model0 (dsL ds)+ foldl1 model0 ds = F.foldl1 model0 (dsL ds)+ foldr1 model0 ds = F.foldr1 model0 (dsL ds)++instance Functor (DS_List label) where+ fmap f ds = ds { dsL = fmap f $ dsL ds }++instance CK.Functor (DS_List label) where+ fmap f ds = ds { dsL = fmap f $ dsL ds }++instance T.Traversable (DS_List label) where+ traverse f ds = liftA (\dsL' -> ds { dsL = dsL' } ) $ T.traverse f (dsL ds)++instance (Ord label, Ord dataType, Show label, Show dataType) => DataSparse label (DS_List label) dataType where+ emptyds desc = DS_List+ { dsDesc = desc+ , dsL = []+ , dsLen = 0+ }++ getDataDesc ds = dsDesc ds+ getNumObs = length . dsL --dsLen+ getObsL ds = [0..(dsLen ds)-1]+ getDataL = dsL++-- randomize ds = do+-- dsL' <- shuffle $ dsL ds+-- return $ ds { dsL = dsL' }++{- sample num wds = do+ dsL' <- sampleL num $ dsL wds+ return $ wds+ { dsL = dsL'+ , dsLen = length dsL'+ }-}+ +-- zip3dsL :: ds dataType -> [a] -> [b] -> ds (dataType,a,b)+ zip3dsL ds xs ys = ds { dsL = zipped, dsLen = length zipped }+ where zipped = zip3 (dsL ds) xs ys+ + zipdsL ds xs = ds { dsL = zipped, dsLen = length zipped }+ where zipped = zip (dsL ds) xs+ + filterds cond ds = ds { dsL = dsL', dsLen = length dsL' }+ where dsL' = filter cond $ dsL ds+ + splitdtree dt ds = ( ds { dsL = dsL1, dsLen = length dsL1 }+ , ds { dsL = dsL2, dsLen = length dsL2 }+ )+ where + dsL1 = filter (<=dt) (dsL ds)+ dsL2 = filter (> dt) (dsL ds)+ +{- randSplit factor ds = do+ (dsL1,dsL2) <- randSplitL factor $ dsL ds+ let ds1 = ds+ { dsL = dsL1+ , dsLen = trace "DS_List.randSplit.ds1 WARNING: using slow length function" $ length dsL2+ }+ let ds2 = ds+ { dsL = dsL2+ , dsLen = trace "DS_List.randSplit.ds2 WARNING: using slow length function" $ length dsL2+ }+ return (ds1,ds2)-}+ + takeFirst len ds = ds + { dsL = newL+ , dsLen = length newL+ }+ where+ newL = take len $ dsL ds ++ dropFirst len ds = ds + { dsL = drop len $ dsL ds + , dsLen = positive $ (dsLen ds)-len+ }+ where+ positive x = if x<0+ then 0+ else x++instance (NFData label, NFData dataType) => NFData (DS_List dataType label) where+ rnf ds = seq (rnf (dsDesc ds)) $ rnf (dsL ds)++-- instance (Binary label, Binary dataType) => Binary (DS_List dataType label) where+-- -- put lds = put (ldsDesc lds) >> put (Stream $ map (\(l,dp) -> (l,Stream dp)) $ ldsL lds) {->> put (ldLen lds)-}+-- put ds = do+-- put $ dsDesc ds+-- put $ Stream $ dsL ds+-- put $ dsLen ds+-- get = liftM3 DS_List get (liftM unstream get) get++---------------------------------------+-- test LDS_List++test_numLabels = 97+test_lenList = 10000++inflds = DS_List+ { dsDesc = DataDesc test_numLabels [0..test_numLabels-1] 500000+ , dsL = [(mod i test_numLabels, [(j,Continuous $ fromIntegral j) | j<-[1..100]]) | i <- [1..test_lenList]]+ , dsLen = test_lenList+ }+ ++-------------------------------------------------------------------------------+-- IO functions++dd2intdd :: (DataDesc label) -> (DataDesc Int)+dd2intdd desc = desc { labelL = [0..numLabels desc-1] }++ds2intds :: (Ord label, Show label) => (DS_List label (LDPS label)) -> (DS_List Int (LDPS Int))+ds2intds ds = DS_List+ { dsDesc = dd2intdd $ dsDesc ds+ , dsL = map (\(label,dp)->(getIndex label, dp)) $ dsL ds+ , dsLen = dsLen ds+ }+ where+ getIndex label = case (elemIndex label $ labelL $ getDataDesc ds) of+ Nothing -> error "stringds2intds: something awful happend"+ Just x -> x++dd2booldd :: (DataDesc label) -> (DataDesc Bool)+dd2booldd desc = desc { numLabels=2, labelL = [True,False] }++ds2boolds :: (Ord label, Show label) => [label] -> (DS_List label (LDPS label)) -> (DS_List Bool (LDPS Bool))+ds2boolds tL ds = DS_List+ { dsDesc = dd2booldd $ dsDesc ds+ , dsL = map (\(label,dp)->(newLabel label, dp)) $ dsL ds+ , dsLen = dsLen ds+ }+ where+ newLabel label = if label `elem` tL+ then True+ else False++instance DataLoaderCSV (DS_List String (LDPS String)) where+ loadDataCSV filedesc = do+ ret <- loadData filedesc+ return $+ case ret of+ Left msg -> error $ show msg+ Right x -> x++-- | Lazily loads a file into a TrainingData type for use with the classification algorithms+loadData :: DatafileDesc -> IO (Either ParseError (DS_List String (LDPS String)))+loadData filedesc = liftM (liftM $ csv2data filedesc) $ loadCSV $ datafilePath filedesc++{- do+ csveither <- loadCSV $ datafileName filedesc+ return $ liftM csv2data csveither+ return $ do+ csv <- csveither+ return csv2data-}+-- let dsL = map (\x -> (last x, list2datapoints $ init x)) csv+-- let labelL = extractLabelL dsL []+-- +-- return $ DS_List +-- { dsDesc = DataDesc +-- { numLabels = length labelL+-- , numAttr = length $ snd $ head dsL+-- } +-- , dsL = dsL+-- , dsLen = length dsL +-- , dsLabelL = labelL+-- }++csv2data :: DatafileDesc -> [[String]] -> (DS_List String (LDPS String))+csv2data filedesc csv = DS_List + { dsDesc = DataDesc + { numLabels = length labelL+ , labelL = labelL+ , numAttr = length $ snd $ head dsL+ } + , dsL = dsL+ , dsLen = length dsL + }+ where+ dsL = map csv2ldps csv+ csv2ldps row = case datafileLabelColumn filedesc of+ LastC -> (last row, list2datapoints (datafileMissingStr filedesc) $ init row)+ FirstC -> (head row, list2datapoints (datafileMissingStr filedesc) $ tail row)+ IndexC x -> error "csv2data: Index x not implemented"+ labelL = extractLabelL dsL []++list2datapoints :: Maybe String -> [String] -> [(Int,DataItem)]+list2datapoints missingStr xs = mapi (\i x -> (i,format x)) xs+ where + format str = + case readMay str of+ Just x -> Continuous x+ Nothing -> if Just str==missingStr+ then Missing+ else Discrete str++mapi :: (Int -> a -> b) -> [a] -> [b]+mapi = go 0+ where+ go itr f [] = []+ go itr f (x:xs) = (f itr x):(go (itr+1) f xs)+++extractLabelL :: (Eq label) => [(label,dp)] -> [label] -> [label]+extractLabelL [] labelL = labelL+extractLabelL ((label,dp):xs) labelL = + if label `elem` labelL+ then extractLabelL xs labelL+ else extractLabelL xs (label:labelL)++---------------++-- csv2data :: Maybe String -> Maybe [String -> DataItem] -> [[String]] -> TrainingData String+-- csv2data missingStr Nothing csv = csv2dataAuto missingStr csv+-- csv2data missingStr (Just fs) csv = error "forced value types not implemented"+-- -- csv2data missingStr (Just fs) csv = csv2dataForce missingStr fs csv+-- +-- csv2dataAuto :: Maybe String -> [[String]] -> TrainingData String+-- csv2dataAuto missingStr csv = map (\dp -> (last dp, map cell2sql $ init dp)) csv+-- where +-- cell2sql x = +-- if Just x==missingStr+-- then Missing+-- else case (reads x::[(Double,String)]) of+-- [] -> toDataItem (x::String)+-- (x:xs) -> toDataItem $ fst x++-- csv2dataForce :: Maybe String -> [String -> DataItem] -> [[String]] -> TrainingData String+-- csv2dataForce missingStr fs csv = +-- [(last line,+-- [ if Just cell==missingStr+-- then Missing+-- else f cell+-- | (f,cell) <- zip fs $ init line+-- ])+-- | line <- csv+-- ]
+ src/HLearn/Evaluation/CrossValidation.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BangPatterns #-}++module HLearn.Evaluation.CrossValidation+ where++import qualified Data.Map as Map+import qualified Data.Set as S+-- import qualified Data.Vector as V++import Debug.Trace+import Data.DList++import HLearn.Algebra+import HLearn.DataContainers+-- import HLearn.Evaluation.Metrics+import HLearn.Models.Classification+import HLearn.Models.Distributions+import qualified Control.ConstraintKinds as CK++-------------------------------------------------------------------------------+-- standard k-fold cross validation++-- crossValidation :: +-- ( HomTrainer modelparams datapoint model+-- , PerformanceMeasure perfmeasure model container datapoint ret+-- , Semigroup ret+-- , CK.Functor container+-- , CK.FunctorConstraint container datapoint+-- , CK.FunctorConstraint container model+-- , CK.Foldable container+-- , CK.FoldableConstraint container model+-- , CK.FoldableConstraint container datapoint+-- , CK.Partitionable container+-- , CK.PartitionableConstraint container datapoint+-- )+-- => modelparams -> container datapoint -> perfmeasure -> Int -> ret+-- crossValidation modelparams dataset perfmeasure k = reduce $ do+-- testdata <- datasetL+-- let trainingdata = testdata+-- let model = train' modelparams trainingdata+-- let score = measure perfmeasure model testdata+-- return score+-- where+-- datasetL = CK.partition k dataset++crossValidation :: + ( HomTrainer modelparams datapoint model+ , Semigroup ret+ , Semigroup (container datapoint)+ , CK.Functor container+ , CK.FunctorConstraint container datapoint+ , CK.FunctorConstraint container model+ , CK.Foldable container+ , CK.FoldableConstraint container model+ , CK.FoldableConstraint container datapoint+ , CK.Partitionable container+ , CK.PartitionableConstraint container datapoint+ ) => modelparams -> container datapoint -> (model -> container datapoint -> ret) -> Int -> ret+crossValidation modelparams dataset perfmeasure k = reduce $ do+ (testdata, trainingdata) <- genTestList datasetL+ let model = train' modelparams trainingdata+ let score = perfmeasure model testdata+ return score+ where+ datasetL = CK.partition k dataset++crossValidation_par modelparams dataset perfmeasure k = (parallel reduce) $ do+ (testdata, trainingdata) <- genTestList datasetL+ let model = train' modelparams trainingdata+ let score = perfmeasure model testdata+ return score+ where+ datasetL = CK.partition k dataset++crossValidation_monoid :: + ( HomTrainer modelparams datapoint model+ , Semigroup model+ , Semigroup ret+ , Semigroup (container datapoint)+ , CK.Functor container+ , CK.FunctorConstraint container datapoint+ , CK.FunctorConstraint container model+ , CK.Foldable container+ , CK.FoldableConstraint container model+ , CK.FoldableConstraint container datapoint+ , CK.Partitionable container+ , CK.PartitionableConstraint container datapoint+ ) => modelparams -> container datapoint -> (model -> container datapoint -> ret) -> Int -> ret+crossValidation_monoid modelparams dataset perfmeasure k = reduce $ do+ (testdata,model) <- zip datasetL $ listAllBut modelL+ let score = perfmeasure model testdata+ return score+ where+ modelL = fmap (train' modelparams) datasetL+ datasetL = CK.partition k dataset++crossValidation_monoid_par modelparams dataset perfmeasure k = (parallel reduce) $ do+ (testdata,model) <- zip datasetL $ listAllBut modelL+ let score = perfmeasure model testdata+ return score+ where+ modelL = fmap (train' modelparams) datasetL+ datasetL = CK.partition k dataset+++crossValidation_group :: + ( HomTrainer modelparams datapoint model+ , Group model+ , Semigroup ret+ , Semigroup (container datapoint)+ , CK.Functor container+ , CK.FunctorConstraint container datapoint+ , CK.FunctorConstraint container model+ , CK.Foldable container+ , CK.FoldableConstraint container model+ , CK.FoldableConstraint container datapoint+ , CK.Partitionable container+ , CK.PartitionableConstraint container datapoint+ ) => modelparams -> container datapoint -> (model -> container datapoint -> ret) -> Int -> ret+crossValidation_group modelparams dataset perfmeasure k = reduce $ do+ testdata <- datasetL+ let model = fullModel <> (inverse $ train' modelparams testdata)+ let score = perfmeasure model testdata+ return score + where+ fullModel = reduce modelL+ modelL = fmap (train' modelparams) datasetL+ datasetL = CK.partition k dataset++crossValidation_group_par modelparams dataset perfmeasure k = (parallel reduce) $ do+ testdata <- datasetL+ let model = fullModel <> (inverse $ train' modelparams testdata)+ let score = perfmeasure model testdata+ return score + where+ fullModel = (parallel reduce) modelL+ modelL = fmap (train' modelparams) datasetL+ datasetL = CK.partition k dataset+++listAllBut2 :: (Semigroup a) => [a] -> [a]+listAllBut2 !xs = [reduce $ testL i | i <- itrL]+ where+ itrL = [0..(length xs)-1]+ testL i = (take (i) xs) ++ (drop (i+1) xs)++listAllBut :: (Semigroup a) => [a] -> [a]+listAllBut !xs = [reduce $ testL i | i <- itrL]+ where+ itrL = [0..(length xs)-1]+ testL i = (fromList $ take (i) xs) `mappend` (fromList $ drop (i+1) xs)++instance CK.Foldable DList where+ foldr = Data.DList.foldr++genTestList :: (Semigroup a) => [a] -> [(a,a)]+genTestList xs = zip xs $ listAllBut xs+++-- class PerformanceMeasure measure model container datapoint outtype | measure -> outtype where+-- measure :: measure -> model -> container datapoint -> outtype+-- +-- data Accuracy = Accuracy+-- +-- instance+-- ( CK.Functor container+-- , CK.FunctorConstraint container Double+-- , CK.FunctorConstraint container (label,DPS)+-- , CK.Foldable container+-- , CK.FoldableConstraint container Double+-- , CK.FoldableConstraint container [Double]+-- , CK.FoldableConstraint container datapoint+-- , CK.FoldableConstraint container (LDPS label)+-- , CK.FoldableConstraint container [LDPS label]+-- , Classifier model DPS label+-- ) => PerformanceMeasure Accuracy model container (LDPS label) (Gaussian Double)+-- where+-- +-- measure metricparams model testdata = train1dp ((foldl1 (+) checkedL)/(fromIntegral $ numdp) :: Double)+-- where+-- checkdp (label,dp) = indicator $ label==(classify model dp)+-- checkedL = CK.toList $ CK.fmap checkdp testdata+-- numdp = length $ CK.toList testdata++accuracy :: + ( CK.Functor container+ , CK.FunctorConstraint container Double+ , CK.FunctorConstraint container (label,datapoint)+ , CK.Foldable container+ , CK.FoldableConstraint container Double+ , CK.FoldableConstraint container [Double]+ , CK.FoldableConstraint container datapoint+ , CK.FoldableConstraint container (Labeled datapoint label)+ , CK.FoldableConstraint container [Labeled datapoint label]+ , Classifier model datapoint label+ , Eq label+ ) => model -> container (Labeled datapoint label) -> (Gaussian Double)+accuracy model testdata = train1dp ((foldl1 (+) checkedL)/(fromIntegral $ numdp) :: Double)+ where+ checkdp (label,dp) = indicator $ label==(classify model dp)+ checkedL = CK.toList $ CK.fmap checkdp testdata+ numdp = length $ CK.toList testdata+++-- data CVType = CV_Normal | CV_Monoid | CV_Group+-- +-- data CVParams = CVParams+-- { folds :: Int+-- , metric :: Metric metric model ds label outtype+-- }+-- +-- data CVResults = CVResults+-- {+-- }+-- +-- instance Model CVParams CVResults where+-- +-- instance HomTrainer CVParams (LDPS label) CVResults where+-- train' CVParams ldps = undefined+-- +-- instance Monoid CVResults+-- +-- instance Semigroup CVResults++-- crossValidation :: +-- ( NFData model+-- , NFData outtype+-- , Semigroup outtype+-- , DataSparse label ds label+-- , DataSparse label ds DPS+-- , DataSparse label ds (Labeled DPS label)+-- , DataSparse label ds (Weighted (Labeled DPS label))+-- , DataSparse label ds [(label,probability)]+-- , HomTrainer modelparams model DPS label+-- , Metric metric model ds label outtype+-- ) =>+-- metric+-- -> modelparams+-- -> ds (Labeled DPS label)+-- -> Double+-- -> Double+-- -> Int+-- -> Random outtype+-- crossValidation metric modelparams inputdata trainingRatio labeledRatio rounds = foldl1' (<>) $+-- [ do+-- (trainingdata,testdata) <- randSplit trainingRatio inputdata+-- (lds,uds) <- randSplit labeledRatio trainingdata+-- let uds' = fmap snd uds+-- model <- trainBatchSS modelparams lds uds'+-- return $ deepseq model $ measure metric model testdata+-- | i <- [1..rounds]+-- ]+
+ src/HLearn/Models/Classification.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances, FlexibleContexts, BangPatterns #-}++module HLearn.Models.Classification+ where++import Data.Number.LogFloat++import HLearn.Algebra+import HLearn.Models.Distributions.Categorical+import HLearn.DataContainers+++-------------------------------------------------------------------------------+-- bool <-> int++indicator :: (Num a) => Bool -> a+indicator b = + if b+ then 1+ else 0 ++bool2num :: (Num a) => Bool -> a+bool2num b = + if b+ then 1+ else -1+ +num2bool :: (Ord a, Num a) => a -> Bool+num2bool a = + if a<0+ then False+ else True ++-------------------------------------------------------------------------------+-- ClassificationParams++data ClassificationParams label params = ClassificationParams+ { cparams :: params+ , datadesc :: DataDesc label+ }++-------------------------------------------------------------------------------+-- Classification++class {-(Label label) =>-} ProbabilityClassifier model datatype label | model -> label where+ probabilityClassify :: model -> datatype -> Categorical label Double+ +-- straightClassify :: model -> datatype -> label+-- straightClassify = mean . probabilityClassify+-- straightClassify model dp = classificationLabel $ probabilityClassify model dp+-- straightClassify model dp = fst . argmaxBy compare snd $ probabilityClassify model dp+ +class {-(Label label) =>-} Classifier model datatype label | model -> label where+ classify :: model -> datatype -> label++-- instance (ProbabilityClassifier model datatype label) => Classifier model datatype label where+-- classify model dp = mean $ probabilityClassify model dp
+ src/HLearn/Models/Classifiers/NBayes.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE MultiParamTypeClasses, IncoherentInstances, BangPatterns, FlexibleInstances, UndecidableInstances #-}++module HLearn.Models.Classifiers.NBayes+ ( NBayes (..)+ , NaiveBayes+ , NBayesParams (..), defNBayesParams+-- , file2nbayes, nbayes2file+ , getDist, labelProb+ )+ where+ +import Control.Monad.ST.Strict+import Control.Monad.Primitive+import Data.List+import Data.List.Extras+import Data.STRef+-- import Data.Vector.Binary+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream as Stream+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Mutable as VM+import qualified Data.ByteString as BS+import Debug.Trace+-- import qualified Numeric.Algebra as Alg+import System.IO+import Test.QuickCheck++import HLearn.Algebra+import HLearn.DataContainers+import HLearn.Models.Classification+import HLearn.Models.Distributions+import HLearn.Models.DistributionContainer++instance NFData a => NFData (V.Vector a) where+ rnf v = V.foldl' (\x y -> y `deepseq` x) () v++-------------------------------------------------------------------------------+-- NBayesParams++data NBayesParams datatype = NBayesParams+ deriving (Read,Show,Eq)+ +instance (Label label) => Model (ClassificationParams label (NBayesParams label)) (NaiveBayes label) where+ getparams (SGJust model) = ClassificationParams NBayesParams (dataDesc model)++instance NFData (NBayesParams datatype) where+ rnf params = ()++defNBayesParams = NBayesParams++-------------------------------------------------------------------------------+-- NBayes++type NaiveBayes label = RegSG2Group (NBayes label)++data NBayes label = NBayes+ { dataDesc :: !(DataDesc label)+ , labelDist :: !(Categorical label Double)+ , attrDist :: !(V.Vector (V.Vector DistContainer)) -- ^ The inner vector corresponds to attributes and the outer vector labels+ }+ deriving ({-Read,-}Show)+ +getDist :: NBayes Int -> Int -> Int -> DistContainer+getDist nb attrI label = (attrDist nb) V.! label V.! attrI+ +-- labelProb :: NBayes Int -> Int -> LogFloat+labelProb :: NBayes Int -> Int -> Double+labelProb = pdf . labelDist+ +-- instance (Label label) => Model (NBayes label) label where+-- datadesc = dataDesc++instance (NFData label) => NFData (NBayes label) where+ rnf nb = seq (rnf $ attrDist nb) $ seq (rnf $ dataDesc nb) (rnf $ labelDist nb)++-------------------------------------------------------------------------------+-- Algebra++instance (Label label) => Semigroup (NBayes label) where+ (<>) a b =+ if (dataDesc a)/=(dataDesc b)+ then error $ "mappend.NBayes: cannot combine nbayes with different sizes! lhs="++(show $ dataDesc a)++"; rhs="++(show $ dataDesc b)+ else NBayes+ { dataDesc = dataDesc a+ , labelDist = (labelDist a) <> (labelDist b)+ , attrDist = V.zipWith (V.zipWith mappend) (attrDist a) (attrDist b)+ }++instance (Label label) => RegularSemigroup (NBayes label) where+ inverse nb = nb+ { labelDist = inverse $ labelDist nb+ , attrDist = V.map (V.map inverse) $ attrDist nb+ }++-------------------------------------------------------------------------------+-- Training++-- instance (Label label) => HomTrainer (NBayesParams,DataDesc label) (LDPS label) (NaiveBayes label) where+instance HomTrainer (ClassificationParams Int (NBayesParams Int)) (LDPS Int) (NaiveBayes Int) where+ train1dp' (ClassificationParams NBayesParams desc) (label,dp) = SGJust $ NBayes+ { dataDesc = desc+ , labelDist = train1dp label+ , attrDist = emptyvecs V.// [(label,newLabelVec)] + }+ where+ emptyvecs = V.fromList [V.fromList [mempty | y<-[1..numAttr desc]] | x<-[1..numLabels desc]]+ newLabelVec = V.accum add1dp (emptyvecs V.! label) dp++emptyNBayes :: (Ord label) => DataDesc label -> NBayes label+emptyNBayes desc = NBayes+ { dataDesc = desc+ , labelDist = mempty+ , attrDist = V.fromList [V.fromList [mempty | y<-[1..numAttr desc]] | x<-[1..numLabels desc]]+ }++{-instance (OnlineTrainer NBayesParams (NBayes label) datatype label) => + BatchTrainer NBayesParams (NBayes label) datatype label + where+ + trainBatch = trainOnline++instance (Label label) => EmptyTrainer NBayesParams (NBayes label) label where+ emptyModel desc NBayesParams = NBayes+ { dataDesc = desc+ , labelDist = mempty+ , attrDist = V.fromList [V.fromList [mempty | y<-[1..numAttr desc]] | x<-[1..numLabels desc]]+ }++instance OnlineTrainer NBayesParams (NBayes Int) DPS Int where+-- add1dp desc NBayesUndefined (label,dp) = add1dp desc (emptyNBayes desc) (label,dp)+ add1dp desc modelparams nb (label,dp) = return $+ nb { labelDist = add1sample (labelDist nb) label+ , attrDist = (attrDist nb) V.// [(label,newLabelVec)] + }+ where+ newLabelVec = V.accum add1sample (attrDist nb V.! label) dp-}+ ++-------------------------------------------------------------------------------+-- Classification++instance Classifier (NaiveBayes Int) DPS Int where+-- classify model dp = fst $ argmaxBy compare snd $ probabilityClassify model dp+ classify (SGJust model) dp = mostLikely $ probabilityClassify model dp++instance ProbabilityClassifier (NBayes Int) DPS Int where+ probabilityClassify nb dp = train {-CategoricalParams -}answer+ {-normedAnswer-}+ where+ labelProbGivenDp label = (labelProbGivenNothing label)*(dpProbGivenLabel label)+ labelProbGivenNothing label = pdf (labelDist nb) label+ dpProbGivenLabel label = foldl (*) ({-logFloat-} (1::Double)) (attrProbL label)+ attrProbL label = [ pdf (attrDist nb V.! label V.! attrIndex) di | (attrIndex,di) <- dp]++ answer = [ (label, labelProbGivenDp label) | label <- [0..(numLabels $ dataDesc nb)-1]]+ normedAnswer = zip [0..] $ normalizeL [labelProbGivenDp label | label <- [0..(numLabels $ dataDesc nb)-1]]+++normalizeL :: (Fractional a) => [a] -> [a]+normalizeL xs = map (/s) xs+ where+ s = sum xs+
+ src/HLearn/Models/DistributionContainer.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module HLearn.Models.DistributionContainer+ where++import Debug.Trace+import GHC.Float (double2Float, float2Double)+import Numeric.SpecFunctions (logFactorial)+import Test.QuickCheck hiding (classify)++import qualified Data.Foldable as F+import qualified Data.Map as Map++import Prelude hiding (log)++import HLearn.Algebra+import HLearn.DataContainers+import HLearn.Models.Classification+import HLearn.Models.Distributions++-------------------------------------------------------------------------------++data MaybeDistributionParams baseparams = MaybeDistributionParams baseparams++instance (Model baseparams basedist) => Model (MaybeDistributionParams baseparams) (MaybeDistribution basedist) where+ getparams (MaybeDistribution basedist) = MaybeDistributionParams $ getparams basedist+ +instance (DefaultModel baseparams basedist) => DefaultModel (MaybeDistributionParams baseparams) (MaybeDistribution basedist) where+ defparams = MaybeDistributionParams $ defparams++newtype MaybeDistribution basedist = MaybeDistribution basedist+ deriving (Eq,Show,Read,Semigroup)++instance (Monoid basedist) => Monoid (MaybeDistribution basedist)+ where + mempty = MaybeDistribution mempty+ mappend (MaybeDistribution d1) (MaybeDistribution d2) = MaybeDistribution $ d1 `mappend` d2++instance + ( DefaultHomTrainer baseparams datatype basedist+ , Monoid basedist+ ) => HomTrainer (MaybeDistributionParams baseparams) (Maybe datatype) (MaybeDistribution basedist)+ where+ + train1dp' (MaybeDistributionParams baseparams) Nothing = MaybeDistribution mempty+ train1dp' (MaybeDistributionParams baseparams) (Just x) = MaybeDistribution $ train1dp x+-- instance (DistributionEstimator basedist datatype) => DistributionEstimator (MaybeDistribution basedist) (Maybe datatype) where+-- add1sample (MaybeDistribution basedist) dp = case dp of+-- Nothing -> MaybeDistribution $ basedist+-- Just x -> MaybeDistribution $ add1sample basedist x++instance + ( Distribution basedist sampletype Double+ ) => Distribution (MaybeDistribution basedist) (Maybe sampletype) Double+ where+ + pdf (MaybeDistribution basedist) dp = case dp of+ Nothing -> 1+ Just x -> pdf basedist x+ + cdf (MaybeDistribution basedist) dp = case dp of+ Nothing -> 0+ Just x -> cdf basedist x+ + cdfInverse (MaybeDistribution basedist) prob = Just $ cdfInverse basedist prob++-- drawSample (MaybeDistribution basedist) = do+-- sample <- drawSample basedist+-- return $ Just sample++---------------------------------------+ +newtype ContinuousDistribution basedist = ContinuousDistribution (MaybeDistribution basedist)+ deriving (Eq,Show,Read,Semigroup)++data ContinuousDistributionParams baseparams = ContinuousDistributionParams ++instance Model (ContinuousDistributionParams baseparams) (ContinuousDistribution basedist) where+ getparams _ = ContinuousDistributionParams++instance DefaultModel (ContinuousDistributionParams baseparams) (ContinuousDistribution basedist) where+ defparams = ContinuousDistributionParams++instance + ( DefaultHomTrainer (MaybeDistributionParams baseparams) (Maybe Double) (MaybeDistribution basedist)+ , Monoid basedist+ , Semigroup basedist+ ) => + HomTrainer (ContinuousDistributionParams baseparams) DataItem (ContinuousDistribution basedist) + where++ train1dp' ContinuousDistributionParams dp = case dp of+ Missing -> ContinuousDistribution $ train1dp (Nothing :: Maybe Double)+ Continuous x -> ContinuousDistribution $ train1dp $ Just x+ Discrete x -> error "ContinuousDistribution.add1sample: cannot add discrete"+ ++instance + ( Distribution (MaybeDistribution basedist) (Maybe Double) Double+ , Monoid basedist+ ) => + Distribution (ContinuousDistribution basedist) DataItem Double+ where+ + pdf (ContinuousDistribution basedist) dp = case dp of+ Missing -> pdf basedist (Nothing :: Maybe Double)+ Continuous x -> pdf basedist $ Just x+ Discrete x -> error "ContinuousDistribution.pdf: cannot sample discrete"+ + cdf = error "ContinuousDistribution.cdf: not implemented"++-- cdfInverse = error "ContinuousDistribution.cdfInverse: not implemented"+ cdfInverse (ContinuousDistribution maybedist) prob = case cdfInverse maybedist prob of+ Nothing -> Missing+ Just x -> Continuous x+-- cdfInverse (ContinuousDistribution maybedist) (Discrete x) = error "ContinuousDistribution.cdfInverse: cannot discrete"+-- cdfInverse (ContinuousDistribution maybedist) (Continuous x) = cdfInverse maybedist $ Just x++-- drawSample (ContinuousDistribution basedist) = do+-- sample <- drawSample basedist+-- return $ case sample of+-- Nothing -> Missing+-- Just x -> Continuous x++instance (NFData basedist) => NFData (ContinuousDistribution basedist) where+ rnf (ContinuousDistribution (MaybeDistribution basedist)) = rnf basedist++instance (RegularSemigroup basedist) => RegularSemigroup (ContinuousDistribution basedist) where+ inverse (ContinuousDistribution (MaybeDistribution basedist)) = ContinuousDistribution $ MaybeDistribution $ inverse basedist++instance (Monoid basedist) => Monoid (ContinuousDistribution basedist) where+ mempty = ContinuousDistribution $ MaybeDistribution mempty+ + mappend (ContinuousDistribution (MaybeDistribution basedist1)) (ContinuousDistribution (MaybeDistribution basedist2)) = + ContinuousDistribution $ MaybeDistribution $ mappend basedist1 basedist2+ +-------------------------------------------------------------------------------+-- DistContainer+ +data DistContainer = UnknownDist+ | DistContainer (ContinuousDistribution (Gaussian Double))+ | DistDiscrete (Categorical DataItem Double)+-- | DistContainer Poisson+ deriving (Show{-,Read,Eq-})++data DistContainerParams = DistContainerParams++instance Semigroup DistContainer where+ (<>) = mappend ++instance Monoid DistContainer where+ mempty = UnknownDist+ mappend UnknownDist b = b+ mappend a UnknownDist = a+ mappend (DistContainer a) (DistContainer b) = DistContainer $ mappend a b+ mappend (DistDiscrete a) (DistDiscrete b) = DistDiscrete $ mappend a b -- error "DistContiner.mappend (DistDiscrete) not yet implemented"++instance RegularSemigroup DistContainer where+ inverse UnknownDist = UnknownDist+ inverse (DistContainer x) = DistContainer $ inverse x+ inverse (DistDiscrete x) = DistDiscrete $ inverse x++instance Model DistContainerParams DistContainer where+ getparams _ = DistContainerParams++instance DefaultModel DistContainerParams DistContainer where+ defparams = DistContainerParams++instance HomTrainer DistContainerParams DataItem DistContainer where+-- train1dp' DistContainerParams (Gaussian x) = + train1dp' DistContainerParams Missing = trace "Distribution.add1sample: Warning, cannot determine which type of distribution to select." UnknownDist+ train1dp' DistContainerParams di@(Discrete x) = DistDiscrete $ train1dp di+ train1dp' DistContainerParams di@(Continuous x) = DistContainer $ train1dp di++-- instance DistributionEstimator DistContainer DataItem where+-- {-# INLINE add1sample #-}+-- add1sample UnknownDist di = +-- case di of+-- Missing -> trace "Distribution.add1sample: Warning, cannot determine which type of distribution to select." UnknownDist+-- Discrete x -> DistDiscrete $ add1sample (mempty::Categorical DataItem) di+-- Continuous x -> DistContainer $ add1sample (mempty{-:: ContinuousDistribution (Gaussian Double)-}) di+-- add1sample (DistContainer dist) di = DistContainer $ add1sample dist di+-- add1sample (DistDiscrete dist) di = DistDiscrete $ add1sample dist di++instance Distribution DistContainer DataItem Double where++ {-# INLINE pdf #-}+ pdf UnknownDist _ = trace "Distribution.pdf: Warning sampling from an UnkownDist" 0.3+ pdf (DistContainer dist) di = pdf dist di+ pdf (DistDiscrete dist) di = pdf dist di+ + cdf (DistContainer dist) = cdf dist+ cdf (DistDiscrete dist) = cdf dist+ + cdfInverse (DistContainer dist) = cdfInverse dist+ cdfInverse (DistDiscrete dist) = cdfInverse dist+ +{- drawSample (DistContainer dist) = drawSample dist+ drawSample (DistDiscrete dist) = drawSample dist+ drawSample (UnknownDist) = return Missing-}+-- serializationIndex dist = 0+ +{-instance Binary DistContainer where+ put (UnknownDist) = put (0::Word8)+ put (DistContainer dist) = put (serializationIndex dist) >> put dist+ get = do + tag <- getWord8+ case tag of+ 0 -> return UnknownDist+ 1 -> liftM DistContainer get+ 2 -> liftM DistContainer get-}+ +instance NFData DistContainer where+ rnf (UnknownDist) = ()+ rnf (DistContainer dist) = rnf dist+ rnf (DistDiscrete dist) = rnf dist+ ++-------------------------------------------------------------------------------+-- DiscretePDF+ +-- data DiscretePDF = DiscretePDF+-- { pdf :: Map.Map (Maybe String) Int+-- } +-- deriving (Show,Read,Eq)+-- +-- instance Distribution DiscretePDF DataItem where+-- +-- -- serializationIndex d = 0+-- +-- {-# INLINE add1sample #-}+-- add1sample d Missing = DiscretePDF $ Map.insertWith (+) (Nothing) 1 (pdf d)+-- add1sample d (Discrete x) = DiscretePDF $ Map.insertWith (+) (Just x) 1 (pdf d) -- error "add1sample: cannot add discrete DataItem to (Gaussian Double)"+-- add1sample d (Continuous x) = error "add1sample: cannot add continuous DataItem to DiscretePDF"+-- +-- {-# INLINE pdf #-}+-- pdf d Missing = getProb Nothing $ pdf d+-- pdf d (Discrete x) = getProb (Just x) $ pdf d--error "pdf: cannot sample a discrete DataItem from a (Gaussian Double)"+-- pdf d (Continuous x) = error "pdf: cannot sample a continuous DataItem from a DiscretePDF"+-- +-- getProb :: (Maybe String) -> Map.Map (Maybe String) Int -> Probability+-- getProb key pdf = logFloat $ 0.0001+((fi val)/(fi tot)::Double)+-- where+-- val = case Map.lookup key pdf of+-- Nothing -> 0+-- Just x -> x+-- tot = F.foldl' (+) 0 pdf+-- +-- instance Semigroup DiscretePDF where+-- (<>) d1 d2 = DiscretePDF $ Map.unionWith (+) (pdf d1) (pdf d2)+-- +-- instance Monoid DiscretePDF where+-- mempty = DiscretePDF mempty+-- mappend = (<>)+-- +-- instance NFData DiscretePDF where+-- rnf d = rnf $ pdf d++
+ src/examples/demo.lhs view
@@ -0,0 +1,222 @@+\documentclass{article}+%include polycode.fmt++\usepackage{amsmath,amsthm,amsfonts,amssymb,graphicx,color,hyperref}+\usepackage{chngpage,array}+\usepackage{titling}+\newcommand{\subtitle}[1]{%+ \posttitle{%+ \par\end{center}+ \begin{center}\large#1\end{center}+ \vskip0.5em}%+}+\long\def\ignore#1{}+++\title{Homomorphic Learning: Examples}+\author{Anonymous}++\begin{document}+\maketitle++\section{Introduction}++This file contains two short examples that empirically validate the theoretical claims of the main paper and demonstrates usage of the HLearn library.\footnote{We developed the library in Haskell because of Haskell's speed and strong support for algebraic programming.} First, we run all three cross-validation algorithms side-by-side and show that they get the same exact results. Second, we time these computations. These timing results empirically verify the equations from Table 2 in the main text. This is also how we generated Figure 4.++This document is also valid literate Haskell source code. Compiling and running this file runs the experiments. By modifying this file, you can modify these experiments or create your own. To begin, follow these directions:++\begin{enumerate}+\item Download and install the latest version of the Haskell platform from:+\begin{center}+\url{http://www.haskell.org/platform/}+\end{center}++\item Unzip the file hlearn.tgz contained with the supplemental material++\item Install the HLearn library by running the command: +\begin{verbatim}+./install.sh+\end{verbatim}++\item Compile this document by running:+\begin{verbatim}+ghc Examples.lhs+\end{verbatim}++\item Run the newly generated executable:+\begin{verbatim}+./Demo +RTS -N4+\end{verbatim}+where 4 is the number of cores you want to use for the parallelization++\end{enumerate}++\section{Demo 1: All cross-validation functions get the same results}++\ignore{+\begin{code}+import Criterion.Main+import Criterion.Config+ +import HLearn.Algebra+import HLearn.DataContainers+import HLearn.DataContainers.DS_List+import HLearn.Evaluation.CrossValidation+import HLearn.Models.Classification+import HLearn.Models.Classifiers.NBayes +import HLearn.Models.Distributions+\end{code}+}++The function |cv_same| runs all three versions of cross validation, and prints the results right next to each other. This makes it easy to verify that they all return the exact same value no matter the number of folds. This will happen for every number in |k_list|. In order to change the k values the test runs on, modify |k_list| here:+\begin{code}+k_list = [2..20]+\end{code}++\noindent+The output will look something like:++\begin{verbatim}+k=2+crossValidation: mean=0.7549019607843137+crossValidation_monoid: mean=0.7549019607843137+crossValidation_group: mean=0.7549019607843137+k=3+crossValidation: mean=0.7450980392156863+crossValidation_monoid: mean=0.7450980392156863+crossValidation_group: mean=0.7450980392156863+k=4+crossValidation: mean=0.7466369065216105+crossValidation_monoid: mean=0.7466369065216105+crossValidation_group: mean=0.7466369065216105+k=5+crossValidation: mean=0.7485596320106407+crossValidation_monoid: mean=0.7485596320106407+crossValidation_group: mean=0.7485596320106407+...+\end{verbatim}++\noindent+The code is:+\begin{code}+cv_same dataset = do+ let modelparams = (ClassificationParams (NBayesParams :: NBayesParams Int) (dsDesc dataset))+ sequence_ [ do+ putStrLn $ "k="++show k+ putStr "crossValidation: "+ putStrLn $ "mean=" ++ (show $ m1 $ crossValidation modelparams dataset accuracy k)+ putStr "crossValidation_monoid: "+ putStrLn $ "mean=" ++ (show $ m1 $ crossValidation_monoid modelparams dataset accuracy k)+ putStr "crossValidation_group: "+ putStrLn $ "mean=" ++ (show $ m1 $ crossValidation_group modelparams dataset accuracy k)+ | k<-k_list+ ]+ +\end{code}+\section{Demo 2: Measuring the run times}++Now, we will use the Criterion package\footnote{\url{http://hackage.haskell.org/package/criterion}} to measure the run times of our algorithm. Criterion runs each trial several times to reduce error in the timings, so this may take a while. On the screen, we will get output that looks something like:++\begin{verbatim}+warming up+estimating clock resolution...+mean is 2.117738 us (320001 iterations)+found 20705 outliers among 319999 samples (6.5%)+ 11861 (3.7%) low severe+ 8844 (2.8%) high severe+estimating cost of a clock call...+mean is 67.71065 ns (20 iterations)++benchmarking cv-plain ; 30+collecting 10 samples, 1 iterations each, in estimated 5.493829 s+mean: 477.5195 ms, lb 473.4553 ms, ub 482.8627 ms, ci 0.950+std dev: 7.914094 ms, lb 5.782302 ms, ub 10.16983 ms, ci 0.950+variance introduced by outliers: 9.000%+variance is slightly inflated by outliers++...+\end{verbatim}++\noindent+The output of these tests is stored in a ``summary.csv''. We can plot these results to get a graph like Figure 4 in the main text:++\begin{figure}+\end{figure}++\noindent+You can modify the test parameters by adjusting these options:+\begin{code}++numtrials = 30 -- determines the sample rate along the x-axis; + -- larger is more accurate but will take longer++testconfig = defaultConfig + { cfgPerformGC = ljust True+ , cfgSummaryFile = ljust "summary.csv"+ , cfgSamples = ljust 10+ }++\end{code}+The code is:+\begin{code}+cv_runtimes dataset = defaultMainWith testconfig (return ()) $ mconcat+ [ testL "cv-plain ; " crossValidation+ , testL "cv-plain-par ; " crossValidation_par+ , testL "cv-monoid ; " crossValidation_monoid+ , testL "cv-monoid_par; " crossValidation_monoid_par+ , testL "cv-group ; " crossValidation_group+ , testL "cv-group-par ; " crossValidation_group_par+ ]+ where+ modelparams = (ClassificationParams (NBayesParams :: NBayesParams Int) (dsDesc dataset))+ testL str cv = [ bench (str++show n) $ nf (cv modelparams dataset accuracy) n + | n<-numList dataset+ ]+ numList ds = map (\x-> floor $ (fi x)*((fi $ dsLen ds)/(fi numtrials))) [1..numtrials]++fi = fromIntegral+\end{code}++\section{Main function}+We glue the demos together with this main function:+\begin{code}+main = do+ dataset <- datasetIOint+ cv_same dataset+ cv_runtimes dataset+\end{code}+\noindent+You can perform the demos on different data files by changing below. Note that on smaller data sets (e.g. haberman), the overhead of parallelization is too great and there is no performance gain. On larger data sets, however, the parallelization becomes significant.+\begin{code}+datafile = datafile_audiology -- adjust this line to select the data file++datasetIO :: IO (DS_List String (LDPS String))+datasetIO = loadDataCSV datafile+datasetIOint = fmap ds2intds datasetIO++datafile_haberman = DatafileDesc + { datafilePath = "examples/datasets/haberman.data"+ , datafileLabelColumn = LastC+ , datafileMissingStr = Nothing+ }++datafile_pima = DatafileDesc + { datafilePath = "examples/datasets/pima-indians-diabetes.data"+ , datafileLabelColumn = LastC+ , datafileMissingStr = Nothing+ }+ +datafile_krvskp = DatafileDesc + { datafilePath = "examples/datasets/kr-vs-kp.data"+ , datafileLabelColumn = LastC+ , datafileMissingStr = Nothing+ }+ +datafile_audiology = DatafileDesc -- multiclass, and missing labels+ { datafilePath = "examples/datasets/audiology.standardized.data"+ , datafileLabelColumn = LastC+ , datafileMissingStr = Just "?"+ }+\end{code}++\end{document}