Strating to add PhyloView and PhyloQuery

src/Gargantext/Viz/Phylo.hs

@@ -46,14 +46,14 @@ import Gargantext.Prelude
 data PhyloExport =
      PhyloExport { _phyloExport_param :: PhyloParam
                  , _phyloExport_data :: Phylo
-     } deriving (Generic)
+     } deriving (Generic, Show)
 
 -- | .phylo parameters
 data PhyloParam = 
      PhyloParam { _phyloParam_version     :: Text -- Double ?
                 , _phyloParam_software    :: Software
                 , _phyloParam_params      :: Hash
-     } deriving (Generic)
+     } deriving (Generic, Show)
 
 type Hash = Text
 
@@ -62,7 +62,7 @@ type Hash = Text
 data Software =
      Software { _software_name    :: Text
               , _software_version :: Text
-     } deriving (Generic)
+     } deriving (Generic, Show)
 
 ------------------------------------------------------------------------
 
@@ -172,12 +172,12 @@ data Document = Document
 type Cluster = [PhyloGroup]
 
 
--- | A List of PhyloGroup in a PhyloGraph
-type PhyloNodes = [PhyloGroup]
--- | A List of weighted links between some PhyloGroups in a PhyloGraph
-type PhyloEdges = [((PhyloGroup,PhyloGroup),Weight)]
+-- | A List of PhyloGroup in a Graph
+type GroupNodes = [PhyloGroup]
+-- | A List of weighted links between some PhyloGroups in a Graph
+type GroupEdges = [((PhyloGroup,PhyloGroup),Weight)]
 -- | The association as a Graph between a list of Nodes and a list of Edges
-type PhyloGraph = (PhyloNodes,PhyloEdges)
+type GroupGraph = (GroupNodes,GroupEdges)
 
 
 data PhyloError = LevelDoesNotExist
@@ -192,32 +192,103 @@ data Clustering  = Louvain | RelatedComponents
 
 data PairTo = Childs | Parents 
 
--- | Views type
+------------------------------------------------------------------------
+-- | To export a Phylo | --
+
+
+-- | PhyloView | --
+
+
+data EdgeType = Ascendant | Descendant | Complete deriving (Show)
+
+data PhyloView = PhyloView
+  { _phylo_viewParam       :: PhyloParam
+  , _phylo_viewLabel       :: Text
+  , _phylo_viewDescription :: Text
+  , _phylo_viewEdgeType    :: EdgeType
+  , _phylo_viewMeta        :: Map Text Double
+  , _phylo_viewBranches    :: [PhyloBranch]
+  , _phylo_viewNodes       :: [PhyloNode]
+  , _phylo_viewEdges       :: [PhyloEdge]
+  } deriving (Show)
+
+
+data PhyloBranch = PhyloBranch 
+  { _phylo_branchId    :: PhyloBranchId
+  , _phylo_branchLabel :: Text
+  , _phylo_branchMeta  :: Map Text Double
+  } deriving (Show)  
+
+
+data PhyloEdge = PhyloEdge
+  { _phylo_edgeSource :: PhyloGroupId
+  , _phylo_edgeTarget :: PhyloGroupId
+  , _phylo_edgeWeight :: Weight
+  } deriving (Show)
+
+
+data PhyloNode = PhyloNode
+  { _phylo_nodeId        :: PhyloGroupId
+  , _phylo_nodeLabel     :: Text
+  , _phylo_nodeNgramsIdx :: [Int] 
+  , _phylo_nodeNgrams    :: Maybe [Ngrams]
+  , _phylo_nodeMeta      :: Map Text Double
+  , _phylo_nodeParent    :: Maybe PhyloGroupId 
+  } deriving (Show)
+
+-- | PhyloQuery | --
+
+
+data Filter = LonelyBranchFilter 
+data Metric = BranchAge
+data Tagger = BranchLabelFreq | GroupLabelCooc | GroupDynamics
 
-data EdgeType = Directed | UnDirected
 
-data ViewGraph = ViewGraph
-  { _view_graphParam    :: PhyloParam
-  , _view_graphLabel    :: Text
-  , _view_graphEdgeType :: EdgeType
-  , _view_graphBranches :: [(PhyloBranchId,Text)]
-  , _view_graphNodes    :: [ViewNode]
-  , _view_graphEdges    :: [ViewEdge]
-  } 
+data Sort   = ByBranchAge
+data Order  = Asc | Desc 
 
-data ViewEdge = ViewEdge
-  { _view_edgeSource :: PhyloGroupId
-  , _view_edgeTarget :: PhyloGroupId
-  , _view_edgeWeight :: Weight
+
+data QueryParam  = Qp1 Int | Qp2 Text | Qp3 Bool deriving (Eq, Ord)
+data DisplayMode = Flat | Nested 
+
+
+-- | A query filter seen as : prefix && ((filter params)(clause)) 
+data QueryFilter = QueryFilter
+  { _query_filter :: Filter
+  , _query_params :: [QueryParam]
+  , _query_clause :: (QueryParam -> Bool)
+  }
+
+
+-- | A PhyloQuery is the structured representation of a user query to be applied to a Phylo
+data PhyloQuery = PhyloQuery 
+  { _query_lvl    :: Level
+
+  -- Does the PhyloGraph contain ascendant, descendant or both (filiation) edges ?
+  , _query_edgeType :: EdgeType
+
+  -- Does the PhyloGraph contain some levelChilds ? How deep must it go ?
+  , _query_childs      :: Bool
+  , _query_childsDepth :: Level
+
+  -- Ordered lists of filters, taggers and metrics to be applied to the PhyloGraph
+  -- Firstly the metrics, then the filters and the taggers   
+  , _query_metrics :: [Metric]
+  , _query_filters :: [QueryFilter]
+  , _query_taggers :: [Tagger]
+
+  -- An asc or desc sort to apply to the PhyloGraph
+  , _query_sort :: Maybe (Sort,Order)
+
+  -- A display mode to apply to the PhyloGraph, ie: [Node[Node,Edge],Edge] or [[Node,Node],[Edge,Edge]] 
+  , _query_display :: DisplayMode
+  , _query_verbose :: Bool
   }
 
-data ViewNode = ViewNode
-  { _view_nodeId     :: PhyloGroupId
-  , _view_nodeLabel  :: Text
-  , _view_nodeNgrams :: [Ngrams]
-  , _view_nodeMeta   :: Map Text Double
-  , _view_nodeParent :: PhyloGroupId 
-  }  
+
+------------------------------------------------------------------------
+-- | Lenses and Json | --
+
 
 -- | Lenses
 makeLenses ''Phylo
@@ -227,10 +298,12 @@ makeLenses ''Software
 makeLenses ''PhyloGroup
 makeLenses ''PhyloLevel
 makeLenses ''PhyloPeriod
+makeLenses ''PhyloView
+makeLenses ''PhyloQuery
 
 -- | JSON instances
 $(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       ) 
-$(deriveJSON (unPrefix "_phylo_period" ) 'PhyloPeriod  )
+$(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
 $(deriveJSON (unPrefix "_phylo_level"  ) ''PhyloLevel  )
 $(deriveJSON (unPrefix "_phylo_group"  ) ''PhyloGroup  )
 -- 

src/Gargantext/Viz/Phylo/Aggregates/Cluster.hs

@@ -35,14 +35,14 @@ import qualified Data.Set    as Set
 
 
 -- | To apply a Clustering method to a PhyloGraph
-graphToClusters :: (Clustering,[Double]) -> PhyloGraph -> [[PhyloGroup]]
+graphToClusters :: (Clustering,[Double]) -> GroupGraph -> [Cluster]
 graphToClusters (clust,param) (nodes,edges) = case clust of 
   Louvain           -> undefined -- louvain (nodes,edges)
   RelatedComponents -> relatedComp 0 (head nodes) (tail nodes,edges) [] []   
 
 
 -- | To transform a Phylo into Clusters of PhyloGroups at a given level
-phyloToClusters :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> Phylo -> Map (Date,Date) [[PhyloGroup]]
+phyloToClusters :: Level -> (Proximity,[Double]) -> (Clustering,[Double]) -> Phylo -> Map (Date,Date) [Cluster]
 phyloToClusters lvl (prox,param) (clus,param') p = Map.fromList 
                                                  $ zip (getPhyloPeriods p) 
                                                        (map (\prd -> let graph = groupsToGraph (prox,param) (getGroupsWithFilters lvl prd p) p

src/Gargantext/Viz/Phylo/BranchMaker.hs

@@ -36,7 +36,7 @@ import qualified Data.Set    as Set
 
 
 -- | To transform a PhyloGraph into a list of PhyloBranches by using the relatedComp clustering
-graphToBranches :: Level -> PhyloGraph -> Phylo -> [(Int,PhyloGroupId)]
+graphToBranches :: Level -> GroupGraph -> Phylo -> [(Int,PhyloGroupId)]
 graphToBranches lvl (nodes,edges) p = concat 
                                     $ map (\(idx,gs) -> map (\g -> (idx,getGroupId g)) gs)
                                     $ zip [1..]
@@ -44,10 +44,10 @@ graphToBranches lvl (nodes,edges) p = concat
 
 
 -- | To transform a list of PhyloGroups into a PhyloGraph by using a given Proximity mesure
-groupsToGraph :: (Proximity,[Double]) -> [PhyloGroup] -> Phylo -> PhyloGraph
+groupsToGraph :: (Proximity,[Double]) -> [PhyloGroup] -> Phylo -> GroupGraph
 groupsToGraph (prox,param) groups p = (groups,edges)
   where 
-    edges :: PhyloEdges
+    edges :: GroupEdges
     edges = case prox of  
       FromPairs          -> (nub . concat) $ map (\g -> (map (\g' -> ((g',g),1)) $ getGroupParents g p)
                                                         ++
@@ -71,6 +71,6 @@ setPhyloBranches lvl p = alterGroupWithLevel (\g -> let bIdx = (fst . head) $ fi
     bs :: [(Int,PhyloGroupId)]
     bs = graphToBranches lvl graph p
     --------------------------------------
-    graph :: PhyloGraph
+    graph :: GroupGraph
     graph = groupsToGraph (FromPairs,[]) (getGroupsWithLevel lvl p) p
     --------------------------------------
\ No newline at end of file

src/Gargantext/Viz/Phylo/Example.hs

@@ -33,6 +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, member, adjust, singleton, empty, (!), keys, restrictKeys, mapWithKey, filterWithKey, mapKeys, intersectionWith, unionWith)
+import Data.Maybe       (mapMaybe)
 import Data.Semigroup   (Semigroup)
 import Data.Set         (Set)
 import Data.Text        (Text, unwords, toLower, words)
@@ -124,18 +125,126 @@ freqToLabel thr l ngs = ngramsToLabel ngs $ mostFreqNgrams thr l
 --                && notElem ((head . getBranchPeriods) b) (take nbPsup $ reverse periods)
 --     --------------------------------------
 
 
--- alterBranchLabel f b p = over (phylo_branchLabel) (\lbl -> f 2 (getGroupsFromIds (getBranchGroupIds b) p) (getVector Ngrams p)) b
-
--- toPhyloView1 :: Level -> Phylo -> [PhyloBranch]
--- toPhyloView1 lvl p = bs 
---   where 
---     bs = map (\b -> alterBranchLabel freqToLabel b p)
---        $ filterLoneBranches 1 1 1 (getPhyloPeriods p)
 
---        $ getPhyloBranches p 
+
+filterLonelyBranch :: PhyloView -> PhyloView
+filterLonelyBranch graph = graph
+
+filterHandler :: QueryFilter -> PhyloView -> PhyloView
+filterHandler fq graph = case _query_filter fq of 
+  LonelyBranchFilter -> filterLonelyBranch graph 
+
+
+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
+
+addPhyloNodes :: Bool -> Bool -> Vector Ngrams -> [PhyloGroup] -> [PhyloNode]
+addPhyloNodes isR isV ns gs = map (\g -> let idxs = getGroupNgrams g
+                                         in PhyloNode 
+                                              (getGroupId g) "" idxs
+                                              (if isV 
+                                                then Just (ngramsToText ns idxs)
+                                                else Nothing)
+                                              empty 
+                                              (if isR
+                                                then Just (head $ getGroupLevelParentsId g)
+                                                else Nothing)
+                                  ) $ gs
+
+
+initPhyloEdge :: PhyloGroup -> [Pointer] -> [PhyloEdge]
+initPhyloEdge g pts = map (\pt -> PhyloEdge (getGroupId g) (fst pt) (snd pt)) pts
+
+addPhyloEdgesLevel :: EdgeType -> [PhyloGroup] -> [PhyloEdge]
+addPhyloEdgesLevel e gs = concat 
+                        $ map (\g -> case e of
+                                      Ascendant  -> initPhyloEdge g (_phylo_groupLevelParents g)
+                                      Descendant -> initPhyloEdge g (_phylo_groupLevelChilds g)) gs
+
+addPhyloEdgesPeriod :: EdgeType -> [PhyloGroup] -> [PhyloEdge]
+addPhyloEdgesPeriod e gs = concat 
+                         $ map (\g -> case e of
+                                        Ascendant  -> initPhyloEdge g (_phylo_groupPeriodParents g)
+                                        Descendant -> initPhyloEdge g (_phylo_groupPeriodChilds g)) gs
+
+
+addBranches :: Level -> Phylo -> [PhyloBranch]
+addBranches lvl p = map (\id -> initPhyloBranch id "") 
+                  $ getBranchIdsWith lvl p 
+
+
+initPhyloView :: Level -> Text -> Text -> EdgeType -> Bool -> Phylo -> PhyloView 
+initPhyloView lvl lbl dsc e vb p = PhyloView (getPhyloParams p) lbl dsc e empty
+                                    ([] ++ (addBranches lvl p)) 
+                                    ([] ++ (addPhyloNodes True vb (getFoundations p) groups))
+                                    (case e of
+                                      Complete -> [] ++ (addPhyloEdgesPeriod Ascendant groups) ++ (addPhyloEdgesPeriod Descendant groups)
+                                      _        -> [] ++ (addPhyloEdgesPeriod e groups))
+  where
+    --------------------------------------
+    groups :: [PhyloGroup]
+    groups = getGroupsWithLevel lvl p
+    --------------------------------------
+
+
+addChildNodes :: Bool -> Level -> Level -> Bool -> EdgeType -> Phylo -> PhyloView -> PhyloView
+addChildNodes ok lvl lvl' vb e p v
+  | not ok      = v
+  | lvl == lvl' = v
+  | otherwise   = addChildNodes ok lvl (lvl' - 1) vb e p 
+                $ v & over (phylo_viewBranches) (++ (addBranches (lvl' - 1) p))
+                    & over (phylo_viewNodes) (++ (addPhyloNodes False vb (getFoundations p) groups'))
+                    & over (phylo_viewEdges) (case e of 
+                                                Complete -> (++ ((addPhyloEdgesPeriod Ascendant groups') ++ (addPhyloEdgesPeriod Descendant groups')))
+                                                _        -> (++ (addPhyloEdgesPeriod e groups)))
+                    & over (phylo_viewEdges) (++ (addPhyloEdgesLevel Descendant groups))
+                    & over (phylo_viewEdges) (++ (addPhyloEdgesLevel Ascendant groups'))
+    where
+      --------------------------------------
+      groups :: [PhyloGroup]
+      groups = getGroupsWithLevel lvl' p
+      --------------------------------------  
+      groups' :: [PhyloGroup]
+      groups' = getGroupsWithLevel (lvl' - 1) p
+      --------------------------------------                        
+
+queryToView :: PhyloQuery -> Phylo -> PhyloView
+queryToView q p = addChildNodes (_query_childs q) (_query_lvl q) (_query_childsDepth q) (_query_verbose q) (_query_edgeType q) p
+                $ initPhyloView (_query_lvl q) "Phylo2000" "This is a Phylo" (_query_edgeType q) (_query_verbose q) p
+
+
+defaultQuery :: PhyloQuery
+defaultQuery = PhyloQuery 3 Descendant False 0 [] [] [] Nothing Flat True
+
+
+textQuery :: Text
+textQuery = "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
+              & over (query_metrics) (++ [BranchAge])
+              & over (query_filters) (++ [QueryFilter LonelyBranchFilter [Qp1 2,Qp1 2,Qp1 1] (== Qp3 True)])
+              & over (query_taggers) (++ [BranchLabelFreq,GroupLabelCooc])
+
+
+toPhyloView :: Text -> Phylo -> PhyloView
+toPhyloView url p = queryToView (urlToQuery url) p
+
 
 ------------------------------------------------------------------------
 -- | STEP 11 | -- Incrementaly cluster the PhyloGroups n times, link them through the Periods and build level n of the Phylo   

src/Gargantext/Viz/Phylo/Metrics/Clustering.hs

@@ -38,7 +38,7 @@ import qualified Data.Set    as Set
 -- (nodes,edges) = the initial PhyloGraph minus the current PhyloGroup
 -- next = the next PhyloGroups to be added in the cluster  
 -- memo = the memory of the allready created clusters
-relatedComp :: Int -> PhyloGroup -> PhyloGraph -> [PhyloGroup] -> [[PhyloGroup]] -> [[PhyloGroup]]
+relatedComp :: Int -> PhyloGroup -> GroupGraph -> [PhyloGroup] -> [[PhyloGroup]] -> [[PhyloGroup]]
 relatedComp idx curr (nodes,edges) next memo
   | null nodes' && null next' = memo'
   | (not . null) next'        = relatedComp idx (head next') (nodes',edges) (tail next') memo'
@@ -59,7 +59,7 @@ relatedComp idx curr (nodes,edges) next memo
     --------------------------------------
 
 
-louvain :: (PhyloNodes,PhyloEdges) -> IO [[PhyloGroup]]
+louvain :: (GroupNodes,GroupEdges) -> IO [[PhyloGroup]]
 louvain (nodes,edges) = map (\community -> map (\node -> nodes !! (l_node_id node)) community)
                       <$> groupBy (\a b -> (l_community_id a) == (l_community_id b))
                       <$> (cLouvain $ mapKeys (\(x,y) -> (idx x, idx y)) $ fromList edges)

src/Gargantext/Viz/Phylo/Tools.hs

@@ -116,9 +116,9 @@ filterNestedSets h l l'
   | otherwise              = filterNestedSets (head l) (tail l) (h : l')
 
 
--- | To filter some PhyloEdges with a given threshold
-filterPhyloEdges :: Double -> PhyloEdges -> PhyloEdges
-filterPhyloEdges thr edges = filter (\((s,t),w) -> w > thr) edges 
+-- | To filter some GroupEdges with a given threshold
+filterGroupEdges :: Double -> GroupEdges -> GroupEdges
+filterGroupEdges thr edges = filter (\((s,t),w) -> w > thr) edges 
 
 
 -- | To get the foundations of a Phylo
@@ -133,6 +133,11 @@ getIdxInFoundations n p = case (elemIndex n (getFoundations p)) of
     Just idx -> idx
 
 
+-- | To maybe get the PhyloBranchId of a PhyloGroup
+getGroupBranchId :: PhyloGroup -> Maybe PhyloBranchId
+getGroupBranchId = _phylo_groupBranchId 
+
+
 -- | To get the PhyloGroups Childs of a PhyloGroup
 getGroupChilds :: PhyloGroup -> Phylo -> [PhyloGroup]
 getGroupChilds g p = getGroupsFromIds (map fst $ _phylo_groupPeriodChilds g) p
@@ -158,6 +163,11 @@ getGroupLevelChildsId :: PhyloGroup -> [PhyloGroupId]
 getGroupLevelChildsId g = map fst $ _phylo_groupLevelChilds g
 
 
+-- | To get the PhyloGroups Level Parents Ids of a PhyloGroup
+getGroupLevelParentsId :: PhyloGroup -> [PhyloGroupId]
+getGroupLevelParentsId g = map fst $ _phylo_groupLevelParents g
+
+
 -- | To get the Ngrams of a PhyloGroup
 getGroupNgrams :: PhyloGroup -> [Int]
 getGroupNgrams =  _phylo_groupNgrams
@@ -234,8 +244,8 @@ getLastLevel p = (last . sort)
                       . phylo_periodLevels ) p
 
 
--- | To get the neighbours (directed/undirected) of a PhyloGroup from a list of PhyloEdges 
-getNeighbours :: Bool -> PhyloGroup -> PhyloEdges -> [PhyloGroup]
+-- | 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 
   True  -> map (\((s,t),w) -> t) 
              $ filter (\((s,t),w) -> s == g) e