[API] PostNodeAsync funs, before refactoring
[gargantext.git] / src / Gargantext / Viz / Phylo.hs
index f38fd3a312edb4241e955674e8a44b5abce7bc61..556907003b79f6439bfe5190692682651c43532c 100644 (file)
@@ -22,25 +22,27 @@ one 8, e54847.
 
 -}
 
-{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 
 module Gargantext.Viz.Phylo where
 
+import Control.DeepSeq
 import Control.Lens (makeLenses)
 import Data.Aeson.TH (deriveJSON,defaultOptions)
+import Data.Map     (Map)
 import Data.Maybe   (Maybe)
-import Data.Text    (Text)
 import Data.Set     (Set)
-import Data.Map     (Map)
+import Data.Swagger
+import Data.Text    (Text)
 import Data.Vector  (Vector)
---import Data.Time.Clock.POSIX  (POSIXTime)
 import GHC.Generics (Generic)
---import Gargantext.Database.Schema.Ngrams (NgramsId)
-import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Prelude
+import Gargantext.Text.Context (TermList)
+import Prelude (Bounded)
 
 --------------------
 -- | PhyloParam | --
@@ -73,23 +75,21 @@ data Software =
 -- Periods     : list of all the periods of a Phylo
 data Phylo =
      Phylo { _phylo_duration    :: (Start, End)
-           , _phylo_foundations :: Vector Ngrams
-           , _phylo_foundationsPeaks :: PhyloPeaks
+           , _phylo_foundations :: PhyloFoundations
            , _phylo_periods     :: [PhyloPeriod]
+           , _phylo_docsByYears :: Map Date Double
+           , _phylo_cooc        :: !(Map Date (Map (Int,Int) Double))
+           , _phylo_fis         :: !(Map (Date,Date) [PhyloFis])
            , _phylo_param       :: PhyloParam
            }
            deriving (Generic, Show, Eq)
 
--- | The PhyloPeaks describe the aggregation of some foundations Ngrams behind a list of Ngrams trees (ie: a forest)
--- PeaksLabels are the root labels of each Ngrams trees
-data PhyloPeaks =
-      PhyloPeaks { _phylo_peaksLabels :: Vector Ngrams
-                 , _phylo_peaksForest :: [Tree Ngrams]
-                 }
-                 deriving (Generic, Show, Eq)
 
--- | A Tree of Ngrams where each node is a label
-data Tree a = Empty | Node a [Tree a] deriving (Show, Eq)
+-- | The foundations of a phylomemy created from a given TermList 
+data PhyloFoundations =
+  PhyloFoundations { _phylo_foundationsRoots :: Vector Ngrams
+                   , _phylo_foundationsTermsList :: TermList
+  } deriving (Generic, Show, Eq)
 
 
 -- | Date : a simple Integer
@@ -151,9 +151,10 @@ data PhyloGroup =
      PhyloGroup { _phylo_groupId            :: PhyloGroupId
                 , _phylo_groupLabel         :: Text
                 , _phylo_groupNgrams        :: [Int]
+                , _phylo_groupNgramsMeta    :: Map Text [Double]
                 , _phylo_groupMeta          :: Map Text Double
-                , _phylo_groupCooc          :: Map (Int, Int) Double
                 , _phylo_groupBranchId      :: Maybe PhyloBranchId
+                , _phylo_groupCooc          :: !(Map (Int,Int) Double)
 
                 , _phylo_groupPeriodParents :: [Pointer]
                 , _phylo_groupPeriodChilds  :: [Pointer]
@@ -161,7 +162,9 @@ data PhyloGroup =
                 , _phylo_groupLevelParents  :: [Pointer]
                 , _phylo_groupLevelChilds   :: [Pointer]
                 }
-                deriving (Generic, Show, Eq, Ord)
+                deriving (Generic, NFData, Show, Eq, Ord)
+
+-- instance NFData PhyloGroup
 
 
 -- | Level : A level of aggregation (-1 = Txt, 0 = Ngrams, 1 = Fis, [2..] = Cluster)
@@ -193,7 +196,7 @@ type Ngrams = Text
 data Document = Document
       { date :: Date
       , text :: [Ngrams]
-      } deriving (Show)
+      } deriving (Show,Generic,NFData)
 
 -- | Clique : Set of ngrams cooccurring in the same Document
 type Clique   = Set Ngrams
@@ -203,19 +206,19 @@ type Support  = Int
 data PhyloFis = PhyloFis
   { _phyloFis_clique  :: Clique
   , _phyloFis_support :: Support
-  , _phyloFis_metrics :: Map (Int,Int) (Map Text [Double])
-  } deriving (Show)
+  , _phyloFis_period  :: (Date,Date)
+  } deriving (Generic,NFData,Show,Eq)
 
 -- | A list of clustered PhyloGroup
 type PhyloCluster = [PhyloGroup]
 
 
--- | 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)]
+-- | A PhyloGroup in a Graph
+type GroupNode  = PhyloGroup
+-- | A weighted links between two PhyloGroups in a Graph
+type GroupEdge  = ((PhyloGroup,PhyloGroup),Weight)
 -- | The association as a Graph between a list of Nodes and a list of Edges
-type GroupGraph = (GroupNodes,GroupEdges)
+type GroupGraph = ([GroupNode],[GroupEdge])
 
 
 ---------------
@@ -237,21 +240,22 @@ data PhyloError = LevelDoesNotExist
 data Cluster = Fis FisParams
              | RelatedComponents RCParams
              | Louvain LouvainParams
-        deriving (Generic, Show, Eq)
+        deriving (Generic, Show, Eq, Read)
 
 -- | Parameters for Fis clustering
 data FisParams = FisParams
   { _fis_keepMinorFis :: Bool
   , _fis_minSupport   :: Support
-  } deriving (Generic, Show, Eq)
+  , _fis_minSize      :: Int
+  } deriving (Generic, Show, Eq, Read)
 
 -- | Parameters for RelatedComponents clustering
 data RCParams = RCParams
-  { _rc_proximity :: Proximity } deriving (Generic, Show, Eq)
+  { _rc_proximity :: Proximity } deriving (Generic, Show, Eq, Read)
 
 -- | Parameters for Louvain clustering
 data LouvainParams = LouvainParams
-  { _louvain_proximity :: Proximity } deriving (Generic, Show, Eq)
+  { _louvain_proximity :: Proximity } deriving (Generic, Show, Eq, Read)
 
 
 -------------------
@@ -263,17 +267,17 @@ data LouvainParams = LouvainParams
 data Proximity = WeightedLogJaccard WLJParams
                | Hamming HammingParams
                | Filiation
-          deriving (Generic, Show, Eq)
+          deriving (Generic, Show, Eq, Read)
 
 -- | Parameters for WeightedLogJaccard proximity
 data WLJParams = WLJParams
   { _wlj_threshold   :: Double
   , _wlj_sensibility :: Double
-  } deriving (Generic, Show, Eq)
+  } deriving (Generic, Show, Eq, Read)
 
 -- | Parameters for Hamming proximity
 data HammingParams = HammingParams
-  { _hamming_threshold :: Double } deriving (Generic, Show, Eq)
+  { _hamming_threshold :: Double } deriving (Generic, Show, Eq, Read)
 
 
 ----------------
@@ -282,13 +286,19 @@ data HammingParams = HammingParams
 
 
 -- | Filter constructors
-data Filter = SmallBranch SBParams deriving (Generic, Show, Eq)
+data Filter = LonelyBranch LBParams
+            | SizeBranch SBParams
+            deriving (Generic, Show, Eq)
 
--- | Parameters for SmallBranch filter
+-- | Parameters for LonelyBranch filter
+data LBParams = LBParams
+  { _lb_periodsInf :: Int
+  , _lb_periodsSup :: Int
+  , _lb_minNodes   :: Int } deriving (Generic, Show, Eq)
+
+-- | Parameters for SizeBranch filter
 data SBParams = SBParams
-  { _sb_periodsInf :: Int
-  , _sb_periodsSup :: Int
-  , _sb_minNodes   :: Int } deriving (Generic, Show, Eq)
+  { _sb_minSize :: Int } deriving (Generic, Show, Eq)
 
 
 ----------------
@@ -297,7 +307,7 @@ data SBParams = SBParams
 
 
 -- | Metric constructors
-data Metric = BranchAge deriving (Generic, Show, Eq)
+data Metric = BranchAge | BranchBirth | BranchGroups deriving (Generic, Show, Eq, Read)
 
 
 ----------------
@@ -306,7 +316,8 @@ data Metric = BranchAge deriving (Generic, Show, Eq)
 
 
 -- | Tagger constructors
-data Tagger = BranchLabelFreq | GroupLabelCooc | GroupDynamics deriving (Show)
+data Tagger = BranchPeakFreq | BranchPeakCooc | BranchPeakInc
+            | GroupLabelCooc | GroupLabelInc  | GroupLabelIncDyn deriving (Show,Generic,Read)
 
 
 --------------
@@ -315,8 +326,8 @@ data Tagger = BranchLabelFreq | GroupLabelCooc | GroupDynamics deriving (Show)
 
 
 -- | Sort constructors
-data Sort  = ByBranchAge deriving (Generic, Show)
-data Order = Asc | Desc  deriving (Generic, Show)
+data Sort  = ByBranchAge | ByBranchBirth deriving (Generic, Show, Read, Enum, Bounded)
+data Order = Asc | Desc  deriving (Generic, Show, Read)
 
 
 --------------------
@@ -340,6 +351,11 @@ data PhyloQueryBuild = PhyloQueryBuild
 
     -- Inter-temporal matching method of the Phylo
     , _q_interTemporalMatching :: Proximity
+    , _q_interTemporalMatchingFrame :: Int
+    , _q_interTemporalMatchingFrameTh :: Double
+
+    , _q_reBranchThr :: Double
+    , _q_reBranchNth :: Int
 
     -- Last level of reconstruction
     , _q_nthLevel   :: Level
@@ -348,7 +364,7 @@ data PhyloQueryBuild = PhyloQueryBuild
     } deriving (Generic, Show, Eq)
 
 -- | To choose the Phylo edge you want to export : --> <-- <--> <=>
-data Filiation = Ascendant | Descendant | Merge | Complete deriving (Generic, Show)
+data Filiation = Ascendant | Descendant | Merge | Complete deriving (Generic, Show, Read)
 data EdgeType  = PeriodEdge | LevelEdge deriving (Generic, Show, Eq)
 
 -------------------
@@ -363,6 +379,7 @@ data PhyloView = PhyloView
   , _pv_description :: Text
   , _pv_filiation   :: Filiation
   , _pv_level       :: Level
+  , _pv_periods     :: [PhyloPeriodId]
   , _pv_metrics     :: Map Text [Double]
   , _pv_branches    :: [PhyloBranch]
   , _pv_nodes       :: [PhyloNode]
@@ -372,7 +389,7 @@ data PhyloView = PhyloView
 -- | A phyloview is made of PhyloBranches, edges and nodes
 data PhyloBranch = PhyloBranch
   { _pb_id      :: PhyloBranchId
-  , _pb_label   :: Text
+  , _pb_peak    :: Text
   , _pb_metrics :: Map Text [Double]
   } deriving (Generic, Show)
 
@@ -390,6 +407,7 @@ data PhyloNode = PhyloNode
   , _pn_idx :: [Int]
   , _pn_ngrams    :: Maybe [Ngrams]
   , _pn_metrics      :: Map Text [Double]
+  , _pn_cooc :: Map (Int,Int) Double
   , _pn_parents :: Maybe [PhyloGroupId]
   , _pn_childs  :: [PhyloNode]
   } deriving (Generic, Show)
@@ -400,7 +418,9 @@ data PhyloNode = PhyloNode
 
 
 data ExportMode = Json | Dot | Svg
+  deriving (Generic, Show, Read)
 data DisplayMode = Flat | Nested
+  deriving (Generic, Show, Read)
 
 -- | A PhyloQueryView describes a Phylo as an output view
 data PhyloQueryView = PhyloQueryView
@@ -438,7 +458,7 @@ makeLenses ''PhyloParam
 makeLenses ''Software
 --
 makeLenses ''Phylo
-makeLenses ''PhyloPeaks
+makeLenses ''PhyloFoundations
 makeLenses ''PhyloGroup
 makeLenses ''PhyloLevel
 makeLenses ''PhyloPeriod
@@ -463,8 +483,7 @@ makeLenses ''PhyloEdge
 
 
 $(deriveJSON (unPrefix "_phylo_"       ) ''Phylo       )
-$(deriveJSON (unPrefix "_phylo_peaks"  ) ''PhyloPeaks  )
-$(deriveJSON defaultOptions ''Tree  )
+$(deriveJSON (unPrefix "_phylo_foundations"  ) ''PhyloFoundations  )
 $(deriveJSON (unPrefix "_phylo_period" ) ''PhyloPeriod )
 $(deriveJSON (unPrefix "_phylo_level"  ) ''PhyloLevel  )
 $(deriveJSON (unPrefix "_phylo_group"  ) ''PhyloGroup  )
@@ -483,6 +502,8 @@ $(deriveJSON (unPrefix "_hamming_" ) ''HammingParams )
 $(deriveJSON (unPrefix "_louvain_" ) ''LouvainParams )
 $(deriveJSON (unPrefix "_rc_" )      ''RCParams      )
 $(deriveJSON (unPrefix "_wlj_" )     ''WLJParams     )
+--
+$(deriveJSON (unPrefix "_lb_" )      ''LBParams      )
 $(deriveJSON (unPrefix "_sb_" )      ''SBParams      )
 --
 $(deriveJSON (unPrefix "_q_" )  ''PhyloQueryBuild  )
@@ -494,6 +515,57 @@ $(deriveJSON (unPrefix "_pn_" ) ''PhyloNode   )
 $(deriveJSON defaultOptions ''Filiation )
 $(deriveJSON defaultOptions ''EdgeType  )
 
+---------------------------
+-- | Swagger instances | --
+---------------------------
+
+instance ToSchema Phylo where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
+instance ToSchema PhyloFoundations where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_foundations")
+instance ToSchema PhyloPeriod where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_period")
+instance ToSchema PhyloLevel where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_level")
+instance ToSchema PhyloGroup where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_group")
+instance ToSchema PhyloFis where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phyloFis_")
+instance ToSchema Software where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_software_")
+instance ToSchema PhyloParam where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phyloParam_")
+instance ToSchema Filter
+instance ToSchema Metric
+instance ToSchema Cluster
+instance ToSchema Proximity where
+  declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
+instance ToSchema FisParams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fis_")
+instance ToSchema HammingParams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hamming_")
+instance ToSchema LouvainParams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_louvain_")
+instance ToSchema RCParams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_rc_")
+instance ToSchema WLJParams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wlj_")
+instance ToSchema LBParams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lb_")
+instance ToSchema SBParams where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_sb_")
+instance ToSchema PhyloQueryBuild where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_q_")
+instance ToSchema PhyloView where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_pv_")
+instance ToSchema PhyloBranch where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_pb_")
+instance ToSchema PhyloEdge where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_pe_")
+instance ToSchema PhyloNode where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_pn_")
+instance ToSchema Filiation
+instance ToSchema EdgeType
 
 ----------------------------
 -- | TODO XML instances | --