src/Gargantext/Core/Viz/Graph.hs

   1 {-|
   2 Module      : Gargantext.Core.Viz.Graph
   3 Description : Graph utils
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13 {-# LANGUAGE TemplateHaskell      #-}
  14
  15 module Gargantext.Core.Viz.Graph
  16   where
  17
  18 import Data.ByteString.Lazy as DBL (readFile, writeFile)
  19 import Data.HashMap.Strict (HashMap, lookup)
  20 import Data.HashSet (HashSet)
  21 import Data.Text (pack)
  22 import GHC.IO (FilePath)
  23 import Gargantext.API.Ngrams.Types (NgramsTerm(..), NgramsRepoElement(..), mSetToList)
  24 import Gargantext.Core.Methods.Similarities (GraphMetric)
  25 import Gargantext.Core.Types (ListId)
  26 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
  27 import Gargantext.Database.Admin.Types.Node (NodeId)
  28 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  29 import Gargantext.Prelude
  30 import qualified Data.Aeson   as DA
  31 import qualified Data.HashSet as HashSet
  32 import qualified Data.Text    as Text
  33 import qualified Text.Read    as Text
  34
  35 data TypeNode = Terms | Unknown
  36   deriving (Show, Generic)
  37
  38 instance ToJSON TypeNode
  39 instance FromJSON TypeNode
  40 instance ToSchema TypeNode
  41
  42 data Attributes = Attributes { clust_default :: Int }
  43   deriving (Show, Generic)
  44 $(deriveJSON (unPrefix "") ''Attributes)
  45 instance ToSchema Attributes
  46
  47 data Node = Node { node_size  :: Int
  48                  , node_type  :: NgramsType -- TypeNode -- TODO NgramsType | Person
  49                  , node_id    :: Text     -- TODO NgramId
  50                  , node_label :: Text
  51                  , node_x_coord :: Double
  52                  , node_y_coord :: Double
  53                  , node_attributes :: Attributes
  54                  , node_children :: [Text]
  55                  }
  56   deriving (Show, Generic)
  57 $(deriveJSON (unPrefix "node_") ''Node)
  58 instance ToSchema Node where
  59   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
  60
  61
  62 data Edge = Edge { edge_source :: Text
  63                  , edge_target :: Text
  64                  , edge_weight :: Double
  65                  , edge_confluence :: Double
  66                  , edge_id     :: Text
  67                  }
  68   deriving (Show, Generic)
  69
  70 $(deriveJSON (unPrefix "edge_") ''Edge)
  71
  72 instance ToSchema Edge where
  73   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
  74
  75 ---------------------------------------------------------------
  76 data LegendField = LegendField { _lf_id :: Int
  77                                , _lf_color :: Text
  78                                , _lf_label :: Text
  79                                }
  80   deriving (Show, Generic)
  81 $(deriveJSON (unPrefix "_lf_") ''LegendField)
  82
  83 instance ToSchema LegendField where
  84   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
  85
  86 makeLenses ''LegendField
  87
  88 ---------------------------------------------------------------
  89 data Partite = Partite { _partite_nodes :: HashSet NgramsTerm
  90                        , _partite_type :: NgramsType
  91                        }
  92   deriving (Show, Generic)
  93 $(deriveJSON (unPrefix "_partite_") ''Partite)
  94 instance ToSchema Partite where
  95   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_partite_")
  96 makeLenses ''Partite
  97
  98
  99 data MultiPartite = MultiPartite { _multipartite_data1 :: Partite
 100                                  , _multipartite_data2 :: Partite
 101                                  }
 102   deriving (Show, Generic)
 103 $(deriveJSON (unPrefix "_multipartite_") ''MultiPartite)
 104 instance ToSchema MultiPartite where
 105   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_multipartite_")
 106 makeLenses ''MultiPartite
 107
 108 defaultMultipartite :: MultiPartite
 109 defaultMultipartite = MultiPartite a a
 110   where
 111     a = Partite HashSet.empty NgramsTerms
 112
 113 ---------------------------------------------------------------
 114
 115 type Version = Int
 116 data ListForGraph =
 117   ListForGraph { _lfg_listId  :: ListId
 118                , _lfg_version :: Version
 119                } deriving (Show, Generic)
 120 $(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
 121
 122 instance ToSchema ListForGraph where
 123   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
 124
 125 makeLenses ''ListForGraph
 126
 127 data Strength = Strong | Weak
 128     deriving (Generic, Eq, Ord, Enum, Bounded, Show)
 129
 130 $(deriveJSON (unPrefix "") ''Strength)
 131 instance ToSchema Strength where
 132   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 133
 134 instance Arbitrary Strength where
 135   arbitrary = elements $ [Strong, Weak]
 136
 137
 138
 139 data GraphMetadata =
 140   GraphMetadata { _gm_title            :: Text          -- title of the graph
 141                 , _gm_metric           :: GraphMetric
 142                 , _gm_edgesStrength    :: Maybe Strength
 143                 , _gm_corpusId         :: [NodeId]      -- we can map with different corpus
 144                 , _gm_legend           :: [LegendField] -- legend of the Graph
 145                 , _gm_list             :: ListForGraph
 146                 , _gm_startForceAtlas  :: Bool
 147                 -- , _gm_nodesTypes       :: Maybe (NgramsType, NgramsType)
 148                 -- , _gm_version       :: Int
 149                 }
 150   deriving (Show, Generic)
 151 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
 152 instance ToSchema GraphMetadata where
 153   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
 154 makeLenses ''GraphMetadata
 155
 156
 157
 158 data Graph = Graph { _graph_nodes    :: [Node]
 159                    , _graph_edges    :: [Edge]
 160                    , _graph_metadata :: Maybe GraphMetadata
 161                    }
 162   deriving (Show, Generic)
 163 $(deriveJSON (unPrefix "_graph_") ''Graph)
 164 makeLenses ''Graph
 165
 166 instance ToSchema Graph where
 167   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
 168
 169 -- | Intances for the mock
 170 instance Arbitrary Graph where
 171   arbitrary = elements $ [defaultGraph]
 172
 173 defaultGraph :: Graph
 174 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}
 175
 176
 177 -----------------------------------------------------------
 178 -- V3 Gargantext Version
 179
 180 data AttributesV3 = AttributesV3 { cl :: Int }
 181   deriving (Show, Generic)
 182 $(deriveJSON (unPrefix "") ''AttributesV3)
 183
 184 data NodeV3 = NodeV3 { no_id :: Int
 185                      , no_at :: AttributesV3
 186                      , no_s  :: Int
 187                      , no_lb :: Text
 188                      }
 189   deriving (Show, Generic)
 190 $(deriveJSON (unPrefix "no_") ''NodeV3)
 191
 192 data EdgeV3 = EdgeV3 { eo_s :: Int
 193                      , eo_t :: Int
 194                      , eo_w :: Text
 195                      }
 196   deriving (Show, Generic)
 197 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
 198
 199 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
 200                        , go_nodes :: [NodeV3]
 201                        }
 202   deriving (Show, Generic)
 203 $(deriveJSON (unPrefix "go_") ''GraphV3)
 204
 205 -----------------------------------------------------------
 206 data Camera = Camera { _camera_angle :: Double
 207                      , _camera_ratio :: Double
 208                      , _camera_x     :: Double
 209                      , _camera_y     :: Double }
 210   deriving (Show, Generic)
 211 $(deriveJSON (unPrefix "_camera_") ''Camera)
 212 makeLenses ''Camera
 213
 214 instance ToSchema Camera where
 215   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_camera_")
 216
 217 -----------------------------------------------------------
 218 data HyperdataGraph =
 219   HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
 220                  , _hyperdataCamera :: !(Maybe Camera)
 221                  } deriving (Show, Generic)
 222 $(deriveJSON (unPrefix "_") ''HyperdataGraph)
 223 instance ToSchema HyperdataGraph where
 224   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 225
 226 defaultHyperdataGraph :: HyperdataGraph
 227 defaultHyperdataGraph = HyperdataGraph Nothing Nothing
 228
 229
 230 instance Hyperdata HyperdataGraph
 231 makeLenses ''HyperdataGraph
 232
 233 instance FromField HyperdataGraph
 234   where
 235     fromField = fromField'
 236
 237 instance DefaultFromField SqlJsonb HyperdataGraph
 238   where
 239     defaultFromField = fromPGSFromField
 240
 241 -----------------------------------------------------------
 242 -- This type is used to return graph via API
 243 -- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
 244 data HyperdataGraphAPI =
 245   HyperdataGraphAPI { _hyperdataAPIGraph  :: Graph
 246                     , _hyperdataAPICamera :: !(Maybe Camera)
 247                     } deriving (Show, Generic)
 248 $(deriveJSON (unPrefix "_hyperdataAPI") ''HyperdataGraphAPI)
 249 instance ToSchema HyperdataGraphAPI where
 250   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hyperdataAPI")
 251
 252 makeLenses ''HyperdataGraphAPI
 253
 254 instance FromField HyperdataGraphAPI
 255   where
 256     fromField = fromField'
 257
 258 -----------------------------------------------------------
 259 graphV3ToGraph :: GraphV3 -> Graph
 260 graphV3ToGraph (GraphV3 links nodes) = Graph { _graph_nodes = map nodeV32node nodes
 261                                              , _graph_edges = zipWith linkV32edge [1..] links
 262                                              , _graph_metadata = Nothing }
 263   where
 264     nodeV32node :: NodeV3 -> Node
 265     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 266                 = Node { node_size = no_s'
 267                        , node_type = NgramsTerms
 268                        , node_id = cs $ show no_id'
 269                        , node_label = no_lb'
 270                        , node_x_coord = 0
 271                        , node_y_coord = 0
 272                        , node_attributes = Attributes cl'
 273                        , node_children = []
 274                        }
 275
 276     linkV32edge :: Int -> EdgeV3 -> Edge
 277     linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') =
 278       Edge { edge_source = cs $ show eo_s'
 279            , edge_target = cs $ show eo_t'
 280            , edge_weight = (Text.read $ Text.unpack eo_w') :: Double
 281            , edge_confluence = 0.5
 282            , edge_id = cs $ show n }
 283
 284
 285 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 286 graphV3ToGraphWithFiles g1 g2 = do
 287   -- GraphV3 <- IO Fichier
 288   graph <- DBL.readFile g1
 289   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 290         Nothing -> panic (Text.pack "no graph")
 291         Just new -> new
 292
 293   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 294
 295 readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
 296 readGraphFromJson fp = do
 297   graph <- liftBase $ DBL.readFile fp
 298   pure $ DA.decode graph
 299
 300
 301 -----------------------------------------------------------
 302 mergeGraphNgrams :: Graph -> Maybe (HashMap NgramsTerm NgramsRepoElement) -> Graph
 303 mergeGraphNgrams g Nothing = g
 304 mergeGraphNgrams graph@(Graph { _graph_nodes }) (Just listNgrams) = set graph_nodes newNodes graph
 305   where
 306     newNodes = insertChildren <$> _graph_nodes
 307     insertChildren (Node { node_label, .. }) = Node { node_children = children', .. }
 308       where
 309         -- lookup (NgramsTerm node_label) in listNgrams, then fetch (NgramsRepoElement _nre_children)
 310         children' = case (lookup (NgramsTerm node_label) listNgrams) of
 311           Nothing  -> []
 312           Just (NgramsRepoElement { _nre_children }) -> unNgramsTerm <$> mSetToList _nre_children