module Data.Graph.Analysis.Utils
(
node,
label,
labels,
edge,
eLabel,
addLabels,
addLabels',
getLabels,
getLabels',
filterNodes,
filterNodes',
pathValues,
undir,
oneWay,
mkSimple,
compact,
compact',
compactSame,
nlmap,
delLNodes,
toPosGraph,
getPositions,
createLookup,
setCluster,
reCluster,
reClusterBy,
clusterCount,
single,
longerThan,
addLengths,
longest,
lengthSort,
groupElems,
sortMinMax,
shuffle,
mean,
statistics,
statistics',
fixPoint,
fixPointGraphs,
fixPointBy
) where
import Data.Graph.Analysis.Internal
import Data.Graph.Analysis.Types
import Data.Graph.Inductive.Graph
import Data.GraphViz( dotizeGraph
, Attribute(..)
, Pos(..)
, Point(..))
import Data.List(nub, nubBy, (\\), find, sort, sortBy, group, groupBy)
import Data.Maybe(fromJust)
import Data.Function(on)
import qualified Data.Set as Set
import qualified Data.IntMap as IMap
import Data.IntMap(IntMap)
import Control.Arrow(first, second)
import System.Random(RandomGen, randomR)
labels :: (Graph g) => g a b -> [a]
labels = map label . labNodes
edge :: LEdge b -> Edge
edge (n1,n2,_) = (n1,n2)
eLabel :: LEdge b -> b
eLabel (_,_,b) = b
pathValues :: LPath a -> [LNode a]
pathValues (LP lns) = lns
undir :: (Eq b, DynGraph gr) => gr a b -> gr a b
undir = gmap dupEdges
where
dupEdges (p,n,l,s) = (ps',n,l,ps)
where
ps = nub $ p ++ s
ps' = filter (not . isLoop) ps
isLoop (_,n') = n == n'
oneWay :: (DynGraph g, Eq b) => g a b -> g a b
oneWay = gmap rmPre
where
rmPre (p,n,l,s) = (p \\ s,n,l,s)
mkSimple :: (DynGraph gr) => gr a b -> gr a b
mkSimple = gmap simplify
where
rmLoops n = filter ((/=) n . snd)
rmDups = nubBy ((==) `on` snd)
simpleEdges n = rmDups . rmLoops n
simplify (p,n,l,s) = (p',n,l,s')
where
p' = simpleEdges n p
s' = simpleEdges n s
compact :: (DynGraph gr) => gr a b -> gr a [b]
compact = gmap cmpct
where
cEs = map (swap . second (map fst))
. groupElems snd
cmpct (p,n,l,s) = (cEs p, n, l, cEs s)
compact' :: (DynGraph gr) => gr a b -> gr a Int
compact' = emap length . compact
compactSame :: (Ord b, DynGraph gr) => gr a b -> gr a (Int,b)
compactSame = gmap cmpct
where
cEs = map toAdj . group . sort
toAdj as = let (l,n) = head as in ((length as,l),n)
cmpct (p,n,l,s) = (cEs p, n, l, cEs s)
nlmap :: (DynGraph gr) => (LNode a -> c) -> gr a b -> gr c b
nlmap f = gmap f'
where
f' (p,n,l,s) = (p,n,f (n,l),s)
delLNodes :: (DynGraph gr) => LNGroup a -> gr a b -> gr a b
delLNodes = delNodes . map fst
toPosGraph :: (DynGraph gr, Ord b) => Bool -> gr a b -> gr (PosLabel a) b
toPosGraph dir = nlmap getPos . emap rmAttrs . dotizeGraph dir
where
rmAttrs = snd
isPoint attr = case attr of
Pos{} -> True
_ -> False
getPos (n,(as,l)) = PLabel { xPos = x
, yPos = y
, pnode = n
, plabel = l
}
where
(Pos (PointPos (Point x y))) = fromJust $ find isPoint as
getPositions :: (DynGraph gr, Ord b) => Bool -> gr a b -> [PosLabel a]
getPositions dir = map label . labNodes . toPosGraph dir
createLookup :: [[Node]] -> IntMap Int
createLookup = IMap.fromList . concatMap addCluster . zip [1..] . lengthSort
where
addCluster (k,ns) = map (flip (,) k) ns
setCluster :: (DynGraph gr) => IntMap Int -> gr a b -> gr (GenCluster a) b
setCluster m = nlmap assClust
where
assClust (n,l) = GC (m IMap.! n) l
reCluster :: (DynGraph g) => g (GenCluster a) b -> g (GenCluster a) b
reCluster g = reClusterBy cs' g
where
cnts = IMap.toList $ clusterCount g
cPop = map fst $ sortBy (flip compare `on` snd) cnts
cs' = IMap.fromList $ zip cPop [1..]
reClusterBy :: (DynGraph g) => IntMap Int -> g (GenCluster a) b
-> g (GenCluster a) b
reClusterBy m = nmap newClust
where
newClust c = c { clust = m IMap.! clust c }
clusterCount :: (Graph g) => g (GenCluster a) b -> IntMap Int
clusterCount = ufold incMap IMap.empty
where
incMap (_,_,l,_) = IMap.insertWith ins (clust l) 1
ins _ c = c + 1
single :: [a] -> Bool
single [_] = True
single _ = False
longerThan :: Int -> [a] -> Bool
longerThan n = not . null . drop n
addLengths :: [[a]] -> [(Int,[a])]
addLengths = map ( \ as -> (length as, as))
longest :: [[a]] -> [a]
longest = head . lengthSort
lengthSort :: [[a]] -> [[a]]
lengthSort = map snd . sortBy (flip compare `on` fst) . addLengths
groupElems :: (Ord b) => (a -> b) -> [a] -> [(b,[a])]
groupElems f = map createGroup
. groupBy ((==) `on` fst)
. sortBy (compare `on` fst)
. map addOrd
where
addOrd a = (f a, a)
createGroup bas@((b,_):_) = (b, map snd bas)
createGroup [] = error "Grouping resulted in an empty list!"
sortMinMax :: (Ord a) => [a] -> ([a],a,a)
sortMinMax as = (as',aMin,aMax)
where
aSet = Set.fromList as
as' = Set.toAscList aSet
aMin = Set.findMin aSet
aMax = Set.findMax aSet
shuffle :: (RandomGen g) => g -> [a] -> ([a],g)
shuffle g [] = ([],g)
shuffle g [x] = ([x],g)
shuffle g xs = randomMerge g'' ((shYs,yn),(shZs,zn))
where
((ys, yn), (zs, zn)) = splitAndCount xs (([], 0), ([], 0))
(shYs,g') = shuffle g ys
(shZs,g'') = shuffle g' zs
splitAndCount :: [a] -> (([a], Int), ([a], Int)) -> (([a], Int), ([a], Int))
splitAndCount [] result = result
splitAndCount (x : xs) ((ys, yn), (zs, zn)) =
splitAndCount xs ((x : zs, zn + 1), (ys, yn))
randomMerge :: (RandomGen g) => g -> (([a], Int), ([a], Int)) -> ([a],g)
randomMerge g (([],_),(ys,_)) = (ys,g)
randomMerge g ((xs,_),([],_)) = (xs,g)
randomMerge g ((x:xs,xn),(y:ys,yn)) = if n <= xn
then first (x:) xg
else first (y:) yg
where
xg = randomMerge g' ((xs, xn 1), (y : ys, yn))
yg = randomMerge g' ((x : xs, xn), (ys, yn 1))
(n, g') = randomR (1, xn + yn) g
mean :: [Double] -> Double
mean = go 0 0
where
go :: Double -> Int -> [Double] -> Double
go s l [] = s / fromIntegral l
go s l (x:xs) = go (s+x) (l+1) xs
statistics :: [Double]
-> (Double,Double)
statistics as = (av,stdDev)
where
av = mean as
stdDev = sqrt . mean $ map (sq . subtract av) as
statistics' :: [Int]
-> (Int,Int)
statistics' as = (av', stdDev')
where
(av,stdDev) = statistics $ map fromIntegral as
av' = round av
stdDev' = round stdDev
fixPoint :: (Eq a) => (a -> a) -> a -> a
fixPoint = fixPointBy (==)
fixPointBy :: (a -> a -> Bool) -> (a -> a) -> a -> a
fixPointBy eq f x = if eq x x'
then x'
else fixPointBy eq f x'
where
x' = f x
fixPointGraphs :: (Eq a, Eq b, Graph g) => (g a b -> g a b) -> g a b -> g a b
fixPointGraphs = fixPointBy equal