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,9 @@ -- * Result analysis -- $analfuncts lengthAnalysis, - classifyRoots + classifyRoots, + interiorChains, + applyAlg ) where import Data.Graph.Analysis.Utils @@ -48,7 +50,7 @@ -- | The library version. version :: String -version = "0.4" +version = "0.5" {- | This represents the information that's being passed in that we want @@ -99,7 +101,7 @@ addLabel (x,y) = (x,y,()) -- The valid edges in the graph. graphEdges = catMaybes $ map validEdge (relationships params) - -- Validate an edge + -- Validate a node validNode l = case (findNode l) of (Just n) -> Just (n,l) _ -> Nothing @@ -153,9 +155,21 @@ classifyRoots :: (Eq a) => GraphData a -> ([LNode a], [LNode a], [LNode a]) classifyRoots gd = (areWanted, notRoots, notWanted) where - g = graph gd wntd = wantedRoots gd - rts = rootsOf g + rts = applyAlg rootsOf gd areWanted = intersect wntd rts notRoots = wntd \\ rts notWanted = rts \\ wntd + +-- | Only return those chains (see 'chainsIn') where the non-initial +-- nodes are /not/ expected roots. +interiorChains :: (Eq a) => GraphData a -> [LNGroup a] +interiorChains gd = filter (not . interiorRoot) chains + where + chains = applyAlg chainsIn gd + rts = wantedRoots gd + interiorRoot = any (`elem` rts) . tail + +-- | Apply an algorithm to the data to be analysed. +applyAlg :: (AGr a -> b) -> GraphData a -> b +applyAlg f = f . graph diff --git a/Data/Graph/Analysis/Algorithms.hs b/Data/Graph/Analysis/Algorithms.hs --- a/Data/Graph/Analysis/Algorithms.hs +++ b/Data/Graph/Analysis/Algorithms.hs @@ -13,11 +13,9 @@ -- $algorithms module Data.Graph.Analysis.Algorithms.Common, module Data.Graph.Analysis.Algorithms.Directed, - module Data.Graph.Analysis.Algorithms.Clustering, - applyAlg + module Data.Graph.Analysis.Algorithms.Clustering ) where -import Data.Graph.Analysis.Types import Data.Graph.Analysis.Algorithms.Common import Data.Graph.Analysis.Algorithms.Directed import Data.Graph.Analysis.Algorithms.Clustering @@ -28,8 +26,3 @@ return a list of @LNode@s, whilst the primed version (e.g. `cliquesIn'') will return a list of @Node@s. -} - --- | Apply an algorithm to the data to be analysed. -applyAlg :: (AGr a -> b) -> GraphData a -> b -applyAlg f = f . graph - 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 @@ -14,7 +14,6 @@ ( -- * Clustering Algorithms -- ** Non-deterministic algorithms -- $chinesewhispers - Whispering, chineseWhispers, -- ** Spatial Algorithms -- $relneighbours @@ -22,21 +21,21 @@ -- * Graph Collapsing -- $collapsing CNodes(..), - collapseGraph + collapseGraph, + trivialCollapse, + cNodes ) where import Data.Graph.Analysis.Types import Data.Graph.Analysis.Utils import Data.Graph.Analysis.Visualisation(showNodes) import Data.Graph.Analysis.Algorithms.Common -import Data.Graph.Analysis.Algorithms.Directed(rootsOf') import Data.Graph.Inductive.Graph import Data.List import Data.Maybe import Data.Function -import qualified Data.Set as Set import qualified Data.Set.BKTree as BK import Data.Set.BKTree(BKTree, Metric(..)) import Control.Arrow @@ -45,7 +44,7 @@ -- ----------------------------------------------------------------------------- {- $chinesewhispers - The Chinese Whispering Algorithm. + The Chinese Whispers Algorithm. This is an adaptation of the algorithm described in: Biemann, C. (2006): Chinese Whispers - an Efficient Graph Clustering @@ -59,40 +58,29 @@ (also, we want the algorithm to be dependent solely upon the /structure/ of the graph, not what it contains). - * Increase the weighting of those nodes present in interesting structures, - such as loops and root nodes. This is to try and ensure that these nodes - end up in the same cluster. - + * Explicitly shuffle the node order for each iteration. Simplistically, the way it works is this: 1. Every node is assigned into its own unique cluster. - 2. For each iteration, sort the nodes into each order. For each node, - it joins the most popular cluster in its neighbourhood - (where popularity is defined by the sum of the weightings). + 2. Sort the nodes into some random order. Each node joins the + most popular cluster in its neighbourhood (where popularity + is defined as the sum of the node weightings in that cluster). 3. Repeat step 2. until a fixed point is reached. Note that this algorithm is non-deterministic, and that for some graphs no fixed point may be reached (and the algorithm may oscillate between a few different graph clusterings). --} --- | An instance of 'ClusterLabel' used for the Chinese Whispers algorithm. -data Whispering a = W { name :: a -- ^ The original label. - , whisp :: Int -- ^ The current cluster this node is in. - , coeff :: Double -- ^ The node's weighting. - } deriving (Show,Eq) - -instance (Show a) => ClusterLabel (Whispering a) Int where - cluster = whisp - nodelabel = show . name + Chinese Whispers is @O(number of edges)@. +-} -- | The actual Chinese Whispers algorithm. chineseWhispers :: (RandomGen g, Eq a, Eq b, DynGraph gr) => g -> gr a b - -> gr (Whispering a) b -chineseWhispers g gr = fst $ fixPointBy eq whispering (gr',g) + -> gr (GenCluster a) b +chineseWhispers g gr = reCluster . fst $ fixPointBy eq whispering (gr',g) where eq = equal `on` fst ns = nodes gr @@ -105,57 +93,43 @@ -- | Choose a new cluster for the given 'Node'. Note that this updates -- the graph each time a new cluster value is chosen. -whisperNode :: (RandomGen g, DynGraph gr) => (gr (Whispering a) b,g) - -> Node -> (gr (Whispering a) b,g) +whisperNode :: (RandomGen g, DynGraph gr) => (gr (GenCluster a) b,g) + -> Node -> (gr (GenCluster a) b,g) whisperNode (gr,g) n = (c' & gr',g') where (Just c,gr') = match n gr (g',c') = whisper gr g c -- | Choose a new cluster for the given @Context@. -whisper :: (RandomGen g, Graph gr) => gr (Whispering a) b -> g - -> Context (Whispering a) b -> (g,Context (Whispering a) b) -whisper gr g (p,n,al,s) = (g',(p,n,al {whisp = w'},s)) +whisper :: (RandomGen g, Graph gr) => gr (GenCluster a) b -> g + -> Context (GenCluster a) b -> (g,Context (GenCluster a) b) +whisper gr g (p,n,al,s) = (g',(p,n,al { clust = w' },s)) where (w',g') = case (neighbors gr n) of - [] -> (whisp al,g) + [] -> (clust al,g) -- Add this current node to the list of neighbours to add -- extra weighting, as it seems to give better results. ns -> chooseWhisper g (addLabels gr (n:ns)) --- | Choose which cluster to pick by taking the one with maximum sum of --- weightings. If more than one has the same maximum, choose one +-- | Choose which cluster to pick by taking the one with maximum number of +-- nodes. If more than one has the same maximum, choose one -- randomly. -chooseWhisper :: (RandomGen g) => g -> [LNode (Whispering a)] +chooseWhisper :: (RandomGen g) => g -> [LNode (GenCluster a)] -> (Int,g) -chooseWhisper g lns = pick maxWspWgts +chooseWhisper g lns = pick maxWsps where -- This isn't the most efficient method of choosing a random list element, -- but the graph is assumed to be relatively sparse and thus ns should -- be relatively short. pick ns = first (ns!!) $ randomR (0,length ns - 1) g - whispWgts = map (second sumWgts) . groupElems whisp $ map label lns - maxWspWgts = map fst . snd . head $ groupElems (negate . snd) whispWgts - sumWgts = sum . map coeff + whisps = map (second length) . groupElems clust $ map label lns + maxWsps = map fst . snd . head $ groupElems (negate . snd) whisps -- | Convert the graph into a form suitable for the Chinese Whispers algorithm. -addWhispers :: (DynGraph gr) => gr a b -> gr (Whispering a) b +addWhispers :: (DynGraph gr) => gr a b -> gr (GenCluster a) b addWhispers g = gmap augment g where - augment (p,n,l,s) = (p,n,W { name = l - , whisp = n - , coeff = coefFor n - },s) - -- Note that cliques are also cycles... - -- cliques = Set.fromList . concat $ cliquesIn' g - cycles = Set.fromList . concat $ cyclesIn' g - roots = Set.fromList $ rootsOf' g - -- Give more emphasis to interesting parts of the graph. - coefFor n - | Set.member n roots = 3 - | Set.member n cycles = 2 - | otherwise = 1 - + augment (p,n,l,s) = (p,n, GC { clust = n, nLbl = l }, s) {- @@ -207,7 +181,8 @@ The algorithm is renamed 'relativeNeighbourhood'. Experimentally, it seems to work better with larger graphs (i.e. more nodes), since - then Graphviz makes the apparent clusters more obvious. + then Graphviz makes the apparent clusters more obvious. The actual + algorithm is @O(n^2)@, where /n/ is the number of 'Node's in the graph. -} -- | The renamed CLUSTER algorithm. Attempts to cluster a graph by using @@ -216,7 +191,7 @@ -> gr (GenCluster a) b relativeNeighbourhood g = setCluster cMap g where - cMap = createLookup . concatMap rn $ componentsOf g + cMap = createLookup $ rn g rn g' = nbrCluster rng where rng :: Gr () Int @@ -260,7 +235,7 @@ lune = intersect (rgnFor l1) (rgnFor l2) -- | Performs the actual clustering algorithm on the RNG. -nbrCluster :: (DynGraph gr) => gr a Int -> [[Node]] +nbrCluster :: (DynGraph gr) => gr a Int -> [NGroup] nbrCluster g | numNodes == 1 = [ns] -- Can't split up a single node. | eMax < 2*eMin = [ns] -- The inter-cluster relative neighbours @@ -310,6 +285,10 @@ -- | A collapsed node contains a list of nodes that it represents. data CNodes a = CN [LNode a] +-- | The 'LNode's stored in a 'CNodes'. +cNodes :: CNodes a -> [LNode a] +cNodes (CN lns) = lns + -- | This definition of 'show' is written so as to make the shapes of the -- nodes in Graphviz roughly circular, rather than one long ellipse. instance (Show a) => Show (CNodes a) where @@ -322,6 +301,15 @@ cg = makeCollapsible g interestingParts = [cliquesIn', cyclesIn', chainsIn'] +-- | Return @'True'@ if the collapsed graph is either a singleton node +-- or else isomorphic to the original graph (i.e. not collapsed at all). +trivialCollapse :: (Graph gr) => gr (CNodes a) b -> Bool +trivialCollapse cg = allCollapsed || notCollapsed + where + allCollapsed = (single lns) || (null lns) + notCollapsed = all (single . cNodes) lns + lns = labels cg + -- | Allow the graph to be collapsed. makeCollapsible :: (DynGraph gr) => gr a b -> gr (CNodes a) b makeCollapsible = nlmap (CN . return) @@ -337,7 +325,6 @@ (Just c2, g'') = match n2 g' -- The new edges. nbrBy f = map (\(a,b) -> (b,a)) - -- not sure if this should be included: . nub . filter (\(n,_) -> notElem n [n1,n2]) $ (f c1 ++ f c2) p = nbrBy lpre' diff --git a/Data/Graph/Analysis/Algorithms/Common.hs b/Data/Graph/Analysis/Algorithms/Common.hs --- a/Data/Graph/Analysis/Algorithms/Common.hs +++ b/Data/Graph/Analysis/Algorithms/Common.hs @@ -138,7 +138,7 @@ isClique _ [] = False isClique gr ns = null . foldl1' intersect . - map ((\\ ns) . corecursive gr) $ ns + map ((\\ ns) . twoCycle gr) $ ns -- | Find all regular subgraphs of the given graph. findRegular :: (Graph g) => g a b -> [[Node]] @@ -156,7 +156,7 @@ regularOf :: (Graph g) => g a b -> Node -> [[Node]] regularOf gr n = map (n:) (alsoRegular gr crs) where - crs = corecursive gr n + crs = twoCycle gr n -- | Recursively find all regular subgraphs only containing nodes -- in the given list. @@ -166,21 +166,21 @@ alsoRegular g (n:ns) = [n] : rs ++ (alsoRegular g ns) where rs = map (n:) (alsoRegular g $ intersect crn ns) - crn = corecursive g n + crn = twoCycle g n -- | Return all nodes that are co-recursive with the given node -- (i.e. for n, find all n' such that n->n' and n'->n). -corecursive :: (Graph g) => g a b -> Node -> [Node] -corecursive gr n = filter (elem n . suc gr) (delete n $ suc gr n) +twoCycle :: (Graph g) => g a b -> Node -> [Node] +twoCycle gr n = filter (elem n . suc gr) (delete n $ suc gr n) -- | Determines if the list of nodes represents a regular subgraph. isRegular :: (Graph g) => g a b -> NGroup -> Bool -isRegular g ns = all allCorecursive split +isRegular g ns = all allTwoCycle split where -- Node + Rest of list split = zip ns tns' tns' = tail $ tails ns - allCorecursive (n,rs) = null $ rs \\ (corecursive g n) + allTwoCycle (n,rs) = null $ rs \\ (twoCycle g n) -- ----------------------------------------------------------------------------- {- $cycles 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 @@ -94,19 +94,19 @@ -- | Find all leaves of the graph. leavesOf :: (Graph g) => g a b -> LNGroup a -leavesOf = endBy pre +leavesOf = endBy suc -- | Find all leaves of the graph. leavesOf' :: (Graph g) => g a b -> NGroup -leavesOf' = endBy' pre +leavesOf' = endBy' suc -- | Returns @True@ if this 'LNode' is a leaf. isLeaf :: (Graph g) => g a b -> LNode a -> Bool -isLeaf = endNode pre +isLeaf = endNode suc -- | Returns @True@ if this 'Node' is a leaf. isLeaf' :: (Graph g) => g a b -> Node -> Bool -isLeaf' = endNode' pre +isLeaf' = endNode' suc -- ----------------------------------------------------------------------------- @@ -116,19 +116,19 @@ -- | Find all singletons of the graph. singletonsOf :: (Graph g) => g a b -> LNGroup a -singletonsOf = endBy pre +singletonsOf = endBy neighbors -- | Find all singletons of the graph. singletonsOf' :: (Graph g) => g a b -> NGroup -singletonsOf' = endBy' pre +singletonsOf' = endBy' neighbors -- | Returns @True@ if this 'LNode' is a singleton. isSingleton :: (Graph g) => g a b -> LNode a -> Bool -isSingleton = endNode pre +isSingleton = endNode neighbors -- | Returns @True@ if this 'Node' is a singleton. isSingleton' :: (Graph g) => g a b -> Node -> Bool -isSingleton' = endNode' pre +isSingleton' = endNode' neighbors -- ----------------------------------------------------------------------------- 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 @@ -21,13 +21,15 @@ today, tryCreateDirectory, createGraph, - maximumSize + createSize, + unDotPath ) where import Data.GraphViz import Data.GraphViz.Attributes import Data.Graph.Analysis.Visualisation +import Data.Maybe import Data.Time import Control.Exception import System.Directory @@ -49,14 +51,17 @@ 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, -- | Pre-matter - title :: DocInline, - author :: String, - date :: String, + title :: DocInline, + author :: String, + date :: String, -- | Main-matter - content :: [DocElement] + content :: [DocElement] } -- | Represents the class of document generators. @@ -81,20 +86,22 @@ | Enumeration [DocElement] | Itemized [DocElement] | Definition DocInline DocElement - | DocImage DocInline Location | GraphImage DocGraph - deriving (Show) +-- | Inline elements of a document. data DocInline = Text String | BlankSpace | Grouping [DocInline] | Bold DocInline | Emphasis DocInline | DocLink DocInline Location - deriving (Show) + | DocImage DocInline Location -type DocGraph = (FilePath,DocInline,DotGraph) +-- | Let the 'DocumentGenerator' instance apply extra settings, such as size. +type AttrsToGraph = [Attribute] -> DotGraph +type DocGraph = (FilePath,DocInline,AttrsToGraph) + -- ----------------------------------------------------------------------------- {- $utilities @@ -124,20 +131,57 @@ isRight _ = False -- | Attempts to creates a png file (with the given filename in the --- given directory) and - if successful - returns a 'DocImage' link. -createGraph :: FilePath -> DocGraph -> IO (Maybe DocElement) -createGraph fp (fn,inl,dg) = do created <- runGraphviz dg output filename' - if created - then return (Just img) - else return Nothing +-- 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 -> [Attribute] -> Maybe [Attribute] + -> DocGraph -> IO (Maybe DocElement) +createGraph fp gfp as mas (fn,inl,ag) + = do eImg <- gI as DocImage fn inl Nothing + if (isJust eImg) + then case mas of + Nothing -> rt eImg + (Just as') -> do rt =<< gI as' DocLink fn' (toImg eImg) eImg + else return Nothing where + fn' = fn ++ "-large" + i2e i = Just (i,Paragraph [i]) + rt = return . fmap snd + toImg = fst . fromJust + gI a ln nm lb fl = do mImg <- graphImage fp gfp a ln (nm,lb,ag) + case mImg of + Nothing -> return fl + (Just img) -> return $ i2e img + +-- | Create the inline image/link from the given DocGraph. +graphImage :: FilePath -> FilePath -> [Attribute] + -> (DocInline -> Location -> DocInline) + -> DocGraph -> IO (Maybe DocInline) +graphImage fp gfp as link (fn,inl,ag) + = do created <- runGraphviz dg output filename' + if created + then return (Just img) + else return Nothing + where + dg = ag as + fn' = unDotPath fn ext = "png" output = Png - filename = fn <.> ext + filename = gfp fn' <.> ext filename' = fp filename loc = File filename - img = DocImage inl loc + img = link inl loc --- | The recommended maximum size for graphs. -maximumSize :: Attribute -maximumSize = Size 15 10 +-- | Create the "Data.GraphViz" 'Size' 'Attribute' using the given width +-- and a 6:4 width:height ratio. +createSize :: Double -> Attribute +createSize w = Size w (w*4/6) + +-- | Replace all @.@ with @-@ in the given 'FilePath', since some output +-- formats (e.g. LaTeX) don't like extraneous @.@'s in the filename. +unDotPath :: FilePath -> FilePath +unDotPath = map replace + where + replace '.' = '-' + replace c = c 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 @@ -27,6 +27,7 @@ -- TODO : the ability to create multiple files. import Data.Graph.Analysis.Reporting +import Data.GraphViz.Attributes(Attribute) import Data.List import Data.Maybe @@ -43,25 +44,28 @@ -} pandocHtml :: PandocDocument -pandocHtml = PD { writer = writeHtmlString - , extension = "html" - , header = "" -- Header will be included +pandocHtml = pd { writer = writeHtmlString + , extension = "html" + , header = "" -- Header will be included + , extGraphSize = Just $ defaultWidth * 10 } pandocLaTeX :: PandocDocument -pandocLaTeX = PD { writer = writeLaTeX +pandocLaTeX = pd { writer = writeLaTeX , extension = "tex" , header = defaultLaTeXHeader + -- 4.5" should be less than \textwidth in LaTeX. + , graphSize = 4.5 } pandocRtf :: PandocDocument -pandocRtf = PD { writer = writeRTF +pandocRtf = pd { writer = writeRTF , extension = "rtf" , header = defaultRTFHeader } pandocMarkdown :: PandocDocument -pandocMarkdown = PD { writer = writeMarkdown +pandocMarkdown = pd { writer = writeMarkdown , extension = "text" , header = "" } @@ -72,11 +76,33 @@ Pandoc definition. -} -data PandocDocument = PD { writer :: WriterOptions -> Pandoc -> String - , extension :: FilePath - , header :: String +-- | 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, + -- | The file extension used + extension :: FilePath, + -- | The Pandoc header to use + header :: String, + -- | Maximum width of graphs to be produced. + graphSize :: Double, + -- | Optional maximum width of external linked graph. + extGraphSize :: Maybe Double } +-- | 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 = defaultWidth, + extGraphSize = Nothing + } + +defaultWidth :: Double +defaultWidth = 10 + instance DocumentGenerator PandocDocument where createDocument = createPandoc docExtension = extension @@ -91,24 +117,32 @@ -- | Used when traversing the document structure. data PandocProcess = PP { secLevel :: Int , filedir :: FilePath + , graphdir :: FilePath + , grSize :: [Attribute] + , eGSize :: Maybe [Attribute] } -- | Start with a level 1 heading. defaultProcess :: PandocProcess defaultProcess = PP { secLevel = 1 - , filedir = "" + , graphdir = undefined + , filedir = undefined + , grSize = undefined + , eGSize = undefined } -- | Create the document. createPandoc :: PandocDocument -> Document -> IO (Maybe FilePath) createPandoc p d = do created <- tryCreateDirectory dir + -- If the first one fails, so will this one. + tryCreateDirectory $ dir gdir if (not created) then failDoc else do elems <- multiElems pp (content d) case elems of Just es -> do let es' = htmlAuthDt : es - pd = Pandoc meta es' - doc = convert pd + pnd = Pandoc meta es' + doc = convert pnd wr <- tryWrite doc case wr of (Right _) -> success @@ -116,12 +150,18 @@ Nothing -> failDoc where dir = rootDirectory d + gdir = graphDirectory d auth = author d dt = date d 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 } + createSize' = return . createSize + pp = defaultProcess { filedir = dir + , graphdir = gdir + , grSize = createSize' (graphSize p) + , eGSize = fmap createSize' (extGraphSize p) + } opts = writerOptions { writerHeader = (header p) } convert = (writer p) opts file = dir (fileFront d) <.> (extension p) @@ -144,7 +184,7 @@ htmlInfo auth dt = RawHtml html where heading = "

Document Information

" - html = unlines [heading,htmlize auth, htmlize dt] + html = unlines [heading, htmlize auth, htmlize dt] htmlize str = "

" ++ str ++ "

" -- | Link conversion @@ -153,13 +193,14 @@ loc2target (File file) = (file,"") -- | Conversion of simple inline elements. -inlines :: DocInline -> [Inline] -inlines (Text str) = [Str str] -inlines BlankSpace = [Space] -inlines (Grouping grp) = concat . intersperse [Space] $ map inlines grp -inlines (Bold inl) = [Strong (inlines inl)] -inlines (Emphasis inl) = [Emph (inlines inl)] -inlines (DocLink inl loc) = [Link (inlines inl) (loc2target loc)] +inlines :: DocInline -> [Inline] +inlines (Text str) = [Str str] +inlines BlankSpace = [Space] +inlines (Grouping grp) = concat . intersperse [Space] $ map inlines grp +inlines (Bold inl) = [Strong (inlines inl)] +inlines (Emphasis inl) = [Emph (inlines inl)] +inlines (DocLink inl loc) = [Link (inlines inl) (loc2target loc)] +inlines (DocImage inl loc) = [Image (inlines inl) (loc2target loc)] {- | Conversion of complex elements. The only reason it's in the IO monad is @@ -195,11 +236,10 @@ xdef = fmap (return . (,) x') def' return (fmap (return . DefinitionList) xdef) -elements _ (DocImage inl loc) = do let img = Image (inlines inl) - (loc2target loc) - return $ Just [Plain [img]] - -elements p (GraphImage dg) = do el <- createGraph (filedir p) dg +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 @@ -210,7 +250,6 @@ if (any isNothing elems') then return Nothing else return (Just $ concatMap fromJust elems') - -- | As for 'multiElems', but don't @concat@ the resulting 'Block's. 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 @@ -69,7 +69,10 @@ nodelabel :: a -> String -- | A generic cluster-label type. -data GenCluster a = GC Int a +data GenCluster a = GC { clust :: Int + , nLbl :: a + } + deriving (Eq,Show) instance (Show a) => ClusterLabel (GenCluster a) Int where cluster (GC c _) = c 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 @@ -16,8 +16,10 @@ module Data.Graph.Analysis.Utils ( -- * Graph functions -- ** Data extraction + -- $extracting node, label, + labels, edge, eLabel, addLabels, @@ -30,21 +32,28 @@ mkSimple, nlmap, -- ** Graph layout - -- | These next two are re-exported from "Data.GraphViz" + -- $spatial + -- These next two are re-exported from "Data.GraphViz" AttributeNode, AttributeEdge, dotizeGraph, toPosGraph, getPositions, -- ** Cluster functions + -- $cluster createLookup, setCluster, assignCluster, + reCluster, + reClusterBy, + clusterCount, -- * List functions + -- $list single, longerThan, addLengths, longest, + lengthSort, groupElems, sortMinMax, blockPrint, @@ -84,21 +93,25 @@ -- ----------------------------------------------------------------------------- --- | Extracting data from graphs. +-- $extracting Extracting data from graphs. -- | The node number of an 'LNode'. node :: LNode a -> Node node = fst --- | The label of an 'LNode' +-- | 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 + -- | Extract the 'Edge' from the 'LEdge'. edge :: LEdge b -> Edge edge (n1,n2,_) = (n1,n2) --- | The label of an 'LEdge' +-- | The label of an 'LEdge'. eLabel :: LEdge b -> b eLabel (_,_,b) = b @@ -121,7 +134,7 @@ -- ----------------------------------------------------------------------------- --- | Manipulating graphs. +-- Manipulating graphs. {- | Make the graph undirected, i.e. for every edge from A to B, there @@ -139,7 +152,7 @@ dupEdges (p,n,l,s) = (ps',n,l,ps) where ps = nub $ p ++ s - ps' = snd $ partition isLoop ps + ps' = filter (not . isLoop) ps isLoop (_,n') = n == n' -- | This is a pseudo-inverse of 'undir': any edges that are both successor @@ -170,9 +183,12 @@ -- ----------------------------------------------------------------------------- -{- | +{- $spatial Spatial positioning of graphs. Use the 'graphToGraph' function in "Data.GraphViz" to determine potential graph layouts. + + Note that for convenience sake, 'AttributeNode' and 'AttributeEdge' + from "Data.GraphViz" have been re-exported. -} -- | Pass the plain graph through 'graphToGraph'. This is an IO action, @@ -209,11 +225,11 @@ -- ----------------------------------------------------------------------------- --- | Cluster utility functions. +-- $cluster Cluster utility functions. -- | Create a cluster-lookup 'IntMap'. createLookup :: [[Node]] -> IntMap Int -createLookup = IMap.fromList . concatMap addCluster . zip [1..] +createLookup = IMap.fromList . concatMap addCluster . zip [1..] . lengthSort where addCluster (k,ns) = map (flip (,) k) ns @@ -228,9 +244,32 @@ assignCluster :: (ClusterLabel a c) => LNode a -> NodeCluster c a assignCluster nl@(_,a) = C (cluster a) (N nl) +-- | Change the cluster values in the graph by having the largest cluster +-- have the smallest cluster label. +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..] + +-- | Change the cluster values using the given lookup 'IntMap'. +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) } + +-- | Create an 'IntMap' of the size of each cluster. +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 + -- ----------------------------------------------------------------------------- --- | List utility functions. +-- $list List utility functions. -- | Return true if and only if the list contains a single element. single :: [a] -> Bool @@ -248,9 +287,11 @@ -- | Returns the longest list in a list of lists. longest :: [[a]] -> [a] -longest = snd . maximumBy (compare `on` fst) - . addLengths +longest = head . lengthSort +lengthSort :: [[a]] -> [[a]] +lengthSort = map snd . sortBy (flip compare `on` fst) . addLengths + -- | Group elements by the given grouping function. groupElems :: (Ord b) => (a -> b) -> [a] -> [(b,[a])] groupElems f = map createGroup @@ -392,7 +433,7 @@ -- ----------------------------------------------------------------------------- --- | Statistics functions. +-- Statistics functions. -- | An efficient mean function by Don Stewart, available from: -- @@ -422,7 +463,7 @@ -- ----------------------------------------------------------------------------- --- | Other utility functions. +-- Other utility functions. -- | Find the fixed point of a function with the given initial value. fixPoint :: (Eq a) => (a -> a) -> a -> a diff --git a/Data/Graph/Analysis/Visualisation.hs b/Data/Graph/Analysis/Visualisation.hs --- a/Data/Graph/Analysis/Visualisation.hs +++ b/Data/Graph/Analysis/Visualisation.hs @@ -181,7 +181,7 @@ runGraphvizCommand cmd gr t fp = runGraphvizInternal (show cmd) gr t fp -- | This command should /not/ be available outside this module, as --- it isn't safe: running an arbitrary command will crash the program. +-- it isn't safe: running an arbitrary command will crash the programme. runGraphvizInternal :: String -> DotGraph -> GraphvizOutput -> FilePath -> IO Bool runGraphvizInternal cmd gr t fp @@ -283,5 +283,11 @@ showCycle lns@(ln:_) = showPath (lns ++ [ln]) -- | Show a group of nodes, with no implicit ordering. -showNodes :: (Show a) => LNGroup a -> String -showNodes = blockPrintList . map label +showNodes :: (Show a) => LNGroup a -> String +showNodes [] = "" +showNodes lns = blockPrint' . addCommas + $ map (show . label) lns + where + addCommas [] = [] + addCommas [l] = [l] + addCommas (l:ls) = (l ++ ", ") : addCommas ls diff --git a/Graphalyze.cabal b/Graphalyze.cabal --- a/Graphalyze.cabal +++ b/Graphalyze.cabal @@ -1,5 +1,5 @@ Name: Graphalyze -Version: 0.4 +Version: 0.5 Synopsis: Graph-Theoretic Analysis library. Description: A library to use graph theory to analyse the relationships inherent in discrete data.