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