module Data.Graph.Analysis.Utils
(
node,
label,
edge,
eLabel,
addLabels,
filterNodes,
filterNodes',
pathValues,
undir,
oneWay,
nlmap,
AttributeNode,
AttributeEdge,
dotizeGraph,
toPosGraph,
getPositions,
createLookup,
setCluster,
assignCluster,
single,
longerThan,
longest,
groupElems,
sortMinMax,
blockPrint,
shuffle,
mean,
statistics,
statistics',
fixPoint,
fixPointGraphs,
fixPointBy,
sq,
fI
) where
import Data.Graph.Analysis.Types
import Data.Graph.Inductive.Graph
import Data.GraphViz
import Data.List
import Data.Maybe
import Data.Function
import qualified Data.Set as Set
import qualified Data.IntMap as IMap
import Data.IntMap(IntMap)
import Control.Monad
import Control.Arrow
import System.Random
import System.IO.Unsafe(unsafePerformIO)
node :: LNode a -> Node
node = fst
label :: LNode a -> a
label = snd
edge :: LEdge b -> Edge
edge (n1,n2,_) = (n1,n2)
eLabel :: LEdge b -> b
eLabel (_,_,b) = b
addLabels :: (Graph g) => g a b -> [Node] -> [LNode a]
addLabels gr = map (ap (,) (fromJust . lab gr))
filterNodes :: (Graph g) => (g a b -> LNode a -> Bool) -> g a b -> [LNode a]
filterNodes p g = filter (p g) (labNodes g)
filterNodes' :: (Graph g) => (g a b -> Node -> Bool) -> g a b -> [Node]
filterNodes' p g = filter (p g) (nodes g)
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' = snd $ partition 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)
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)
dotizeGraph :: (DynGraph gr, Ord b) => gr a b
-> gr (AttributeNode a) (AttributeEdge b)
dotizeGraph g = unsafePerformIO
$ graphToGraph g gAttrs noAttrs noAttrs
where
gAttrs = []
noAttrs = const []
toPosGraph :: (DynGraph gr, Ord b) => gr a b -> gr (PosLabel a) b
toPosGraph = nlmap getPos . emap rmAttrs . dotizeGraph
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 (PointList ((Point x y):_))) = fromJust $ find isPoint as
getPositions :: (DynGraph gr, Ord b) => gr a b -> [PosLabel a]
getPositions = map label . labNodes . toPosGraph
createLookup :: [[Node]] -> IntMap Int
createLookup = IMap.fromList . concatMap addCluster . zip [1..]
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
assignCluster :: (ClusterLabel a c) => LNode a -> NodeCluster c a
assignCluster nl@(_,a) = C (cluster a) (N nl)
single :: [a] -> Bool
single [_] = True
single _ = False
longerThan :: Int -> [a] -> Bool
longerThan n = not . null . drop n
longest :: [[a]] -> [a]
longest = snd . maximumBy (compare `on` fst)
. map addLength
where
addLength xs = (length xs,xs)
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
blockPrint :: (Show a) => [a] -> String
blockPrint as = init
. unlines $ map unwords lns
where
showl a = let sa = show a in (sa, length sa)
las = map showl as
sidelen :: Double
sidelen = (1.75*) . sqrt . fromIntegral . sum $ map snd las
slen = round sidelen
serr = round $ sidelen/10
lns = unfoldr (takeLen slen serr) las
takeLen :: Int -> Int -> [(String,Int)] -> Maybe ([String],[(String,Int)])
takeLen _ _ [] = Nothing
takeLen len err ((a,l):als) = Just lr
where
lmax = len + err
lr = if l > len
then ([a],als)
else (a:as,als')
(as,als') = takeLine (lmax l 1) als
takeLine :: Int -> [(String,Int)] -> ([String],[(String,Int)])
takeLine len als
| null als = ([],als)
| len <= 0 = ([],als)
| l > len = ([],als)
| otherwise = (a:as,als'')
where
((a,l):als') = als
len' = len l 1
(as,als'') = takeLine len' als'
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 f = fixPointBy (==) f
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 f = fixPointBy equal f
sq :: (Num a) => a -> a
sq x = x * x
fI :: (Num a) => Int -> a
fI = fromIntegral