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 import Gargantext.Core.Types (ListId)
  24 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
  25 import Gargantext.Database.Admin.Types.Node (NodeId)
  26 import Gargantext.Core.Viz.Graph.Distances (GraphMetric)
  27 import Gargantext.Prelude
  28 import Test.QuickCheck (elements)
  29 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  30 import qualified Data.Aeson as DA
  31 import qualified Data.Text as T
  32 import qualified Text.Read as T
  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                  }
  55   deriving (Show, Generic)
  56 $(deriveJSON (unPrefix "node_") ''Node)
  57 instance ToSchema Node where
  58   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "node_")
  59
  60
  61 data Edge = Edge { edge_source :: Text
  62                  , edge_target :: Text
  63                  , edge_weight :: Double
  64                  , edge_confluence :: Double
  65                  , edge_id     :: Text
  66                  }
  67   deriving (Show, Generic)
  68
  69 $(deriveJSON (unPrefix "edge_") ''Edge)
  70
  71 instance ToSchema Edge where
  72   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "edge_")
  73
  74 ---------------------------------------------------------------
  75 data LegendField = LegendField { _lf_id :: Int
  76                                , _lf_color :: Text
  77                                , _lf_label :: Text
  78    } deriving (Show, Generic)
  79 $(deriveJSON (unPrefix "_lf_") ''LegendField)
  80
  81 instance ToSchema LegendField where
  82   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lf_")
  83
  84 makeLenses ''LegendField
  85 ---------------------------------------------------------------
  86 type Version = Int
  87 data ListForGraph =
  88   ListForGraph { _lfg_listId  :: ListId
  89                , _lfg_version :: Version
  90                } deriving (Show, Generic)
  91 $(deriveJSON (unPrefix "_lfg_") ''ListForGraph)
  92
  93 instance ToSchema ListForGraph where
  94   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_lfg_")
  95
  96 makeLenses ''ListForGraph
  97
  98 --
  99 data GraphMetadata =
 100   GraphMetadata { _gm_title    :: Text          -- title of the graph
 101                 , _gm_metric   :: GraphMetric
 102                 , _gm_corpusId :: [NodeId]      -- we can map with different corpus
 103                 , _gm_legend   :: [LegendField] -- legend of the Graph
 104                 , _gm_list     :: ListForGraph
 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 mack
 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 -----------------------------------------------------------
 163 data HyperdataGraph =
 164   HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
 165                  } deriving (Show, Generic)
 166 $(deriveJSON (unPrefix "") ''HyperdataGraph)
 167
 168 defaultHyperdataGraph :: HyperdataGraph
 169 defaultHyperdataGraph = HyperdataGraph Nothing
 170
 171
 172 instance Hyperdata HyperdataGraph
 173 makeLenses ''HyperdataGraph
 174
 175 instance FromField HyperdataGraph
 176   where
 177     fromField = fromField'
 178
 179 instance QueryRunnerColumnDefault PGJsonb HyperdataGraph
 180   where
 181     queryRunnerColumnDefault = fieldQueryRunnerColumn
 182
 183 -----------------------------------------------------------
 184 graphV3ToGraph :: GraphV3 -> Graph
 185 graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
 186   where
 187     nodeV32node :: NodeV3 -> Node
 188     nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
 189                 = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
 190
 191     linkV32edge :: Int -> EdgeV3 -> Edge
 192     linkV32edge n (EdgeV3 eo_s' eo_t' eo_w') = Edge (cs $ show eo_s')
 193                                                     (cs $ show eo_t')
 194                                                     ((T.read $ T.unpack eo_w') :: Double)
 195                                                     0.5
 196                                                     (cs $ show n)
 197
 198
 199 graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
 200 graphV3ToGraphWithFiles g1 g2 = do
 201   -- GraphV3 <- IO Fichier
 202   graph <- DBL.readFile g1
 203   let newGraph = case DA.decode graph :: Maybe GraphV3 of
 204         Nothing -> panic (T.pack "no graph")
 205         Just new -> new
 206
 207   DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 208
 209 readGraphFromJson :: MonadBase IO m => FilePath -> m (Maybe Graph)
 210 readGraphFromJson fp = do
 211   graph <- liftBase $ DBL.readFile fp
 212   pure $ DA.decode graph