module Math.Clumpiness.Pinpoint where
import Data.Maybe
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import Data.Monoid
import Data.Tree
import Control.Arrow
import Math.TreeFun.Tree
import Math.TreeFun.Types
import Math.Clumpiness.Types
import Math.Clumpiness.Utilities
import Math.Clumpiness.Algorithms
getValidPropertyMap :: (Ord a, Ord b)
=> Tree (SuperNode a)
-> PropertyMap a b
-> PropertyMap a b
getValidPropertyMap tree = M.filterWithKey (\k _ -> Set.member k vertices)
where
vertices = Set.fromList . map myRootLabel . flatten $ tree
rootSubtree :: Tree (SuperNode a) -> Tree (SuperNode a)
rootSubtree ( Node { rootLabel = SuperNode { myRootLabel = x
, myLeaves = y
}
, subForest = xs
}
) =
Node { rootLabel = SuperNode { myRootLabel = x
, myLeaves = y
, myParent = SuperRoot
}
, subForest = xs
}
viableNode :: (Ord a, Ord b) => (b -> Bool) -> PropertyMap a b -> a -> Bool
viableNode viable propertyMap x = (>= Just 0)
. fmap (Seq.length . fmap viable)
. M.lookup x
$ propertyMap
pinpointRecursion :: (Ord a, Ord b)
=> (b -> Bool)
-> PropertyMap a b
-> Tree (SuperNode a)
-> Seq.Seq (Pinpoint a b)
pinpointRecursion _ _ (Node { subForest = [] }) = Seq.empty
pinpointRecursion viable propertyMap tree@( Node { rootLabel = SuperNode { myRootLabel = label
, myLeaves = descendents
, myParent = parent
}
, subForest = xs }
) =
case newPinpoint of
Nothing -> continue
(Just x) -> x Seq.<| continue
where
continue = mconcat
. map (pinpointRecursion viable validPropertyMap)
$ xs
newPinpoint = case parent of
SuperRoot -> Nothing
_ -> Just
Pinpoint { pinpointLabel = label
, pinpointClumpiness = clump
, pinpointLeaves = relevantLeaves
}
relevantLeaves = Seq.fromList
. filter (viableNode viable validPropertyMap)
. M.keys
$ descendents
clump = Seq.fromList
$ generateClumpMap viable validPropertyMap newTree
validPropertyMap = getValidPropertyMap newTree propertyMap
newTree = filterRootLeaves . rootSubtree $ tree
pinpoint :: (Ord a, Ord b) => Double
-> Int
-> (b -> Bool)
-> PropertyMap a b
-> Tree (SuperNode a)
-> Seq.Seq (Pinpoint a b)
pinpoint minClumpiness minLeaves viable propertyMap tree =
Seq.filter
( \x -> (not . Seq.null . pinpointClumpiness $ x)
&& (Seq.length . pinpointLeaves $ x) >= minLeaves
)
. fmap (\x -> x { pinpointClumpiness = filterClumpSeq
. pinpointClumpiness
$ x
}
)
$ pinpointList
where
pinpointList = pinpointRecursion viable propertyMap tree
validPropertyMap subtree = getValidPropertyMap subtree propertyMap
filterClumpSeq = Seq.filter ((>= minClumpiness) . thd')