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_ratio :: Double
 207                      , _camera_x     :: Double
 208                      , _camera_y     :: Double }
 209   deriving (Show, Generic)
 210 $(deriveJSON (unPrefix "_camera_") ''Camera)
 211 makeLenses ''Camera
 212
 213 instance ToSchema Camera where
 214   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_camera_")
 215
 216 -----------------------------------------------------------
 217 data HyperdataGraph =
 218   HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
 219                  , _hyperdataCamera :: !(Maybe Camera)
 220                  } deriving (Show, Generic)
 221 $(deriveJSON (unPrefix "_") ''HyperdataGraph)
 222 instance ToSchema HyperdataGraph where
 223   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 224
 225 defaultHyperdataGraph :: HyperdataGraph
 226 defaultHyperdataGraph = HyperdataGraph Nothing Nothing
 227
 228
 229 instance Hyperdata HyperdataGraph
 230 makeLenses ''HyperdataGraph
 231
 232 instance FromField HyperdataGraph
 233   where
 234     fromField = fromField'
 235
 236 instance DefaultFromField SqlJsonb HyperdataGraph
 237   where
 238     defaultFromField = fromPGSFromField
 239
 240 -----------------------------------------------------------
 241 -- This type is used to return graph via API
 242 -- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
 243 data HyperdataGraphAPI =
 244   HyperdataGraphAPI { _hyperdataAPIGraph  :: Graph
 245                     , _hyperdataAPICamera :: !(Maybe Camera)
 246                     } deriving (Show, Generic)
 247 $(deriveJSON (unPrefix "_hyperdataAPI") ''HyperdataGraphAPI)
 248 instance ToSchema HyperdataGraphAPI where
 249   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hyperdataAPI")
 250
 251 makeLenses ''HyperdataGraphAPI
 252
 253 instance FromField HyperdataGraphAPI
 254   where
 255     fromField = fromField'
 256
 257 -----------------------------------------------------------
 258 graphV3ToGraph :: GraphV3 -> Graph
 259 graphV3ToGraph (GraphV3 links nodes) = Graph { _graph_nodes = map nodeV32node nodes
 260                                              , _graph_edges = zipWith linkV32edge [1..] links
 261                                              , _graph_metadata = Nothing }
 262   where
 263     nodeV32node :: NodeV3 -> Node
 264     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 265                 = Node { node_size = no_s'
 266                        , node_type = NgramsTerms
 267                        , node_id = cs $ show no_id'
 268                        , node_label = no_lb'
 269                        , node_x_coord = 0
 270                        , node_y_coord = 0
 271                        , node_attributes = Attributes cl'
 272                        , node_children = []
 273                        }
 274
 275     linkV32edge :: Int -> EdgeV3 -> Edge
 276     linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') =
 277       Edge { edge_source = cs $ show eo_s'
 278            , edge_target = cs $ show eo_t'
 279            , edge_weight = (Text.read $ Text.unpack eo_w') :: Double
 280            , edge_confluence = 0.5
 281            , edge_id = cs $ show n }
 282
 283
 284 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 285 graphV3ToGraphWithFiles g1 g2 = do
 286   -- GraphV3 <- IO Fichier
 287   graph <- DBL.readFile g1
 288   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 289         Nothing -> panic (Text.pack "no graph")
 290         Just new -> new
 291
 292   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 293
 294 readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
 295 readGraphFromJson fp = do
 296   graph <- liftBase $ DBL.readFile fp
 297   pure $ DA.decode graph
 298
 299
 300 -----------------------------------------------------------
 301 mergeGraphNgrams :: Graph -> Maybe (HashMap NgramsTerm NgramsRepoElement) -> Graph
 302 mergeGraphNgrams g Nothing = g
 303 mergeGraphNgrams graph@(Graph { _graph_nodes }) (Just listNgrams) = set graph_nodes newNodes graph
 304   where
 305     newNodes = insertChildren <$> _graph_nodes
 306     insertChildren (Node { node_label, .. }) = Node { node_children = children', .. }
 307       where
 308         -- lookup (NgramsTerm node_label) in listNgrams, then fetch (NgramsRepoElement _nre_children)
 309         children' = case (lookup (NgramsTerm node_label) listNgrams) of
 310           Nothing  -> []
 311           Just (NgramsRepoElement { _nre_children }) -> unNgramsTerm <$> mSetToList _nre_children