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
  14 {-# LANGUAGE TemplateHaskell       #-}
  15
  16 module Gargantext.Core.Viz.Graph
  17   where
  18
  19 import Data.ByteString.Lazy as DBL (readFile, writeFile)
  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.Core.Types (ListId)
  28 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
  29 import Gargantext.Database.Admin.Types.Node (NodeId)
  30 import Gargantext.Core.Methods.Distances (GraphMetric)
  31 import Gargantext.Prelude
  32
  33
  34 data TypeNode = Terms | Unknown
  35   deriving (Show, Generic)
  36
  37 instance ToJSON TypeNode
  38 instance FromJSON TypeNode
  39 instance ToSchema TypeNode
  40
  41 data Attributes = Attributes { clust_default :: Int }
  42   deriving (Show, Generic)
  43 $(deriveJSON (unPrefix "") ''Attributes)
  44 instance ToSchema Attributes
  45
  46 data Node = Node { node_size  :: Int
  47                  , node_type  :: TypeNode -- TODO NgramsType | Person
  48                  , node_id    :: Text     -- TODO NgramId
  49                  , node_label :: Text
  50                  , node_x_coord :: Double
  51                  , node_y_coord :: Double
  52                  , node_attributes :: Attributes
  53                  }
  54   deriving (Show, Generic)
  55 $(deriveJSON (unPrefix "node_") ''Node)
  56 instance ToSchema Node where
  57   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
  58
  59
  60 data Edge = Edge { edge_source :: Text
  61                  , edge_target :: Text
  62                  , edge_weight :: Double
  63                  , edge_confluence :: Double
  64                  , edge_id     :: Text
  65                  }
  66   deriving (Show, Generic)
  67
  68 $(deriveJSON (unPrefix "edge_") ''Edge)
  69
  70 instance ToSchema Edge where
  71   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
  72
  73 ---------------------------------------------------------------
  74 data LegendField = LegendField { _lf_id :: Int
  75                                , _lf_color :: Text
  76                                , _lf_label :: Text
  77    } deriving (Show, Generic)
  78 $(deriveJSON (unPrefix "_lf_") ''LegendField)
  79
  80 instance ToSchema LegendField where
  81   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
  82
  83 makeLenses ''LegendField
  84 ---------------------------------------------------------------
  85 type Version = Int
  86 data ListForGraph =
  87   ListForGraph { _lfg_listId  :: ListId
  88                , _lfg_version :: Version
  89                } deriving (Show, Generic)
  90 $(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
  91
  92 instance ToSchema ListForGraph where
  93   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
  94
  95 makeLenses ''ListForGraph
  96
  97 --
  98 data GraphMetadata =
  99   GraphMetadata { _gm_title            :: Text          -- title of the graph
 100                 , _gm_metric           :: GraphMetric
 101                 , _gm_corpusId         :: [NodeId]      -- we can map with different corpus
 102                 , _gm_legend           :: [LegendField] -- legend of the Graph
 103                 , _gm_list             :: ListForGraph
 104                 , _gm_startForceAtlas  :: Bool
 105                 -- , _gm_version       :: Int
 106                 }
 107   deriving (Show, Generic)
 108 $(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
 109 instance ToSchema GraphMetadata where
 110   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gm_")
 111 makeLenses ''GraphMetadata
 112
 113
 114 data Graph = Graph { _graph_nodes    :: [Node]
 115                    , _graph_edges    :: [Edge]
 116                    , _graph_metadata :: Maybe GraphMetadata
 117                    }
 118   deriving (Show, Generic)
 119 $(deriveJSON (unPrefix "_graph_") ''Graph)
 120 makeLenses ''Graph
 121
 122 instance ToSchema Graph where
 123   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_graph_")
 124
 125 -- | Intances for the mock
 126 instance Arbitrary Graph where
 127   arbitrary = elements $ [defaultGraph]
 128
 129 defaultGraph :: Graph
 130 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 {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 {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 {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 {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 {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 {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 {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 {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}}], _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}
 131
 132
 133 -----------------------------------------------------------
 134 -- V3 Gargantext Version
 135
 136 data AttributesV3 = AttributesV3 { cl :: Int }
 137   deriving (Show, Generic)
 138 $(deriveJSON (unPrefix "") ''AttributesV3)
 139
 140 data NodeV3 = NodeV3 { no_id :: Int
 141                      , no_at :: AttributesV3
 142                      , no_s  :: Int
 143                      , no_lb :: Text
 144                      }
 145   deriving (Show, Generic)
 146 $(deriveJSON (unPrefix "no_") ''NodeV3)
 147
 148 data EdgeV3 = EdgeV3 { eo_s :: Int
 149                      , eo_t :: Int
 150                      , eo_w :: Text
 151                      }
 152   deriving (Show, Generic)
 153 $(deriveJSON (unPrefix "eo_") ''EdgeV3)
 154
 155 data GraphV3 = GraphV3 { go_links :: [EdgeV3]
 156                        , go_nodes :: [NodeV3]
 157                        }
 158   deriving (Show, Generic)
 159 $(deriveJSON (unPrefix "go_") ''GraphV3)
 160
 161 -----------------------------------------------------------
 162 data Camera = Camera { _camera_ratio :: Double
 163                      , _camera_x     :: Double
 164                      , _camera_y     :: Double }
 165   deriving (Show, Generic)
 166 $(deriveJSON (unPrefix "_camera_") ''Camera)
 167 makeLenses ''Camera
 168
 169 instance ToSchema Camera where
 170   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_camera_")
 171
 172 -----------------------------------------------------------
 173 data HyperdataGraph =
 174   HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
 175                  , _hyperdataCamera :: !(Maybe Camera)
 176                  } deriving (Show, Generic)
 177 $(deriveJSON (unPrefix "_") ''HyperdataGraph)
 178 instance ToSchema HyperdataGraph where
 179   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 180
 181 defaultHyperdataGraph :: HyperdataGraph
 182 defaultHyperdataGraph = HyperdataGraph Nothing Nothing
 183
 184
 185 instance Hyperdata HyperdataGraph
 186 makeLenses ''HyperdataGraph
 187
 188 instance FromField HyperdataGraph
 189   where
 190     fromField = fromField'
 191
 192 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 193   where
 194     queryRunnerColumnDefault = fieldQueryRunnerColumn
 195
 196 -----------------------------------------------------------
 197 -- This type is used to return graph via API
 198 -- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
 199 data HyperdataGraphAPI =
 200   HyperdataGraphAPI { _hyperdataAPIGraph  :: Graph
 201                     , _hyperdataAPICamera :: !(Maybe Camera)
 202                     } deriving (Show, Generic)
 203 $(deriveJSON (unPrefix "_hyperdataAPI") ''HyperdataGraphAPI)
 204 instance ToSchema HyperdataGraphAPI where
 205   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_hyperdataAPI")
 206
 207 makeLenses ''HyperdataGraphAPI
 208
 209 instance FromField HyperdataGraphAPI
 210   where
 211     fromField = fromField'
 212
 213 -----------------------------------------------------------
 214 graphV3ToGraph :: GraphV3 -> Graph
 215 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
 216   where
 217     nodeV32node :: NodeV3 -> Node
 218     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 219                 = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
 220
 221     linkV32edge :: Int -> EdgeV3 -> Edge
 222     linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') = Edge (cs $ show eo_s')
 223                                                     (cs $ show eo_t')
 224                                                     ((T.read $ T.unpack eo_w') :: Double)
 225                                                     0.5
 226                                                     (cs $ show n)
 227
 228
 229 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 230 graphV3ToGraphWithFiles g1 g2 = do
 231   -- GraphV3 <- IO Fichier
 232   graph <- DBL.readFile g1
 233   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 234         Nothing -> panic (T.pack "no graph")
 235         Just new -> new
 236
 237   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 238
 239 readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
 240 readGraphFromJson fp = do
 241   graph <- liftBase $ DBL.readFile fp
 242   pure $ DA.decode graph