[MERGE] Phylo

src/Gargantext/Core/Viz/Phylo.hs

@@ -430,7 +430,6 @@ data Phylo =
 instance ToSchema Phylo where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
 
-
 ----------------
 -- | Period | --
 ----------------

src/Gargantext/Core/Viz/Phylo/API.hs

@@ -188,4 +188,3 @@ instance ToParamSchema Metric
 instance ToParamSchema Order
 instance ToParamSchema Sort
 instance ToSchema Order
-

src/Gargantext/Core/Viz/Phylo/PhyloExport.hs

@@ -66,19 +66,21 @@ toAttr :: AttributeName -> Lazy.Text -> CustomAttribute
 toAttr k v = customAttribute k v
 
 metaToAttr :: Map Text.Text [Double] -> [CustomAttribute]
-metaToAttr meta = map (\(k,v) -> toAttr (fromStrict k) $ (pack . unwords) $ map show v) $ toList meta
+metaToAttr meta = map (\(k, v) -> toAttr (fromStrict k) $ (pack . unwords) $ map show v) $ toList meta
 
 groupIdToDotId :: PhyloGroupId -> DotId
-groupIdToDotId (((d,d'),lvl),idx) = (fromStrict . Text.pack) $ ("group" <> (show d) <> (show d') <> (show lvl) <> (show idx))
+groupIdToDotId (((d, d'), lvl), idx) =
+  (fromStrict . Text.pack) $ "group" <> show d <> show d' <> show lvl <> show idx
 
 branchIdToDotId :: PhyloBranchId -> DotId
-branchIdToDotId bId = (fromStrict . Text.pack) $ ("branch" <> show (snd bId))
+branchIdToDotId bId = (fromStrict . Text.pack) $ "branch" <> show (snd bId)
 
 periodIdToDotId :: Period -> DotId
-periodIdToDotId prd = (fromStrict . Text.pack) $ ("period" <> show (fst prd) <> show (snd prd))
+periodIdToDotId prd = (fromStrict . Text.pack) $ "period" <> show (fst prd) <> show (snd prd)
 
 groupToTable :: Vector Ngrams -> PhyloGroup -> H.Label
-groupToTable fdt g = H.Table H.HTable
+groupToTable fdt g =
+  H.Table H.HTable
   { H.tableFontAttrs = Just [H.PointSize 14, H.Align H.HLeft]
   , H.tableAttrs = [H.Border 0, H.CellBorder 0, H.BGColor (toColor White)]
   , H.tableRows = [header]
@@ -90,7 +92,8 @@ groupToTable fdt g = H.Table H.HTable
     where
       --------------------------------------
       ngramsToRow :: [(Ngrams, (Double, Double))] -> H.Row
-        ngramsToRow ns = H.Cells $ map (\(n,(d,_)) ->
+      ngramsToRow ns =
+        H.Cells $ map (\(n, (d, _)) ->
                           H.LabelCell [ H.Align H.HLeft
                                       , dynamicToColor $ floor d] $ H.Text [H.Str $ fromStrict n]) ns
       --------------------------------------
@@ -109,7 +112,12 @@ groupToTable fdt g = H.Table H.HTable
 branchToDotNode :: PhyloBranch -> Int -> Dot DotId
 branchToDotNode b bId =
     node (branchIdToDotId $ b ^. branch_id)
-         ([FillColor [toWColor CornSilk], FontName "Arial", FontSize 40, Shape Egg, Style [SItem Bold []], Label (toDotLabel $ b ^. branch_label)]
+         ( [ FillColor [toWColor CornSilk]
+           , FontName "Arial"
+           , FontSize 40
+           , Shape Egg
+           , Style [SItem Bold []]
+           , Label (toDotLabel $ b ^. branch_label) ]
          <> (metaToAttr $ b ^. branch_meta)
          <> [ toAttr "nodeType" "branch"
             , toAttr "bId"      (pack $ show bId)
@@ -121,19 +129,24 @@ branchToDotNode b bId =
 
 periodToDotNode :: (Date,Date) -> (Text.Text,Text.Text) -> Dot DotId
 periodToDotNode prd prd' =
-    node (periodIdToDotId prd)
-         ([Shape BoxShape, FontSize 50, Label (toDotLabel $ Text.pack (show (fst prd) <> " " <> show (snd prd)))]
+    node (periodIdToDotId prd) $
+         [ Shape BoxShape
+         , FontSize 50
+         , Label $ toDotLabel $ Text.pack $ show (fst prd) <> " " <> show (snd prd) ]
          <> [ toAttr "nodeType" "period"
-            , toAttr "strFrom" (fromStrict $ Text.pack $ (show $ fst prd'))
-            , toAttr "strTo"   (fromStrict $ Text.pack $ (show $ snd prd'))
-            , toAttr "from" (fromStrict $ Text.pack $ (show $ fst prd))
-            , toAttr "to"   (fromStrict $ Text.pack $ (show $ snd prd))])
+            , toAttr "strFrom" $ fromStrict $ Text.pack $ show $ fst prd'
+            , toAttr "strTo"   $ fromStrict $ Text.pack $ show $ snd prd'
+            , toAttr "from" $ fromStrict $ Text.pack $ show $ fst prd
+            , toAttr "to"   $ fromStrict $ Text.pack $ show $ snd prd ]
 
 
 groupToDotNode :: Vector Ngrams -> PhyloGroup -> Int -> Dot DotId
 groupToDotNode fdt g bId =
     node (groupIdToDotId $ getGroupId g)
-                     ([FontName "Arial", Shape Square, penWidth 4,  toLabel (groupToTable fdt g)]
+    ( [ FontName "Arial"
+      , Shape Square
+      , penWidth 4
+      , toLabel (groupToTable fdt g) ]
       <> [ toAttr "nodeType" "group"
          , toAttr "gid" (groupIdToDotId $ getGroupId g)
          , toAttr "from" (pack $ show (fst $ g ^. phylo_groupPeriod))
@@ -598,7 +611,13 @@ getGroupThr step g =
         breaks = (g ^. phylo_groupMeta) ! "breaks"
      in (last' "export" (take (round $ (last' "export" breaks) + 1) seaLvl)) - step
 
-toAncestor :: Double -> Map Int Double -> PhyloSimilarity -> Double -> [PhyloGroup] -> PhyloGroup -> PhyloGroup
+toAncestor :: Double
+           -> Map Int Double
+           -> PhyloSimilarity
+           -> Double
+           -> [PhyloGroup]
+           -> PhyloGroup
+           -> PhyloGroup
 toAncestor nbDocs diago similarity step candidates ego =
   let curr = ego ^. phylo_groupAncestors
    in ego & phylo_groupAncestors .~ (curr ++ (map (\(g,w) -> (getGroupId g,w))
@@ -607,7 +626,13 @@ toAncestor nbDocs diago similarity step candidates ego =
          $ filter (\g -> g ^. phylo_groupBranchId /= ego ^. phylo_groupBranchId ) candidates))
 
 
-headsToAncestors :: Double -> Map Int Double -> PhyloSimilarity -> Double -> [PhyloGroup] -> [PhyloGroup] -> [PhyloGroup]
+headsToAncestors :: Double
+                 -> Map Int Double
+                 -> PhyloSimilarity
+                 -> Double
+                 -> [PhyloGroup]
+                 -> [PhyloGroup]
+                 -> [PhyloGroup]
 headsToAncestors nbDocs diago similarity step heads acc =
   if (null heads)
     then acc

src/Gargantext/Core/Viz/Phylo/PhyloMaker.hs

@@ -263,7 +263,6 @@ maybeDefaultParams phylo =  if (defaultMode (getConfig phylo))
 
 -- To build the first phylo step from docs and terms
 -- QL: backend entre phyloBase et Clustering
--- tophylowithoutLink
 toPhyloWithoutLink :: [Document] -> PhyloConfig -> Phylo
 toPhyloWithoutLink docs conf = joinRoots
                              $ findSeaLadder

src/Gargantext/Core/Viz/Phylo/PhyloTools.hs

@@ -172,11 +172,11 @@ toLstDate ds = snd
 
 getTimeScale :: Phylo -> [Char]
 getTimeScale p = case (timeUnit $ getConfig p) of
-    Epoch _ _ _ -> "epoch"
-    Year  _ _ _ -> "year"
-    Month _ _ _ -> "month"
-    Week  _ _ _ -> "week"
-    Day   _ _ _ -> "day"
+    Epoch {} -> "epoch"
+    Year  {} -> "year"
+    Month {} -> "month"
+    Week  {} -> "week"
+    Day   {} -> "day"
 
 
 -- | Get a regular & ascendante timeScale from a given list of dates
@@ -188,27 +188,27 @@ toTimeScale dates step =
 
 getTimeStep :: TimeUnit -> Int
 getTimeStep time = case time of
-    Epoch _ s _ -> s
-    Year  _ s _ -> s
-    Month _ s _ -> s
-    Week  _ s _ -> s
-    Day   _ s _ -> s
+    Epoch { .. } -> _epoch_step
+    Year  { .. } -> _year_step
+    Month { .. } -> _month_step
+    Week  { .. } -> _week_step
+    Day   { .. } -> _day_step
 
 getTimePeriod :: TimeUnit -> Int
 getTimePeriod time = case time of
-    Epoch p _ _ -> p
-    Year  p _ _ -> p
-    Month p _ _ -> p
-    Week  p _ _ -> p
-    Day   p _ _ -> p
+    Epoch { .. } -> _epoch_period
+    Year  { .. } -> _year_period
+    Month { .. } -> _month_period
+    Week  { .. } -> _week_period
+    Day   { .. } -> _day_period
 
 getTimeFrame :: TimeUnit -> Int
 getTimeFrame time = case time of
-    Epoch _ _ f -> f
-    Year  _ _ f -> f
-    Month _ _ f -> f
-    Week  _ _ f -> f
-    Day   _ _ f -> f
+    Epoch { .. } -> _epoch_matchingFrame
+    Year  { .. } -> _year_matchingFrame
+    Month { .. } -> _month_matchingFrame
+    Week  { .. } -> _week_matchingFrame
+    Day   { .. } -> _day_matchingFrame
 
 -------------
 -- | Fis | --
@@ -220,7 +220,7 @@ isNested :: Eq a => [a] -> [a] -> Bool
 isNested l l'
   | null l'               = True
   | length l' > length l  = False
-  | (union  l l') == l    = True
+  | union  l l' == l      = True
   | otherwise             = False
 
 
@@ -251,8 +251,8 @@ traceSupport mFis = foldl (\msg cpt -> msg <> show (countSup cpt supports) <> "
 
 traceFis :: [Char] -> Map (Date, Date) [Clustering] -> Map (Date, Date) [Clustering]
 traceFis msg mFis = trace ( "\n" <> "-- | " <> msg <> " : " <> show (sum $ map length $ elems mFis) <> "\n"
-                         <> "Support : " <> (traceSupport mFis) <> "\n"
-                         <> "Nb Ngrams : "  <> (traceClique mFis)  <> "\n" ) mFis
+                         <> "Support : " <> traceSupport mFis <> "\n"
+                         <> "Nb Ngrams : "  <> traceClique mFis  <> "\n" ) mFis
 
 
 ----------------