diff --git a/Data/Graph/Analysis.hs b/Data/Graph/Analysis.hs --- a/Data/Graph/Analysis.hs +++ b/Data/Graph/Analysis.hs @@ -29,7 +29,11 @@ -- $analfuncts lengthAnalysis, classifyRoots, - interiorChains + inaccessibleNodes, + interiorChains, + collapseAndUpdate, + collapseAndUpdate', + levelGraphFromRoot ) where import Data.Graph.Analysis.Internal @@ -41,9 +45,13 @@ import Data.Graph.Inductive.Graph -import Data.Maybe(mapMaybe) +import Data.List(find) +import Data.Maybe(mapMaybe, maybe) import qualified Data.Map as M +import Data.Map(Map) import qualified Data.Set as S +import Data.Set(Set) +import Control.Arrow(first) import Data.Version(showVersion) import qualified Paths_Graphalyze as Paths(version) @@ -122,26 +130,38 @@ {- | Compare the actual roots in the graph with those that are expected - (i.e. those in 'wantedRoots'). Returns (in order): + (i.e. those in 'wantedRootNodes'). Returns (in order): - * Those roots that are expected (i.e. elements of 'wantedRoots' + * Those roots that are expected (i.e. elements of 'wantedRootNodes' that are roots). * Those roots that are expected but not present (i.e. elements of - 'wantedRoots' that /aren't/ roots. + 'wantedRootNodes' that /aren't/ roots. * Unexpected roots (i.e. those roots that aren't present in - 'wantedRoots'). + 'wantedRootNodes'). -} -classifyRoots :: (Ord n) => GraphData n e -> ([LNode n], [LNode n], [LNode n]) +classifyRoots :: GraphData n e -> (Set Node, Set Node, Set Node) classifyRoots gd = (areWanted, notRoots, notWanted) where - wntd = S.fromList $ wantedRoots gd - rts = S.fromList $ applyAlg rootsOf gd - areWanted = S.toList $ S.intersection wntd rts - notRoots = S.toList $ S.difference wntd rts - notWanted = S.toList $ S.difference rts wntd + wntd = S.fromList $ wantedRootNodes gd + rts = S.fromList $ applyAlg rootsOf' gd + areWanted = S.intersection wntd rts + notRoots = S.difference wntd rts + notWanted = S.difference rts wntd +-- | Find the nodes that are not reachable from the expected roots +-- (i.e. those in 'wantedRootNodes'). +inaccessibleNodes :: GraphData n e -> Set Node +inaccessibleNodes gd = allNs `S.difference` reachableNs + where + -- We can't use accessibleOnlyFrom' on notWanted from + -- classifyRoots, as there might be nodes that are roots but not + -- detectable (e.g. a loop). + allNs = S.fromList $ applyAlg nodes gd + rs = S.fromList $ wantedRootNodes gd + reachableNs = applyAlg accessibleFrom' gd rs + -- | Only return those chains (see 'chainsIn') where the non-initial -- nodes are /not/ expected roots. interiorChains :: (Eq n, Eq e) => GraphData n e -> [LNGroup n] @@ -151,3 +171,37 @@ rts = wantedRoots gd interiorRoot = any (`elem` rts) . tail +-- | As with 'collapseAndReplace', but also update the +-- 'wantedRootNodes' to contain the possibly compressed nodes. +-- Since the datums they refer to may no longer exist (as they are +-- compressed), 'unusedRelationships' is set to @[]@. +collapseAndUpdate :: (Ord n) => [AGr n e -> [(NGroup, n)]] + -> GraphData n e -> GraphData n e +collapseAndUpdate fs = fst . collapseAndUpdate' fs + +-- | As with 'collapseAndUpdate', but also includes a lookup 'Map' +-- from the old label to the new. +collapseAndUpdate' :: (Ord n) => [AGr n e -> [(NGroup, n)]] + -> GraphData n e -> (GraphData n e, Map n n) +collapseAndUpdate' fs gd = (gd', repLookup) + where + gr = graph gd + (gr', reps) = collapseAndReplace' fs gr + lns' = mkNodeMap $ labNodes gr' + reps' = map (first S.fromList) reps + rs = S.fromList $ wantedRootNodes gd + replace r = maybe r ((M.!) lns' . snd) + $ find (S.member r . fst) reps' + gd' = gd { graph = gr' + , wantedRootNodes = S.toList $ S.map replace rs + , unusedRelationships = [] + } + nlLookup = M.fromList $ labNodes gr + getLs = mapMaybe (flip M.lookup nlLookup) + repLookup = M.fromList . spreadOut $ map (first getLs) reps + +-- | As with 'levelGraph', but use the expected roots rather than the +-- actual roots. +levelGraphFromRoot :: (Ord n) => GraphData n e + -> GraphData (GenCluster n) e +levelGraphFromRoot gd = updateGraph (levelGraphFrom (wantedRootNodes gd)) gd diff --git a/Data/Graph/Analysis/Algorithms/Clustering.hs b/Data/Graph/Analysis/Algorithms/Clustering.hs --- a/Data/Graph/Analysis/Algorithms/Clustering.hs +++ b/Data/Graph/Analysis/Algorithms/Clustering.hs @@ -7,6 +7,9 @@ Clustering and grouping algorithms that are graph-invariant and require no user intervention. + + For a clustering algorithm that works only on directed graphs, see + @levelGraph@ in "Data.Graph.Analysis.Algorithms.Directed". -} module Data.Graph.Analysis.Algorithms.Clustering ( -- * Clustering Algorithms @@ -21,7 +24,8 @@ CNodes, collapseGraph, collapseGraphBy, - collapseGraphBy', + collapseAndReplace, + collapseAndReplace', trivialCollapse, ) where @@ -34,9 +38,10 @@ import Data.List(foldl', tails, delete, intersect) import Data.Function(on) +import Data.Maybe(fromJust) import qualified Data.Set.BKTree as BK import Data.Set.BKTree(BKTree, Metric(..)) -import Control.Arrow(first, second) +import Control.Arrow(first, second, (***)) import System.Random(RandomGen, randomR) -- ----------------------------------------------------------------------------- @@ -276,6 +281,10 @@ It may be possible to extend this to a clustering algorithm by collapsing low density regions into high density regions. + + If providing custom collapsing functions, you should ensure that + for each function, it is not possible to have a recursive situation + where a collapsed node keeps getting collapsed to itself. -} -- | A collapsed node contains a list of nodes that it represents. @@ -292,24 +301,32 @@ -- | Use the given functions to determine which nodes to collapse. collapseGraphBy :: (DynGraph gr) => [gr (CNodes a) b -> [NGroup]] -> gr a b -> gr (CNodes a) b -collapseGraphBy fs = collapseGr fs' +collapseGraphBy fs = fst . collapseGr fs' where fs' = map (map (flip (,) Nothing) .) fs -- | Use the given functions to determine which nodes to collapse, -- with a new label to represent the collapsed nodes. -collapseGraphBy' :: (DynGraph gr) => [gr a b -> [(NGroup, a)]] - -> gr a b -> gr a b -collapseGraphBy' fs = unCollapse . collapseGr fs' +collapseAndReplace :: (DynGraph gr) => [gr a b -> [(NGroup, a)]] + -> gr a b -> gr a b +collapseAndReplace fs = fst . collapseAndReplace' fs + +-- | As with 'collapseAndReplace', but also return the +-- @('NGroup', a)@'s calculated with the functions provided. +collapseAndReplace' :: (DynGraph gr) => [gr a b -> [(NGroup, a)]] + -> gr a b -> (gr a b, [(NGroup, a)]) +collapseAndReplace' fs = (unCollapse *** strip) . collapseGr fs' where - -- convert gr a b -> [(NGroup a)] to + -- convert gr a b -> [(NGroup, a)] to -- gr (CNodes a) b -> [(NGroup, Maybe a)] - fs' = map ((.nmap head) . (map (second Just) .)) fs + fs' = map ((. nmap head) . (map (second Just) .)) fs + -- Strip the Maybes + strip = map (second fromJust) -- | Collapse the graph. collapseGr :: (DynGraph gr) => [gr (CNodes a) b -> [(NGroup, Maybe a)]] - -> gr a b -> gr (CNodes a) b -collapseGr fs g = foldl' collapseAllBy (makeCollapsible g) fs + -> gr a b -> (gr (CNodes a) b, [(NGroup, Maybe a)]) +collapseGr fs g = foldl' collapseAllBy (makeCollapsible g, []) fs -- | Return @'True'@ if the collapsed graph is either a singleton node -- or else isomorphic to the original graph (i.e. not collapsed at all). @@ -347,16 +364,21 @@ c' = (p,n1,l1++l2,s) -- | Collapse the list of nodes down to one node. -collapseAll :: (DynGraph gr) => gr (CNodes a) b - -> (NGroup, Maybe a) +collapseAll :: (DynGraph gr) => (NGroup, Maybe a) -> gr (CNodes a) b -collapseAll g ([],_) = g -- These two cases -collapseAll g ([_],_) = g -- shouldn't occur. -collapseAll g ((n:ns),ma) = adj $ foldl' collapser g ns + -> gr (CNodes a) b +collapseAll ([],_) g = g -- This case shouldn't occur +collapseAll ([n],ma) g = maybeAdjustLabel n ma g +collapseAll ((n:ns),ma) g = foldl' collapser g' ns where - adj = maybe id (adjustLabel n) ma - collapser g' = collapse g' n + g' = maybeAdjustLabel n ma g + collapser = flip collapse n +maybeAdjustLabel :: (DynGraph gr) => Node -> Maybe a -> gr (CNodes a) b + -> gr (CNodes a) b +maybeAdjustLabel n = maybe id (adjustLabel n) + +-- | Replace the label of the provided node with @[a]@. adjustLabel :: (DynGraph gr) => Node -> a -> gr (CNodes a) b -> gr (CNodes a) b adjustLabel n a g = c & g' @@ -365,12 +387,13 @@ c = (p,n,[a],s) -- | Collapse all results of the given function. -collapseAllBy :: (DynGraph gr) => gr (CNodes a) b +collapseAllBy :: (DynGraph gr) => (gr (CNodes a) b, [(NGroup, Maybe a)]) -> (gr (CNodes a) b -> [(NGroup, Maybe a)]) - -> gr (CNodes a) b -collapseAllBy g f = case (filter (not . single . fst) $ f g) of + -> (gr (CNodes a) b, [(NGroup, Maybe a)]) +collapseAllBy g f = case (filter (not . null . fst) $ f (fst g)) of [] -> g -- We re-evaluate the function in case -- the original results used nodes that -- have been collapsed down. - (nsr:_) -> collapseAllBy (collapseAll g nsr) f + (nsr:_) -> second (nsr :) + $ collapseAllBy (first (collapseAll nsr) g) f diff --git a/Data/Graph/Analysis/Algorithms/Directed.hs b/Data/Graph/Analysis/Algorithms/Directed.hs --- a/Data/Graph/Analysis/Algorithms/Directed.hs +++ b/Data/Graph/Analysis/Algorithms/Directed.hs @@ -25,8 +25,16 @@ coreOf, -- * Clustering levelGraph, + levelGraphFrom, + minLevel, + -- * Node accessibility + accessibleFrom, + accessibleFrom', + accessibleOnlyFrom, + accessibleOnlyFrom', -- * Other - leafMinPaths + leafMinPaths, + leafMinPaths' ) where import Data.Graph.Analysis.Types @@ -36,10 +44,13 @@ import Data.Graph.Inductive.Query.BFS(esp) import Data.List(minimumBy, unfoldr) +import Data.Maybe(fromMaybe) import Data.Function(on) import qualified Data.Map as M +import Data.Map(Map) import qualified Data.Set as S import Data.Set(Set) +import Control.Monad(ap) -- ----------------------------------------------------------------------------- {- $ends @@ -161,29 +172,49 @@ {- | Cluster the nodes in the graph based upon how far away they are - from a root node. Root nodes are in the cluster labelled "0", - nodes in level "n" are at least /n/ edges away from a root node. + from a root node. Root nodes are in the cluster labelled 'minLevel', + nodes in level \"n\" (with @n > minLevel@) are at least /n/ edges away + from a root node. -} -levelGraph :: (Ord a) => (DynGraph g) => g a b -> g (GenCluster a) b -levelGraph g = gmap addLbl g +levelGraph :: (Ord a, DynGraph g) => g a b -> g (GenCluster a) b +levelGraph g = levelGraphFrom (rootsOf' g) g + +-- | As with 'levelGraph' but provide a custom grouping of 'Node's to +-- consider as the \"roots\". +levelGraphFrom :: (Ord a, DynGraph g) => NGroup -> g a b + -> g (GenCluster a) b +levelGraphFrom rs g = gmap addLbl g where - lvls = zip [0..] . map S.toList $ graphLevels g + lvls = zip [minLevel..] . map S.toList $ graphLevels rs g lvMap = M.fromList $ concatMap (\(l,ns) -> map (flip (,) l) ns) lvls - mkLbl n l = GC { clust = lvMap M.! n + mkLbl n l = GC { clust = getLevel n , nLbl = l } addLbl (p,n,l,s) = (p, n, mkLbl n l, s) + -- Have to consider unaccessible nodes. + getLevel n = fromMaybe (pred minLevel) $ n `M.lookup` lvMap + +-- | The level of the nodes in the 'NGroup' provided to +-- 'levelGraphFrom' (or the root nodes for 'levelGraph'). A level +-- less than this indicates that the node is not accessible. +minLevel :: Int +minLevel = 0 + type NSet = Set Node -- | Obtain the levels in the graph. -graphLevels :: (DynGraph g) => g a b -> [NSet] -graphLevels g = unfoldr getNextLevel - (S.fromList $ rootsOf' g, g) +graphLevels :: (Graph g) => NGroup -> g a b -> [NSet] +graphLevels = flip graphLevels' . S.fromList -getNextLevel :: (DynGraph g) => (NSet, g a b) +graphLevels' :: (Graph g) => g a b -> NSet -> [NSet] +graphLevels' g = unfoldr getNextLevel . flip (,) g + +-- | The @(NSet, g a b)@ parameters are the current nodes to be +-- starting with in the current graph. +getNextLevel :: (Graph g) => (NSet, g a b) -> Maybe (NSet, (NSet, g a b)) getNextLevel (ns,g) | S.null ns = Nothing @@ -191,8 +222,8 @@ where g' = delNodes (S.toList ns) g ns' = flip S.difference ns - . S.unions . S.toList - $ S.map getSuc ns + . S.unions . map getSuc + $ S.toList ns getSuc = S.fromList . suc g -- ----------------------------------------------------------------------------- @@ -208,6 +239,14 @@ rs = rootsOf' g ls = leavesOf' g +{- | + The shortest paths to each of the leaves in the graph (excluding + singletons). This can be used to obtain an indication of the + overall height/depth of the graph. + -} +leafMinPaths' :: (Graph g) => g a b -> [NGroup] +leafMinPaths' = map (map node) . leafMinPaths + -- | Given the list of roots in this graph, find the shortest path to -- this leaf node. lfMinPth :: (Graph g) => g a b -> [Node] -> Node -> LNGroup a @@ -216,3 +255,39 @@ . minimumBy (compare `on` fst) . addLengths $ map (\ r -> esp r l g) rs + +-- ----------------------------------------------------------------------------- + +-- | Find all 'Node's that can be reached from the provided 'Node's. +accessibleFrom :: (Graph g) => g a b -> [Node] -> [Node] +accessibleFrom g = S.toList . accessibleFrom' g . S.fromList + +-- | Find all 'Node's that can be reached from the provided nodes +-- using 'Set's rather than lists. +accessibleFrom' :: (Graph g) => g a b -> Set Node -> Set Node +accessibleFrom' g = S.unions . graphLevels' g + +-- | Find those 'Node's that are reachable only from the provided +-- 'Node's. +accessibleOnlyFrom :: (Graph g) => g a b -> [Node] -> [Node] +accessibleOnlyFrom g = S.toList . accessibleOnlyFrom' g . S.fromList + +-- | Find those 'Node's that are reachable only from the provided +-- 'Node's, using 'Set's rather than lists. +accessibleOnlyFrom' :: (Graph g) => g a b -> Set Node -> Set Node +accessibleOnlyFrom' g = M.keysSet + . fixPoint keepOnlyInternal + . setKeys (pre g) + . accessibleFrom' g + +-- | Pseudo-inverse of 'M.keysSet'. +setKeys :: (Ord a) => (a -> b) -> Set a -> Map a b +setKeys f = M.fromDistinctAscList . map (ap (,) f) . S.toAscList + +-- | Removing nodes which have predecessors outside of this Map. +keepOnlyInternal :: Map Node NGroup -> Map Node NGroup +keepOnlyInternal = M.filter =<< onlyInternalPred + +-- | Are these predecessor nodes all found within this Map? +onlyInternalPred :: Map Node NGroup -> NGroup -> Bool +onlyInternalPred = all . flip M.member diff --git a/Data/Graph/Analysis/Internal.hs b/Data/Graph/Analysis/Internal.hs --- a/Data/Graph/Analysis/Internal.hs +++ b/Data/Graph/Analysis/Internal.hs @@ -17,6 +17,8 @@ import Data.Either(partitionEithers) import qualified Data.Map as M import Data.Map(Map) +import qualified Data.Set as S +import Data.Set(Set) import Data.Maybe(fromJust) import Control.Arrow((***)) import Control.Monad(ap) @@ -39,11 +41,61 @@ applyBoth :: (a -> b) -> (a,a) -> (b,b) applyBoth f = f *** f +-- | Create a lookup 'Map' to determine which 'Node' has a specific label. mkNodeMap :: (Ord a) => [LNode a] -> Map a Node mkNodeMap = M.fromList . map swap +spreadOut :: [([a], b)] -> [(a,b)] +spreadOut = concatMap spread + where + spread (as, b) = map (flip (,) b) as + -- ----------------------------------------------------------------------------- +-- Items re-exported in Utils (needed by Types, so defined here to +-- avoid cycles). +-- | The node number of an 'LNode'. +node :: LNode a -> Node +node = fst + +-- | The label of an 'LNode'. +label :: LNode a -> a +label = snd + +-- | Find all the labelled nodes in the graph that match the given predicate. +filterNodes :: (Graph g) => (g a b -> LNode a -> Bool) -> g a b -> [LNode a] +filterNodes p g = filter (p g) (labNodes g) + +-- | Find all the nodes in the graph that match the given predicate. +filterNodes' :: (Graph g) => (g a b -> Node -> Bool) -> g a b -> [Node] +filterNodes' p g = filter (p g) (nodes g) + +-- | Obtain the labels for a list of 'Node's. +-- It is assumed that each 'Node' is indeed present in the given graph. +addLabels :: (Graph g) => g a b -> [Node] -> [LNode a] +addLabels gr = map (ap (,) (fromJust . lab gr)) + +-- | Obtain the labels for a 'Set' of 'Node's. +-- It is assumed that each 'Node' is indeed present in the given graph. +addLabels' :: (Ord a, Graph g) => g a b -> Set Node -> Set (LNode a) +addLabels' gr = S.map (ap (,) (fromJust . lab gr)) + +-- | Obtain the labels for a list of 'Node's. +-- It is assumed that each 'Node' is indeed present in the given graph. +getLabels :: (Graph g) => g a b -> [Node] -> [a] +getLabels gr = map label . addLabels gr + +-- | Obtain the labels for a list of 'Node's. +-- It is assumed that each 'Node' is indeed present in the given graph. +getLabels' :: (Ord a, Graph g) => g a b -> Set Node -> Set a +getLabels' gr = S.fromList -- List fusion might make this more + -- efficient than multiple S.map's with the + -- resulting internal re-organisation. + . getLabels gr + . S.toList + +-- ----------------------------------------------------------------------------- + -- | A relationship between two nodes with a label. type Rel n e = (n, n, e) @@ -79,11 +131,3 @@ dupSwap e@(x,y,l) | x == y = [e] | otherwise = [e, (y,x,l)] graphEdges = dupSwap' gEdges - --- This is needed by Types, so it's defined here and then exported by --- Utils to avoid cyclic problems. - --- | Obtain the labels for a list of 'Node's. --- It is assumed that each 'Node' is indeed present in the given graph. -addLabels :: (Graph g) => g a b -> [Node] -> [LNode a] -addLabels gr = map (ap (,) (fromJust . lab gr)) diff --git a/Data/Graph/Analysis/Reporting.hs b/Data/Graph/Analysis/Reporting.hs --- a/Data/Graph/Analysis/Reporting.hs +++ b/Data/Graph/Analysis/Reporting.hs @@ -16,7 +16,9 @@ DocElement(..), DocInline(..), GraphSize(..), - DocGraph, + DocGraph(..), + VisParams(..), + VisProperties(..), -- * Helper functions -- $utilities addLegend, @@ -30,12 +32,12 @@ import Data.Graph.Inductive(Node) import Data.GraphViz -import Data.Maybe(isJust, fromJust, catMaybes) import Data.Time(getZonedTime, zonedTimeToLocalTime, formatTime) import Control.Exception.Extensible(SomeException(..), tryJust) import System.Directory(createDirectoryIfMissing) -import System.FilePath((), (<.>)) +import System.FilePath((), makeRelative) import System.Locale(defaultTimeLocale) +import Control.Monad(liftM, when) -- ----------------------------------------------------------------------------- @@ -52,19 +54,20 @@ instance of 'DocumentGenerator'. -} data Document = Doc { -- | Document location - rootDirectory :: FilePath, - fileFront :: String, + rootDirectory :: FilePath + , fileFront :: String -- | The sub-directory of 'rootDirectory', -- where graphs are to be created. - graphDirectory :: FilePath, + , graphDirectory :: FilePath -- | Pre-matter - title :: DocInline, - author :: String, - date :: String, + , title :: DocInline + , author :: String + , date :: String -- | Main-matter - legend :: [(DocGraph, DocInline)], - content :: [DocElement] + , legend :: [(DocGraph, DocInline)] + , content :: [DocElement] } + deriving (Eq, Ord, Show, Read) -- | Represents the class of document generators. class DocumentGenerator dg where @@ -76,11 +79,9 @@ docExtension :: dg -> String -- | Representation of a location, either on the internet or locally. -data Location = Web String | File FilePath - -instance Show Location where - show (Web url) = url - show (File fp) = fp +data Location = Web String + | File FilePath + deriving (Eq, Ord, Show, Read) -- | Elements of a document. data DocElement = Section DocInline [DocElement] @@ -89,6 +90,7 @@ | Itemized [DocElement] | Definitions [(DocInline, DocInline)] | GraphImage DocGraph + deriving (Eq, Ord, Show, Read) -- | Inline elements of a document. data DocInline = Text String @@ -98,12 +100,47 @@ | Emphasis DocInline | DocLink DocInline Location | DocImage DocInline Location + deriving (Eq, Ord, Show, Read) -- | Specify the 'DotGraph' to turn into an image, its filename (sans -- extension) and its caption. The 'DotGraph' should not have a -- 'Size' set. -type DocGraph = (FilePath, DocInline, DotGraph Node) +data DocGraph = DG { -- | What name to provide the image file + -- (without an extension). + imageFile :: FilePath + , description :: DocInline + , dotGraph :: DotGraph Node + } + deriving (Eq, Ord, Show, Read) +-- | Defines the parameters used for creating visualisations of +-- graphs. +data VisParams = VParams { -- | Root directory of the document. + rootDir :: FilePath + -- | Image sub-directory. + , graphDir :: FilePath + -- | The default visualisation. + , defaultImage :: VisProperties + -- | If @'Just' vp'@, then a larger + -- visualisation is linked to from the + -- default one. + , largeImage :: Maybe VisProperties + -- | Should the Dot source code be saved as well? + , saveDot :: Bool + } + deriving (Eq, Ord, Show, Read) + +-- | A specification on how to visualise a 'DocGraph'. +data VisProperties = VProps { size :: GraphSize + , format :: GraphvizOutput + } + deriving (Eq, Ord, Show, Read) + +-- | Specify the size the 'DotGraph' should be at. +data GraphSize = GivenSize Point -- ^ Specify the size to use. + | DefaultSize -- ^ Let GraphViz choose an appropriate size. + deriving (Eq, Ord, Show, Read) + -- ----------------------------------------------------------------------------- {- $utilities @@ -111,29 +148,30 @@ -} -- | Create the legend section and add it to the document proper. -addLegend :: FilePath -> FilePath -> Document -> IO Document -addLegend fp gfp d = do mLg <- legendToElement fp gfp $ legend d - let es = content d - es' = maybe es (flip (:) es) mLg - return $ d { legend = [] - , content = es' - } +addLegend :: FilePath -> FilePath -> VisProperties + -> Document -> IO Document +addLegend fp gfp vp d = do mLg <- legendToElement fp gfp vp $ legend d + let es = content d + es' = maybe es (flip (:) es) mLg + return $ d { legend = [] + , content = es' + } -legendToElement :: FilePath -> FilePath -> [(DocGraph, DocInline)] +legendToElement :: FilePath -> FilePath -> VisProperties + -> [(DocGraph, DocInline)] -> IO (Maybe DocElement) -legendToElement _ _ [] = return Nothing -legendToElement fp gfp ls = do mDefs <- mapM (uncurry (legToDef fp gfp)) ls - let defs = catMaybes mDefs - df = Definitions defs - sec = Section (Text "Legend") [df] - return $ Just sec - -legToDef :: FilePath -> FilePath -> DocGraph -> DocInline - -> IO (Maybe (DocInline, DocInline)) -legToDef fp gfp dg def = fmap (fmap (flip (,) def)) img - where - img = graphImage fp gfp DefaultSize Png "png" DocImage dg +legendToElement _ _ _ [] = return Nothing +legendToElement fp gfp vp ls = do defs <- mapM (uncurry (legToDef fp gfp vp)) ls + let df = Definitions defs + return $ Just $ Section (Text "Legend") [df] +legToDef :: FilePath -> FilePath -> VisProperties + -> DocGraph -> DocInline + -> IO (DocInline, DocInline) +legToDef fp gfp vp dg def = liftM (flip (,) def) + $ graphImage' fp gfp vp' dg + where + vp' = vp { size = DefaultSize } -- | Return today's date as a string, e.g. \"Monday 1 January, 2000\". -- This arbitrary format is chosen as there doesn't seem to be a way @@ -158,62 +196,73 @@ isRight (Right _) = True isRight _ = False --- | Attempts to creates a png file (with the given filename in the --- given directory) from the graph using the given attributes. --- If the second set of attributes is not 'Nothing', then the first --- image links to the second. The whole result is wrapped in a --- 'Paragraph'. -createGraph :: FilePath -> FilePath -> GraphSize -> Maybe GraphSize - -> DocGraph -> IO (Maybe DocElement) -createGraph fp gfp s ms (fn,inl,ag) - = do eImg <- gI s Png "png" DocImage fn inl Nothing - if isJust eImg - then case ms of - Nothing -> rt eImg - (Just s') -> rt =<< gI s' Svg "svg" DocLink fn' (toImg eImg) eImg - else return Nothing - where - fn' = fn ++ "-large" - i2e i = Just (i,Paragraph [i]) - rt = return . fmap snd - -- This is safe because of the isJust above. - toImg = fst . fromJust - gI a o e ln nm lb fl = do mImg <- graphImage fp gfp a o e ln (nm,lb,ag) - case mImg of - Nothing -> return fl - (Just img) -> return $ i2e img +-- | Attempts to create image files (with the given filename in the +-- given directory) from the graph. If the second 'VisProperties' +-- not 'Nothing', then the first image links to the second. The +-- whole result is wrapped in a 'Paragraph'. 'unDotPath' is applied +-- to the filename in the 'DocGraph'. +createGraph :: VisParams -- ^ Visualisation parameters. + -> DocGraph + -> IO DocElement +createGraph params dg + = do when (saveDot params) (graphImage rDir gDir vpD dgD >> return ()) + dl <- graphImage' rDir gDir vp dg' + dl' <- maybe return tryImg mvp dl + return $ Paragraph [dl'] + where + rDir = rootDir params + gDir = graphDir params + vp = defaultImage params + vpD = VProps { size = DefaultSize + , format = Canon + } + mvp = largeImage params + dg' = dg { imageFile = unDotPath $ imageFile dg } + dgL = checkLargeFilename vp mvp dg' + dgD = checkFilename vp vpD "dot" dg' + tryImg vp' di = liftM (either (const di) (DocLink di)) + $ graphImage rDir gDir vp' dgL --- | Create the inline image/link from the given DocGraph. -graphImage :: FilePath -> FilePath -> GraphSize - -> GraphvizOutput -> FilePath - -> (DocInline -> Location -> DocInline) - -> DocGraph -> IO (Maybe DocInline) -graphImage fp gfp s output ext link (fn,inl,dg) - = do created <- runGraphviz dg' output filename' - if created - then return (Just img) - else return Nothing - where - dg' = setSize s dg - fn' = unDotPath fn - filename = gfp fn' <.> ext - filename' = fp filename - loc = File filename - img = link inl loc +-- | If both output formats are the same, then the larger image needs +-- a different filename. +checkLargeFilename :: VisProperties -> Maybe VisProperties + -> DocGraph -> DocGraph +checkLargeFilename _ Nothing dg = dg +checkLargeFilename vp1 (Just vp2) dg = checkFilename vp1 vp2 "large" dg --- | Specify the size the 'DotGraph' should be at. -data GraphSize = GivenSize Point -- ^ Specify the size to use. - | DefaultSize -- ^ Let GraphViz choose an appropriate size. +checkFilename :: VisProperties -> VisProperties -> String + -> DocGraph -> DocGraph +checkFilename vp1 vp2 s dg + | format vp1 == format vp2 = dg { imageFile = imageFile dg ++ '-' : s } + | otherwise = dg +graphImage :: FilePath -> FilePath -> VisProperties -> DocGraph + -> IO (Either DocInline Location) +graphImage rDir gDir vp dg = liftM (either' Text (File . fixPath)) + $ addExtension (runGraphviz dot) + (format vp) + filename + where + dot = setSize vp $ dotGraph dg + filename = rDir gDir imageFile dg + fixPath = makeRelative rDir + +graphImage' :: FilePath -> FilePath -> VisProperties -> DocGraph + -> IO DocInline +graphImage' rDir gDir vp dg = liftM (either id f) + $ graphImage rDir gDir vp dg + where + f = DocImage (description dg) + -- | Add a 'GlobalAttribute' to the 'DotGraph' specifying the given size. -setSize :: GraphSize -> DotGraph a -> DotGraph a -setSize DefaultSize g = g -setSize (GivenSize p) g = g { graphStatements = stmts' } - where - stmts = graphStatements g - stmts' = stmts { attrStmts = a : attrStmts stmts } - a = GraphAttrs [s] - s = Size p +setSize :: VisProperties -> DotGraph a -> DotGraph a +setSize vp g = case size vp of + DefaultSize -> g + (GivenSize s) -> g { graphStatements = setS s} + where + setS s = stmts { attrStmts = sizeA s : attrStmts stmts } + stmts = graphStatements g + sizeA s = GraphAttrs [Size s] -- | Using a 6:4 ratio, create the given 'Point' representing -- width,height from the width. @@ -227,3 +276,8 @@ where replace '.' = '-' replace c = c + +-- | Map either element of an 'Either'. +either' :: (a -> c) -> (b -> d) -> Either a b -> Either c d +either' fl _ (Left a) = Left $ fl a +either' _ fr (Right b) = Right $ fr b diff --git a/Data/Graph/Analysis/Reporting/Pandoc.hs b/Data/Graph/Analysis/Reporting/Pandoc.hs --- a/Data/Graph/Analysis/Reporting/Pandoc.hs +++ b/Data/Graph/Analysis/Reporting/Pandoc.hs @@ -21,13 +21,15 @@ pandocHtml, pandocLaTeX, pandocRtf, - pandocMarkdown + pandocMarkdown, + alsoSaveDot ) where -- TODO : the ability to create multiple files. import Data.Graph.Analysis.Reporting +import Data.GraphViz.Commands(GraphvizOutput(Png, Svg)) import Text.Pandoc import Data.List(intersperse) @@ -44,30 +46,32 @@ -} pandocHtml :: PandocDocument -pandocHtml = pd { writer = writeHtmlString - , extension = "html" - , header = "" -- Header will be included - , extGraphSize = Just DefaultSize +pandocHtml = pd { writer = writeHtmlString + , extension = "html" + , templateName = "html" + , extGraphProps = Just VProps { size = DefaultSize + , format = Svg + } } pandocLaTeX :: PandocDocument -pandocLaTeX = pd { writer = writeLaTeX - , extension = "tex" - , header = defaultLaTeXHeader +pandocLaTeX = pd { writer = writeLaTeX + , extension = "tex" + , templateName = "latex" -- 4.5" should be less than \textwidth in LaTeX. - , graphSize = createSize 4.5 + , graphProps = defaultProps { size = createSize 4.5 } } pandocRtf :: PandocDocument pandocRtf = pd { writer = writeRTF , extension = "rtf" - , header = defaultRTFHeader + , templateName = "rtf" } pandocMarkdown :: PandocDocument pandocMarkdown = pd { writer = writeMarkdown , extension = "text" - , header = "" + , templateName = "markdown" } -- ----------------------------------------------------------------------------- @@ -79,32 +83,41 @@ -- | Definition of a Pandoc Document. Size measurements are in inches, -- and a 6:4 ratio is used for width:length. data PandocDocument = PD { -- | The Pandoc document style - writer :: WriterOptions -> Pandoc -> String, + writer :: WriterOptions -> Pandoc -> String -- | The file extension used - extension :: FilePath, - -- | The Pandoc header to use - header :: String, + , extension :: FilePath + -- | Which template to get. + , templateName :: String -- | Size of graphs to be produced. - graphSize :: GraphSize, + , graphProps :: VisProperties -- | Optional size of external linked graphs. - extGraphSize :: Maybe GraphSize + , extGraphProps :: Maybe VisProperties + -- | Should the Dot source code be saved as well? + , keepDot :: Bool } -- | Some default sizes. Note that all other fields of 'PandocDocument' -- still need to be defined. pd :: PandocDocument -pd = PD { writer = undefined, - extension = undefined, - header = undefined, - graphSize = defaultSize, - extGraphSize = Nothing +pd = PD { writer = undefined + , extension = undefined + , templateName = undefined + , graphProps = defaultProps + , extGraphProps = Nothing + , keepDot = False } +-- | Also save the generated Dot code to file when creating visualisations. +alsoSaveDot :: PandocDocument -> PandocDocument +alsoSaveDot p = p { keepDot = True } + defaultWidth :: Double defaultWidth = 10 -defaultSize :: GraphSize -defaultSize = createSize defaultWidth +defaultProps :: VisProperties +defaultProps = VProps { size = createSize defaultWidth + , format = Png + } instance DocumentGenerator PandocDocument where createDocument = createPandoc @@ -119,34 +132,30 @@ -- | Used when traversing the document structure. data PandocProcess = PP { secLevel :: Int - , filedir :: FilePath - , graphdir :: FilePath - , grSize :: GraphSize - , eGSize :: Maybe GraphSize + , visParams :: VisParams } + deriving (Eq, Ord, Show, Read) -- | Start with a level 1 heading. defaultProcess :: PandocProcess -defaultProcess = PP { secLevel = 1 - , graphdir = undefined - , filedir = undefined - , grSize = undefined - , eGSize = undefined +defaultProcess = PP { secLevel = 1 + , visParams = undefined } -- | Create the document. createPandoc :: PandocDocument -> Document -> IO (Maybe FilePath) -createPandoc p d = do created <- tryCreateDirectory dir +createPandoc p d = do Right template <- getDefaultTemplate (templateName p) + created <- tryCreateDirectory dir -- If the first one fails, so will this one. tryCreateDirectory $ dir gdir if not created then failDoc - else do d' <- addLegend dir gdir d + else do d' <- addLegend dir gdir (graphProps p) d elems <- multiElems pp $ content d' case elems of Just es -> do let es' = htmlAuthDt : es pnd = Pandoc meta es' - doc = convert pnd + doc = convert template pnd wr <- tryWrite doc case wr of (Right _) -> success @@ -160,13 +169,14 @@ meta = makeMeta (title d) auth dt -- Html output doesn't show date and auth anywhere by default. htmlAuthDt = htmlInfo auth dt - pp = defaultProcess { filedir = dir - , graphdir = gdir - , grSize = graphSize p - , eGSize = extGraphSize p - } - opts = writerOptions { writerHeader = (header p) } - convert = writer p opts + pp = defaultProcess { visParams = vp } + vp = VParams { rootDir = dir + , graphDir = gdir + , defaultImage = graphProps p + , largeImage = extGraphProps p + , saveDot = keepDot p + } + convert t = writer p (writerOptions {writerTemplate = t}) file = dir fileFront d <.> extension p tryWrite :: String -> IO (Either SomeException ()) tryWrite = try . writeFile file @@ -180,8 +190,8 @@ -} -- | The meta information -makeMeta :: DocInline -> String -> String -> Meta -makeMeta t a = Meta (inlines t) [a] +makeMeta :: DocInline -> String -> String -> Meta +makeMeta tle a t = Meta (inlines tle) [[Str a]] [Str t] -- | Html output doesn't show the author and date; use this to print it. htmlInfo :: String -> String -> Block @@ -236,16 +246,11 @@ return (fmap (return . BulletList) elems') elements _ (Definitions defs) = return . Just . return . DefinitionList - $ map (inlines *** (return . Plain . inlines)) + $ map (inlines *** ((:[]) . (:[]) + . Plain . inlines)) defs -elements p (GraphImage dg) = do el <- createGraph (filedir p) - (graphdir p) - (grSize p) - (eGSize p) dg - case el of - Nothing -> return Nothing - Just img -> elements p img +elements p (GraphImage dg) = elements p =<< createGraph (visParams p) dg -- | Concatenate the result of multiple calls to 'elements'. multiElems :: PandocProcess -> [DocElement] -> IO (Maybe [Block]) diff --git a/Data/Graph/Analysis/Types.hs b/Data/Graph/Analysis/Types.hs --- a/Data/Graph/Analysis/Types.hs +++ b/Data/Graph/Analysis/Types.hs @@ -22,6 +22,8 @@ LNGroup, -- * Functions on @GraphData@. wantedRoots, + addRoots, + addRootsBy, applyAlg, applyDirAlg, mergeUnused, @@ -74,6 +76,22 @@ gns = S.fromList $ nodes g rs = S.fromList $ wantedRootNodes gd rs' = S.toList $ gns `S.intersection` rs + +-- | Add extra expected root nodes. No checks are made that these +-- are valid 'Node' values. +addRoots :: GraphData n e -> NGroup -> GraphData n e +addRoots gd ns = gd { wantedRootNodes = S.toList rs' } + where + ns' = S.fromList ns + rs = S.fromList $ wantedRootNodes gd + rs' = rs `S.union` ns' + +-- | Use a filtering function to find extra root nodes to add. +addRootsBy :: (LNode n -> Bool) -> GraphData n e -> GraphData n e +addRootsBy p gd = addRoots gd rs' + where + p' _ = p + rs' = map node $ applyAlg (filterNodes p') gd -- | Apply an algorithm to the data to be analysed. applyAlg :: (AGr n e -> a) -> GraphData n e -> a diff --git a/Data/Graph/Analysis/Utils.hs b/Data/Graph/Analysis/Utils.hs --- a/Data/Graph/Analysis/Utils.hs +++ b/Data/Graph/Analysis/Utils.hs @@ -11,14 +11,17 @@ ( -- * Graph functions -- ** Data extraction -- $extracting - node, - label, + node, -- Re-exported from Internal + label, -- Re-exported from Internal labels, edge, eLabel, - addLabels, -- Re-exported from Internal - filterNodes, - filterNodes', + addLabels, -- Re-exported from Internal + addLabels', -- Re-exported from Internal + getLabels, -- Re-exported from Internal + getLabels', -- Re-exported from Internal + filterNodes, -- Re-exported from Internal + filterNodes', -- Re-exported from Internal pathValues, -- ** Graph manipulation undir, @@ -82,14 +85,6 @@ -- $extracting Extracting data from graphs. --- | The node number of an 'LNode'. -node :: LNode a -> Node -node = fst - --- | The label of an 'LNode'. -label :: LNode a -> a -label = snd - -- | The labels of all nodes in a tree. labels :: (Graph g) => g a b -> [a] labels = map label . labNodes @@ -102,14 +97,6 @@ eLabel :: LEdge b -> b eLabel (_,_,b) = b --- | Find all the labelled nodes in the graph that match the given predicate. -filterNodes :: (Graph g) => (g a b -> LNode a -> Bool) -> g a b -> [LNode a] -filterNodes p g = filter (p g) (labNodes g) - --- | Find all the nodes in the graph that match the given predicate. -filterNodes' :: (Graph g) => (g a b -> Node -> Bool) -> g a b -> [Node] -filterNodes' p g = filter (p g) (nodes g) - -- | Extract the actual 'LNode's from an 'LPath'. pathValues :: LPath a -> [LNode a] pathValues (LP lns) = lns @@ -171,7 +158,7 @@ compact' = emap length . compact -- | Compact the graph by adjoining identical duplicate edges. -compactSame :: (Ord b) => (DynGraph gr) => gr a b -> gr a (Int,b) +compactSame :: (Ord b, DynGraph gr) => gr a b -> gr a (Int,b) compactSame = gmap cmpct where cEs = map toAdj . group . sort diff --git a/Graphalyze.cabal b/Graphalyze.cabal --- a/Graphalyze.cabal +++ b/Graphalyze.cabal @@ -1,5 +1,5 @@ Name: Graphalyze -Version: 0.8.0.0 +Version: 0.9.0.0 Synopsis: Graph-Theoretic Analysis library. Description: A library to use graph theory to analyse the relationships inherent in discrete data. @@ -31,8 +31,8 @@ time, bktrees >= 0.2, fgl >= 5.4.2.2, - graphviz >= 2999.6.0.0 && < 2999.7.0.0, - pandoc + graphviz >= 2999.8.0.0 && < 2999.9.0.0, + pandoc >= 1.4 && < 1.5 Exposed-Modules: Data.Graph.Analysis Data.Graph.Analysis.Types diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -12,3 +12,7 @@ * Write a README +* For Reporting, have a Document -> IO Document function that + generates all the visualisations and replaces all GraphImage + DocElement values with DocImage, etc. (and then the Document -> + Pandoc conversion can be pure).