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,
addLengths,
longest,
groupElems,
sortMinMax,
blockPrint,
blockPrint',
blockPrintList,
blockPrintList',
blockPrintWith,
blockPrintWith',
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
addLengths :: [[a]] -> [(Int,[a])]
addLengths = map ( \ as -> (length as, as))
longest :: [[a]] -> [a]
longest = snd . maximumBy (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
blockPrint :: (Show a) => [a] -> String
blockPrint = blockPrintWith " "
blockPrint' :: [String] -> String
blockPrint' = blockPrintWith' " "
blockPrintList :: (Show a) => [a] -> String
blockPrintList = blockPrintWith ", "
blockPrintList' :: [String] -> String
blockPrintList' = blockPrintWith' ", "
blockPrintWith :: (Show a) => String -> [a] -> String
blockPrintWith str = blockPrintWith' str . map show
blockPrintWith' :: String -> [String] -> String
blockPrintWith' sep as = init
. unlines $ map unwords' lns
where
lsep = length sep
las = addLengths as
sidelen :: Double
sidelen = (1.75*) . sqrt . fromIntegral . sum $ map fst las
slen = round sidelen
serr = round $ sidelen/10
lns = unfoldr (takeLen slen serr lsep) las
unwords' = concat . intersperse sep
takeLen :: Int -> Int -> Int -> [(Int,String)]
-> Maybe ([String],[(Int,String)])
takeLen _ _ _ [] = Nothing
takeLen len err lsep ((l,a):als) = Just lr
where
lmax = len + err
lr = if l > len
then ([a],als)
else (a:as,als')
(as,als') = takeLine (lmax l lsep) lsep als
takeLine :: Int -> Int -> [(Int,String)] -> ([String],[(Int,String)])
takeLine len lsep als
| null als = ([],als)
| len <= 0 = ([],als)
| l > len = ([],als)
| otherwise = (a:as,als'')
where
((l,a):als') = als
len' = len l lsep
(as,als'') = takeLine len' lsep 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