-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import Data.Set (Set)
import Data.Map (Map)
import Data.Vector (Vector)
+import Data.Swagger
--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.Text.Context (TermList)
import Gargantext.Prelude
+import Control.DeepSeq
+
--------------------
-- | PhyloParam | --
--------------------
-- 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 (Generic, 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
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]
, _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)
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
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])
---------------
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)
-------------------
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)
----------------
-- | 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)
----------------
-- | Metric constructors
-data Metric = BranchAge deriving (Generic, Show, Eq, Read)
+data Metric = BranchAge | BranchBirth | BranchGroups deriving (Generic, Show, Eq, Read)
----------------
-- | Tagger constructors
-data Tagger = BranchLabelFreq | GroupLabelCooc | GroupDynamics
- deriving (Generic, Show, Read)
+data Tagger = BranchPeakFreq | BranchPeakCooc | BranchPeakInc
+ | GroupLabelCooc | GroupLabelInc | GroupLabelIncDyn deriving (Show,Generic,Read)
--------------
-- | Sort constructors
-data Sort = ByBranchAge deriving (Generic, Show, Read, Enum, Bounded)
+data Sort = ByBranchAge | ByBranchBirth deriving (Generic, Show, Read, Enum, Bounded)
data Order = Asc | Desc deriving (Generic, Show, Read)
-- 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
-- | To choose the Phylo edge you want to export : --> <-- <--> <=>
data Filiation = Ascendant | Descendant | Merge | Complete deriving (Generic, Show, Read)
-data EdgeType = PeriodEdge | LevelEdge deriving (Generic, Show)
+data EdgeType = PeriodEdge | LevelEdge deriving (Generic, Show, Eq)
-------------------
-- | PhyloView | --
, _pv_title :: Text
, _pv_description :: Text
, _pv_filiation :: Filiation
+ , _pv_level :: Level
+ , _pv_periods :: [PhyloPeriodId]
, _pv_metrics :: Map Text [Double]
, _pv_branches :: [PhyloBranch]
, _pv_nodes :: [PhyloNode]
-- | 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)
, _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)
-
------------------------
-- | PhyloQueryView | --
------------------------
+data ExportMode = Json | Dot | Svg
+ deriving (Generic, Show, Read)
data DisplayMode = Flat | Nested
deriving (Generic, Show, Read)
, _qv_sort :: Maybe (Sort,Order)
-- A display mode to apply to the PhyloGraph, ie: [Node[Node,Edge],Edge] or [[Node,Node],[Edge,Edge]]
+ , _qv_export :: ExportMode
, _qv_display :: DisplayMode
, _qv_verbose :: Bool
}
makeLenses ''Software
--
makeLenses ''Phylo
-makeLenses ''PhyloPeaks
+makeLenses ''PhyloFoundations
makeLenses ''PhyloGroup
makeLenses ''PhyloLevel
makeLenses ''PhyloPeriod
$(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 )
$(deriveJSON (unPrefix "_louvain_" ) ''LouvainParams )
$(deriveJSON (unPrefix "_rc_" ) ''RCParams )
$(deriveJSON (unPrefix "_wlj_" ) ''WLJParams )
+--
+$(deriveJSON (unPrefix "_lb_" ) ''LBParams )
$(deriveJSON (unPrefix "_sb_" ) ''SBParams )
--
$(deriveJSON (unPrefix "_q_" ) ''PhyloQueryBuild )
$(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 | --