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