[READING] Type declared at the right place
[gargantext.git] / src / Gargantext / Core / Viz / Phylo / PhyloTools.hs
index 01906c18a29a0310256ec72beb8fd9f0d0727989..2efacb24e0649a1144f009f53decb1673170df13 100644 (file)
@@ -13,11 +13,13 @@ Portability : POSIX
 module Gargantext.Core.Viz.Phylo.PhyloTools where
 
 import Data.Vector (Vector, elemIndex)
-import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy, maximum, group)
+import Data.List (sort, concat, null, union, (++), tails, sortOn, nub, init, tail, partition, tails, nubBy, group)
 import Data.Set (Set, disjoint)
 import Data.Map (Map, elems, fromList, unionWith, keys, member, (!), filterWithKey, fromListWith, empty, restrictKeys)
 import Data.String (String)
-import Data.Text (Text)
+import Data.Text (Text,unpack)
+
+import Prelude (floor,read)
 
 import Gargantext.Prelude
 import Gargantext.Core.Viz.AdaptativePhylo
@@ -56,6 +58,22 @@ printIOComment cmt =
 -- | Misc | --
 --------------
 
+-- truncate' :: Double -> Int -> Double
+-- truncate' x n = (fromIntegral (floor (x * t))) / t
+--     where t = 10^n
+
+truncate' :: Double -> Int -> Double
+truncate' x n = (fromIntegral $ (floor (x * t) :: Int)) / t
+    where 
+        --------------
+        t :: Double
+        t = 10 ^n
+
+getInMap :: Int -> Map Int Double -> Double
+getInMap k m = 
+    if (member k m)
+        then m ! k
+        else 0
 
 roundToStr :: (PrintfArg a, Floating a) => Int -> a -> String
 roundToStr = printf "%0.*f"
@@ -97,6 +115,10 @@ isRoots n ns = Vector.elem n ns
 ngramsToIdx :: [Ngrams] -> Vector Ngrams -> [Int]
 ngramsToIdx ns fdt = map (\n -> fromJust $ elemIndex n fdt) ns
 
+-- | To transform a list of sources into a list of sources' index
+sourcesToIdx :: [Text] -> Vector Text -> [Int]
+sourcesToIdx ss ps = nub $ map (\s -> fromJust $ elemIndex s ps) ss
+
 -- | To transform a list of Ngrams Indexes into a Label
 ngramsToLabel :: Vector Ngrams -> [Int] -> Text
 ngramsToLabel ngrams l = Text.unwords $ tail' "ngramsToLabel" $ concat $ map (\n -> ["|",n]) $ ngramsToText ngrams l
@@ -135,6 +157,32 @@ toPeriods dates p s =
      $ chunkAlong p s [start .. end]
 
 
+toFstDate :: [Text] -> Text
+toFstDate ds = snd
+             $ head' "firstDate"
+             $ sortOn fst
+             $ map (\d -> 
+                      let d' = read (filter (\c -> c /= '-') $ unpack d)::Int
+                       in (d',d)) ds
+
+toLstDate :: [Text] -> Text
+toLstDate ds = snd
+             $ head' "firstDate"
+             $ reverse
+             $ sortOn fst
+             $ map (\d -> 
+                      let d' = read (filter (\c -> c /= '-') $ unpack d)::Int
+                       in (d',d)) ds  
+
+
+getTimeScale :: Phylo -> [Char]
+getTimeScale p = case (timeUnit $ getConfig p) of
+    Year  _ _ _ -> "year"
+    Month _ _ _ -> "month"
+    Week  _ _ _ -> "week"  
+    Day   _ _ _ -> "day"      
+
+
 -- | Get a regular & ascendante timeScale from a given list of dates
 toTimeScale :: [Date] -> Int -> [Date]
 toTimeScale dates step = 
@@ -144,15 +192,24 @@ toTimeScale dates step =
 
 getTimeStep :: TimeUnit -> Int
 getTimeStep time = case time of 
-    Year _ s _ -> s
+    Year  _ s _ -> s
+    Month _ s _ -> s  
+    Week  _ s _ -> s  
+    Day   _ s _ -> s  
 
 getTimePeriod :: TimeUnit -> Int
 getTimePeriod time = case time of 
-    Year p _ _ -> p  
+    Year  p _ _ -> p
+    Month p _ _ -> p  
+    Week  p _ _ -> p  
+    Day   p _ _ -> p  
 
 getTimeFrame :: TimeUnit -> Int
 getTimeFrame time = case time of 
-    Year _ _ f -> f
+    Year  _ _ f -> f
+    Month _ _ f -> f
+    Week  _ _ f -> f
+    Day   _ _ f -> f            
 
 -------------
 -- | Fis | --
@@ -207,12 +264,12 @@ traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map l
 getCliqueSupport :: Clique -> Int
 getCliqueSupport unit = case unit of 
     Fis s _ -> s
-    MaxClique _ -> 0
+    MaxClique _ _ _ -> 0
 
 getCliqueSize :: Clique -> Int
 getCliqueSize unit = case unit of 
     Fis _ s -> s
-    MaxClique s -> s
+    MaxClique s _ _ -> s
 
 
 --------------
@@ -277,12 +334,14 @@ filterProximity :: Proximity -> Double -> Double -> Bool
 filterProximity proximity thr local = 
     case proximity of
         WeightedLogJaccard _ -> local >= thr
+        WeightedLogSim _ -> local >= thr
         Hamming -> undefined   
 
 getProximityName :: Proximity -> String
 getProximityName proximity =
     case proximity of
         WeightedLogJaccard _ -> "WLJaccard"
+        WeightedLogSim _ -> "WeightedLogSim"
         Hamming -> "Hamming"            
 
 ---------------
@@ -326,9 +385,22 @@ getConfig :: Phylo -> Config
 getConfig phylo = (phylo ^. phylo_param) ^. phyloParam_config
 
 
+setConfig :: Config -> Phylo -> Phylo
+setConfig config phylo = phylo 
+                       & phylo_param .~ (PhyloParam 
+                                            ((phylo ^. phylo_param) ^. phyloParam_version) 
+                                            ((phylo ^. phylo_param) ^. phyloParam_software) 
+                                            config)
+
+-- & phylo_param & phyloParam_config & phyloParam_config .~ config
+
+
 getRoots :: Phylo -> Vector Ngrams
 getRoots phylo = (phylo ^. phylo_foundations) ^. foundations_roots
 
+getSources :: Phylo -> Vector Text
+getSources phylo = _sources (phylo ^. phylo_sources)
+
 phyloToLastBranches :: Phylo -> [[PhyloGroup]]
 phyloToLastBranches phylo = elems 
     $ fromListWith (++)
@@ -381,6 +453,16 @@ updatePhyloGroups lvl m phylo =
                     then m ! id
                     else g ) phylo
 
+updatePeriods :: Map (Date,Date) (Text,Text) -> Phylo -> Phylo
+updatePeriods periods' phylo = 
+    over (phylo_periods . traverse) 
+            (\prd -> 
+                let prd' = periods' ! (prd ^. phylo_periodPeriod)
+                    lvls = map (\lvl -> lvl & phylo_levelPeriod' .~ prd') $ prd ^. phylo_periodLevels
+                 in prd & phylo_periodPeriod' .~ prd'
+                        & phylo_periodLevels  .~ lvls
+                ) phylo
+
 
 traceToPhylo :: Level -> Phylo -> Phylo
 traceToPhylo lvl phylo = 
@@ -417,13 +499,13 @@ mergeMeta bId groups =
 
 groupsToBranches :: Map PhyloGroupId PhyloGroup -> [[PhyloGroup]]
 groupsToBranches groups =
-    -- | run the related component algorithm
+    {- run the related component algorithm -}
     let egos  = map (\g -> [getGroupId g] 
                         ++ (map fst $ g ^. phylo_groupPeriodParents)
                         ++ (map fst $ g ^. phylo_groupPeriodChilds)
                         ++ (map fst $ g ^. phylo_groupAncestors)) $ elems groups
         graph = relatedComponents egos
-    -- | update each group's branch id
+    {- update each group's branch id -}
     in map (\ids ->
         let groups' = elems $ restrictKeys groups (Set.fromList ids)
             bId = mergeBranchIds $ map (\g -> snd $ g ^. phylo_groupBranchId) groups'
@@ -446,7 +528,7 @@ toRelatedComponents nodes edges =
 
 traceSynchronyEnd :: Phylo -> Phylo
 traceSynchronyEnd phylo = 
-    trace ( "\n" <> "-- | End synchronic clustering at level " <> show (getLastLevel phylo) 
+    trace ( "-- | End synchronic clustering at level " <> show (getLastLevel phylo) 
                  <> " with " <> show (length $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " groups"
                  <> " and "  <> show (length $ nub $ map _phylo_groupBranchId $ getGroupsFromLevel (getLastLevel phylo) phylo) <> " branches"
                  <> "\n" ) phylo
@@ -466,6 +548,7 @@ traceSynchronyStart phylo =
 getSensibility :: Proximity -> Double
 getSensibility proxi = case proxi of 
     WeightedLogJaccard s -> s
+    WeightedLogSim s -> s
     Hamming -> undefined
 
 ----------------