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