Skip to content

H
haskell-gargantext
Commit e23cae57 authored by Quentin Lobbé's avatar Quentin Lobbé
Browse files
Options

add the view maker system

parent b7409d1b
Hide whitespace changes
Inline Side-by-side
Showing with 637 additions and 237 deletions
src/Gargantext/Viz/Phylo.hs
View file @ e23cae57
......@@ -237,6 +237,7 @@ data PhyloNode = PhyloNode
, _phylo_nodeNgrams :: Maybe [Ngrams]
, _phylo_nodeMeta :: Map Text Double
, _phylo_nodeParent :: Maybe PhyloGroupId
, _phylo_nodeChilds :: [PhyloNode]
} deriving (Show)
-- | PhyloQuery | --
......
src/Gargantext/Viz/Phylo/Example.hs
View file @ e23cae57
......@@ -33,7 +33,7 @@ import Control.Lens hiding (makeLenses, both, Level)
import Data.Bool (Bool, not)
import Data.List ((\\), notElem, concat, union, intersect, tails, tail, head, last, null, zip, sort, length, any, (++), (!!), nub, sortOn, reverse, splitAt, take, delete, init, groupBy)
import Data.Map (Map, elems, insert, member, adjust, singleton, empty, (!), keys, restrictKeys, mapWithKey, filterWithKey, mapKeys, intersectionWith, unionWith)
import Data.Maybe (mapMaybe,isJust,fromJust)
import Data.Maybe (mapMaybe,isJust,fromJust, isNothing)
import Data.Semigroup (Semigroup)
import Data.Set (Set)
import Data.Text (Text, unwords, toLower, words)
......@@ -57,6 +57,12 @@ import Gargantext.Viz.Phylo.LinkMaker
import Gargantext.Viz.Phylo.Metrics.Proximity
import Gargantext.Viz.Phylo.Metrics.Clustering
import Gargantext.Viz.Phylo.Tools
import Gargantext.Viz.Phylo.View.Display
import Gargantext.Viz.Phylo.View.Filters
import Gargantext.Viz.Phylo.View.Metrics
import Gargantext.Viz.Phylo.View.Sort
import Gargantext.Viz.Phylo.View.Taggers
import Gargantext.Viz.Phylo.View.ViewMaker
import qualified Data.Bool as Bool
......@@ -69,251 +75,33 @@ import qualified Data.Vector as Vector
------------------------------------------------------------------------
-- | STEP 12 | -- Return a Phylo for upcomming visiualization tasks
-- | STEP 12 | -- Return a Phylo as a View for upcomming visiualization tasks
-- | To transform a list of Ngrams Indexes into a Label
ngramsToLabel :: Vector Ngrams -> [Int] -> Text
ngramsToLabel ngrams l = unwords $ ngramsToText ngrams l
-- | To transform a list of Ngrams Indexes into a list of Text
ngramsToText :: Vector Ngrams -> [Int] -> [Text]
ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
-- | To get the nth most frequent Ngrams in a list of PhyloGroups
mostFreqNgrams :: Int -> [PhyloGroup] -> [Int]
mostFreqNgrams thr groups = map fst
$ take thr
$ reverse
$ sortOn snd
$ map (\g -> (head g,length g))
$ groupBy (==)
$ (sort . concat)
$ map getGroupNgrams groups
-- | To get the (nth `div` 2) most cooccuring Ngrams in a PhyloGroup
mostOccNgrams :: Int -> PhyloGroup -> [Int]
mostOccNgrams thr group = (nub . concat )
$ map (\((f,s),d) -> [f,s])
$ take (thr `div` 2)
$ reverse $ sortOn snd $ Map.toList $ getGroupCooc group
freqToLabel :: Int -> [PhyloGroup] -> Vector Ngrams -> Text
freqToLabel thr l ngs = ngramsToLabel ngs $ mostFreqNgrams thr l
--------- To Do tagger, sort et display
getNodeId :: PhyloNode -> PhyloGroupId
getNodeId n = n ^. phylo_nodeId
getSourceId :: PhyloEdge -> PhyloGroupId
getSourceId e = e ^. phylo_edgeSource
getTargetId :: PhyloEdge -> PhyloGroupId
getTargetId e = e ^. phylo_edgeTarget
getNodeBranchId :: PhyloNode -> PhyloBranchId
getNodeBranchId n = case n ^. phylo_nodeBranchId of
Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeBranchId] branchId not found"
Just i -> i
getBranchId :: PhyloBranch -> PhyloBranchId
getBranchId b = b ^. phylo_branchId
getViewBranchIds :: PhyloView -> [PhyloBranchId]
getViewBranchIds v = map getBranchId $ v ^. phylo_viewBranches
cleanNodesEdges :: PhyloView -> PhyloView -> PhyloView
cleanNodesEdges v v' = v' & phylo_viewNodes %~ (filter (\n -> not $ elem (getNodeId n) nIds))
& phylo_viewEdges %~ (filter (\e -> (not $ elem (getSourceId e) nIds)
&& (not $ elem (getTargetId e) nIds)))
where
--------------------------------------
nIds :: [PhyloGroupId]
nIds = map getNodeId
$ filter (\n -> elem (getNodeBranchId n) bIds)
$ getNodesInBranches v
--------------------------------------
bIds :: [PhyloBranchId]
bIds = (getViewBranchIds v) \\ (getViewBranchIds v')
--------------------------------------
filterLonelyBranch :: Int -> Int -> Int -> [PhyloPeriodId] -> PhyloView -> PhyloView
filterLonelyBranch nbInf nbSup nbNs prds v = cleanNodesEdges v v'
where
--------------------------------------
v' :: PhyloView
v' = v & phylo_viewBranches %~ (filter (\b -> let ns = filter (\n -> (getBranchId b) == (getNodeBranchId n))
$ getNodesInBranches v
prds' = nub $ map (\n -> (fst . fst) $ getNodeId n) ns
in not (isLone ns prds')))
--------------------------------------
isLone :: [PhyloNode] -> [PhyloPeriodId] -> Bool
isLone ns prds' = (length ns <= nbNs)
&& notElem (head prds') (take nbInf prds)
&& notElem (head prds') (take nbSup $ reverse prds)
--------------------------------------
getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
getBranchIdsWith lvl p = sortOn snd
$ mapMaybe getGroupBranchId
$ getGroupsWithLevel lvl p
phyloParams :: PhyloParam
phyloParams = PhyloParam "v0.1" (Software "Gargantext" "v4") ""
getPhyloParams :: Phylo -> PhyloParam
getPhyloParams p = phyloParams
initPhyloBranch :: PhyloBranchId -> Text -> PhyloBranch
initPhyloBranch id lbl = PhyloBranch id lbl empty
groupsToNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
in PhyloNode
(getGroupId g)
(getGroupBranchId g)
"" idxs
(if isV
then Just (ngramsToText ns idxs)
else Nothing)
empty
(if (not isR)
then Just (head $ getGroupLevelParentsId g)
else Nothing)
) gs
initPhyloEdge :: PhyloGroupId -> [Pointer] -> EdgeType -> [PhyloEdge]
initPhyloEdge id pts et = map (\pt -> PhyloEdge id (fst pt) et (snd pt)) pts
groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
groupsToEdges fl et gs = case fl of
Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
_ -> concat
$ map (\g -> case fl of
Ascendant -> case et of
PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
LevelEdge -> initPhyloEdge (getGroupId g) (getGroupLevelParents g) et
Descendant -> case et of
PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds g) et
LevelEdge -> initPhyloEdge (getGroupId g) (getGroupLevelChilds g) et
) gs
addBranches :: Level -> Phylo -> [PhyloBranch]
addBranches lvl p = map (\id -> initPhyloBranch id "") $ nub $ getBranchIdsWith lvl p
initPhyloView :: Level -> Text -> Text -> Filiation -> Bool -> Phylo -> PhyloView
initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl empty
([] ++ (addBranches lvl p))
([] ++ (groupsToNodes True vb (getFoundations p) gs))
([] ++ (groupsToEdges fl PeriodEdge gs))
where
--------------------------------------
gs :: [PhyloGroup]
gs = getGroupsWithLevel lvl p
--------------------------------------
addChildNodes :: Bool -> Level -> Level -> Bool -> Filiation -> Phylo -> PhyloView -> PhyloView
addChildNodes shouldDo lvl lvl' vb fl p v =
if (not shouldDo) || (lvl == lvl')
then v
else addChildNodes shouldDo lvl (lvl' - 1) vb fl p
$ v & phylo_viewBranches %~ (++ (addBranches (lvl' - 1) p))
& phylo_viewNodes %~ (++ (groupsToNodes False vb (getFoundations p) gs'))
& phylo_viewEdges %~ (++ (groupsToEdges fl PeriodEdge gs'))
& phylo_viewEdges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
& phylo_viewEdges %~ (++ (groupsToEdges Ascendant LevelEdge gs'))
where
--------------------------------------
gs :: [PhyloGroup]
gs = getGroupsWithLevel lvl' p
--------------------------------------
gs' :: [PhyloGroup]
gs' = getGroupsWithLevel (lvl' - 1) p
--------------------------------------
addBranchMeta :: PhyloBranchId -> Text -> Double -> PhyloView -> PhyloView
addBranchMeta id lbl val v = over (phylo_viewBranches
. traverse)
(\b -> if getBranchId b == id
then b & phylo_branchMeta %~ insert lbl val
else b) v
getNodesInBranches :: PhyloView -> [PhyloNode]
getNodesInBranches v = filter (\n -> isJust $ n ^. phylo_nodeBranchId)
$ v ^. phylo_viewNodes
branchAge :: PhyloView -> PhyloView
branchAge v = foldl (\v' b -> let bId = (fst . head) b
prds = sortOn fst $ map snd b
in addBranchMeta bId "age" ((abs . fromIntegral)
$ ((snd . last) prds) - ((fst . head) prds)) v') v
$ groupBy ((==) `on` fst)
$ sortOn fst
$ map (\n -> (getNodeBranchId n, (fst . fst) $ getNodeId n))
$ getNodesInBranches v
processMetrics :: [Metric] -> Phylo -> PhyloView -> PhyloView
processMetrics ms p v = foldl (\v' m -> case m of
BranchAge -> branchAge v'
_ -> panic "[ERR][Viz.Phylo.Example.processMetrics] metric not found") v ms
processFilters :: [QueryFilter] -> Phylo -> PhyloView -> PhyloView
processFilters fs p v = foldl (\v' f -> case f ^. query_filter of
LonelyBranch -> filterLonelyBranch (round $ (f ^. query_params) !! 0)
(round $ (f ^. query_params) !! 1)
(round $ (f ^. query_params) !! 2) (getPhyloPeriods p) v'
_ -> panic "[ERR][Viz.Phylo.Example.processFilters] filter not found") v fs
queryToView :: PhyloQuery -> Phylo -> PhyloView
queryToView q p = processFilters (q ^.query_filters) p
$ processMetrics (q ^.query_metrics) p
$ addChildNodes (q ^. query_childs) (q ^. query_lvl) (q ^. query_childsDepth) (q ^. query_verbose) (q ^. query_filiation) p
$ initPhyloView (q ^. query_lvl) "Phylo2000" "This is a Phylo" (q ^. query_filiation) (q ^. query_verbose) p
-- | To do : add a queryParser from an URL and then update the defaultQuery
urlToQuery :: Text -> PhyloQuery
urlToQuery url = defaultQuery
& query_metrics %~ (++ [BranchAge])
& query_filters %~ (++ [QueryFilter LonelyBranch [2,2,1]])
& query_taggers %~ (++ [BranchLabelFreq,GroupLabelCooc])
defaultQuery :: PhyloQuery
defaultQuery = PhyloQuery 3 Descendant False 0 [] [] [] Nothing Flat True
defaultQuery = PhyloQuery 3 Descendant False 1 [] [] [] (Just (ByBranchAge,Asc)) Flat True
urlQuery :: Text
urlQuery = "level=3&childs=false&filter=LonelyBranchFilter(2,2,1):true&metric=BranchAge&tagger=BranchLabelFreq&tagger=GroupLabelCooc"
-- | To do : add a queryParser from an URL and then update the defaultQuery
urlToQuery :: Text -> PhyloQuery
urlToQuery url = defaultQuery
& query_lvl .~ 3
& query_childs .~ False
& query_metrics %~ (++ [BranchAge])
& query_filters %~ (++ [QueryFilter LonelyBranch [2,2,1]])
& query_taggers %~ (++ [BranchLabelFreq,GroupLabelCooc])
toPhyloView :: Text -> Phylo -> PhyloView
toPhyloView url p = queryToView (urlToQuery url) p
phyloView :: PhyloView
phyloView = toPhyloView urlQuery phylo6
------------------------------------------------------------------------
-- | STEP 11 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo
......
src/Gargantext/Viz/Phylo/Tools.hs
View file @ e23cae57
......@@ -18,7 +18,8 @@ module Gargantext.Viz.Phylo.Tools
where
import Control.Lens hiding (both, Level)
import Data.List (filter, intersect, (++), sort, null, head, tail, last, tails, delete, nub, concat, union)
import Data.List (filter, intersect, (++), sort, null, head, tail, last, tails, delete, nub, concat, union, sortOn)
import Data.Maybe (mapMaybe)
import Data.Map (Map, mapKeys, member, elems, adjust)
import Data.Set (Set)
import Data.Text (Text, toLower)
......@@ -37,6 +38,7 @@ import qualified Data.Vector as Vector
-- | Tools | --
-- | To alter a PhyloGroup matching a given Level
alterGroupWithLevel :: (PhyloGroup -> PhyloGroup) -> Level -> Phylo -> Phylo
alterGroupWithLevel f lvl p = over ( phylo_periods
. traverse
......@@ -49,7 +51,6 @@ alterGroupWithLevel f lvl p = over ( phylo_periods
else g ) p
-- | To alter each list of PhyloGroups following a given function
alterPhyloGroups :: ([PhyloGroup] -> [PhyloGroup]) -> Phylo -> Phylo
alterPhyloGroups f p = over ( phylo_periods
......@@ -121,6 +122,23 @@ filterGroupEdges :: Double -> GroupEdges -> GroupEdges
filterGroupEdges thr edges = filter (\((s,t),w) -> w > thr) edges
-- | To get the PhyloBranchId of a PhyloBranch
getBranchId :: PhyloBranch -> PhyloBranchId
getBranchId b = b ^. phylo_branchId
-- | To get a list of PhyloBranchIds given a Level in a Phylo
getBranchIdsWith :: Level -> Phylo -> [PhyloBranchId]
getBranchIdsWith lvl p = sortOn snd
$ mapMaybe getGroupBranchId
$ getGroupsWithLevel lvl p
-- | To get the Meta value of a PhyloBranch
getBranchMeta :: Text -> PhyloBranch -> Double
getBranchMeta k b = (b ^. phylo_branchMeta) Map.! k
-- | To get the foundations of a Phylo
getFoundations :: Phylo -> Vector Ngrams
getFoundations = _phylo_foundations
......@@ -228,11 +246,16 @@ getGroups = view ( phylo_periods
)
-- | To all PhyloGroups matching a list of PhyloGroupIds in a Phylo
-- | To get all PhyloGroups matching a list of PhyloGroupIds in a Phylo
getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
-- | To get the corresponding list of PhyloGroups from a list of PhyloNodes
getGroupsFromNodes :: [PhyloNode] -> Phylo -> [PhyloGroup]
getGroupsFromNodes ns p = getGroupsFromIds (map getNodeId ns) p
-- | To get all the PhyloGroup of a Phylo with a given level and period
getGroupsWithFilters :: Int -> (Date,Date) -> Phylo -> [PhyloGroup]
getGroupsWithFilters lvl prd p = (getGroupsWithLevel lvl p)
......@@ -274,6 +297,7 @@ getLastLevel p = (last . sort)
. phylo_periodLevels ) p
-- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of GroupEdges
getNeighbours :: Bool -> PhyloGroup -> GroupEdges -> [PhyloGroup]
getNeighbours directed g e = case directed of
......@@ -283,9 +307,52 @@ getNeighbours directed g e = case directed of
$ filter (\((s,t),w) -> s == g || t == g) e
-- | To get the Branches of a Phylo
-- getPhyloBranches :: Phylo -> [PhyloBranch]
-- getPhyloBranches = _phylo_branches
-- | To get the PhyloBranchId of PhyloNode if it exists
getNodeBranchId :: PhyloNode -> PhyloBranchId
getNodeBranchId n = case n ^. phylo_nodeBranchId of
Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeBranchId] branchId not found"
Just i -> i
-- | To get the PhyloGroupId of a PhyloNode
getNodeId :: PhyloNode -> PhyloGroupId
getNodeId n = n ^. phylo_nodeId
-- | To get the Level of a PhyloNode
getNodeLevel :: PhyloNode -> Level
getNodeLevel n = (snd . fst) $ getNodeId n
-- | To get the Parent Node of a PhyloNode in a PhyloView
getNodeParent :: PhyloNode -> PhyloView -> PhyloNode
getNodeParent n v = head
$ filter (\n' -> getNodeId n' == getNodeParentId n)
$ v ^. phylo_viewNodes
-- | To get the Parent Node id of a PhyloNode if it exists
getNodeParentId :: PhyloNode -> PhyloGroupId
getNodeParentId n = case n ^. phylo_nodeParent of
Nothing -> panic "[ERR][Viz.Phylo.Tools.getNodeParentId] node parent not found"
Just id -> id
-- | To get a list of PhyloNodes grouped by PhyloBranch in a PhyloView
getNodesByBranches :: PhyloView -> [(PhyloBranchId,[PhyloNode])]
getNodesByBranches v = zip bIds $ map (\id -> filter (\n -> (getNodeBranchId n) == id)
$ getNodesInBranches v ) bIds
where
--------------------------------------
bIds :: [PhyloBranchId]
bIds = getViewBranchIds v
--------------------------------------
-- | To get a list of PhyloNodes owned by any PhyloBranches in a PhyloView
getNodesInBranches :: PhyloView -> [PhyloNode]
getNodesInBranches v = filter (\n -> isJust $ n ^. phylo_nodeBranchId)
$ v ^. phylo_viewNodes
-- | To get the PhylolevelId of a given PhyloLevel
......@@ -309,6 +376,21 @@ getPhyloPeriodId :: PhyloPeriod -> PhyloPeriodId
getPhyloPeriodId prd = _phylo_periodId prd
-- | To get the PhyloGroupId of the Source of a PhyloEdge
getSourceId :: PhyloEdge -> PhyloGroupId
getSourceId e = e ^. phylo_edgeSource
-- | To get the PhyloGroupId of the Target of a PhyloEdge
getTargetId :: PhyloEdge -> PhyloGroupId
getTargetId e = e ^. phylo_edgeTarget
-- | To get all the PhyloBranchIds of a PhyloView
getViewBranchIds :: PhyloView -> [PhyloBranchId]
getViewBranchIds v = map getBranchId $ v ^. phylo_viewBranches
-- | To init the foundation of the Phylo as a Vector of Ngrams
initFoundations :: [Ngrams] -> Vector Ngrams
initFoundations l = Vector.fromList $ map toLower l
......
src/Gargantext/Viz/Phylo/View/Display.hs 0 → 100644
View file @ e23cae57
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy Tools to build/manage it
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.View.Display
where
import Control.Lens hiding (makeLenses, both, Level)
import Data.List (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
import Data.Map (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys,insert)
import Data.Maybe (isNothing)
import Data.Set (Set)
import Data.Text (Text,unwords)
import Data.Tuple (fst, snd)
import Data.Vector (Vector)
import Gargantext.Prelude hiding (head)
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as Vector
-- | To transform a flat Phyloview into a nested Phyloview
toNestedView :: [PhyloNode] -> [PhyloNode] -> [PhyloNode]
toNestedView ns ns'
| null ns' = ns
| otherwise = toNestedView (filter (\n -> lvl' == getNodeLevel n) nested)
(filter (\n -> lvl' < getNodeLevel n) nested)
where
--------------------------------------
lvl' :: Level
lvl' = getNodeLevel $ head $ nested
--------------------------------------
nested :: [PhyloNode]
nested = foldl (\ns' n -> let nId' = getNodeParentId n
in map (\n' -> if getNodeId n' == nId'
then n' & phylo_nodeChilds %~ (++ [n])
else n') ns') ns' ns
--------------------------------------
-- | To process a DisplayMode to a PhyloView
processDisplay :: DisplayMode -> PhyloView -> PhyloView
processDisplay d v = case d of
Flat -> v
Nested -> let ns = sortOn getNodeLevel $ v ^. phylo_viewNodes
lvl = getNodeLevel $ head ns
in v & phylo_viewNodes .~ toNestedView (filter (\n -> lvl == getNodeLevel n) ns)
(filter (\n -> lvl < getNodeLevel n) ns)
_ -> panic "[ERR][Viz.Phylo.Example.processDisplay] display not found"
\ No newline at end of file
src/Gargantext/Viz/Phylo/View/Filters.hs 0 → 100644
View file @ e23cae57
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy Tools to build/manage it
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.View.Filters
where
import Control.Lens hiding (makeLenses, both, Level)
import Data.List (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
import Data.Map (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys)
import Data.Maybe (isNothing)
import Data.Set (Set)
import Data.Text (Text,unwords)
import Data.Tuple (fst, snd)
import Data.Vector (Vector)
import Gargantext.Prelude hiding (head)
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as Vector
-- | To clean a PhyloView list of Nodes, Edges, etc after having filtered its Branches
cleanNodesEdges :: PhyloView -> PhyloView -> PhyloView
cleanNodesEdges v v' = v' & phylo_viewNodes %~ (filter (\n -> not $ elem (getNodeId n) nIds))
& phylo_viewNodes %~ (map (\n -> if isNothing (n ^. phylo_nodeParent)
then n
else if elem (getNodeParentId n) nIds
then n & phylo_nodeParent .~ Nothing
else n ))
& phylo_viewEdges %~ (filter (\e -> (not $ elem (getSourceId e) nIds)
&& (not $ elem (getTargetId e) nIds)))
where
--------------------------------------
nIds :: [PhyloGroupId]
nIds = map getNodeId
$ filter (\n -> elem (getNodeBranchId n) bIds)
$ getNodesInBranches v
--------------------------------------
bIds :: [PhyloBranchId]
bIds = (getViewBranchIds v) \\ (getViewBranchIds v')
--------------------------------------
-- | To filter all the lonelyBranches (ie: isolated one in time & with a small number of nodes) of a PhyloView
filterLonelyBranch :: Int -> Int -> Int -> [PhyloPeriodId] -> PhyloView -> PhyloView
filterLonelyBranch nbInf nbSup nbNs prds v = cleanNodesEdges v v'
where
--------------------------------------
v' :: PhyloView
v' = v & phylo_viewBranches %~ (filter (\b -> let ns = filter (\n -> (getBranchId b) == (getNodeBranchId n))
$ getNodesInBranches v
prds' = nub $ map (\n -> (fst . fst) $ getNodeId n) ns
in not (isLone ns prds')))
--------------------------------------
isLone :: [PhyloNode] -> [PhyloPeriodId] -> Bool
isLone ns prds' = (length ns <= nbNs)
&& notElem (head prds') (take nbInf prds)
&& notElem (head prds') (take nbSup $ reverse prds)
--------------------------------------
-- | To process a list of QueryFilter to a PhyloView
processFilters :: [QueryFilter] -> Phylo -> PhyloView -> PhyloView
processFilters fs p v = foldl (\v' f -> case f ^. query_filter of
LonelyBranch -> filterLonelyBranch (round $ (f ^. query_params) !! 0)
(round $ (f ^. query_params) !! 1)
(round $ (f ^. query_params) !! 2) (getPhyloPeriods p) v'
_ -> panic "[ERR][Viz.Phylo.View.Filters.processFilters] filter not found") v fs
\ No newline at end of file
src/Gargantext/Viz/Phylo/View/Metrics.hs 0 → 100644
View file @ e23cae57
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy Tools to build/manage it
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.View.Metrics
where
import Control.Lens hiding (makeLenses, both, Level)
import Data.List (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
import Data.Map (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys,insert)
import Data.Maybe (isNothing)
import Data.Set (Set)
import Data.Text (Text,unwords)
import Data.Tuple (fst, snd)
import Data.Vector (Vector)
import Gargantext.Prelude hiding (head)
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as Vector
-- | To add a new meta Metric to a PhyloBranch
addBranchMeta :: PhyloBranchId -> Text -> Double -> PhyloView -> PhyloView
addBranchMeta id lbl val v = over (phylo_viewBranches
. traverse)
(\b -> if getBranchId b == id
then b & phylo_branchMeta %~ insert lbl val
else b) v
-- | To get the age (in year) of all the branches of a PhyloView
branchAge :: PhyloView -> PhyloView
branchAge v = foldl (\v' b -> let bId = (fst . head) b
prds = sortOn fst $ map snd b
in addBranchMeta bId "age" ((abs . fromIntegral)
$ ((snd . last) prds) - ((fst . head) prds)) v') v
$ groupBy ((==) `on` fst)
$ sortOn fst
$ map (\n -> (getNodeBranchId n, (fst . fst) $ getNodeId n))
$ getNodesInBranches v
-- | To process a list of Metrics to a PhyloView
processMetrics :: [Metric] -> Phylo -> PhyloView -> PhyloView
processMetrics ms p v = foldl (\v' m -> case m of
BranchAge -> branchAge v'
_ -> panic "[ERR][Viz.Phylo.Example.processMetrics] metric not found") v ms
src/Gargantext/Viz/Phylo/View/Sort.hs 0 → 100644
View file @ e23cae57
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy Tools to build/manage it
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.View.Sort
where
import Control.Lens hiding (makeLenses, both, Level)
import Data.List (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
import Data.Map (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys,insert)
import Data.Maybe (isNothing)
import Data.Set (Set)
import Data.Text (Text,unwords)
import Data.Tuple (fst, snd)
import Data.Vector (Vector)
import Gargantext.Prelude hiding (head)
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as Vector
-- | To sort a PhyloView by Age
sortBranchByAge :: Order -> PhyloView -> PhyloView
sortBranchByAge o v = v & phylo_viewBranches %~ f
where
--------------------------------------
f :: [PhyloBranch] -> [PhyloBranch]
f xs = case o of
Asc -> sortOn (getBranchMeta "age") xs
Desc -> reverse $ sortOn (getBranchMeta "age") xs
--------------------------------------
-- | To process a Sort to a PhyloView
processSort :: Maybe (Sort,Order) -> Phylo -> PhyloView -> PhyloView
processSort s p v = case s of
Nothing -> v
Just s -> case fst s of
ByBranchAge -> sortBranchByAge (snd s) v
_ -> panic "[ERR][Viz.Phylo.View.Sort.processSort] sort not found"
\ No newline at end of file
src/Gargantext/Viz/Phylo/View/Taggers.hs 0 → 100644
View file @ e23cae57
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy Tools to build/manage it
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.View.Taggers
where
import Control.Lens hiding (makeLenses, both, Level)
import Data.List (last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort)
import Data.Map (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys)
import Data.Set (Set)
import Data.Text (Text,unwords)
import Data.Tuple (fst, snd)
import Data.Vector (Vector)
import Gargantext.Prelude hiding (head)
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as Vector
-- | To transform a list of Ngrams Indexes into a Label
ngramsToLabel :: Vector Ngrams -> [Int] -> Text
ngramsToLabel ngrams l = unwords $ ngramsToText ngrams l
-- | To transform a list of Ngrams Indexes into a list of Text
ngramsToText :: Vector Ngrams -> [Int] -> [Text]
ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
-- | To get the nth most frequent Ngrams in a list of PhyloGroups
mostFreqNgrams :: Int -> [PhyloGroup] -> [Int]
mostFreqNgrams thr groups = map fst
$ take thr
$ reverse
$ sortOn snd
$ map (\g -> (head g,length g))
$ groupBy (==)
$ (sort . concat)
$ map getGroupNgrams groups
-- | To transform the nth most frequent Ngrams into a label
freqToLabel :: Int -> Vector Ngrams -> [PhyloGroup] -> Text
freqToLabel thr ngs l = ngramsToLabel ngs $ mostFreqNgrams thr l
-- | To get the (nth `div` 2) most cooccuring Ngrams in a PhyloGroup
mostOccNgrams :: Int -> PhyloGroup -> [Int]
mostOccNgrams thr group = (nub . concat )
$ map (\((f,s),d) -> [f,s])
$ take (thr `div` 2)
$ reverse $ sortOn snd $ Map.toList $ getGroupCooc group
-- | To alter the label of a PhyloBranch
alterBranchLabel :: (PhyloBranchId,Text) -> PhyloView -> PhyloView
alterBranchLabel (id,lbl) v = over (phylo_viewBranches
. traverse)
(\b -> if getBranchId b == id
then b & phylo_branchLabel .~ lbl
else b) v
-- | To set the label of a PhyloBranch as the nth most frequent terms of its PhyloNodes
branchLabelFreq :: PhyloView -> Int -> Phylo -> PhyloView
branchLabelFreq v thr p = foldl (\v' (id,lbl) -> alterBranchLabel (id,lbl) v') v
$ map (\(id,ns) -> (id, freqToLabel thr (getFoundations p)
$ getGroupsFromNodes ns p))
$ getNodesByBranches v
-- | 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 (phylo_viewNodes
. traverse)
(\n -> let lbl = ngramsToLabel (getFoundations p)
$ mostOccNgrams thr
$ head $ getGroupsFromIds [getNodeId n] p
in n & phylo_nodeLabel .~ lbl) v
-- | To process a sorted list of Taggers to a PhyloView
processTaggers :: [Tagger] -> Phylo -> PhyloView -> PhyloView
processTaggers ts p v = foldl (\v' t -> case t of
BranchLabelFreq -> branchLabelFreq v' 2 p
GroupLabelCooc -> nodeLabelCooc v' 2 p
_ -> panic "[ERR][Viz.Phylo.View.Taggers.processTaggers] tagger not found") v ts
src/Gargantext/Viz/Phylo/View/ViewMaker.hs 0 → 100644
View file @ e23cae57
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy Tools to build/manage it
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.View.ViewMaker
where
import Control.Lens hiding (makeLenses, both, Level)
import Data.List (notElem,last,head,union,concat,null,nub,(++),init,tail,elemIndex,groupBy,(!!),sortOn,sort,(\\))
import Data.Map (Map,elems,adjust,unionWith,intersectionWith,fromList,mapKeys,insert,empty)
import Data.Maybe (isNothing)
import Data.Set (Set)
import Data.Text (Text,unwords)
import Data.Tuple (fst, snd)
import Data.Vector (Vector)
import Gargantext.Prelude hiding (head)
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Tools
import Gargantext.Viz.Phylo.View.Display
import Gargantext.Viz.Phylo.View.Filters
import Gargantext.Viz.Phylo.View.Metrics
import Gargantext.Viz.Phylo.View.Sort
import Gargantext.Viz.Phylo.View.Taggers
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector as Vector
-- | To init a PhyloBranch
initPhyloBranch :: PhyloBranchId -> Text -> PhyloBranch
initPhyloBranch id lbl = PhyloBranch id lbl empty
-- | To init a PhyloEdge
initPhyloEdge :: PhyloGroupId -> [Pointer] -> EdgeType -> [PhyloEdge]
initPhyloEdge id pts et = map (\pt -> PhyloEdge id (fst pt) et (snd pt)) pts
-- | To init a PhyloView
initPhyloView :: Level -> Text -> Text -> Filiation -> Bool -> Phylo -> PhyloView
initPhyloView lvl lbl dsc fl vb p = PhyloView (getPhyloParams p) lbl dsc fl empty
([] ++ (phyloToBranches lvl p))
([] ++ (groupsToNodes True vb (getFoundations p) gs))
([] ++ (groupsToEdges fl PeriodEdge gs))
where
--------------------------------------
gs :: [PhyloGroup]
gs = getGroupsWithLevel lvl p
--------------------------------------
-- | To transform a list of PhyloGroups into a list of PhyloNodes
groupsToNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
groupsToNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
in PhyloNode
(getGroupId g)
(getGroupBranchId g)
"" idxs
(if isV
then Just (ngramsToText ns idxs)
else Nothing)
empty
(if (not isR)
then Just (head $ getGroupLevelParentsId g)
else Nothing)
[]
) gs
-- | To transform a list of PhyloGroups into a list of PhyloEdges
groupsToEdges :: Filiation -> EdgeType -> [PhyloGroup] -> [PhyloEdge]
groupsToEdges fl et gs = case fl of
Complete -> (groupsToEdges Ascendant et gs) ++ (groupsToEdges Descendant et gs)
_ -> concat
$ map (\g -> case fl of
Ascendant -> case et of
PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodParents g) et
LevelEdge -> initPhyloEdge (getGroupId g) (getGroupLevelParents g) et
Descendant -> case et of
PeriodEdge -> initPhyloEdge (getGroupId g) (getGroupPeriodChilds g) et
LevelEdge -> initPhyloEdge (getGroupId g) (getGroupLevelChilds g) et
) gs
-- | To transform a Phylo into a list of PhyloBranch for a given Level
phyloToBranches :: Level -> Phylo -> [PhyloBranch]
phyloToBranches lvl p = map (\id -> initPhyloBranch id "") $ nub $ getBranchIdsWith lvl p
-- | To add recursively a list of PhyloNodes and Edges to PhyloView from a given Level and Depth
addChildNodes :: Bool -> Level -> Level -> Bool -> Filiation -> Phylo -> PhyloView -> PhyloView
addChildNodes shouldDo lvl lvlMin vb fl p v =
if (not shouldDo) || (lvl == lvlMin)
then v
else addChildNodes shouldDo (lvl - 1) lvlMin vb fl p
$ v & phylo_viewBranches %~ (++ (phyloToBranches (lvl - 1) p))
& phylo_viewNodes %~ (++ (groupsToNodes False vb (getFoundations p) gs'))
& phylo_viewEdges %~ (++ (groupsToEdges fl PeriodEdge gs'))
& phylo_viewEdges %~ (++ (groupsToEdges Descendant LevelEdge gs ))
& phylo_viewEdges %~ (++ (groupsToEdges Ascendant LevelEdge gs'))
where
--------------------------------------
gs :: [PhyloGroup]
gs = getGroupsWithLevel lvl p
--------------------------------------
gs' :: [PhyloGroup]
gs' = getGroupsWithLevel (lvl - 1) p
--------------------------------------
-- | To transform a PhyloQuery into a PhyloView
queryToView :: PhyloQuery -> Phylo -> PhyloView
queryToView q p = processDisplay (q ^. query_display)
$ processSort (q ^. query_sort) p
$ processTaggers (q ^. query_taggers) p
$ processFilters (q ^. query_filters) p
$ processMetrics (q ^. query_metrics) p
$ addChildNodes (q ^. query_childs) (q ^. query_lvl) (q ^. query_childsDepth) (q ^. query_verbose) (q ^. query_filiation) p
$ initPhyloView (q ^. query_lvl) "Phylo2000" "This is a Phylo" (q ^. query_filiation) (q ^. query_verbose) p
-- | dirty params
phyloParams :: PhyloParam
phyloParams = PhyloParam "v0.1" (Software "Gargantext" "v4") ""
-- | To do : effectively get the PhyloParams of a Phylo
getPhyloParams :: Phylo -> PhyloParam
getPhyloParams p = phyloParams
\ No newline at end of file
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