{-# LANGUAGE BangPatterns #-}
module Math.Clumpiness.Algorithms where
import Data.Maybe
import Data.List
import Data.Tree
import Control.Applicative
import Data.Ratio
import qualified Data.Map as M
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Function (on)
import Math.TreeFun.Tree
import Math.TreeFun.Types
import Math.Clumpiness.Types
geomAvg :: [Double] -> Double
geomAvg xs = product xs ** (1 / genericLength xs)
weigh :: Double -> Double
weigh x = 1 / x
relevantList :: (Eq a) => a -> a -> [(a, Int)] -> [Int]
relevantList p1 p2 l
| p1 `elem` map fst relevantNodes && p2 `elem` map fst relevantNodes
&& (length relevantNodes > 1) = map snd relevantNodes
| otherwise = []
where
relevantNodes = filter (\x -> fst x `elem` [p1, p2]) l
relevantMap :: (Ord a, Ord b)
=> b
-> b
-> PropertyMap a b
-> M.Map a c
-> M.Map a c
relevantMap p1 p2 propertyMap lm
| Set.member p1 relevantProperties && Set.member p2 relevantProperties
&& (M.size relevantNodes > 1) = relevantNodes
| otherwise = M.empty
where
relevantNodes = M.filterWithKey ( \k _ -> maybeToBool
. fmap (F.any (`elem` [p1, p2]))
$ property k ) lm
relevantProperties = Set.fromList
. F.toList
. F.foldl' (Seq.><) Seq.empty
. map fromJust
. filter isJust
. map property
. M.keys
$ lm
maybeToBool Nothing = False
maybeToBool (Just x) = x
property x = M.lookup x propertyMap
relevantMapSame :: (Ord a, Ord b)
=> b
-> PropertyMap a b
-> M.Map a c
-> M.Map a c
relevantMapSame p1 propertyMap lm
| Set.member p1 relevantProperties
&& (not . Set.null . Set.filter (/= p1) $ relevantProperties) = lm
| otherwise = M.empty
where
relevantProperties = Set.fromList
. F.toList
. F.foldl' (Seq.><) Seq.empty
. map fromJust
. filter isJust
. map property
. M.keys
$ lm
property x = M.lookup x $ propertyMap
getNodeClumpiness :: (Ord a, Ord b)
=> b
-> b
-> PropertyMap a b
-> Tree (SuperNode a)
-> Double
getNodeClumpiness _ _ _ (Node {rootLabel = SuperNode {myParent = SuperRoot}})
= 0
getNodeClumpiness p1 p2 propertyMap n
= sum
. map (weigh . fst . snd)
. M.toAscList
. getRelevant (p1 == p2)
. M.mapKeys myRootLabel
. leavesParentMult 1 0
$ n
where
getRelevant True = relevantMapSame
p1
propertyMap
getRelevant False = relevantMap p1 p2 propertyMap
getPropertyClumpiness :: (Ord a, Ord b)
=> b
-> b
-> PropertyMap a b
-> Tree (SuperNode a)
-> Double
getPropertyClumpiness _ _ _ (Node { subForest = [] }) = 0
getPropertyClumpiness p1 p2 propertyMap n@(Node { subForest = xs })
= sum $ getNodeClumpiness p1 p2 propertyMap n : rest
where
rest = map (getPropertyClumpiness p1 p2 propertyMap) xs
generateClumpMap :: (Ord a, Ord b)
=> (b -> Bool)
-> PropertyMap a b
-> Tree (SuperNode a)
-> ClumpList b
generateClumpMap viable originalPropertyMap originalTree =
map getRelationship propertyCompareList
where
propertyCompareList = (\ !p1 !p2 -> (p1, p2))
<$> propertyList
<*> propertyList
getRelationship (!p1, !p2) = divResult clump p1 p2
getRelationship _ = error "Unsupported metric"
divResult f p1 p2 =
if p1 == p2
then
( p1, p2, 1 - ( (geomAvg [divWeight False p1 p2 f p1, divWeight True p1 p2 f p2])
/ numProperties ) )
else
( p1, p2, (geomAvg [divWeight False p1 p2 f p1, divWeight False p1 p2 f p2])
/ numProperties )
divWeight True p1 p2 f p = trivialCheck True p
$ (f p1 p2 * fromRational (1 % numInner'))
* fromRational (numLeaves' % numNotPLeavesF p)
divWeight False p1 p2 f p = trivialCheck False p
$ (f p1 p2 * fromRational (1 % numInner'))
* fromRational (numLeaves' % numPLeavesF p)
trivialCheck True p f = if numNotPLeavesF p > 0 && numPLeavesF p > 1
then if numNotPLeavesF p < numLeaves'
&& numInner' > 0
&& numLeaves' > 0
then f
else 1
else 0
trivialCheck False p f = if numPLeavesF p > 0
&& numInner' > 0
&& numLeaves' > 0
then f
else 0
clump p1 p2 = getPropertyClumpiness p1 p2 propertyMap tree
numPLeavesF p = numPLeaves (F.elem p)
numNotPLeavesF p = numPLeaves (not . Seq.null . Seq.filter (/= p))
numPLeaves f = fromIntegral
. M.size
. M.filter f
$ propertyMap
property x = fromMaybe Seq.empty $ M.lookup x propertyMap
propertyList = filter viable . getProperties $ propertyMap
numProperties = 2
numLeaves' = numLeaves tree
numInner' = numInner tree - 1
propertyMap = M.filterWithKey
(\k _ -> not . Set.member k $ rootLeaves)
originalPropertyMap
rootLeaves = Set.fromList
. map myRootLabel
. getRootLeaves
$ originalTree
tree = filterRootLeaves originalTree