Skip to content

H
haskell-gargantext
Commit 0df9416b authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[GRAPH] API update (WIP).

parent 7f6848cd
Hide whitespace changes
Inline Side-by-side
Showing with 52 additions and 30 deletions
src/Gargantext/API/Ngrams.hs
View file @ 0df9416b
......@@ -83,6 +83,10 @@ module Gargantext.API.Ngrams
, getNgramsTableMap
, tableNgramsPull
, tableNgramsPut
, Versioned(..)
, currentVersion
, listNgramsChangedSince
)
where
......
src/Gargantext/Database/Schema/Node.hs
View file @ 0df9416b
......@@ -44,6 +44,7 @@ import Gargantext.Database.Queries.Filter (limit', offset')
import Gargantext.Database.Types.Node (NodeType(..), defaultCorpus, Hyperdata, HyperData(..))
import Gargantext.Database.Utils
import Gargantext.Prelude hiding (sum, head)
import Gargantext.Viz.Graph (HyperdataGraph(..))
import Opaleye hiding (FromField)
import Opaleye.Internal.QueryArr (Query)
......@@ -218,11 +219,11 @@ nodeTable :: Table NodeWrite NodeRead
nodeTable = Table "nodes" (pNode Node { _node_id = optional "id"
, _node_typename = required "typename"
, _node_userId = required "user_id"
, _node_parentId = optional "parent_id"
, _node_name = required "name"
, _node_date = optional "date"
, _node_hyperdata = required "hyperdata"
}
)
......@@ -266,21 +267,19 @@ type NodeSearchReadNull =
(Column (Nullable PGJsonb) )
(Column (Nullable PGTSVector) )
--{-
nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
nodeTableSearch = Table "nodes" (pNodeSearch NodeSearch { _ns_id = optional "id"
, _ns_typename = required "typename"
, _ns_userId = required "user_id"
, _ns_parentId = required "parent_id"
, _ns_name = required "name"
, _ns_date = optional "date"
, _ns_hyperdata = required "hyperdata"
, _ns_search = optional "search"
}
)
--}
queryNodeSearchTable :: Query NodeSearchRead
queryNodeSearchTable = queryTable nodeTableSearch
......@@ -434,7 +433,6 @@ nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Jus
name = maybe "Annuaire" identity maybeName
annuaire = maybe defaultAnnuaire identity maybeAnnuaire
------------------------------------------------------------------------
{-
......@@ -498,7 +496,7 @@ nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just
------------------------------------------------------------------------
arbitraryGraph :: HyperdataGraph
arbitraryGraph = HyperdataGraph (Just "Preferences")
arbitraryGraph = HyperdataGraph Nothing
nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
......@@ -518,10 +516,8 @@ nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
------------------------------------------------------------------------
arbitraryDashboard :: HyperdataDashboard
arbitraryDashboard = HyperdataDashboard (Just "Preferences")
------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
......
src/Gargantext/Database/Types/Node.hs
View file @ 0df9416b
......@@ -62,13 +62,13 @@ import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Viz.Phylo (Phylo)
--import Gargantext.Database.Utils
------------------------------------------------------------------------
newtype NodeId = NodeId Int
deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON)
instance ToField NodeId where
toField (NodeId n) = toField n
instance FromField NodeId where
fromField field mdata = do
n <- fromField field mdata
......@@ -78,6 +78,7 @@ instance FromField NodeId where
instance ToSchema NodeId
type NodeTypeId = Int
type NodeName = Text
type TSVector = Text
......@@ -87,13 +88,13 @@ data NodePoly id typename userId
parentId name date
hyperdata = Node { _node_id :: id
, _node_typename :: typename
, _node_userId :: userId
, _node_parentId :: parentId
, _node_name :: name
, _node_date :: date
, _node_hyperdata :: hyperdata
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_node_") ''NodePoly)
......@@ -103,7 +104,6 @@ $(makeLenses ''NodePoly)
type Node json = NodePoly NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
------------------------------------------------------------------------
......@@ -401,13 +401,6 @@ $(deriveJSON (unPrefix "hyperdataDashboard_") ''HyperdataDashboard)
instance Hyperdata HyperdataDashboard
-- TODO add the Graph Structure here
data HyperdataGraph = HyperdataGraph { hyperdataGraph_preferences :: !(Maybe Text)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataGraph_") ''HyperdataGraph)
instance Hyperdata HyperdataGraph
------------------------------------------------------------------------
-- TODO add the Graph Structure here
......
src/Gargantext/Viz/Graph.hs
View file @ 0df9416b
......@@ -9,6 +9,7 @@ Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
......@@ -26,7 +27,7 @@ import GHC.Generics (Generic)
import GHC.IO (FilePath)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Core.Types (ListId)
import Gargantext.Database.Types.Node (NodeId)
import Gargantext.Database.Types.Node (NodeId, Hyperdata)
import Gargantext.Prelude
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......@@ -87,6 +88,7 @@ data GraphMetadata = GraphMetadata { _gm_title :: Text -- title of the grap
, _gm_corpusId :: [NodeId] -- we can map with different corpus
, _gm_legend :: [LegendField] -- legend of the Graph
, _gm_listId :: ListId
, _gm_version :: Int
}
deriving (Show, Generic)
$(deriveJSON (unPrefix "_gm_") ''GraphMetadata)
......@@ -143,6 +145,15 @@ data GraphV3 = GraphV3 { go_links :: [EdgeV3]
$(deriveJSON (unPrefix "go_") ''GraphV3)
-----------------------------------------------------------
data HyperdataGraph = HyperdataGraph { _hyperdataGraph :: !(Maybe Graph)
} deriving (Show, Generic)
$(deriveJSON (unPrefix "") ''HyperdataGraph)
instance Hyperdata HyperdataGraph
makeLenses ''HyperdataGraph
-----------------------------------------------------------
graphV3ToGraph :: GraphV3 -> Graph
......
src/Gargantext/Viz/Graph/API.hs
View file @ 0df9416b
......@@ -24,8 +24,9 @@ Portability : POSIX
module Gargantext.Viz.Graph.API
where
import Control.Lens (set)
import Control.Lens -- (set, (^.), (_Just), (^?))
import Control.Monad.IO.Class (liftIO)
import Gargantext.API.Ngrams (currentVersion, listNgramsChangedSince, Versioned(..))
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Types
import Gargantext.Core.Types.Main
......@@ -61,30 +62,47 @@ graphAPI n = getGraph n
getGraph :: NodeId -> GargServer (Get '[JSON] Graph)
getGraph nId = do
nodeGraph <- getNode nId HyperdataGraph
-- get HyperdataGraphp from Database
-- if Nothing else if version == current version then compute
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let graphVersion = graph ^? _Just
. graph_metadata
. _Just
. gm_version
let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
v <- currentVersion
let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
identity
$ nodeGraph ^. node_parentId
case graph of
Nothing -> computeGraph 0 nId NgramsTerms v
Just graph' -> if graphVersion == Just v
then pure graph'
else computeGraph 0 nId NgramsTerms v
computeGraph cId nId nt v = do
lId <- defaultList cId
let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
let metadata = GraphMetadata "Title" [cId]
[ LegendField 1 "#FFF" "Cluster"
, LegendField 2 "#FFF" "Cluster"
]
lId
v
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
lIds <- selectNodesWithUsername NodeList userMaster
ngs <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] NgramsTerms
ngs <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] nt
myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False)
<$> groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) NgramsTerms (Map.keys ngs)
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
graph <- liftIO $ cooc2graph 0 myCooc
pure $ set graph_metadata (Just metadata) graph
postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
postGraph = undefined
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment