-- |
--
-- Decision tree learning, used in statistics, data mining and machine
-- learning, uses a decision tree as a predictive model which maps
-- observations about an item to conclusions about the item's target
-- value. In these tree structures, leaves represent class labels and
-- branches represent conjunctions of features that lead to those
-- class labels.
--
-- In data mining, a decision tree describes data but not decisions;
-- rather the resulting classification tree can be an input for
-- decision making.
--
-- (<https://en.wikipedia.org/wiki/Decision_tree_learning>,
-- Dec 6 2011)
-- TODO: 'interactive' example
module Data.HInduce.Classifier.DecisionTree
( -- * Decision Tree
DTree(..)
, DTreeAlgebra(..)
, buildDTree
, foldD
, toDot
-- * Deciders
, Decider(..)
, DecideOrd(..)
, DecideSet(..)
, AutoDecide(..)
-- * Composing @Decider@s
--
-- | Though @autoDeciders@ may provide good results, deciders
-- may be out there that do not get generated. These
-- functions let deviate from autoDeciders and compose very
-- specific deciders.
, genOrds
, genOrdsAvg
, genPair
, genMany
, avgF, avgI
-- , genEq -- TODO not of sufficient quality to export now
) where
import Data.Convertible
import Data.HInduce.Classifier
import Data.List
import Data.List.HIUtils
import Data.Maybe
import Data.Ord
import Data.Ratio
import Control.Arrow
import Text.Layout
import Text.Layout.DisplayText
import Text.Layout.DisplayLatex
-- | @decide@ defines the type and semantics of a split. For example,
-- the split \"attr <= 20\" is created by @DecideOrd 20@.
--
-- For every possible value of type @branch@, an actual tree branch
-- may be created. Allowing many distinct values in @branch@ is a bad
-- idea. Too many of these may have little predictive value and
-- exhaust the training database more quickly.
--
-- @decider@: The representation of the decider
-- @attr@: The data it needs
-- @branch@: The key of that leads to a branch
class Decider decider attr branch | decider -> attr branch where
-- | Distinguish values of type @attr@ using @decider@.
decide :: decider -> attr -> branch
-- | Decide with Ord
data (Ord t) => DecideOrd t = DecideOrd t
deriving (Show, Read)
-- | Decide with set ([]) membership, requiring Eq
data (Eq t) => DecideSet t = DecideSet [t]
deriving (Show, Read)
-- | Decider with index for use with lists
data Ixd decider = decider :!! Int
deriving (Show, Read)
instance (Ord attr) => Decider (DecideOrd attr) attr Bool where
decide (DecideOrd pivot) = (<= pivot)
-- <= is easier than < in presence of round-down
instance (Eq attr) => Decider (DecideSet attr) attr Bool where
decide (DecideSet set) = (`elem` set)
instance (Decider decider attr branch) => Decider (Ixd decider) [attr] branch where
decide (decider :!! i) = decide decider . (!! i)
instance (Decider deca attra branch, Decider decb attrb branch) =>
Decider (Either deca decb) (attra, attrb) branch where
decide (Left dec) = decide dec . fst
decide (Right dec) = decide dec . snd
-- | Concept of a decider generator. Not actually used in the code because it would obfuscate a simple computation.
type DeciderGenerator attr decider = [attr] -> [decider]
-- | @AutoDecide@ is used to generate possible splits based on actual
-- attributes, in a straightforward fashion. Think of AutoDecide as a
-- default implementation for @Decider@ generation.
class AutoDecide attr decider | attr -> decider where
autoDeciders :: [attr] -> [decider]
-- | Decider generator implementation for any ordered data; considers all sensible @(<= pivot)@s.
genOrds :: (Ord attr) => [attr] -> [DecideOrd attr]
genOrds window = map DecideOrd $ filter (/= maximum window) window
-- | Decider generator for any ordered data; considers all possible @(<= pivot)@s.
genOrdsAvg :: (Ord attr) => (attr -> attr -> attr) -> [attr] -> [DecideOrd attr]
genOrdsAvg favg window = map DecideOrd $ zipWith favg window' (tail window')
where window' = uniqSort window
-- | Decider generator for any categorical data; considers all possible sets.
genEq :: (Ord attr) => [attr] -> [DecideSet attr]
genEq window = map DecideSet $ subsequences {- ;) -} $ uniqSort window
genPair :: DeciderGenerator attra decidera
-> DeciderGenerator attrb deciderb
-> DeciderGenerator (attra, attrb) (Either decidera deciderb)
genPair p q v = (map Left . p . map fst) v ++ (map Right . q . map snd) v
genMany :: DeciderGenerator attr decider
-> DeciderGenerator [attr] (Ixd decider)
genMany d window =
if not $ all (== length (head window)) $ map length window
then error "Refusing to generate deciders for variable length list attribute"
else [d' :!! i | i <- [0 .. (length$ head window)-1]
, d' <- d (map (!! i) window)]
-- | @avgF a b = (a+b) / 2@, to be used with genOrdsAvg
avgF :: (Fractional a) => a -> a -> a
avgF a b = (a+b) / 2
-- | @avgI a b = (a+b) `div` 2@, to be used with genOrdsAvg
avgI :: (Integral a) => a -> a -> a
avgI a b = (a+b) `div` 2
instance AutoDecide Double (DecideOrd Double) where autoDeciders = genOrdsAvg avgF
instance AutoDecide Float (DecideOrd Float) where autoDeciders = genOrdsAvg avgF
instance AutoDecide Int (DecideOrd Int) where autoDeciders = genOrdsAvg avgI
instance AutoDecide Integer (DecideOrd Integer) where autoDeciders = genOrdsAvg avgI
instance (Integral a) => AutoDecide (Ratio a) (DecideOrd (Ratio a)) where autoDeciders = genOrdsAvg avgF
instance AutoDecide Char (DecideSet Char) where autoDeciders = genEq
instance AutoDecide [Char] (DecideSet [Char]) where autoDeciders = genEq
instance (AutoDecide a xa, AutoDecide b xb) =>
AutoDecide (a,b) (Either xa xb)
where autoDeciders = genPair autoDeciders autoDeciders {- (map Left . autoDeciders . map fst) v ++
(map Right . autoDeciders . map snd) v -}
{-
Note: this does not work because of FunDep in Decider
Every n-tuple type needs a new Either-like type with n constructors.
It's sad.
instance ( AutoDecide a xa
, AutoDecide b xb
, AutoDecide c xc
) =>
AutoDecide (a, b, c) (Either xa (Either xb xc))
where autoDeciders = autoDeciders . map (\(a, b, c) -> (a, (b, c)))
-}
doSplit :: (Decider decider attr branch, Ord branch) =>
(x -> attr) -> decider -> [x] -> [(branch, [x])]
doSplit toattr dec = aggregateAL . map ((decide dec . toattr) &&& id)
doLabel :: (Ord label) => (x -> label) -> [x] -> [(label, [x])]
doLabel tolabel = aggregateAL . map (tolabel &&& id)
measureImpurity :: (Ord label) => (attr -> label) -> [(branch, [attr])] -> Double
measureImpurity tolabel = f . impurityAndCounts
where f :: [(Double, Int)] -> Double
f = sum . map (uncurry (*) . second fromIntegral)
impu = gini . map (length . snd) . doLabel tolabel
impurityAndCounts = map ((impu &&& length) . snd)
-- | Calculate the gini impurity based on the real class label frequencies.
gini :: (Integral i, Fractional f) => [i] -> f
gini = sum . map (\x -> x * (1 - x)) . relFreq
rateSplits :: (Decider decider attr branch,
Ord branch, Ord label) =>
DeciderGenerator attr decider ->
(x -> attr) ->
(x -> label) ->
[x] ->
[(decider, Double)]
rateSplits decGen toattr tolabel window = map (\dec -> (dec,) $ measureImpurity tolabel $ doSplit toattr dec window) . decGen . map toattr $ window
-- | A decision tree data structure that allows arbitrary numbers of
-- children. It has been proven that a binary tree is equally
-- expressive, but considering that decision trees are a 'white box'
-- model, we do not want to limit ourselves to the binary case because
-- other numbers of children may make more sense to humans.
--
-- Converting between binary and arbitrary-child trees is feasible though,
-- but probably not very interesting.
data DTree decider branch label = Node { dDecider :: decider
, dChildren :: [(branch, DTree decider branch label)]
}
| Leaf { dLabel :: label
}
deriving (Show, Eq)
-- | An algebra on decision trees
data DTreeAlgebra decider branch label a =
DTreeAlgebra { fleaf :: label -> a
, fnode :: decider -> [(branch, a)] -> a
}
-- | fold on a DTree
foldD :: DTreeAlgebra dec branch label a -> DTree dec branch label -> a
foldD (DTreeAlgebra fleaf _) (Leaf label) = fleaf label
foldD a@(DTreeAlgebra _ fnode) (Node dec children) = fnode dec $ map (second (foldD a)) children
-- | Prediction is
predictAlgebra :: (Decider dec attr branch, Eq branch) =>
attr -> DTreeAlgebra dec branch label label
predictAlgebra newobservation = DTreeAlgebra { fleaf = fleaf, fnode = fnode }
where
fleaf = id
fnode dec children = error "Incomplete tree"
`fromMaybe` lookup (decide dec newobservation) children
-- | Use a DTree to predict the class label of a (possibly) yet unseen object.
-- Library users: use @classify@.
predict :: (Decider dec attr branch, Eq branch) =>
attr -> DTree dec branch a -> a
predict a = foldD (predictAlgebra a)
instance (Decider decider attr branch, Eq branch) => Classifier (DTree decider branch label) attr label where
classify = flip predict
-- | Learn a Decision Tree classifier based on a list of observations.
buildDTree' :: (Ord label, Ord branch,
AutoDecide attr dec,
Decider dec attr branch) =>
(x -> attr) ->
(x -> label) ->
[x] ->
DTree dec branch label
buildDTree' = buildDTree autoDeciders
buildDTree :: (Ord label, Ord branch, Decider decider attr branch) =>
DeciderGenerator attr decider ->
(x -> attr) ->
(x -> label) ->
[x] ->
DTree decider branch label
buildDTree decGen toAttr toLabel window = case rateSplits decGen toAttr toLabel window of
[] -> case window of
[] -> error "Empty window"
window -> Leaf . majority . map toLabel $ window
splits -> case uniqSort (map toLabel window) of
[x] -> Leaf x
_ -> let
(best, _) = minimumBy (comparing snd) splits
subwins = doSplit toAttr best window
in Node best $ map (second (buildDTree decGen toAttr toLabel)) subwins
-- Rendering --
-- | Render a decision tree to Graphviz Dot format.
toDot :: (Show decider, Show branch, Show label) =>
DTree decider branch label -> String
toDot t = "digraph G {\n" ++
foldD (DTreeAlgebra { fleaf = fleaf, fnode = fnode }) t "dtree" ++
"}\n"
where
fleaf label pfx = pfx++" [label="++show (show label)++"];\n"
fnode dec cs pfx = pfx++" [label="++show (show dec)++" shape=plaintext];\n"++
((concatMap (\(n, (key, f)) ->
let newpfx = pfx ++ "_c"++show n
in pfx++" -> " ++ newpfx ++
"[label="++show (show key)++"];\n" ++
f newpfx
)
$ zip nat0 cs) :: String)
instance (Show decider, Show branch, Show label) =>
Convertible (DTree decider branch label) DisplayText where
safeConvert = Right . DisplayText . printTree 0
where
spcs = flip replicate ' '
printTree indent Node {dDecider=dec,dChildren=children} =
spcs indent ++ "Node " ++ show dec ++ "\n" ++
concatMap (\(k, v) -> spcs (indent+2) ++ show k ++ "\n" ++
printTree (indent + 4) v)
children
printTree indent Leaf {dLabel=label} =
spcs indent ++ "Leaf " ++ show label ++ "\n"
instance (Show decider, Show branch, Show label) =>
Convertible (DTree decider branch label) DisplayLatex where
safeConvert t = Right $ DisplayLatex $ "\\begin{tikzpicture}\n\\" ++
(printTree 0 "" t) ++ ";\\end{tikzpicture}\n"
where
spcs = flip replicate ' '
--printTree :: Int -> String -> DTree dec branch label -> String
printTree indent key Node {dChildren=children, dDecider=dec} =
spcs indent ++ "node{" ++ key ++ show dec ++ "}\n" ++
concatMap (\(k, v) -> "child {\n" ++
printTree (indent + 4) (show k++"\\\\\n") v ++
"}\n"
) children ++
"\n"
printTree indent key Leaf {dLabel=label} =
spcs indent ++ "\\node {" ++ show label ++ "}\n"