module Biobase.Taxonomy.Visualization (
module Biobase.Taxonomy.Types,
drawTaxonomyComparison,
drawTaxonomy,
writeTree,
writeDotTree,
writeJsonTree
) where
import Prelude
import Biobase.Taxonomy.Types
import Data.Graph.Inductive.Tree
import Data.Graph.Inductive.Basic
import qualified Data.GraphViz as GV
import qualified Data.GraphViz.Printing as GVP
import qualified Data.GraphViz.Attributes.Colors as GVAC
import qualified Data.GraphViz.Attributes.Complete as GVA
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Aeson as AE
import qualified Data.Text.Lazy as T
drawTaxonomy :: Bool -> Gr SimpleTaxon Double -> String
drawTaxonomy :: Bool -> Gr SimpleTaxon Double -> String
drawTaxonomy Bool
withRank Gr SimpleTaxon Double
inputGraph = do
let nodeFormating :: (t, SimpleTaxon) -> [Attribute]
nodeFormating = if Bool
withRank then (t, SimpleTaxon) -> [Attribute]
forall t. (t, SimpleTaxon) -> [Attribute]
nodeFormatWithRank else (t, SimpleTaxon) -> [Attribute]
forall t. (t, SimpleTaxon) -> [Attribute]
nodeFormatWithoutRank
let params :: GraphvizParams t SimpleTaxon el () SimpleTaxon
params = GraphvizParams t SimpleTaxon Any () SimpleTaxon
forall n nl el. GraphvizParams n nl el () nl
GV.nonClusteredParams {isDirected :: Bool
GV.isDirected = Bool
True
, globalAttributes :: [GlobalAttributes]
GV.globalAttributes = [[Attribute] -> GlobalAttributes
GV.GraphAttrs [GraphSize -> Attribute
GVA.Size (Double -> Maybe Double -> Bool -> GraphSize
GVA.GSize (Double
20 :: Double) (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
20 :: Double)) Bool
False)]]
, isDotCluster :: () -> Bool
GV.isDotCluster = Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True
, fmtNode :: (t, SimpleTaxon) -> [Attribute]
GV.fmtNode = (t, SimpleTaxon) -> [Attribute]
forall t. (t, SimpleTaxon) -> [Attribute]
nodeFormating
, fmtEdge :: (t, t, el) -> [Attribute]
GV.fmtEdge = [Attribute] -> (t, t, el) -> [Attribute]
forall a b. a -> b -> a
const []
}
let dotFormat :: DotGraph Node
dotFormat = GraphvizParams Node SimpleTaxon Double () SimpleTaxon
-> Gr SimpleTaxon Double -> DotGraph Node
forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
GV.graphToDot GraphvizParams Node SimpleTaxon Double () SimpleTaxon
forall t el. GraphvizParams t SimpleTaxon el () SimpleTaxon
params Gr SimpleTaxon Double
inputGraph
let dottext :: Text
dottext = DotCode -> Text
GVP.renderDot (DotCode -> Text) -> DotCode -> Text
forall a b. (a -> b) -> a -> b
$ DotGraph Node -> DotCode
forall a. PrintDot a => a -> DotCode
GVP.toDot DotGraph Node
dotFormat
Text -> String
T.unpack Text
dottext
nodeFormatWithRank :: (t, SimpleTaxon) -> [GVA.Attribute]
nodeFormatWithRank :: (t, SimpleTaxon) -> [Attribute]
nodeFormatWithRank (t
_,SimpleTaxon
l) = [Text -> Attribute
GV.textLabel ([Text] -> Text
T.concat [String -> Text
T.pack (Rank -> String
forall a. Show a => a -> String
show (SimpleTaxon -> Rank
simpleRank SimpleTaxon
l)), String -> Text
T.pack (String
"\n") , SimpleTaxon -> Text
simpleScientificName SimpleTaxon
l])]
nodeFormatWithoutRank :: (t, SimpleTaxon) -> [GVA.Attribute]
nodeFormatWithoutRank :: (t, SimpleTaxon) -> [Attribute]
nodeFormatWithoutRank (t
_,SimpleTaxon
l) = [Text -> Attribute
GV.textLabel (SimpleTaxon -> Text
simpleScientificName SimpleTaxon
l)]
drawTaxonomyComparison :: Bool -> (Int,Gr CompareTaxon Double) -> String
drawTaxonomyComparison :: Bool -> (Node, Gr CompareTaxon Double) -> String
drawTaxonomyComparison Bool
withRank (Node
treeNumber,Gr CompareTaxon Double
inputGraph) = do
let cList :: [Color]
cList = Node -> [Color]
makeColorList Node
treeNumber
let nodeFormating :: (t, CompareTaxon) -> [Attribute]
nodeFormating = if Bool
withRank then ([Color] -> (t, CompareTaxon) -> [Attribute]
forall t. [Color] -> (t, CompareTaxon) -> [Attribute]
compareNodeFormatWithRank [Color]
cList) else ([Color] -> (t, CompareTaxon) -> [Attribute]
forall t. [Color] -> (t, CompareTaxon) -> [Attribute]
compareNodeFormatWithoutRank [Color]
cList)
let params :: GraphvizParams t CompareTaxon el () CompareTaxon
params = GraphvizParams t CompareTaxon Any () CompareTaxon
forall n nl el. GraphvizParams n nl el () nl
GV.nonClusteredParams {isDirected :: Bool
GV.isDirected = Bool
True
, globalAttributes :: [GlobalAttributes]
GV.globalAttributes = []
, isDotCluster :: () -> Bool
GV.isDotCluster = Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True
, fmtNode :: (t, CompareTaxon) -> [Attribute]
GV.fmtNode = (t, CompareTaxon) -> [Attribute]
forall t. (t, CompareTaxon) -> [Attribute]
nodeFormating
, fmtEdge :: (t, t, el) -> [Attribute]
GV.fmtEdge = [Attribute] -> (t, t, el) -> [Attribute]
forall a b. a -> b -> a
const []
}
let dotFormat :: DotGraph Node
dotFormat = GraphvizParams Node CompareTaxon Double () CompareTaxon
-> Gr CompareTaxon Double -> DotGraph Node
forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
GV.graphToDot GraphvizParams Node CompareTaxon Double () CompareTaxon
forall t el. GraphvizParams t CompareTaxon el () CompareTaxon
params (Gr CompareTaxon Double -> Gr CompareTaxon Double
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
grev Gr CompareTaxon Double
inputGraph)
let dottext :: Text
dottext = DotCode -> Text
GVP.renderDot (DotCode -> Text) -> DotCode -> Text
forall a b. (a -> b) -> a -> b
$ DotGraph Node -> DotCode
forall a. PrintDot a => a -> DotCode
GVP.toDot DotGraph Node
dotFormat
Text -> String
T.unpack Text
dottext
compareNodeFormatWithRank :: [GVA.Color] -> (t, CompareTaxon) -> [GVA.Attribute]
compareNodeFormatWithRank :: [Color] -> (t, CompareTaxon) -> [Attribute]
compareNodeFormatWithRank [Color]
cList (t
_,CompareTaxon
l) = [Text -> Attribute
GV.textLabel ([Text] -> Text
T.concat [String -> Text
T.pack (Rank -> String
forall a. Show a => a -> String
show (CompareTaxon -> Rank
compareRank CompareTaxon
l) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"),CompareTaxon -> Text
compareScientificName CompareTaxon
l]), Style -> Attribute
GV.style Style
GV.wedged, ColorList -> Attribute
GVA.Color ([Node] -> [Color] -> ColorList
selectColors (CompareTaxon -> [Node]
inTree CompareTaxon
l) [Color]
cList)]
compareNodeFormatWithoutRank :: [GVA.Color] -> (t, CompareTaxon) -> [GVA.Attribute]
compareNodeFormatWithoutRank :: [Color] -> (t, CompareTaxon) -> [Attribute]
compareNodeFormatWithoutRank [Color]
cList (t
_,CompareTaxon
l) = [Text -> Attribute
GV.textLabel (CompareTaxon -> Text
compareScientificName CompareTaxon
l), Style -> Attribute
GV.style Style
GV.wedged, ColorList -> Attribute
GVA.Color ([Node] -> [Color] -> ColorList
selectColors (CompareTaxon -> [Node]
inTree CompareTaxon
l) [Color]
cList)]
selectColors :: [Int] -> [GVA.Color] -> GVAC.ColorList
selectColors :: [Node] -> [Color] -> ColorList
selectColors [Node]
inTrees [Color]
currentColorList = [Color] -> ColorList
GVAC.toColorList ((Node -> Color) -> [Node] -> [Color]
forall a b. (a -> b) -> [a] -> [b]
map (\Node
i -> [Color]
currentColorList [Color] -> Node -> Color
forall a. [a] -> Node -> a
!! Node
i) [Node]
inTrees)
makeColorList :: Int -> [GVA.Color]
makeColorList :: Node -> [Color]
makeColorList Node
treeNumber = [Color]
cList
where cList :: [Color]
cList = (Node -> Color) -> [Node] -> [Color]
forall a b. (a -> b) -> [a] -> [b]
map (\Node
i -> Double -> Double -> Double -> Color
GVAC.HSV ((Node -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Node
iDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Node -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Node
neededColors) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.708) Double
0.5 Double
1.0) [Node
0..Node
neededColors]
neededColors :: Node
neededColors = Node
treeNumber Node -> Node -> Node
forall a. Num a => a -> a -> a
- Node
1
writeTree :: String -> String -> Bool -> Gr SimpleTaxon Double -> IO ()
writeTree :: String -> String -> Bool -> Gr SimpleTaxon Double -> IO ()
writeTree String
requestedFormat String
outputDirectoryPath Bool
withRank Gr SimpleTaxon Double
inputGraph = do
case String
requestedFormat of
String
"dot" -> String -> Bool -> Gr SimpleTaxon Double -> IO ()
writeDotTree String
outputDirectoryPath Bool
withRank Gr SimpleTaxon Double
inputGraph
String
"json"-> String -> Gr SimpleTaxon Double -> IO ()
writeJsonTree String
outputDirectoryPath Gr SimpleTaxon Double
inputGraph
String
_ -> String -> Bool -> Gr SimpleTaxon Double -> IO ()
writeDotTree String
outputDirectoryPath Bool
withRank Gr SimpleTaxon Double
inputGraph
writeDotTree :: String -> Bool -> Gr SimpleTaxon Double -> IO ()
writeDotTree :: String -> Bool -> Gr SimpleTaxon Double -> IO ()
writeDotTree String
outputDirectoryPath Bool
withRank Gr SimpleTaxon Double
inputGraph = do
let diagram :: String
diagram = Bool -> Gr SimpleTaxon Double -> String
drawTaxonomy Bool
withRank (Gr SimpleTaxon Double -> Gr SimpleTaxon Double
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
grev Gr SimpleTaxon Double
inputGraph)
String -> String -> IO ()
writeFile (String
outputDirectoryPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"taxonomy.dot") String
diagram
writeJsonTree :: String -> Gr SimpleTaxon Double -> IO ()
writeJsonTree :: String -> Gr SimpleTaxon Double -> IO ()
writeJsonTree String
outputDirectoryPath Gr SimpleTaxon Double
inputGraph = do
let jsonOutput :: ByteString
jsonOutput = Gr SimpleTaxon Double -> ByteString
forall a. ToJSON a => a -> ByteString
AE.encode (Gr SimpleTaxon Double -> Gr SimpleTaxon Double
forall (gr :: * -> * -> *) a b. DynGraph gr => gr a b -> gr a b
grev Gr SimpleTaxon Double
inputGraph)
String -> ByteString -> IO ()
L.writeFile (String
outputDirectoryPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"taxonomy.json") ByteString
jsonOutput