{-|
Module : Gargantext.Core.Viz.Graph
Description : Graph utils
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Core.Viz.Graph
where
import Data.ByteString.Lazy as DBL (readFile, writeFile)
import Data.HashMap.Strict (HashMap, lookup)
import Data.HashSet (HashSet)
import Data.Text (pack)
import GHC.IO (FilePath)
import Gargantext.API.Ngrams.Types (NgramsTerm(..), NgramsRepoElement(..), mSetToList)
import Gargantext.Core.Methods.Similarities (GraphMetric)
import Gargantext.Core.Types (ListId)
import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude
import qualified Data.Aeson as DA
import qualified Data.HashSet as HashSet
import qualified Data.Text as Text
import qualified Text.Read as Text
data TypeNode = Terms | Unknown
deriving (Show, Generic)
instance ToJSON TypeNode
instance FromJSON TypeNode
instance ToSchema TypeNode
data Attributes = Attributes { clust_default :: Int }
deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''Attributes)
instance ToSchema Attributes
data Node = Node { node_size :: Int
, node_type :: NgramsType -- TypeNode -- TODO NgramsType | Person
, node_id :: Text -- TODO NgramId
, node_label :: Text
, node_x_coord :: Double
, node_y_coord :: Double
, node_attributes :: Attributes
, node_children :: [Text]
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "node_") ''Node)
instance ToSchema Node where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
data Edge = Edge { edge_source :: Text
, edge_target :: Text
, edge_weight :: Double
, edge_confluence :: Double
, edge_id :: Text
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "edge_") ''Edge)
instance ToSchema Edge where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
---------------------------------------------------------------
data LegendField = LegendField { _lf_id :: Int
, _lf_color :: Text
, _lf_label :: Text
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_lf_") ''LegendField)
instance ToSchema LegendField where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
makeLenses ''LegendField
---------------------------------------------------------------
data Partite = Partite { _partite_nodes :: HashSet NgramsTerm
, _partite_type :: NgramsType
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_partite_") ''Partite)
instance ToSchema Partite where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_partite_")
makeLenses ''Partite
data MultiPartite = MultiPartite { _multipartite_data1 :: Partite
, _multipartite_data2 :: Partite
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_multipartite_") ''MultiPartite)
instance ToSchema MultiPartite where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_multipartite_")
makeLenses ''MultiPartite
defaultMultipartite :: MultiPartite
defaultMultipartite = MultiPartite a a
where
a = Partite HashSet.empty NgramsTerms
---------------------------------------------------------------
type Version = Int
data ListForGraph =
ListForGraph { _lfg_listId :: ListId
, _lfg_version :: Version
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
instance ToSchema ListForGraph where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
makeLenses ''ListForGraph
data Strength = Strong | Weak
deriving (Generic, Eq, Ord, Enum, Bounded, Show)
$(deriveJSON (unPrefix "") ''Strength)
instance ToSchema Strength where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
instance Arbitrary Strength where
arbitrary = elements $ [Strong, Weak]
data GraphMetadata =
GraphMetadata { _gm_title :: Text -- title of the graph
, _gm_metric :: GraphMetric
, _gm_edgesStrength :: Maybe Strength
, _gm_corpusId :: [NodeId] -- we can map with different corpus
, _gm_legend :: [LegendField] -- legend of the Graph
, _gm_list :: ListForGraph
, _gm_startForceAtlas :: Bool
-- , _gm_nodesTypes :: Maybe (NgramsType, NgramsType)
-- , _gm_version :: Int
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
instance ToSchema GraphMetadata where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
makeLenses ''GraphMetadata
data Graph = Graph { _graph_nodes :: [Node]
, _graph_edges :: [Edge]
, _graph_metadata :: Maybe GraphMetadata
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_graph_") ''Graph)
makeLenses ''Graph
instance ToSchema Graph where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
-- | Intances for the mock
instance Arbitrary Graph where
arbitrary = elements $ [defaultGraph]
defaultGraph :: Graph
defaultGraph = Graph {_graph_nodes = [Node {node_x_coord=0, node_y_coord=0, node_size = 4, node_type = NgramsTerms, node_id = pack "0", node_label = pack "animal", node_attributes = Attributes {clust_default = 0}, node_children = []},Node {node_x_coord=0, node_y_coord=0, node_size = 3, node_type = NgramsTerms, node_id = pack "1", node_label = pack "bird", node_attributes = Attributes {clust_default = 0}, node_children = []},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = NgramsTerms, node_id = pack "2", node_label = pack "boy", node_attributes = Attributes {clust_default = 1}, node_children = []},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = NgramsTerms, node_id = pack "3", node_label = pack "dog", node_attributes = Attributes {clust_default = 0}, node_children = []},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = NgramsTerms, node_id = pack "4", node_label = pack "girl", node_attributes = Attributes {clust_default = 1}, node_children = []},Node {node_x_coord=0, node_y_coord=0, node_size = 4, node_type = NgramsTerms, node_id = pack "5", node_label = pack "human body", node_attributes = Attributes {clust_default = 1}, node_children = []},Node {node_x_coord=0, node_y_coord=0, node_size = 3, node_type = NgramsTerms, node_id = pack "6", node_label = pack "object", node_attributes = Attributes {clust_default = 2}, node_children = []},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = NgramsTerms, node_id = pack "7", node_label = pack "pen", node_attributes = Attributes {clust_default = 2}, node_children = []},Node {node_x_coord=0, node_y_coord=0, node_size = 2, node_type = NgramsTerms, node_id = pack "8", node_label = pack "table", node_attributes = Attributes {clust_default = 2}, node_children = []}], _graph_edges = [Edge {edge_source = pack "0", edge_target = pack "0", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "0"},Edge {edge_source = pack "1", edge_target = pack "0", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "1"},Edge {edge_source = pack "1", edge_target = pack "1", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "2"},Edge {edge_source = pack "2", edge_target = pack "2", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "3"},Edge {edge_source = pack "2", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "4"},Edge {edge_source = pack "3", edge_target = pack "0", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "5"},Edge {edge_source = pack "3", edge_target = pack "1", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "6"},Edge {edge_source = pack "3", edge_target = pack "3", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "7"},Edge {edge_source = pack "4", edge_target = pack "4", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "8"},Edge {edge_source = pack "4", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "9"},Edge {edge_source = pack "5", edge_target = pack "5", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "10"},Edge {edge_source = pack "6", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "11"},Edge {edge_source = pack "7", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "12"},Edge {edge_source = pack "7", edge_target = pack "7", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "13"},Edge {edge_source = pack "8", edge_target = pack "6", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "14"},Edge {edge_source = pack "8", edge_target = pack "7", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "15"},Edge {edge_source = pack "8", edge_target = pack "8", edge_weight = 1.0, edge_confluence=0.5, edge_id = pack "16"}], _graph_metadata = Nothing}
-----------------------------------------------------------
-- V3 Gargantext Version
data AttributesV3 = AttributesV3 { cl :: Int }
deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''AttributesV3)
data NodeV3 = NodeV3 { no_id :: Int
, no_at :: AttributesV3
, no_s :: Int
, no_lb :: Text
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "no_") ''NodeV3)
data EdgeV3 = EdgeV3 { eo_s :: Int
, eo_t :: Int
, eo_w :: Text
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "eo_") ''EdgeV3)
data GraphV3 = GraphV3 { go_links :: [EdgeV3]
, go_nodes :: [NodeV3]
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "go_") ''GraphV3)
-----------------------------------------------------------
data Camera = Camera { _camera_ratio :: Double
, _camera_x :: Double
, _camera_y :: Double }
deriving (Show, Generic)
$(deriveJSON (unPrefix "_camera_") ''Camera)
makeLenses ''Camera
instance ToSchema Camera where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_camera_")
-----------------------------------------------------------
data HyperdataGraph =
HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
, _hyperdataCamera :: !(Maybe Camera)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_") ''HyperdataGraph)
instance ToSchema HyperdataGraph where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
defaultHyperdataGraph :: HyperdataGraph
defaultHyperdataGraph = HyperdataGraph Nothing Nothing
instance Hyperdata HyperdataGraph
makeLenses ''HyperdataGraph
instance FromField HyperdataGraph
where
fromField = fromField'
instance DefaultFromField SqlJsonb HyperdataGraph
where
defaultFromField = fromPGSFromField
-----------------------------------------------------------
-- This type is used to return graph via API
-- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
data HyperdataGraphAPI =
HyperdataGraphAPI { _hyperdataAPIGraph :: Graph
, _hyperdataAPICamera :: !(Maybe Camera)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_hyperdataAPI") ''HyperdataGraphAPI)
instance ToSchema HyperdataGraphAPI where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hyperdataAPI")
makeLenses ''HyperdataGraphAPI
instance FromField HyperdataGraphAPI
where
fromField = fromField'
-----------------------------------------------------------
graphV3ToGraph :: GraphV3 -> Graph
graphV3ToGraph (GraphV3 links nodes) = Graph { _graph_nodes = map nodeV32node nodes
, _graph_edges = zipWith linkV32edge [1..] links
, _graph_metadata = Nothing }
where
nodeV32node :: NodeV3 -> Node
nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
= Node { node_size = no_s'
, node_type = NgramsTerms
, node_id = cs $ show no_id'
, node_label = no_lb'
, node_x_coord = 0
, node_y_coord = 0
, node_attributes = Attributes cl'
, node_children = []
}
linkV32edge :: Int -> EdgeV3 -> Edge
linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') =
Edge { edge_source = cs $ show eo_s'
, edge_target = cs $ show eo_t'
, edge_weight = (Text.read $ Text.unpack eo_w') :: Double
, edge_confluence = 0.5
, edge_id = cs $ show n }
graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
graphV3ToGraphWithFiles g1 g2 = do
-- GraphV3 <- IO Fichier
graph <- DBL.readFile g1
let newGraph = case DA.decode graph :: Maybe GraphV3 of
Nothing -> panic (Text.pack "no graph")
Just new -> new
DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
readGraphFromJson fp = do
graph <- liftBase $ DBL.readFile fp
pure $ DA.decode graph
-----------------------------------------------------------
mergeGraphNgrams :: Graph -> Maybe (HashMap NgramsTerm NgramsRepoElement) -> Graph
mergeGraphNgrams g Nothing = g
mergeGraphNgrams graph@(Graph { _graph_nodes }) (Just listNgrams) = set graph_nodes newNodes graph
where
newNodes = insertChildren <$> _graph_nodes
insertChildren (Node { node_label, .. }) = Node { node_children = children', .. }
where
-- lookup (NgramsTerm node_label) in listNgrams, then fetch (NgramsRepoElement _nre_children)
children' = case (lookup (NgramsTerm node_label) listNgrams) of
Nothing -> []
Just (NgramsRepoElement { _nre_children }) -> unNgramsTerm <$> mSetToList _nre_children