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