-- | Functions for  visualization of taxonomy data.
module Biobase.Taxonomy.Visualization (  -- * Datatypes
                       -- Datatypes used to represent taxonomy data
                       module Biobase.Taxonomy.Types,
                       -- * Visualization
                       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

---------------------------------------
-- Visualisation functions

-- | Draw graph in dot format. Used in Ids2Tree tool.
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
                       --, GV.fmtNode = \ (_,l) -> [GV.textLabel (TL.pack (show (simpleRank l) ++ "\n" ++ T.unpack (simpleScientificName l)))]
                       , 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)]

-- | Draw tree comparison graph in dot format. Used in Ids2TreeCompare tool.
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
                       --, GV.fmtNode = \ (_,l) -> [GV.textLabel (TL.pack (show (compareRank l) ++ "\n" ++ B.unpack (compareScientificName l))), GV.style GV.wedged, GVA.Color (selectColors (inTree l) cList)]
                       , 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)]

-- | Colors from color list are selected according to in which of the compared trees the node is contained.
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)

-- | A color list is sampled from the spectrum according to how many trees are compared.
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

-- | Write tree representation either as dot or json to provided file path
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

-- | Write tree representation as dot to provided file path.
-- Graphviz tools like dot can be applied to the written .dot file to generate e.g. svg-format images.
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

-- | Write tree representation as json to provided file path.
-- You can visualize the result for example with 3Djs.
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