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.Text (pack)
  21 import GHC.IO (FilePath)
  22
  23 import qualified Data.Aeson as DA
  24 import qualified Data.Text as T
  25 import qualified Text.Read as T
  26
  27 import Gargantext.API.Ngrams.Types (NgramsTerm(..), NgramsRepoElement(..), mSetToList)
  28 import Gargantext.Core.Methods.Distances (GraphMetric)
  29 import Gargantext.Core.Types (ListId)
  30 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
  31 import Gargantext.Database.Admin.Types.Node (NodeId)
  32 import Gargantext.Prelude
  33
  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  :: 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 type Version = Int
  89 data ListForGraph =
  90   ListForGraph { _lfg_listId  :: ListId
  91                , _lfg_version :: Version
  92                } deriving (Show, Generic)
  93 $(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
  94
  95 instance ToSchema ListForGraph where
  96   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
  97
  98 makeLenses ''ListForGraph
  99
 100 data Strength = Strong | Weak
 101     deriving (Generic, Eq, Ord, Enum, Bounded, Show)
 102
 103 $(deriveJSON (unPrefix "") ''Strength)
 104 instance ToSchema Strength where
 105   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "")
 106
 107 instance Arbitrary Strength where
 108   arbitrary = elements $ [Strong, Weak]
 109
 110
 111
 112 data GraphMetadata =
 113   GraphMetadata { _gm_title            :: Text          -- title of the graph
 114                 , _gm_metric           :: GraphMetric
 115                 , _gm_edgesStrength    :: Maybe Strength
 116                 , _gm_corpusId         :: [NodeId]      -- we can map with different corpus
 117                 , _gm_legend           :: [LegendField] -- legend of the Graph
 118                 , _gm_list             :: ListForGraph
 119                 , _gm_startForceAtlas  :: Bool
 120                 -- , _gm_version       :: Int
 121                 }
 122   deriving (Show, Generic)
 123 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
 124 instance ToSchema GraphMetadata where
 125   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
 126 makeLenses ''GraphMetadata
 127
 128
 129
 130 data Graph = Graph { _graph_nodes    :: [Node]
 131                    , _graph_edges    :: [Edge]
 132                    , _graph_metadata :: Maybe GraphMetadata
 133                    }
 134   deriving (Show, Generic)
 135 $(deriveJSON (unPrefix "_graph_") ''Graph)
 136 makeLenses ''Graph
 137
 138 instance ToSchema Graph where
 139   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
 140
 141 -- | Intances for the mock
 142 instance Arbitrary Graph where
 143   arbitrary = elements $ [defaultGraph]
 144
 145 defaultGraph :: Graph
 146 defaultGraph = Graph {_graph_nodes = [Node {node_x_coord=0, node_y_coord=0, node_size = 4, node_type = Terms, 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 = Terms, 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 = Terms, 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 = Terms, 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 = Terms, 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 = Terms, 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 = Terms, 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 = Terms, 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 = Terms, 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}
 147
 148
 149 -----------------------------------------------------------
 150 -- V3 Gargantext Version
 151
 152 data AttributesV3 = AttributesV3 { cl :: Int }
 153   deriving (Show, Generic)
 154 $(deriveJSON (unPrefix "") ''AttributesV3)
 155
 156 data NodeV3 = NodeV3 { no_id :: Int
 157                      , no_at :: AttributesV3
 158                      , no_s  :: Int
 159                      , no_lb :: Text
 160                      }
 161   deriving (Show, Generic)
 162 $(deriveJSON (unPrefix "no_") ''NodeV3)
 163
 164 data EdgeV3 = EdgeV3 { eo_s :: Int
 165                      , eo_t :: Int
 166                      , eo_w :: Text
 167                      }
 168   deriving (Show, Generic)
 169 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
 170
 171 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
 172                        , go_nodes :: [NodeV3]
 173                        }
 174   deriving (Show, Generic)
 175 $(deriveJSON (unPrefix "go_") ''GraphV3)
 176
 177 -----------------------------------------------------------
 178 data Camera = Camera { _camera_ratio :: Double
 179                      , _camera_x     :: Double
 180                      , _camera_y     :: Double }
 181   deriving (Show, Generic)
 182 $(deriveJSON (unPrefix "_camera_") ''Camera)
 183 makeLenses ''Camera
 184
 185 instance ToSchema Camera where
 186   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_camera_")
 187
 188 -----------------------------------------------------------
 189 data HyperdataGraph =
 190   HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
 191                  , _hyperdataCamera :: !(Maybe Camera)
 192                  } deriving (Show, Generic)
 193 $(deriveJSON (unPrefix "_") ''HyperdataGraph)
 194 instance ToSchema HyperdataGraph where
 195   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 196
 197 defaultHyperdataGraph :: HyperdataGraph
 198 defaultHyperdataGraph = HyperdataGraph Nothing Nothing
 199
 200
 201 instance Hyperdata HyperdataGraph
 202 makeLenses ''HyperdataGraph
 203
 204 instance FromField HyperdataGraph
 205   where
 206     fromField = fromField'
 207
 208 instance DefaultFromField SqlJsonb HyperdataGraph
 209   where
 210     defaultFromField = fromPGSFromField
 211
 212 -----------------------------------------------------------
 213 -- This type is used to return graph via API
 214 -- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
 215 data HyperdataGraphAPI =
 216   HyperdataGraphAPI { _hyperdataAPIGraph  :: Graph
 217                     , _hyperdataAPICamera :: !(Maybe Camera)
 218                     } deriving (Show, Generic)
 219 $(deriveJSON (unPrefix "_hyperdataAPI") ''HyperdataGraphAPI)
 220 instance ToSchema HyperdataGraphAPI where
 221   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hyperdataAPI")
 222
 223 makeLenses ''HyperdataGraphAPI
 224
 225 instance FromField HyperdataGraphAPI
 226   where
 227     fromField = fromField'
 228
 229 -----------------------------------------------------------
 230 graphV3ToGraph :: GraphV3 -> Graph
 231 graphV3ToGraph (GraphV3 links nodes) = Graph { _graph_nodes = map nodeV32node nodes
 232                                              , _graph_edges = zipWith linkV32edge [1..] links
 233                                              , _graph_metadata = Nothing }
 234   where
 235     nodeV32node :: NodeV3 -> Node
 236     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 237                 = Node { node_size = no_s'
 238                        , node_type = Terms
 239                        , node_id = cs $ show no_id'
 240                        , node_label = no_lb'
 241                        , node_x_coord = 0
 242                        , node_y_coord = 0
 243                        , node_attributes = Attributes cl'
 244                        , node_children = []
 245                        }
 246
 247     linkV32edge :: Int -> EdgeV3 -> Edge
 248     linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') =
 249       Edge { edge_source = cs $ show eo_s'
 250            , edge_target = cs $ show eo_t'
 251            , edge_weight = (T.read $ T.unpack eo_w') :: Double
 252            , edge_confluence = 0.5
 253            , edge_id = cs $ show n }
 254
 255
 256 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 257 graphV3ToGraphWithFiles g1 g2 = do
 258   -- GraphV3 <- IO Fichier
 259   graph <- DBL.readFile g1
 260   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 261         Nothing -> panic (T.pack "no graph")
 262         Just new -> new
 263
 264   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 265
 266 readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
 267 readGraphFromJson fp = do
 268   graph <- liftBase $ DBL.readFile fp
 269   pure $ DA.decode graph
 270
 271
 272 -----------------------------------------------------------
 273 mergeGraphNgrams :: Graph -> Maybe (HashMap NgramsTerm NgramsRepoElement) -> Graph
 274 mergeGraphNgrams g Nothing = g
 275 mergeGraphNgrams graph@(Graph { _graph_nodes }) (Just listNgrams) = set graph_nodes newNodes graph
 276   where
 277     newNodes = insertChildren <$> _graph_nodes
 278     insertChildren (Node { node_label, .. }) = Node { node_children = children', .. }
 279       where
 280         -- lookup (NgramsTerm node_label) in listNgrams, then fetch (NgramsRepoElement _nre_children)
 281         children' = case (lookup (NgramsTerm node_label) listNgrams) of
 282           Nothing  -> []
 283           Just (NgramsRepoElement { _nre_children }) -> unNgramsTerm <$> mSetToList _nre_children