ElEve: alternative split
[gargantext.git] / src / Gargantext / Viz / Graph.hs
index cb2d1e5033db6e5c19b6832432c670450a25662d..9e6f2813567bc35c54e9ee42af162fcfebeed5d4 100644 (file)
@@ -1,6 +1,6 @@
 {-|
 Module      : Gargantext.Viz.Graph
-Description : 
+Description : Graph utils
 Copyright   : (c) CNRS, 2017-Present
 License     : AGPL + CECILL v3
 Maintainer  : team@gargantext.org
@@ -16,48 +16,165 @@ Portability : POSIX
 module Gargantext.Viz.Graph
   where
 
-import GHC.Generics (Generic)
+import Control.Lens (makeLenses)
+import Control.Monad.IO.Class (MonadIO(liftIO))
 import Data.Aeson.TH (deriveJSON)
-import Data.Text (Text)
-import Data.Map (Map)
-
-import Gargantext.Prelude
+import Data.ByteString.Lazy as DBL (readFile, writeFile)
+import Data.Swagger
+import Data.Text (Text, pack)
+import GHC.Generics (Generic)
+import GHC.IO (FilePath)
 import Gargantext.Core.Utils.Prefix (unPrefix)
-
-import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode)
+import Gargantext.Database.Types.Node (NodeId)
+import Gargantext.Prelude
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Data.Aeson as DA
+import qualified Data.Text as T
+import qualified Text.Read as T
 
 
 data TypeNode = Terms | Unknown
   deriving (Show, Generic)
 
 $(deriveJSON (unPrefix "") ''TypeNode)
+instance ToSchema TypeNode
 
 data Attributes = Attributes { clust_default :: Int }
   deriving (Show, Generic)
 $(deriveJSON (unPrefix "") ''Attributes)
+instance ToSchema Attributes
 
-data Node = Node { n_size :: Int
-                 , n_type :: TypeNode
-                 , n_id   :: Text
-                 , n_label :: Text
-                 , n_attributes :: Attributes
+data Node = Node { node_size  :: Int
+                 , node_type  :: TypeNode -- TODO NgramsType | Person
+                 , node_id    :: Text     -- TODO NgramId
+                 , node_label :: Text
+                 , node_x_coord :: Double
+                 , node_y_coord :: Double
+                 , node_attributes :: Attributes
                  }
   deriving (Show, Generic)
-$(deriveJSON (unPrefix "n_") ''Node)
+$(deriveJSON (unPrefix "node_") ''Node)
+instance ToSchema Node where
+  declareNamedSchema =
+    genericDeclareNamedSchema
+      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
+
 
-data Edge = Edge { e_source :: Int
-                 , e_target :: Int
-                 , e_weight :: Double
-                 , e_id     :: Int
+data Edge = Edge { edge_source :: Text
+                 , edge_target :: Text
+                 , edge_weight :: Double
+                 , edge_id     :: Text
                  }
   deriving (Show, Generic)
-$(deriveJSON (unPrefix "e_") ''Edge)
+$(deriveJSON (unPrefix "edge_") ''Edge)
+instance ToSchema Edge where
+  declareNamedSchema =
+    genericDeclareNamedSchema
+      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 5 fieldLabel}
+
+---------------------------------------------------------------
+data LegendField = LegendField { _lf_id :: Int
+                               , _lf_color :: Text
+                               , _lf_label :: Text
+   } deriving (Show, Generic)
+$(deriveJSON (unPrefix "_lf_") ''LegendField)
+
+instance ToSchema LegendField where
+  declareNamedSchema =
+    genericDeclareNamedSchema
+      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
 
-data Graph = Graph { g_nodes :: [Node]
-                   , g_edges :: [Edge]
+makeLenses ''LegendField
+--
+data GraphMetadata = GraphMetadata { _gm_title    :: Text   -- title of the graph
+                                   , _gm_corpusId :: [NodeId]  -- we can map with different corpus
+                                   , _gm_legend :: [LegendField] -- legend of the Graph
+                                   }
+  deriving (Show, Generic)
+$(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
+instance ToSchema GraphMetadata where
+  declareNamedSchema =
+    genericDeclareNamedSchema
+      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 4 fieldLabel}
+makeLenses ''GraphMetadata
+
+
+data Graph = Graph { _graph_nodes :: [Node]
+                   , _graph_edges :: [Edge]
+                   , _graph_metadata :: Maybe GraphMetadata
                    }
   deriving (Show, Generic)
-$(deriveJSON (unPrefix "g_") ''Graph)
+$(deriveJSON (unPrefix "_graph_") ''Graph)
+makeLenses ''Graph
+
+instance ToSchema Graph where
+  declareNamedSchema =
+    genericDeclareNamedSchema
+      defaultSchemaOptions {fieldLabelModifier = \fieldLabel -> drop 7 fieldLabel}
+
+
+-- | Intances for the mack
+instance Arbitrary Graph where
+  arbitrary = elements $ [defaultGraph]
+
+defaultGraph :: Graph
+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_id = pack "0"},Edge {edge_source = pack "1", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "1"},Edge {edge_source = pack "1", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "2"},Edge {edge_source = pack "2", edge_target = pack "2", edge_weight = 1.0, edge_id = pack "3"},Edge {edge_source = pack "2", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "4"},Edge {edge_source = pack "3", edge_target = pack "0", edge_weight = 1.0, edge_id = pack "5"},Edge {edge_source = pack "3", edge_target = pack "1", edge_weight = 1.0, edge_id = pack "6"},Edge {edge_source = pack "3", edge_target = pack "3", edge_weight = 1.0, edge_id = pack "7"},Edge {edge_source = pack "4", edge_target = pack "4", edge_weight = 1.0, edge_id = pack "8"},Edge {edge_source = pack "4", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "9"},Edge {edge_source = pack "5", edge_target = pack "5", edge_weight = 1.0, edge_id = pack "10"},Edge {edge_source = pack "6", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "11"},Edge {edge_source = pack "7", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "12"},Edge {edge_source = pack "7", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "13"},Edge {edge_source = pack "8", edge_target = pack "6", edge_weight = 1.0, edge_id = pack "14"},Edge {edge_source = pack "8", edge_target = pack "7", edge_weight = 1.0, edge_id = pack "15"},Edge {edge_source = pack "8", edge_target = pack "8", edge_weight = 1.0, edge_id = pack "16"}], _graph_metadata = Nothing}
+
+
+-----------------------------------------------------------
+-- V3 Gargantext Version
+
+data AttributesV3 = AttributesV3 { cl :: Int }
+  deriving (Show, Generic)
+$(deriveJSON (unPrefix "") ''AttributesV3)
+
+data NodeV3 = NodeV3 { no_id :: Int
+                     , no_at :: AttributesV3
+                     , no_s  :: Int
+                     , no_lb :: Text
+                     }
+  deriving (Show, Generic)
+$(deriveJSON (unPrefix "no_") ''NodeV3)
+
+data EdgeV3 = EdgeV3 { eo_s :: Int
+                     , eo_t :: Int
+                     , eo_w :: Text
+                     }
+  deriving (Show, Generic)
+$(deriveJSON (unPrefix "eo_") ''EdgeV3)
+
+data GraphV3 = GraphV3 { go_links :: [EdgeV3]
+                       , go_nodes :: [NodeV3]
+                       }
+  deriving (Show, Generic)
+$(deriveJSON (unPrefix "go_") ''GraphV3)
+
 -----------------------------------------------------------
+-----------------------------------------------------------
+
+graphV3ToGraph :: GraphV3 -> Graph
+graphV3ToGraph (GraphV3 links nodes) = Graph (map nodeV32node nodes) (zipWith linkV32edge [1..] links) Nothing
+  where
+    nodeV32node :: NodeV3 -> Node
+    nodeV32node (NodeV3 no_id' (AttributesV3 cl') no_s' no_lb')
+                = Node no_s' Terms (cs $ show no_id') no_lb' 0 0 (Attributes cl')
+
+    linkV32edge :: Int -> EdgeV3 -> Edge
+    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) (cs $ show n)
+
+
+graphV3ToGraphWithFiles :: FilePath -> FilePath -> IO ()
+graphV3ToGraphWithFiles g1 g2 = do
+  -- GraphV3 <- IO Fichier
+  graph <- DBL.readFile g1
+  let newGraph = case DA.decode graph :: Maybe GraphV3 of
+        Nothing -> panic (T.pack "no graph")
+        Just new -> new
 
+  DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
 
+readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
+readGraphFromJson fp = do
+  graph <- liftIO $ DBL.readFile fp
+  pure $ DA.decode graph