diff --git a/HLearn-classification.cabal b/HLearn-classification.cabal --- a/HLearn-classification.cabal +++ b/HLearn-classification.cabal @@ -1,38 +1,21 @@ Name: HLearn-classification -Version: 0.0.1 +Version: 1.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: BSD3 --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 +homepage: http://github.com/mikeizbicki/HLearn/ +bug-reports: http://github.com/mikeizbicki/HLearn/issues Library Build-Depends: base >= 3 && < 5, - HLearn-algebra >= 0.0.1, - HLearn-distributions >= 0.0.1, + HLearn-algebra >= 1.0.0, + HLearn-distributions == 1.0.1, ConstraintKinds >= 0.0.1, -- are these really necessary? @@ -40,10 +23,10 @@ dlist >= 0.5, parsec >= 3.1.3, - Safe >= 0.1, + --Safe >= 0.1, bytestring >= 0.10.0.0, primitive >= 0.4.1, - split >= 0.2.1.1, + --split >= 0.2.1.1, list-extras >= 0.4.1, containers >= 0.5, statistics >= 0.10.2, @@ -55,8 +38,10 @@ MonadRandom >= 0.1.6, logfloat >= 0.12.0, math-functions >= 0.1.1, - normaldistribution >= 1.1.0 - + normaldistribution >= 1.1.0, + deepseq >= 1.3.0, + hashable >= 1.1.2.5, + binary >= 0.5.1 hs-source-dirs: src ghc-options: @@ -67,11 +52,31 @@ -O2 -- -fllvm Exposed-modules: - HLearn.Models.Classification - HLearn.Models.Classifiers.NBayes - HLearn.Models.DistributionContainer - HLearn.DataContainers - HLearn.DataContainers.CSVParser - HLearn.DataContainers.DS_List + HLearn.Models.Classifiers + HLearn.Models.Classifiers.Common + HLearn.Models.Classifiers.Bayes + HLearn.Models.Classifiers.NearestNeighbor + HLearn.Models.Classifiers.Perceptron + HLearn.Models.Classifiers.Centroid + HLearn.Models.Classifiers.Experimental.Boosting.FiniteBoost + HLearn.Models.Classifiers.Experimental.Boosting.MonoidBoost + HLearn.Models.Regression.PowerLaw HLearn.Evaluation.CrossValidation - --HLearn.Evaluation.Metrics + HLearn.Evaluation.RSquared + Extensions: + FlexibleInstances + FlexibleContexts + MultiParamTypeClasses + FunctionalDependencies + UndecidableInstances + ScopedTypeVariables + BangPatterns + TypeOperators + GeneralizedNewtypeDeriving + --DataKinds + TypeFamilies + --PolyKinds + StandaloneDeriving + GADTs + KindSignatures + ConstraintKinds diff --git a/src/HLearn/DataContainers.hs b/src/HLearn/DataContainers.hs deleted file mode 100644 --- a/src/HLearn/DataContainers.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# 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 (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 - diff --git a/src/HLearn/DataContainers/CSVParser.hs b/src/HLearn/DataContainers/CSVParser.hs deleted file mode 100644 --- a/src/HLearn/DataContainers/CSVParser.hs +++ /dev/null @@ -1,63 +0,0 @@ -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-} diff --git a/src/HLearn/DataContainers/DS_List.hs b/src/HLearn/DataContainers/DS_List.hs deleted file mode 100644 --- a/src/HLearn/DataContainers/DS_List.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# 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 --- ] diff --git a/src/HLearn/Evaluation/CrossValidation.hs b/src/HLearn/Evaluation/CrossValidation.hs --- a/src/HLearn/Evaluation/CrossValidation.hs +++ b/src/HLearn/Evaluation/CrossValidation.hs @@ -1,37 +1,29 @@ -{-# 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.Foldable as F import qualified Data.Map as Map import qualified Data.Set as S +import qualified Data.Vector as V -- import qualified Data.Vector as V import Debug.Trace -import Data.DList +import qualified Data.DList as D + import HLearn.Algebra -import HLearn.DataContainers -- import HLearn.Evaluation.Metrics -import HLearn.Models.Classification import HLearn.Models.Distributions +import HLearn.Models.Classifiers.Common import qualified Control.ConstraintKinds as CK ------------------------------------------------------------------------------- -- standard k-fold cross validation --- crossValidation :: --- ( HomTrainer modelparams datapoint model --- , PerformanceMeasure perfmeasure model container datapoint ret --- , Semigroup ret +-- lame_crossvalidation :: +-- ( LameTrainer container datapoint model +-- , Monoid ret +-- , Monoid (container datapoint) -- , CK.Functor container -- , CK.FunctorConstraint container datapoint -- , CK.FunctorConstraint container model @@ -40,128 +32,142 @@ -- , 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 +-- ) => container datapoint -> (model -> container datapoint -> ret) -> Int -> ret +-- lame_crossvalidation dataset perfmeasure k = reduce $ do +-- (testdata, trainingdata) <- genTestList datasetL +-- let model = lame_train trainingdata +-- let score = 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 +-- | This is the standard cross-validation technique for use with the HomTrainer type class. It is asymptotically faster than standard k-fold cross-validation (implemented with lame_crossvalidation), yet is guaranteed to get the exact same answer. +crossvalidation :: + ( HomTrainer model + , Monoid ret + , Monoid (container (Datapoint model)) , 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 + , CK.PartitionableConstraint container (Datapoint model) + , F.Foldable container + , Functor container + ) => container (Datapoint model) -> (model -> container (Datapoint model) -> ret) -> Int -> ret +crossvalidation dataset perfmeasure k = reduce $ do + (testdata,model) <- zip datasetL $ listAllBut modelL let score = perfmeasure model testdata return score where + modelL = fmap train datasetL datasetL = CK.partition k dataset + +-- crossvalidation_group :: +-- ( HomTrainer modelparams datapoint model +-- , Group model +-- , Monoid 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 +-- , F.Foldable container +-- , Functor container +-- ) => 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 +-- +-- lame_crossvalidation dataset perfmeasure k = reduce $ do +-- (testdata, trainingdata) <- genTestList datasetL +-- let model = lame_train 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 +type LossFunction model = model -> [Datapoint model] -> Double -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 +leaveOneOut :: [dp] -> [[dp]] +leaveOneOut xs = map (\x -> [x]) xs -crossValidation_monoid_par modelparams dataset perfmeasure k = (parallel reduce) $ do - (testdata,model) <- zip datasetL $ listAllBut modelL - let score = perfmeasure model testdata - return score +folds :: Int -> [dp] -> [[dp]] +folds n xs = [map snd $ filter (\(i,x)->i `mod` n==j) ixs | j<-[0..n-1]] where - modelL = fmap (train' modelparams) datasetL - datasetL = CK.partition k dataset - + ixs = addIndex 0 xs + addIndex i [] = [] + addIndex i (x:xs) = (i,x):(addIndex (i+1) xs) -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 +errorRate :: + ( Classifier model + , Labeled (Datapoint model) + , Eq (Label (Datapoint model)) +-- , Eq (Datapoint (ResultDistribution model)) + ) => LossFunction model +errorRate model dataL = (fromIntegral $ length $ filter (==True) resultsL) / (fromIntegral $ length dataL) where - fullModel = reduce modelL - modelL = fmap (train' modelparams) datasetL - datasetL = CK.partition k dataset + resultsL = map (\(l1,l2) -> l1/=l2) $ zip trueL classifyL + trueL = map getLabel dataL + classifyL = map (classify model . getAttributes) dataL -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 +crossValidate :: (HomTrainer model, Eq (Datapoint model)) => + [[Datapoint model]] -> LossFunction model -> Normal Double +crossValidate xs f = train $ do + testset <- xs + let trainingset = concat $ filter (/=testset) xs + let model = train trainingset + return $ f model testset + +crossValidate_monoid :: (HomTrainer model, Eq (Datapoint model)) => + [[Datapoint model]] -> LossFunction model -> Normal Double +crossValidate_monoid xs f = train $ do + testset <- xs + let trainingset = concat $ filter (/=testset) xs + let model = train trainingset + return $ f model testset + +crossValidate_group :: (HomTrainer model, Group model) => + [[Datapoint model]] -> LossFunction model -> Normal Double +crossValidate_group xs f = train $ do + (testset,testModel) <- modelL + let model = fullmodel <> inverse testModel + return $ f model testset where - fullModel = (parallel reduce) modelL - modelL = fmap (train' modelparams) datasetL - datasetL = CK.partition k dataset + modelL = zip xs $ map train xs + fullmodel = reduce $ map snd modelL -listAllBut2 :: (Semigroup a) => [a] -> [a] + +-- 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 :: (Monoid 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 :: (Monoid 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 + testL i = D.toList $ (D.fromList $ take (i) xs) `mappend` (D.fromList $ drop (i+1) xs) -genTestList :: (Semigroup a) => [a] -> [(a,a)] +genTestList :: (Monoid a) => [a] -> [(a,a)] genTestList xs = zip xs $ listAllBut xs @@ -181,7 +187,7 @@ -- , CK.FoldableConstraint container (LDPS label) -- , CK.FoldableConstraint container [LDPS label] -- , Classifier model DPS label --- ) => PerformanceMeasure Accuracy model container (LDPS label) (Gaussian Double) +-- ) => PerformanceMeasure Accuracy model container (LDPS label) (Normal Double) -- where -- -- measure metricparams model testdata = train1dp ((foldl1 (+) checkedL)/(fromIntegral $ numdp) :: Double) @@ -190,24 +196,30 @@ -- 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 +-- type Labeled dp label = (label,dp) +-- +-- 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] +-- , CK.FoldableConstraint container (Labeled datapoint label) +-- , CK.FoldableConstraint container [Labeled datapoint label] +-- , Classifier model +-- , UnlabeledDatapoint model ~ datapoint +-- , Label model ~ label +-- , Eq label +-- ) => model -> container (Labeled datapoint label) -> (Normal 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 @@ -228,12 +240,12 @@ -- -- instance Monoid CVResults -- --- instance Semigroup CVResults +-- instance Monoid CVResults -- crossValidation :: -- ( NFData model -- , NFData outtype --- , Semigroup outtype +-- , Monoid outtype -- , DataSparse label ds label -- , DataSparse label ds DPS -- , DataSparse label ds (Labeled DPS label) diff --git a/src/HLearn/Evaluation/RSquared.hs b/src/HLearn/Evaluation/RSquared.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Evaluation/RSquared.hs @@ -0,0 +1,16 @@ +module HLearn.Evaluation.RSquared + where + +import HLearn.Algebra +import HLearn.Models.Classifiers.Common + +rsquared :: + ( Floating (Ring model) + , NumDP model + , Regression model + ) => model -> [Datapoint model] -> Ring model +rsquared m xs = 1-ss_err/ss_tot + where + ss_err = sum $ map (\dp -> ((getLabel dp)-(classify m (getAttributes dp)))^^2) xs + ss_tot = sum $ map (\dp -> ((getLabel dp)-yave)^^2) xs + yave = (sum $ map getLabel xs)/(numdp m) diff --git a/src/HLearn/Models/Classification.hs b/src/HLearn/Models/Classification.hs deleted file mode 100644 --- a/src/HLearn/Models/Classification.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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 diff --git a/src/HLearn/Models/Classifiers.hs b/src/HLearn/Models/Classifiers.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Classifiers.hs @@ -0,0 +1,24 @@ +-- | This file exports the most commonly used modules within HLearn-classifiers. Most likely this is the only file you will have to import. + +module HLearn.Models.Classifiers + ( module HLearn.Models.Classifiers.Common + , module HLearn.Models.Classifiers.Bayes + , module HLearn.Models.Classifiers.NearestNeighbor + , module HLearn.Models.Classifiers.Perceptron + , module HLearn.Models.Classifiers.Experimental.Boosting.FiniteBoost + , module HLearn.Models.Classifiers.Experimental.Boosting.MonoidBoost + , module HLearn.Models.Regression.PowerLaw + , module HLearn.Evaluation.CrossValidation + , module HLearn.Evaluation.RSquared + ) + where + +import HLearn.Models.Classifiers.Common +import HLearn.Models.Classifiers.Bayes +import HLearn.Models.Classifiers.NearestNeighbor +import HLearn.Models.Classifiers.Perceptron +import HLearn.Models.Classifiers.Experimental.Boosting.FiniteBoost +import HLearn.Models.Classifiers.Experimental.Boosting.MonoidBoost +import HLearn.Models.Regression.PowerLaw +import HLearn.Evaluation.CrossValidation +import HLearn.Evaluation.RSquared diff --git a/src/HLearn/Models/Classifiers/Bayes.hs b/src/HLearn/Models/Classifiers/Bayes.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Classifiers/Bayes.hs @@ -0,0 +1,65 @@ +-- | Bayesian classification is one of the standard algorithms in machine learning. Typically, we make the naive bayes assumption of assuming that none of our attributes are correlated. The Bayes data type, however, is capable of both naive and non-naive assumptions. + +module HLearn.Models.Classifiers.Bayes + ( Bayes + ) + where + +import Debug.Trace +import qualified Data.Map as Map +import GHC.TypeLits + +import HLearn.Algebra +import HLearn.Models.Distributions +import HLearn.Models.Classifiers.Common + +------------------------------------------------------------------------------- +-- data types + +newtype Bayes label dist = Bayes dist + deriving (Read,Show,Eq,Ord,Monoid,Abelian,Group) + +------------------------------------------------------------------------------- +-- Training + +instance (Monoid dist, HomTrainer dist) => HomTrainer (Bayes label dist) where + type Datapoint (Bayes label dist) = Datapoint dist + train1dp dp = Bayes $ train1dp dp + +------------------------------------------------------------------------------- +-- Classification + +instance Probabilistic (Bayes labelLens dist) where + type Probability (Bayes labelLens dist) = Probability dist + +instance + ( Margin labelLens dist ~ Categorical label prob + , Ord label, Ord prob, Fractional prob + , label ~ Label (Datapoint dist) + , prob ~ Probability (MarginalizeOut labelLens dist) + , Labeled (Datapoint dist) + , Datapoint (MarginalizeOut labelLens dist) ~ Attributes (Datapoint dist) + , PDF (MarginalizeOut labelLens dist) + , PDF (Margin labelLens dist) + , Marginalize labelLens dist + ) => ProbabilityClassifier (Bayes labelLens dist) + where + type ResultDistribution (Bayes labelLens dist) = Margin labelLens dist + + probabilityClassify (Bayes dist) dp = Categorical $ Map.fromList $ map (\k -> (k,prob k)) labelL + where + prob k = pdf labelDist k * pdf (attrDist k) dp + + labelDist = getMargin (undefined::labelLens) dist + attrDist l = condition (undefined::labelLens) l dist + + Categorical labelMap = labelDist + labelL = Map.keys labelMap + +instance + ( ProbabilityClassifier (Bayes labelLens dist) + , Label (Datapoint (Bayes labelLens dist)) ~ Datapoint (Margin labelLens dist) + , Mean (Margin labelLens dist) + ) => Classifier (Bayes labelLens dist) + where + classify model dp = mean $ probabilityClassify model dp diff --git a/src/HLearn/Models/Classifiers/Centroid.hs b/src/HLearn/Models/Classifiers/Centroid.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Classifiers/Centroid.hs @@ -0,0 +1,54 @@ +module HLearn.Models.Classifiers.Centroid + where + +import qualified Data.Vector.Unboxed as VU + +import HLearn.Algebra + +------------------------------------------------------------------------------- +-- data structures + +data Centroid vector = Centroid + { c_numdp :: Ring vector + , vector :: vector + } + +deriving instance (Show (Ring vector), Show vector) => Show (Centroid vector) +deriving instance (Read (Ring vector), Read vector) => Read (Centroid vector) +deriving instance (Eq (Ring vector), Eq vector) => Eq (Centroid vector) +deriving instance (Ord (Ring vector), Ord vector) => Ord (Centroid vector) + +------------------------------------------------------------------------------- +-- algebra + +instance (HasRing vector, Monoid vector) => Monoid (Centroid vector) where + mempty = Centroid 0 mempty + c1 `mappend` c2 = Centroid + { c_numdp = c_numdp c1 + c_numdp c2 + , vector = vector c1 <> vector c2 + } + +instance (HasRing vector) => HasRing (Centroid vector) where + type Ring (Centroid vector) = Ring vector + +instance + ( MetricSpace vector + , VectorSpace vector + ) => MetricSpace (Centroid vector) + where + distance v1 v2 = distance (vector v1 /. c_numdp v1) (vector v2 /. c_numdp v2) + +------------------------------------------------------------------------------- +-- model + +instance (HasRing vector) => NumDP (Centroid vector) where + numdp = c_numdp + +instance + ( HasRing vector + , Monoid vector + ) => HomTrainer (Centroid vector) + where + type Datapoint (Centroid vector) = vector + + train1dp dp = Centroid { c_numdp=1, vector=dp } diff --git a/src/HLearn/Models/Classifiers/Common.hs b/src/HLearn/Models/Classifiers/Common.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Classifiers/Common.hs @@ -0,0 +1,78 @@ +module HLearn.Models.Classifiers.Common + where + +import HLearn.Algebra +import HLearn.Models.Distributions + +------------------------------------------------------------------------------- +-- 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 + +------------------------------------------------------------------------------- +-- Labeled datapoints + +class Labeled dp where + type Label dp + type Attributes dp + + getLabel :: dp -> Label dp + getAttributes :: dp -> Attributes dp + +instance Labeled (label,attr) where + type Label (label,attr) = label + type Attributes (label,attr) = attr + + getLabel = fst + getAttributes = snd + +------------------------------------------------------------------------------- +-- Classification + +class + ( Labeled (Datapoint model) + ) => ProbabilityClassifier model + where + type ResultDistribution model + probabilityClassify :: model -> Attributes (Datapoint model) -> ResultDistribution model + +class MarginClassifier model where + margin :: model -> Attributes (Datapoint model) -> (Ring model, Label (Datapoint model)) + +class + ( Labeled (Datapoint model) + ) => Classifier model + where + classify :: model -> Attributes (Datapoint model) -> Label (Datapoint model) + +-- | this is a default instance that any instance of Classifier should satisfy if it is also an instance of ProbabilityClassifier +-- instance +-- ( Label (Datapoint model) ~ Datapoint (ResultDistribution model) +-- , Mean (ResultDistribution model) +-- , ProbabilityClassifier model +-- ) => Classifier model +-- where +-- classify model dp = mean $ probabilityClassify model dp + +------------------------------------------------------------------------------- +-- Regression + +-- | Regression is classification where the class labels are (isomorphic to) real numbers. The constraints could probably be better specified, but they're close enough for now. +class (Classifier model, Ring model ~ Label (Datapoint model)) => Regression model +instance (Classifier model, Ring model ~ Label (Datapoint model)) => Regression model diff --git a/src/HLearn/Models/Classifiers/Experimental/Boosting/FiniteBoost.hs b/src/HLearn/Models/Classifiers/Experimental/Boosting/FiniteBoost.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Classifiers/Experimental/Boosting/FiniteBoost.hs @@ -0,0 +1,90 @@ +module HLearn.Models.Classifiers.Experimental.Boosting.FiniteBoost + where + +import qualified Data.Map as Map +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector as V + +import HLearn.Algebra +import HLearn.Models.Distributions +import HLearn.Models.Classifiers.Common + +------------------------------------------------------------------------------- +-- data structures + +class FiniteBoostParams p where + type BaseModel p + getModelL :: p -> [BaseModel p] + numModels :: p -> Int + +newtype FiniteBoost params = FiniteBoost + { weights :: V.Vector (Ring (BaseModel params)) + } +-- deriving (Read,Show,Eq,Ord) + +-- type FiniteBoost weight basemodel = RegSG2Group (FiniteBoost' weight basemodel) + +------------------------------------------------------------------------------- +-- algebra + +instance + ( FiniteBoostParams params + , HasRing (BaseModel params) + ) => Monoid (FiniteBoost params) + where + mempty = FiniteBoost $ V.replicate (numModels (undefined::params)) 0 + b1 `mappend` b2 = FiniteBoost $ V.zipWith (+) (weights b1) (weights b2) + +instance + ( FiniteBoostParams params + , HasRing (BaseModel params) + ) => HasRing (FiniteBoost params) + where + type Ring (FiniteBoost params) = Ring (BaseModel params) + +instance + ( FiniteBoostParams params + , HasRing (BaseModel params) + ) => Group (FiniteBoost params) + where + inverse b = FiniteBoost $ V.map negate (weights b) + +------------------------------------------------------------------------------- +-- model + +instance + ( ProbabilityClassifier (BaseModel params) + , HomTrainer (BaseModel params) + , FiniteBoostParams params + , HasRing (BaseModel params) + , Ring (BaseModel params) ~ Probability (ResultDistribution (BaseModel params)) + , Datapoint (ResultDistribution (BaseModel params)) ~ Label (Datapoint (BaseModel params)) + , PDF (ResultDistribution (BaseModel params)) + ) => HomTrainer (FiniteBoost params) + where + type Datapoint (FiniteBoost params) = Datapoint (BaseModel params) + + train1dp dp = FiniteBoost + { weights = V.generate (V.length modelV) (\i -> pdf (probabilityClassify (modelV V.! i) attr) label) + } + where + attr = getAttributes dp + label = getLabel dp + modelV = V.fromList $ getModelL (undefined :: params) + +------------------------------------------------------------------------------- +-- classification + +instance + ( ProbabilityClassifier (BaseModel params) + , Ring (BaseModel params) ~ Ring (ResultDistribution (FiniteBoost params)) + , Module (ResultDistribution (FiniteBoost params)) + , FiniteBoostParams params + ) => ProbabilityClassifier (FiniteBoost params) + where + type ResultDistribution (FiniteBoost params) = ResultDistribution (BaseModel params) + + probabilityClassify (FiniteBoost weights) dp = + reduce $ V.zipWith (.*) weights (fmap (\model -> probabilityClassify model dp) modelL) + where + modelL = V.fromList $ getModelL (undefined :: params) diff --git a/src/HLearn/Models/Classifiers/Experimental/Boosting/MonoidBoost.hs b/src/HLearn/Models/Classifiers/Experimental/Boosting/MonoidBoost.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Classifiers/Experimental/Boosting/MonoidBoost.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DataKinds #-} + +module HLearn.Models.Classifiers.Experimental.Boosting.MonoidBoost + where + +import Control.Applicative +import Data.List +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq +import Data.Sequence (fromList) +import GHC.TypeLits +import Debug.Trace + +import Test.QuickCheck + +import HLearn.Algebra +import HLearn.Models.Distributions.Visualization.Gnuplot +import HLearn.Models.Distributions +import HLearn.Models.Classifiers.Common + +------------------------------------------------------------------------------- +-- data structures + +data MonoidBoost (k::Nat) basemodel = MonoidBoost + { dataL :: Seq.Seq (Datapoint basemodel) + , modelL :: Seq.Seq basemodel + , weightL :: Seq.Seq (Ring basemodel) + , boost_numdp :: Int + } + +deriving instance (Read (Datapoint basemodel), Read (Ring basemodel), Read basemodel) => Read (MonoidBoost k basemodel) +deriving instance (Show (Datapoint basemodel), Show (Ring basemodel), Show basemodel) => Show (MonoidBoost k basemodel) +deriving instance (Eq (Datapoint basemodel), Eq (Ring basemodel), Eq basemodel) => Eq (MonoidBoost k basemodel) +deriving instance (Ord (Datapoint basemodel), Ord (Ring basemodel), Ord basemodel) => Ord (MonoidBoost k basemodel) + +instance + ( HomTrainer basemodel + , Arbitrary (Datapoint basemodel) + , SingI k + ) => Arbitrary (MonoidBoost k basemodel) + where + arbitrary = train <$> listOf arbitrary + +------------------------------------------------------------------------------- +-- algebra + +testassociativity = quickCheck ((\m1 m2 m3 -> m1<>(m2<>m3)==(m1<>m2)<>m3) + :: MonoidBoost 3 (Normal Rational) + -> MonoidBoost 3 (Normal Rational) + -> MonoidBoost 3 (Normal Rational) + -> Bool + ) + +leave :: Int -> Seq.Seq a -> Seq.Seq a +leave k xs = Seq.drop (Seq.length xs - k) xs + +instance + ( HomTrainer basemodel + , SingI k + ) => Monoid (MonoidBoost k basemodel) + where + mempty = MonoidBoost mempty mempty mempty 0 + mb1 `mappend` mb2 = MonoidBoost + { dataL = dataL' + , modelL = modelL mb1 <> newmodel <> modelL mb2 + , weightL = mempty + , boost_numdp = boost_numdp' + } + where + boost_numdp' = boost_numdp mb1 + boost_numdp mb2 + dataL' = dataL mb1 <> dataL mb2 + + newmodel = Seq.fromList $ newmodels $ leave (2*k) (dataL mb1) <> Seq.take (2*k) (dataL mb2) + newmodels xs = if Seq.length xs >= modelsize + then (train (Seq.take modelsize xs)):(newmodels $ Seq.drop 1 xs) + else [] + + modelsize = 2*k+1 + k = fromIntegral $ fromSing (sing::Sing k) +-- frontL mb = Seq.take k $ dataL mb +-- backL mb = Seq.drop (Seq.length (dataL mb) - k) (dataL mb) + +------------------------------------------------------------------------------- +-- model + +instance + ( SingI k + , HomTrainer basemodel + ) => HomTrainer (MonoidBoost k basemodel) + where + type Datapoint (MonoidBoost k basemodel) = Datapoint basemodel + train1dp dp = MonoidBoost + { dataL = mempty |> dp + , modelL = mempty + , weightL = mempty + , boost_numdp = 1 + } + +------------------------------------------------------------------------------- +-- classification + +instance Probabilistic (MonoidBoost k basemodel) where + type Probability (MonoidBoost k basemodel) = Probability basemodel + +instance + ( ProbabilityClassifier basemodel + , Monoid (ResultDistribution basemodel) + ) => ProbabilityClassifier (MonoidBoost k basemodel) + where + type ResultDistribution (MonoidBoost k basemodel) = ResultDistribution basemodel + probabilityClassify mb dp = reduce $ fmap (flip probabilityClassify dp) $ modelL mb + +------------------------------------------------------------------------------- +-- distribution + +instance + ( PDF basemodel + , Fractional (Probability basemodel) + ) => PDF (MonoidBoost k basemodel) + where + pdf mb dp = ave $ fmap (flip pdf dp) $ modelL mb + where + ave xs = (F.foldl1 (+) xs) / (fromIntegral $ Seq.length xs) + +instance + ( PlottableDistribution basemodel + , Fractional (Probability basemodel) + ) => PlottableDistribution (MonoidBoost k basemodel) + where + + samplePoints mb = concat $ map samplePoints $ F.toList $ modelL mb + plotType _ = plotType (undefined :: basemodel) + diff --git a/src/HLearn/Models/Classifiers/NBayes.hs b/src/HLearn/Models/Classifiers/NBayes.hs deleted file mode 100644 --- a/src/HLearn/Models/Classifiers/NBayes.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# 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 - diff --git a/src/HLearn/Models/Classifiers/NearestNeighbor.hs b/src/HLearn/Models/Classifiers/NearestNeighbor.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Classifiers/NearestNeighbor.hs @@ -0,0 +1,67 @@ +module HLearn.Models.Classifiers.NearestNeighbor + where + +import Control.Applicative +import qualified Data.Foldable as F +import Data.List + +import HLearn.Algebra +import HLearn.Models.Distributions +import HLearn.Models.Classifiers.Common + +------------------------------------------------------------------------------- +-- data structures + +newtype NaiveNN container label dp = NaiveNN + { getcontainer :: container (label,dp) } +-- deriving (Read,Show,Eq,Ord,Semigroup,Monoid,RegularSemigroup) + +deriving instance (Show (container (label,dp))) => Show (NaiveNN container label dp) + +------------------------------------------------------------------------------- +-- algebra + +instance (Monoid (container (label,dp))) => Monoid (NaiveNN container label dp) where + mempty = NaiveNN mempty + mappend nn1 nn2 = NaiveNN $ getcontainer nn1 `mappend` getcontainer nn2 + +------------------------------------------------------------------------------- +-- model + +instance + ( Applicative container + , Monoid (container (label,dp)) + ) => HomTrainer (NaiveNN container label dp) + where + type Datapoint (NaiveNN container label dp) = (label,dp) + train1dp ldp = NaiveNN $ pure ldp + +------------------------------------------------------------------------------- +-- classification + +instance (Probabilistic (NaiveNN container label dp)) where + type Probability (NaiveNN container label dp) = Double + +neighborList :: + ( F.Foldable container + , MetricSpace dp + , Ord (Ring dp) + ) => dp -> NaiveNN container label dp -> [(label,dp)] +neighborList dp (NaiveNN dps) = sortBy f $ F.toList dps + where + f (_,dp1) (_,dp2) = compare (distance dp dp1) (distance dp dp2) + + +instance + ( Ord label + , label ~ Label (label,dp) + , F.Foldable container + , MetricSpace dp + , Ord (Ring dp) + ) => ProbabilityClassifier (NaiveNN container label dp) + where + type ResultDistribution (NaiveNN container label dp) = Categorical label (Ring dp) + + probabilityClassify nn dp = trainW (map (\(l,dp) -> (1,l)) $ take k $ neighborList dp nn) + where + k = 1 diff --git a/src/HLearn/Models/Classifiers/Perceptron.hs b/src/HLearn/Models/Classifiers/Perceptron.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Classifiers/Perceptron.hs @@ -0,0 +1,63 @@ +module HLearn.Models.Classifiers.Perceptron + where + +import qualified Data.Map as Map +import qualified Data.Vector.Unboxed as VU + +import HLearn.Algebra +import HLearn.Models.Distributions +import HLearn.Models.Classifiers.Common +import HLearn.Models.Classifiers.Centroid +import HLearn.Models.Classifiers.NearestNeighbor + +------------------------------------------------------------------------------- +-- data structures + +data Perceptron label dp = Perceptron + { centroids :: Map.Map label (Centroid dp) + } +-- deriving (Read,Show,Eq,Ord) + +deriving instance (Show (Centroid dp), Show label) => Show (Perceptron label dp) + +------------------------------------------------------------------------------- +-- algebra + +instance (Ord label, Monoid (Centroid dp)) => Monoid (Perceptron label dp) where + mempty = Perceptron mempty + p1 `mappend` p2 = Perceptron + { centroids = Map.unionWith (<>) (centroids p1) (centroids p2) + } + +------------------------------------------------------------------------------- +-- model + +instance + ( Monoid dp + , HasRing dp + , Ord label + ) => HomTrainer (Perceptron label dp) + where + type Datapoint (Perceptron label dp) = (label,dp) + + train1dp (label,dp) = Perceptron $ Map.singleton label $ train1dp dp + +------------------------------------------------------------------------------- +-- classification + +instance (HasRing dp) => Probabilistic (Perceptron label dp) where + type Probability (Perceptron label dp) = Ring dp + +instance + ( Ord label + , Ord (Ring dp) + , MetricSpace (Centroid dp) + , Monoid dp + , HasRing dp + ) => ProbabilityClassifier (Perceptron label dp) + where + type ResultDistribution (Perceptron label dp) = (Categorical label (Ring dp)) + + probabilityClassify model dp = probabilityClassify nn (train1dp (dp) :: Centroid dp) + where + nn = NaiveNN $ Map.toList $ centroids model diff --git a/src/HLearn/Models/DistributionContainer.hs b/src/HLearn/Models/DistributionContainer.hs deleted file mode 100644 --- a/src/HLearn/Models/DistributionContainer.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# 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 - - diff --git a/src/HLearn/Models/Regression/PowerLaw.hs b/src/HLearn/Models/Regression/PowerLaw.hs new file mode 100644 --- /dev/null +++ b/src/HLearn/Models/Regression/PowerLaw.hs @@ -0,0 +1,112 @@ +module HLearn.Models.Regression.PowerLaw + where + +import Control.DeepSeq + +import HLearn.Algebra +import HLearn.Models.Classifiers.Common +import HLearn.Evaluation.RSquared + +------------------------------------------------------------------------------- +-- data types + +data PowerLaw ring = PowerLaw + { n :: !ring + , lnxlny :: !ring + , lnx :: !ring + , lnx2 :: !ring + , lny :: !ring + } + deriving (Read,Show,Eq,Ord) + +instance (NFData ring) => NFData (PowerLaw ring) where + rnf pl = deepseq (n pl) + $ deepseq (lnxlny pl) + $ deepseq (lnx pl) + $ deepseq (lnx2 pl) + $ rnf (lny pl) + +------------------------------------------------------------------------------- +-- algebra + +instance (Num ring) => Monoid (PowerLaw ring) where + mempty = PowerLaw 0 0 0 0 0 + a `mappend` b = PowerLaw + { n = n a + n b + , lnxlny = lnxlny a + lnxlny b + , lnx = lnx a + lnx b + , lnx2 = lnx2 a + lnx2 b + , lny = lny a + lny b + } + +instance (Num ring) => Abelian (PowerLaw ring) + +instance (Num ring) => Group (PowerLaw ring) where + inverse a = PowerLaw + { n = -(n a) + , lnxlny = -(lnxlny a) + , lnx = -(lnx a) + , lnx2 = -(lnx2 a) + , lny = -(lny a) + } + +instance (Num ring) => HasRing (PowerLaw ring) where + type Ring (PowerLaw ring) = ring + +instance (Num ring) => Module (PowerLaw ring) where + r .* pl = PowerLaw + { n = r*(n pl) + , lnxlny = r*(lnxlny pl) + , lnx = r*(lnx pl) + , lnx2 = r*(lnx2 pl) + , lny = r*(lny pl) + } + +------------------------------------------------------------------------------- +-- training + +data Coord ring = Coord {x::ring,y::ring} + +instance Labeled (Coord ring) where + type Label (Coord ring)= ring + type Attributes (Coord ring)= ring + getLabel = y + getAttributes = x + +instance (Num ring) => NumDP (PowerLaw ring) where + numdp = n + +instance (Floating ring) => HomTrainer (PowerLaw ring) where + type Datapoint (PowerLaw ring) = Coord ring -- (ring,ring) + train1dp dp = PowerLaw + { n = 1 + , lnxlny = log x * log y + , lnx = log x + , lnx2 = (log x)^2 + , lny = log y + } + where + x = getAttributes dp + y = getLabel dp + +------------------------------------------------------------------------------- +-- classification + +instance (Floating ring) => Classifier (PowerLaw ring) where + classify m x = (exp a)*(x**b) + where + b = ((n m)*(lnxlny m)-(lnx m)*(lny m))/((n m)*(lnx2 m)-(lnx m)^2) + a = ((lny m)-b*(lnx m))/(n m) + +------------------------------------------------------------------------------- +-- examples + +-- this example follows a perfect power law, so result1 == 1.0 +dataset1 = [Coord x (x^3) | x<-[1..100]] +model1 = train dataset1 :: PowerLaw Double +result1 = rsquared model1 dataset1 + +-- mostly powerlaw, but not exact; result2 == 0.943; done in parallel just for fun +dataset2 = [Coord 1 2, Coord 1.5 3, Coord 5.5 15, Coord 2 3, Coord 4 13] +model2 = parallel train dataset2 :: PowerLaw Double +result2 = rsquared model2 dataset2 diff --git a/src/examples/demo.lhs b/src/examples/demo.lhs deleted file mode 100644 --- a/src/examples/demo.lhs +++ /dev/null @@ -1,222 +0,0 @@ -\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}