Skip to content

haskell-gargantext
haskell-gargantext
Commit d3dbcd9b authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski Committed by Alexandre Delanoë
Browse files
Options

[phylo] some small phyloexport refactoring

parent e8c7bfa3
Hide whitespace changes
Inline Side-by-side
Showing with 31 additions and 30 deletions
src/Gargantext/Core/Viz/Phylo/API/Tools.hs
View file @ d3dbcd9b
...@@ -78,7 +78,6 @@ phylo2dot2json phylo = do ...@@ -78,7 +78,6 @@ phylo2dot2json phylo = do
-- parsing a file can be done with: -- parsing a file can be done with:
-- runParser' (Data.GraphViz.Parsing.parse :: Parse (Data.GraphViz.DotGraph Text)) $ TL.fromStrict f -- runParser' (Data.GraphViz.Parsing.parse :: Parse (Data.GraphViz.DotGraph Text)) $ TL.fromStrict f
Shell.callProcess "dot" ["-Tdot", "-o", fileDot, fileFrom] Shell.callProcess "dot" ["-Tdot", "-o", fileDot, fileFrom]
Shell.callProcess "dot" ["-Txdot_json", "-o", fileToJson, fileDot] Shell.callProcess "dot" ["-Txdot_json", "-o", fileToJson, fileDot]
......
src/Gargantext/Core/Viz/Phylo/PhyloExport.hs
View file @ d3dbcd9b
...@@ -28,6 +28,7 @@ import Gargantext.Core.Viz.Phylo.PhyloTools ...@@ -28,6 +28,7 @@ import Gargantext.Core.Viz.Phylo.PhyloTools
import Gargantext.Core.Viz.Phylo.TemporalMatching (filterDocs, filterDiago, reduceDiagos, toSimilarity, getNextPeriods) import Gargantext.Core.Viz.Phylo.TemporalMatching (filterDocs, filterDiago, reduceDiagos, toSimilarity, getNextPeriods)
import Gargantext.Prelude hiding (scale) import Gargantext.Prelude hiding (scale)
import Prelude (writeFile) import Prelude (writeFile)
import Protolude (floor)
import System.FilePath import System.FilePath
import qualified Data.GraphViz.Attributes.HTML as H import qualified Data.GraphViz.Attributes.HTML as H
import qualified Data.Text as Text import qualified Data.Text as Text
...@@ -44,18 +45,18 @@ dotToFile filePath dotG = writeFile filePath $ dotToString dotG ...@@ -44,18 +45,18 @@ dotToFile filePath dotG = writeFile filePath $ dotToString dotG
dotToString :: DotGraph DotId -> [Char] dotToString :: DotGraph DotId -> [Char]
dotToString dotG = unpack (printDotGraph dotG) dotToString dotG = unpack (printDotGraph dotG)
dynamicToColor :: Double -> H.Attribute dynamicToColor :: Int -> H.Attribute
dynamicToColor d dynamicToColor d
| d == 0 = H.BGColor (toColor LightCoral) | d == 0 = H.BGColor (toColor LightCoral)
| d == 1 = H.BGColor (toColor Khaki) | d == 1 = H.BGColor (toColor Khaki)
| d == 2 = H.BGColor (toColor SkyBlue) | d == 2 = H.BGColor (toColor SkyBlue)
| otherwise = H.Color (toColor Black) | otherwise = H.Color (toColor Black)
pickLabelColor :: [Double] -> H.Attribute pickLabelColor :: [Int] -> H.Attribute
pickLabelColor lst pickLabelColor lst
| elem 0 lst = dynamicToColor 0 | elem 0 lst = dynamicToColor 0
| elem 2 lst = dynamicToColor 2
| elem 1 lst = dynamicToColor 1 | elem 1 lst = dynamicToColor 1
| elem 2 lst = dynamicToColor 2
| otherwise = dynamicToColor 3 | otherwise = dynamicToColor 3
toDotLabel :: Text.Text -> Label toDotLabel :: Text.Text -> Label
...@@ -88,20 +89,21 @@ groupToTable fdt g = H.Table H.HTable ...@@ -88,20 +89,21 @@ groupToTable fdt g = H.Table H.HTable
$ zip ((g ^. phylo_groupMeta) ! "dynamics") ((g ^. phylo_groupMeta) ! "inclusion"))} $ zip ((g ^. phylo_groupMeta) ! "dynamics") ((g ^. phylo_groupMeta) ! "inclusion"))}
where where
-------------------------------------- --------------------------------------
ngramsToRow :: [(Ngrams,(Double,Double))] -> H.Row ngramsToRow :: [(Ngrams, (Double, Double))] -> H.Row
ngramsToRow ns = H.Cells $ map (\(n,(d,_)) -> ngramsToRow ns = H.Cells $ map (\(n,(d,_)) ->
H.LabelCell [H.Align H.HLeft,dynamicToColor d] $ H.Text [H.Str $ fromStrict n]) ns H.LabelCell [ H.Align H.HLeft
, dynamicToColor $ floor d] $ H.Text [H.Str $ fromStrict n]) ns
-------------------------------------- --------------------------------------
header :: H.Row header :: H.Row
header = header =
H.Cells [ H.LabelCell [pickLabelColor ((g ^. phylo_groupMeta) ! "dynamics")] H.Cells [ H.LabelCell [pickLabelColor $ floor <$> ((g ^. phylo_groupMeta) ! "dynamics")]
$ H.Text [H.Str $ (((fromStrict . Text.toUpper) $ g ^. phylo_groupLabel) $ H.Text [H.Str $ ((fromStrict . Text.toUpper) $ g ^. phylo_groupLabel)
<> (fromStrict " ( ") <> fromStrict " ( "
<> (pack $ show (fst $ g ^. phylo_groupPeriod)) <> (pack $ show (fst $ g ^. phylo_groupPeriod))
<> (fromStrict " , ") <> fromStrict " , "
<> (pack $ show (snd $ g ^. phylo_groupPeriod)) <> (pack $ show (snd $ g ^. phylo_groupPeriod))
<> (fromStrict " ) ") <> fromStrict " ) "
<> (pack $ show (getGroupId g)))]] <> (pack $ show (getGroupId g))]]
-------------------------------------- --------------------------------------
branchToDotNode :: PhyloBranch -> Int -> Dot DotId branchToDotNode :: PhyloBranch -> Int -> Dot DotId
...@@ -112,8 +114,8 @@ branchToDotNode b bId = ...@@ -112,8 +114,8 @@ branchToDotNode b bId =
<> [ toAttr "nodeType" "branch" <> [ toAttr "nodeType" "branch"
, toAttr "bId" (pack $ show bId) , toAttr "bId" (pack $ show bId)
, toAttr "branchId" (pack $ unwords (map show $ snd $ b ^. branch_id)) , toAttr "branchId" (pack $ unwords (map show $ snd $ b ^. branch_id))
, toAttr "branch_x" (fromStrict $ Text.pack $ (show $ b ^. branch_x)) , toAttr "branch_x" (fromStrict $ Text.pack $ show $ b ^. branch_x)
, toAttr "branch_y" (fromStrict $ Text.pack $ (show $ b ^. branch_y)) , toAttr "branch_y" (fromStrict $ Text.pack $ show $ b ^. branch_y)
, toAttr "label" (pack $ show $ b ^. branch_label) , toAttr "label" (pack $ show $ b ^. branch_label)
]) ])
...@@ -201,29 +203,29 @@ exportToDot :: Phylo -> PhyloExport -> DotGraph DotId ...@@ -201,29 +203,29 @@ exportToDot :: Phylo -> PhyloExport -> DotGraph DotId
exportToDot phylo export = exportToDot phylo export =
trace ("\n-- | Convert " <> show(length $ export ^. export_branches) <> " branches and " trace ("\n-- | Convert " <> show(length $ export ^. export_branches) <> " branches and "
<> show(length $ export ^. export_groups) <> " groups " <> show(length $ export ^. export_groups) <> " groups "
<> show(length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) $ export ^. export_groups) <> " terms to a dot file\n\n" <> show(length $ nub $ concat $ map (^. phylo_groupNgrams) $ export ^. export_groups) <> " terms to a dot file\n\n"
<> "##########################") $ <> "##########################") $
digraph ((Str . fromStrict) $ (phyloName $ getConfig phylo)) $ do digraph ((Str . fromStrict) $ phyloName $ getConfig phylo) $ do
{- 1) init the dot graph -} {- 1) init the dot graph -}
graphAttrs ( [ Label (toDotLabel $ (phyloName $ getConfig phylo))] graphAttrs ( [ Label (toDotLabel $ phyloName $ getConfig phylo)]
<> [ FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps <> [ FontSize 30, LabelLoc VTop, NodeSep 1, RankSep [1], Rank SameRank, Splines SplineEdges, Overlap ScaleOverlaps
, Ratio FillRatio , Ratio FillRatio
-- , Ratio AutoRatio -- , Ratio AutoRatio
, Style [SItem Filled []],Color [toWColor White]] , Style [SItem Filled []],Color [toWColor White]]
{-- home made attributes -} {-- home made attributes -}
<> [(toAttr (fromStrict "phyloFoundations") $ pack $ show (length $ Vector.toList $ getRoots phylo)) <> [ toAttr (fromStrict "phyloFoundations") $ pack $ show (length $ Vector.toList $ getRoots phylo)
,(toAttr (fromStrict "phyloTerms") $ pack $ show (length $ nub $ concat $ map (\g -> g ^. phylo_groupNgrams) $ export ^. export_groups)) , toAttr (fromStrict "phyloTerms") $ pack $ show (length $ nub $ concat $ map (^. phylo_groupNgrams) $ export ^. export_groups)
,(toAttr (fromStrict "phyloDocs") $ pack $ show (sum $ elems $ getDocsByDate phylo)) , toAttr (fromStrict "phyloDocs") $ pack $ show (sum $ elems $ getDocsByDate phylo)
,(toAttr (fromStrict "phyloPeriods") $ pack $ show (length $ elems $ phylo ^. phylo_periods)) , toAttr (fromStrict "phyloPeriods") $ pack $ show (length $ elems $ phylo ^. phylo_periods)
,(toAttr (fromStrict "phyloBranches") $ pack $ show (length $ export ^. export_branches)) , toAttr (fromStrict "phyloBranches") $ pack $ show (length $ export ^. export_branches)
,(toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups)) , toAttr (fromStrict "phyloGroups") $ pack $ show (length $ export ^. export_groups)
,(toAttr (fromStrict "phyloSources") $ pack $ show (Vector.toList $ getSources phylo)) , toAttr (fromStrict "phyloSources") $ pack $ show (Vector.toList $ getSources phylo)
,(toAttr (fromStrict "phyloTimeScale") $ pack $ getTimeScale phylo) , toAttr (fromStrict "phyloTimeScale") $ pack $ getTimeScale phylo
,(toAttr (fromStrict "PhyloScale") $ pack $ show (getLevel phylo)) , toAttr (fromStrict "PhyloScale") $ pack $ show (getLevel phylo)
,(toAttr (fromStrict "phyloQuality") $ pack $ show (phylo ^. phylo_quality)) , toAttr (fromStrict "phyloQuality") $ pack $ show (phylo ^. phylo_quality)
,(toAttr (fromStrict "phyloSeaRiseStart") $ pack $ show (getPhyloSeaRiseStart phylo)) , toAttr (fromStrict "phyloSeaRiseStart") $ pack $ show (getPhyloSeaRiseStart phylo)
,(toAttr (fromStrict "phyloSeaRiseSteps") $ pack $ show (getPhyloSeaRiseSteps phylo)) , toAttr (fromStrict "phyloSeaRiseSteps") $ pack $ show (getPhyloSeaRiseSteps phylo)
-- ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo)) -- ,(toAttr (fromStrict "phyloTermsFreq") $ pack $ show (toList $ _phylo_lastTermFreq phylo))
]) ])
...@@ -462,7 +464,7 @@ idf n groups = log ((fromIntegral $ length groups) / (fromIntegral $ nk n groups ...@@ -462,7 +464,7 @@ idf n groups = log ((fromIntegral $ length groups) / (fromIntegral $ nk n groups
findTfIdf :: [[Int]] -> [(Int,Double)] findTfIdf :: [[Int]] -> [(Int,Double)]
findTfIdf groups = reverse $ sortOn snd $ map (\n -> (n,(tf n groups) * (idf n groups))) $ sort $ nub $ concat groups findTfIdf groups = reverse $ sortOn snd $ map (\n -> (n,(tf n groups) * (idf n groups))) $ nub $ concat groups
findEmergences :: [PhyloGroup] -> Map Int Double -> [(Int,Double)] findEmergences :: [PhyloGroup] -> Map Int Double -> [(Int,Double)]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment