src/Gargantext/Viz/Graph.hs

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