[API][Pairs] search enabled again.
[gargantext.git] / src / Gargantext / Viz / Phylo / Tools.hs
index b94e461ad2d97cb005beff39efdb0b24cce84825..929114512fe69e4e2dc6f195dbee025005037bfa 100644 (file)
@@ -20,9 +20,9 @@ module Gargantext.Viz.Phylo.Tools
   where
 
 import Control.Lens         hiding (both, Level, Empty)
-import Data.List            (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, sortOn, nubBy)
+import Data.List            (filter, intersect, (++), sort, null, tail, last, tails, delete, nub, sortOn, nubBy, concat)
 import Data.Maybe           (mapMaybe,fromMaybe)
-import Data.Map             (Map, mapKeys, member, (!))
+import Data.Map             (Map, mapKeys, member, (!), restrictKeys, elems, empty, filterWithKey, unionWith)
 import Data.Set             (Set)
 import Data.Text            (Text,toLower,unwords)
 import Data.Tuple.Extra
@@ -100,11 +100,23 @@ keepFilled f thr l = if (null $ f thr l) && (not $ null l)
                      else f thr l
 
 
+-- | To get all combinations of a list
+listToFullCombi :: Eq a => [a] -> [(a,a)]
+listToFullCombi l = [(x,y) | x <- l, y <- l]
+
+
 -- | To get all combinations of a list
 listToDirectedCombi :: Eq a => [a] -> [(a,a)]
 listToDirectedCombi l = [(x,y) | x <- l, y <- l, x /= y]
 
 
+listToEqualCombi :: Eq a => [a] -> [(a,a)]
+listToEqualCombi l = [(x,y) | x <- l, y <- l, x == y]
+
+listToPairs :: Eq a => [a] -> [(a,a)]
+listToPairs l = (listToEqualCombi l) ++ (listToUnDirectedCombi l)
+
+
 -- | To get all combinations of a list and apply a function to the resulting list of pairs
 listToDirectedCombiWith :: Eq a => forall b. (a -> b) -> [a] -> [(b,b)]
 listToDirectedCombiWith f l = [(f x,f y) | x <- l, y <- l, x /= y]
@@ -127,7 +139,7 @@ listToUnDirectedCombiWith f l = [ (f x, f y) | (x:rest) <- tails l,  y <- rest ]
 
 -- | To transform a list of Ngrams Indexes into a Label
 ngramsToLabel :: Vector Ngrams -> [Int] -> Text
-ngramsToLabel ngrams l = unwords $ ngramsToText ngrams l
+ngramsToLabel ngrams l = unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
 
 
 -- | To transform a list of Ngrams Indexes into a list of Text
@@ -135,6 +147,11 @@ ngramsToText :: Vector Ngrams -> [Int] -> [Text]
 ngramsToText ngrams l = map (\idx -> ngrams Vector.! idx) l
 
 
+-- | To transform a list of ngrams into a list of indexes
+ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
+ngramsToIdx ns v = sort $ map (\n -> getIdxInVector n v) ns
+
+
 -- | To unify the keys (x,y) that Map 1 share with Map 2 such as: (x,y) <=> (y,x)
 unifySharedKeys :: Eq a => Ord a => Map (a,a) b -> Map (a,a) b -> Map (a,a) b
 unifySharedKeys m1 m2 = mapKeys (\(x,y) -> if member (y,x) m2
@@ -155,8 +172,8 @@ initFoundationsRoots :: [Ngrams] -> Vector Ngrams
 initFoundationsRoots l = Vector.fromList $ map phyloAnalyzer l
 
 -- | To init the base of a Phylo from a List of Periods and Foundations
-initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> PhyloParam -> Phylo
-initPhyloBase pds fds prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) prm
+initPhyloBase :: [(Date, Date)] -> PhyloFoundations -> Map Date Double  -> Map Date (Map (Int,Int) Double) -> Map (Date,Date) [PhyloFis] -> PhyloParam -> Phylo
+initPhyloBase pds fds nbDocs cooc fis prm = Phylo ((fst . (head' "initPhyloBase")) pds, (snd . last) pds) fds (map (\pd -> initPhyloPeriod pd []) pds) nbDocs cooc fis prm
 
 -- | To init the param of a Phylo
 initPhyloParam :: Maybe Text -> Maybe Software -> Maybe PhyloQueryBuild -> PhyloParam
@@ -170,6 +187,41 @@ getLastLevel p = (last . sort)
                       .  traverse
                       . phylo_periodLevels ) p
 
+-- | To get all the coocurency matrix of a phylo
+getPhyloCooc :: Phylo -> Map Date (Map (Int,Int) Double)
+getPhyloCooc p = p ^. phylo_cooc
+
+
+-- | To get the PhyloParam of a Phylo
+getPhyloParams :: Phylo -> PhyloParam
+getPhyloParams = _phylo_param
+
+-- | To get the title of a Phylo
+getPhyloTitle :: Phylo -> Text
+getPhyloTitle p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
+
+-- | To get the desc of a Phylo
+getPhyloDescription :: Phylo -> Text
+getPhyloDescription p = _q_phyloTitle $ _phyloParam_query $ getPhyloParams p
+
+getPhyloMatchingFrame :: Phylo -> Int
+getPhyloMatchingFrame p = _q_interTemporalMatchingFrame $ _phyloParam_query $ getPhyloParams p
+
+getPhyloMatchingFrameTh :: Phylo -> Double
+getPhyloMatchingFrameTh p = _q_interTemporalMatchingFrameTh $ _phyloParam_query $ getPhyloParams p
+
+getPhyloProximity :: Phylo -> Proximity
+getPhyloProximity p = _q_interTemporalMatching $ _phyloParam_query $ getPhyloParams p
+
+getPhyloReBranchThr :: Phylo -> Double
+getPhyloReBranchThr p = _q_reBranchThr $ _phyloParam_query $ getPhyloParams p
+
+getPhyloReBranchNth :: Phylo -> Int
+getPhyloReBranchNth p = _q_reBranchNth $ _phyloParam_query $ getPhyloParams p
+
+getPhyloFis :: Phylo -> Map (Date,Date) [PhyloFis]
+getPhyloFis = _phylo_fis
+
 
 --------------------
 -- | PhyloRoots | --
@@ -186,14 +238,23 @@ getFoundationsRoots p = (getFoundations p) ^. phylo_foundationsRoots
 -- | To get the Index of a Ngrams in the foundationsRoots of a Phylo
 getIdxInRoots :: Ngrams -> Phylo -> Int
 getIdxInRoots n p = case (elemIndex n (getFoundationsRoots p)) of
-    Nothing  -> panic "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots"
+    Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
     Just idx -> idx
 
+getIdxInRoots' :: Ngrams -> Vector Ngrams -> Int
+getIdxInRoots' n root = case (elemIndex n root) of
+    Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInRoots] Ngrams not in foundationsRoots: " <> cs n
+    Just idx -> idx    
+
+getIdxInVector :: Ngrams -> Vector Ngrams -> Int
+getIdxInVector n ns = case (elemIndex n ns) of
+  Nothing  -> panic $ "[ERR][Viz.Phylo.Tools.getIdxInVector] Ngrams not in foundationsRoots: " <> cs n
+  Just idx -> idx
+
 --------------------
 -- | PhyloGroup | --
 --------------------
 
-
 -- | To alter a PhyloGroup matching a given Level
 alterGroupWithLevel :: (PhyloGroup -> PhyloGroup) -> Level -> Phylo -> Phylo
 alterGroupWithLevel f lvl p = over ( phylo_periods
@@ -237,7 +298,6 @@ getGroupId :: PhyloGroup -> PhyloGroupId
 getGroupId = _phylo_groupId
 
 
--- | To get the Cooc Matrix of a PhyloGroup
 getGroupCooc :: PhyloGroup -> Map (Int,Int) Double
 getGroupCooc = _phylo_groupCooc
 
@@ -266,6 +326,11 @@ getGroupLevelParents = _phylo_groupLevelParents
 getGroupLevelParentsId :: PhyloGroup -> [PhyloGroupId]
 getGroupLevelParentsId g = map fst $ getGroupLevelParents g
 
+
+-- | To get the PhyloGroups Level Parents Ids of a PhyloGroup
+getGroupLevelParentId :: PhyloGroup -> PhyloGroupId
+getGroupLevelParentId g = (head' "getGroupLevelParentId") $ getGroupLevelParentsId g
+
 -- | To get the Meta value of a PhyloGroup
 getGroupMeta :: Text -> PhyloGroup -> Double
 getGroupMeta k g = (g ^. phylo_groupMeta) ! k
@@ -339,9 +404,19 @@ getGroups = view ( phylo_periods
                  )
 
 
--- | To get all PhyloGroups matching a list of PhyloGroupIds in a Phylo
+-- | To get all PhyloGroups matching a list of PhyloGoupIds in a Phylo
+-- getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
+-- getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
+
+getGroupFromId :: PhyloGroupId -> Phylo -> PhyloGroup
+getGroupFromId id p = 
+  let groups = Map.fromList $ map (\g -> (getGroupId g, g)) $ getGroups p
+  in  groups ! id 
+
 getGroupsFromIds :: [PhyloGroupId] -> Phylo -> [PhyloGroup]
-getGroupsFromIds ids p = filter (\g -> elem (getGroupId g) ids) $ getGroups p
+getGroupsFromIds ids p =
+  let groups = Map.fromList $ map (\g -> (getGroupId g, g)) $ getGroups p
+  in  elems $ restrictKeys groups (Set.fromList ids)
 
 
 -- | To get the corresponding list of PhyloGroups from a list of PhyloNodes
@@ -371,11 +446,30 @@ initGroup :: [Ngrams] -> Text -> Int -> Int -> Int -> Int -> Phylo -> PhyloGroup
 initGroup ngrams lbl idx lvl from' to' p = PhyloGroup
   (((from', to'), lvl), idx)
   lbl
-  (sort $ map (\x -> getIdxInRoots x p) ngrams)
+  idxs
   (Map.empty)
   (Map.empty)
   Nothing
+  (getMiniCooc (listToFullCombi idxs) (periodsToYears [(from', to')]) (getPhyloCooc p))
   [] [] [] []
+  where 
+    idxs = sort $ map (\x -> getIdxInRoots x p) ngrams
+
+
+-- | To sum two coocurency Matrix
+sumCooc :: Map (Int, Int) Double ->  Map (Int, Int) Double ->  Map (Int, Int) Double
+sumCooc m m' = unionWith (+) m m'
+
+-- | To build the mini cooc matrix of each group
+getMiniCooc :: [(Int,Int)] -> Set Date -> Map Date (Map (Int,Int) Double) -> Map (Int,Int) Double
+getMiniCooc pairs years cooc = filterWithKey (\(n,n') _ -> elem (n,n') pairs) cooc'
+  where 
+    --------------------------------------
+    cooc' :: Map (Int,Int) Double
+    cooc' = foldl (\m m' -> sumCooc m m') empty 
+          $ elems 
+          $ restrictKeys cooc years
+    --------------------------------------
 
 
 ---------------------
@@ -410,6 +504,12 @@ initPhyloPeriod :: PhyloPeriodId -> [PhyloLevel] -> PhyloPeriod
 initPhyloPeriod id l = PhyloPeriod id l
 
 
+-- | To transform a list of periods into a set of Dates
+periodsToYears :: [(Date,Date)] -> Set Date
+periodsToYears periods = (Set.fromList . sort . concat)
+                       $ map (\(d,d') -> [d..d']) periods
+
+
 --------------------
 -- | PhyloLevel | --
 --------------------
@@ -456,20 +556,27 @@ setPhyloLevelId lvl' (PhyloLevel (id, _lvl) groups)
 getClique :: PhyloFis -> Clique
 getClique = _phyloFis_clique
 
--- | To get the metrics of a PhyloFis
-getFisMetrics :: PhyloFis -> Map (Int,Int) (Map Text [Double])
-getFisMetrics = _phyloFis_metrics
-
 -- | To get the support of a PhyloFis
 getSupport :: PhyloFis -> Support
 getSupport = _phyloFis_support
 
+-- | To get the period of a PhyloFis
+getFisPeriod :: PhyloFis -> (Date,Date)
+getFisPeriod = _phyloFis_period
+
 
 ----------------------------
 -- | PhyloNodes & Edges | --
 ----------------------------
 
 
+-- | 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
@@ -496,6 +603,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
@@ -704,33 +815,44 @@ getProximity cluster = case cluster of
 
 -- | To initialize all the Cluster / Proximity with their default parameters
 initFis :: Maybe Bool -> Maybe Support -> Maybe Int -> FisParams
-initFis (def True -> kmf) (def 1 -> min') (def 1 -> thr) = FisParams kmf min' thr
+initFis (def True -> kmf) (def 0 -> min') (def 0 -> thr) = FisParams kmf min' thr
 
 initHamming :: Maybe Double -> HammingParams
 initHamming (def 0.01 -> sens) = HammingParams sens
 
-initSmallBranch' :: Maybe Int -> Maybe Int -> Maybe Int -> SBParams
-initSmallBranch' (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = SBParams periodsInf periodsSup minNodes
+initLonelyBranch :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
+initLonelyBranch (def 2 -> periodsInf) (def 2 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
+
+initSizeBranch :: Maybe Int -> SBParams
+initSizeBranch (def 1 -> minSize) = SBParams minSize
 
-initSmallBranch :: Maybe Int -> Maybe Int -> Maybe Int -> SBParams
-initSmallBranch (def 0 -> periodsInf) (def 0 -> periodsSup) (def 1 -> minNodes) = SBParams periodsInf periodsSup minNodes
+initLonelyBranch' :: Maybe Int -> Maybe Int -> Maybe Int -> LBParams
+initLonelyBranch' (def 0 -> periodsInf) (def 0 -> periodsSup) (def 1 -> minNodes) = LBParams periodsInf periodsSup minNodes
 
 initLouvain :: Maybe Proximity -> LouvainParams
 initLouvain (def defaultWeightedLogJaccard -> proxi) = LouvainParams proxi
 
 initRelatedComponents :: Maybe Proximity -> RCParams
-initRelatedComponents (def Filiation -> proxi) = RCParams proxi
+initRelatedComponents (def defaultWeightedLogJaccard -> proxi) = RCParams proxi
 
+-- | TODO user param in main function
 initWeightedLogJaccard :: Maybe Double -> Maybe Double -> WLJParams
-initWeightedLogJaccard (def 0 -> thr) (def 0.01 -> sens) = WLJParams thr sens
+initWeightedLogJaccard (def 0.3 -> thr) (def 20.0 -> sens) = WLJParams thr sens
 
 
 -- | To initialize a PhyloQueryBuild from given and default parameters
-initPhyloQueryBuild :: Text -> Text -> Maybe Int -> Maybe Int -> Maybe Cluster -> Maybe [Metric] -> Maybe [Filter] -> Maybe Proximity -> Maybe Level -> Maybe Cluster -> PhyloQueryBuild
-initPhyloQueryBuild name desc (def 5 -> grain) (def 3 -> steps) (def defaultFis -> cluster) (def [] -> metrics) (def [] -> filters)
-  (def defaultWeightedLogJaccard -> matching') (def 2 -> nthLevel) (def defaultRelatedComponents -> nthCluster) =
-    PhyloQueryBuild name desc grain steps cluster metrics filters matching' nthLevel nthCluster
-
+initPhyloQueryBuild :: Text          -> Text            -> Maybe Int
+                    -> Maybe Int     -> Maybe Cluster   -> Maybe [Metric]
+                    -> Maybe [Filter]-> Maybe Proximity -> Maybe Int
+                    -> Maybe Double  -> Maybe Double    -> Maybe Int
+                    -> Maybe Level   -> Maybe Cluster   -> PhyloQueryBuild
+initPhyloQueryBuild name desc (def 5 -> grain)
+                    (def 1 -> steps)      (def defaultFis -> cluster) (def [] -> metrics)
+                    (def [] -> filters)   (def defaultWeightedLogJaccard -> matching') (def 5 -> frame)
+                    (def 0.8 -> frameThr) (def 0.5 -> reBranchThr) (def 4 -> reBranchNth)
+                    (def 2 -> nthLevel)   (def defaultRelatedComponents -> nthCluster) =
+    PhyloQueryBuild name  desc    grain
+                    steps cluster metrics filters matching' frame frameThr reBranchThr reBranchNth nthLevel nthCluster
 
 
 -- | To initialize a PhyloQueryView default parameters
@@ -760,8 +882,11 @@ defaultRelatedComponents = RelatedComponents (initRelatedComponents Nothing)
 
 -- Filters
 
-defaultSmallBranch :: Filter
-defaultSmallBranch = SmallBranch (initSmallBranch Nothing Nothing Nothing)
+defaultLonelyBranch :: Filter
+defaultLonelyBranch = LonelyBranch (initLonelyBranch Nothing Nothing Nothing)
+
+defaultSizeBranch :: Filter
+defaultSizeBranch = SizeBranch (initSizeBranch Nothing)
 
 -- Params
 
@@ -777,13 +902,27 @@ defaultWeightedLogJaccard :: Proximity
 defaultWeightedLogJaccard = WeightedLogJaccard (initWeightedLogJaccard Nothing Nothing)
 
 -- Queries
+type Title = Text
+type Desc  = Text
 
 defaultQueryBuild :: PhyloQueryBuild
-defaultQueryBuild = initPhyloQueryBuild "Cesar et Cleôpatre" "An example of Phylomemy (french without accent)"
-                              Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+defaultQueryBuild = defaultQueryBuild'
+  "Cesar et Cleôpatre"
+  "An example of Phylomemy (french without accent)"
+
+defaultQueryBuild' :: Title -> Desc -> PhyloQueryBuild
+defaultQueryBuild' t d = initPhyloQueryBuild t d
+                              Nothing Nothing Nothing
+                              Nothing Nothing Nothing
+                              Nothing Nothing Nothing
+                              Nothing Nothing Nothing
 
 defaultQueryView :: PhyloQueryView
-defaultQueryView = initPhyloQueryView Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+defaultQueryView = initPhyloQueryView
+    Nothing Nothing Nothing
+    Nothing Nothing Nothing
+    Nothing Nothing Nothing
+    Nothing Nothing
 
 -- Software