Skip to content

H
haskell-gargantext
Commit 58efcc61 authored by qlobbe's avatar qlobbe
Browse files
Options

adding the ngrams dynamics

parent d746a99b
Hide whitespace changes
Inline Side-by-side
Showing with 94 additions and 15 deletions
src/Gargantext/Viz/Phylo/Metrics.hs
View file @ 58efcc61
......@@ -18,9 +18,13 @@ module Gargantext.Viz.Phylo.Metrics
where
import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import Data.List ((\\), sortOn, concat, nub, take, union, intersect, null)
import Data.Map (Map, foldlWithKey, toList, size, unionWith, intersection, intersectionWith, filterWithKey, elems, fromList, findWithDefault)
import Control.Lens hiding (Level)
import Data.List ((\\), sortOn, concat, nub, take, union, intersect, null, (++), sort)
import Data.Map (Map, (!), foldlWithKey, toList, size, insert, unionWith, intersection, intersectionWith, filterWithKey, elems, fromList, findWithDefault, fromListWith)
import Data.Text (Text)
-- import Debug.Trace (trace)
......@@ -61,7 +65,7 @@ getNgramsMeta :: Map (Int, Int) Double -> [Int] -> Map Text [Double]
getNgramsMeta m ngrams = fromList
[ ("genericity" , map (\n -> genericity m (ngrams \\ [n]) n) ngrams ),
("specificity", map (\n -> specificity m (ngrams \\ [n]) n) ngrams ),
("coverage" , map (\n -> coverage m (ngrams \\ [n]) n) ngrams )]
("coverage" , map (\n -> coverage m (ngrams \\ [n]) n) ngrams )]
-- | To get the nth most occurent elems in a coocurency matrix
......@@ -77,6 +81,48 @@ getNthMostOcc nth cooc = (nub . concat)
-- | Ngrams Dynamics | --
-------------------------
sharedWithParents :: Date -> PhyloBranchId -> Int -> PhyloView -> Bool
sharedWithParents inf bid n pv = elem n
$ foldl (\mem pn -> if ((bid == (fromJust $ (pn ^. pn_bid)))
&& (inf > (fst $ getNodePeriod pn)))
then nub $ mem ++ (pn ^. pn_idx)
else mem ) []
$ (pv ^. pv_nodes)
findDynamics :: Int -> PhyloView -> PhyloNode -> Map Int (Date,Date) -> Double
findDynamics n pv pn m =
let prd = getNodePeriod pn
bid = fromJust $ (pn ^. pn_bid)
end = last' "dynamics" (sort $ map snd $ elems m)
in if (((snd prd) == (snd $ m ! n)) && (snd prd /= end))
-- | decrease
then 0
else if ((fst prd) == (fst $ m ! n))
-- | emergence
then 1
else if (not $ sharedWithParents (fst prd) bid n pv)
-- | recombination
then 2
else 3
processDynamics :: PhyloView -> PhyloView
processDynamics pv = alterPhyloNode (\pn ->
pn & pn_metrics %~ insert "dynamics" (map (\n -> findDynamics n pv pn ngramsDates) $ (pn ^. pn_idx) ) ) pv
where
--------------------------------------
ngramsDates :: Map Int (Date,Date)
ngramsDates = map (\ds -> let ds' = sort ds
in (head' "Dynamics" ds', last' "Dynamics" ds'))
$ fromListWith (++)
$ foldl (\mem pn -> mem ++ (map (\n -> (n, [fst $ getNodePeriod pn, snd $ getNodePeriod pn]))
$ (pn ^. pn_idx))) []
$ (pv ^. pv_nodes)
--------------------------------------
-------------------
-- | Proximity | --
......
src/Gargantext/Viz/Phylo/Tools.hs
View file @ 58efcc61
......@@ -261,7 +261,8 @@ alterGroupWithLevel f lvl p = over ( phylo_periods
. traverse
) (\g -> if getGroupLevel g == lvl
then f g
else g ) p
else g ) p
-- | To alter each list of PhyloGroups following a given function
......@@ -566,6 +567,13 @@ getFisPeriod = _phyloFis_period
----------------------------
-- | To alter a PhyloNode
alterPhyloNode :: (PhyloNode -> PhyloNode) -> PhyloView -> PhyloView
alterPhyloNode f v = over ( pv_nodes
. traverse
) (\pn -> f pn ) v
-- | To filter some GroupEdges with a given threshold
filterGroupEdges :: Double -> [GroupEdge] -> [GroupEdge]
filterGroupEdges thr edges = filter (\((_s,_t),w) -> w > thr) edges
......@@ -592,6 +600,10 @@ getNodeId :: PhyloNode -> PhyloGroupId
getNodeId n = n ^. pn_id
getNodePeriod :: PhyloNode -> (Date,Date)
getNodePeriod n = fst $ fst $ getNodeId n
-- | To get the Level of a PhyloNode
getNodeLevel :: PhyloNode -> Level
getNodeLevel n = (snd . fst) $ getNodeId n
......
src/Gargantext/Viz/Phylo/View/Export.hs
View file @ 58efcc61
......@@ -23,8 +23,8 @@ import Data.GraphViz hiding (DotGraph)
import Data.GraphViz.Attributes.Complete hiding (EdgeType)
import Data.GraphViz.Types.Generalised (DotGraph)
import Data.GraphViz.Types.Monadic
import Data.List ((++),unwords,concat,sortOn,nub)
import Data.Map (Map,toList)
import Data.List ((++),unwords,concat,sortOn,nub,sort,group)
import Data.Map (Map,toList,(!))
import Data.Maybe (isNothing,fromJust)
import Data.Text.Lazy (fromStrict, pack, unpack)
......@@ -36,6 +36,8 @@ import Gargantext.Prelude
import Gargantext.Viz.Phylo hiding (Dot)
import Gargantext.Viz.Phylo.Tools
-- import Debug.Trace (trace)
import Prelude (writeFile)
import System.FilePath
......@@ -130,6 +132,20 @@ setPeakDotEdge :: DotId -> DotId -> Dot DotId
setPeakDotEdge bId nId = edge bId nId [Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])]
colorFromDynamics :: Double -> H.Attribute
colorFromDynamics d
| d == 0 = H.BGColor (toColor LightPink)
| d == 1 = H.BGColor (toColor PaleGreen)
| d == 2 = H.BGColor (toColor SkyBlue)
| otherwise = H.Color (toColor Black)
getGroupDynamic :: [Double] -> H.Attribute
getGroupDynamic dy = colorFromDynamics $ head' "getGroupDynamic" (head' "getGroupDynamic" $ reverse $ sortOn length $ group $ sort dy)
-- | To set an HTML table
setHtmlTable :: PhyloNode -> H.Label
setHtmlTable pn = H.Table H.HTable
......@@ -137,14 +153,18 @@ setHtmlTable pn = H.Table H.HTable
, H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
, H.tableRows = [header] <> (if isNothing $ pn ^. pn_ngrams
then []
else map ngramsToRow $ splitEvery 4 $ fromJust $ pn ^. pn_ngrams) }
else map ngramsToRow $ splitEvery 4 $ zip (fromJust $ pn ^. pn_ngrams) dynamics) }
where
--------------------------------------
ngramsToRow :: [Ngrams] -> H.Row
ngramsToRow ns = H.Cells $ map (\n -> H.LabelCell [H.BAlign H.HLeft] $ H.Text [H.Str $ fromStrict n]) ns
ngramsToRow :: [(Ngrams,Double)] -> H.Row
ngramsToRow ns = H.Cells $ map (\(n,d) -> H.LabelCell [H.BAlign H.HLeft,colorFromDynamics d]
$ H.Text [H.Str $ fromStrict n]) ns
--------------------------------------
dynamics :: [Double]
dynamics = (pn ^. pn_metrics) ! "dynamics"
--------------------------------------
header :: H.Row
header = H.Cells [H.LabelCell [H.Color (toColor Black), H.BGColor (toColor Chartreuse2)]
header = H.Cells [H.LabelCell [getGroupDynamic dynamics]
$ H.Text [H.Str $ (fromStrict . T.toUpper) $ pn ^. pn_label]]
--------------------------------------
......
src/Gargantext/Viz/Phylo/View/Taggers.hs
View file @ 58efcc61
......@@ -28,7 +28,7 @@ import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import Gargantext.Viz.Phylo.BranchMaker
import qualified Data.Map as Map
import Debug.Trace (trace)
-- import Debug.Trace (trace)
-- | To get the nth most frequent Ngrams in a list of PhyloGroups
......@@ -88,14 +88,13 @@ getNthMostMeta nth meta g = map (\(idx,_) -> (getGroupNgrams g !! idx))
$ sortOn snd $ zip [0..]
$ (g ^. phylo_groupNgramsMeta) ! meta
-- | To set the label of a PhyloNode as the nth most coocurent terms of its PhyloNodes
nodeLabelCooc :: PhyloView -> Int -> Phylo -> PhyloView
nodeLabelCooc v thr p = over (pv_nodes
. traverse)
(\n -> let g = head' "nodeLabelCooc" $ getGroupsFromIds [getNodeId n] p
lbl' = ngramsToLabel (getFoundationsRoots p) $ getNthMostMeta thr "coverage" g
in trace (show (lbl')) $ n & pn_label .~ lbl') v
lbl = ngramsToLabel (getFoundationsRoots p) $ getNthMostMeta thr "coverage" g
in n & pn_label .~ lbl) v
-- | To process a sorted list of Taggers to a PhyloView
......
src/Gargantext/Viz/Phylo/View/ViewMaker.hs
View file @ 58efcc61
......@@ -26,6 +26,7 @@ import Data.Vector (Vector)
import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import Gargantext.Viz.Phylo.Metrics
import Gargantext.Viz.Phylo.View.Display
import Gargantext.Viz.Phylo.View.Filters
import Gargantext.Viz.Phylo.View.Metrics
......@@ -71,7 +72,7 @@ groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
(if isV
then Just (ngramsToText ns idxs)
else Nothing)
empty
(g ^. phylo_groupNgramsMeta)
(if (not isR)
then Just (getGroupLevelParentsId g)
else Nothing)
......@@ -146,6 +147,7 @@ toPhyloView q p = traceView
$ processDisplay (q ^. qv_display) (q ^. qv_export)
$ processSort (q ^. qv_sort ) p
$ processTaggers (q ^. qv_taggers) p
$ processDynamics
$ processFilters (q ^. qv_filters) p
$ processMetrics (q ^. qv_metrics) p
$ addChildNodes (q ^. qv_levelChilds) (q ^. qv_lvl) (q ^. qv_levelChildsDepth) (q ^. qv_verbose) (q ^. qv_filiation) p
......
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