Skip to content

H
haskell-gargantext
Commit 5c9f1e5a authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

Merge branch 'dev' into dev-api-node-count

parents 4097d4fe ecc9c601
Hide whitespace changes
Inline Side-by-side
Showing with 162 additions and 72 deletions
src/Gargantext/API.hs
View file @ 5c9f1e5a
......@@ -351,7 +351,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
:<|> withAccess (Proxy :: Proxy TableNgramsApi) Proxy uid <$> PathNode <*> apiNgramsTableDoc
:<|> count -- TODO: undefined
:<|> withAccess (Proxy :: Proxy SearchPairsAPI) Proxy uid <$> PathNode <*> searchPairs -- TODO: move elsewhere
:<|> withAccess (Proxy :: Proxy GraphAPI) Proxy uid <$> PathNode <*> graphAPI -- TODO: mock
:<|> withAccess (Proxy :: Proxy GraphAPI) Proxy uid <$> PathNode <*> graphAPI uid -- TODO: mock
:<|> withAccess (Proxy :: Proxy TreeAPI) Proxy uid <$> PathNode <*> treeAPI
:<|> addToCorpus
:<|> New.api -- TODO-SECURITY
......
src/Gargantext/API/Ngrams.hs
View file @ 5c9f1e5a
......@@ -83,6 +83,10 @@ module Gargantext.API.Ngrams
, getNgramsTableMap
, tableNgramsPull
, tableNgramsPut
, Versioned(..)
, currentVersion
, listNgramsChangedSince
)
where
......@@ -1053,7 +1057,7 @@ getTableNgrams _nType nId tabType listId limit_ offset
% " map1=" % timeSpecs
% " map2=" % timeSpecs
% " map3=" % timeSpecs
% " sql=" % if nSco then "map2" else "map3"
% " sql=" % (if nSco then "map2" else "map3")
% "\n"
) t0 t3 t0 t1 t1 t2 t2 t3
pure tableMap3
......
src/Gargantext/API/Node.hs
View file @ 5c9f1e5a
......@@ -143,7 +143,7 @@ type NodeAPI a = Get '[JSON] (Node a)
:<|> "pie" :> PieApi
:<|> "tree" :> TreeApi
:<|> "phylo" :> PhyloAPI
:<|> "upload" :> UploadAPI
:<|> "add" :> NodeAddAPI
-- TODO-ACCESS: check userId CanRenameNode nodeId
-- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
......@@ -201,7 +201,8 @@ nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode i
:<|> getPie id
:<|> getTree id
:<|> phyloAPI id uId
:<|> postUpload id
:<|> nodeAddAPI id
-- :<|> postUpload id
deleteNodeApi id' = do
node <- getNode' id'
......@@ -377,6 +378,12 @@ instance (ToParamSchema a, HasSwagger sub) =>
& in_ .~ ParamFormData
& paramSchema .~ toParamSchema (Proxy :: Proxy a)
type NodeAddAPI = "file" :> Summary "Node add API"
:> UploadAPI
nodeAddAPI :: NodeId -> GargServer NodeAddAPI
nodeAddAPI id = postUpload id
type UploadAPI = Summary "Upload file(s) to a corpus"
:> MultipartForm Mem (MultipartData Mem)
:> QueryParam "fileType" FileType
......
src/Gargantext/Database/Node/UpdateOpaleye.hs 0 → 100644
View file @ 5c9f1e5a
{-|
Module : Gargantext.Database.Node.UpdateOpaleye
Description : Update Node in Database (Postgres)
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Node.UpdateOpaleye where
import Opaleye
import Data.Aeson (encode, ToJSON)
import Gargantext.Prelude
import Gargantext.Database.Schema.Node
import Gargantext.Database.Types.Node
import Gargantext.Database.Utils (Cmd, mkCmd)
updateHyperdata :: ToJSON a => NodeId -> a -> Cmd err Int64
updateHyperdata i h = mkCmd $ \c -> runUpdate_ c (updateHyperdataQuery i h)
updateHyperdataQuery :: ToJSON a => NodeId -> a -> Update Int64
updateHyperdataQuery i h = Update
{ uTable = nodeTable
, uUpdateWith = updateEasy (\ (Node _ni _nt _nu _np _nn _nd _h)
-> Node _ni _nt _nu _np _nn _nd h'
)
, uWhere = (\row -> _node_id row .== pgNodeId i )
, uReturning = rCount
}
where h' = (pgJSONB $ cs $ encode $ h)
src/Gargantext/Database/Schema/Node.hs
View file @ 5c9f1e5a
......@@ -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)
......@@ -506,6 +504,12 @@ nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
name = maybe "Graph" identity maybeName
graph = maybe arbitraryGraph identity maybeGraph
mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
insertGraph :: ParentId -> UserId -> HyperdataGraph -> Cmd err [GraphId]
insertGraph p u h = insertNodesR [nodeGraphW Nothing (Just h) p u]
------------------------------------------------------------------------
arbitraryPhylo :: HyperdataPhylo
arbitraryPhylo = HyperdataPhylo Nothing Nothing
......@@ -518,10 +522,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
......@@ -695,11 +697,6 @@ defaultList cId =
mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
mkNode nt p u = insertNodesR [nodeDefault nt p u]
mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
where
......
src/Gargantext/Database/Types/Node.hs
View file @ 5c9f1e5a
......@@ -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/Database/Utils.hs
View file @ 5c9f1e5a
......@@ -73,12 +73,13 @@ mkCmd k = do
conn <- view connection
liftIO $ k conn
runCmd :: (HasConnection env) => env
-> Cmd' env err a
runCmd :: (HasConnection env)
=> env -> Cmd' env err a
-> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
runOpaQuery :: Default FromFields fields haskells
=> Select fields -> Cmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runQuery c q
formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
......
src/Gargantext/Viz/Graph.hs
View file @ 5c9f1e5a
......@@ -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 @ 5c9f1e5a
......@@ -24,8 +24,10 @@ Portability : POSIX
module Gargantext.Viz.Graph.API
where
import Control.Lens (set)
import Control.Lens (set, (^.), _Just, (^?))
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (Maybe(..))
import Gargantext.API.Ngrams (currentVersion)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Types
import Gargantext.Core.Types.Main
......@@ -33,9 +35,9 @@ import Gargantext.Database.Config
import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Node.Select
import Gargantext.Database.Schema.Node (getNode)
import Gargantext.Database.Schema.Node (defaultList)
import Gargantext.Database.Schema.Node (getNode, defaultList, insertGraph)
import Gargantext.Database.Types.Node hiding (node_id) -- (GraphId, ListId, CorpusId, NodeId)
import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Prelude
import Gargantext.Viz.Graph
import Gargantext.Viz.Graph.Tools -- (cooc2graph)
......@@ -51,38 +53,68 @@ type GraphAPI = Get '[JSON] Graph
:<|> Put '[JSON] Int
graphAPI :: NodeId -> GargServer GraphAPI
graphAPI n = getGraph n
graphAPI :: UserId -> NodeId -> GargServer GraphAPI
graphAPI u n = getGraph u n
:<|> postGraph n
:<|> putGraph n
------------------------------------------------------------------------
getGraph :: NodeId -> GargServer (Get '[JSON] Graph)
getGraph nId = do
getGraph :: UserId -> NodeId -> GargServer (Get '[JSON] Graph)
getGraph uId nId = do
nodeGraph <- getNode nId HyperdataGraph
-- get HyperdataGraphp from Database
-- if Nothing else if version == current version then compute
let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
let graph = nodeGraph ^. node_hyperdata . hyperdataGraph
let graphVersion = graph ^? _Just
. graph_metadata
. _Just
. gm_version
v <- currentVersion
nodeUser <- getNode (NodeId uId) HyperdataUser
let uId' = nodeUser ^. node_userId
let cId = maybe (panic "[ERR:G.V.G.API] Node has no parent")
identity
$ nodeGraph ^. node_parentId
case graph of
Nothing -> do
graph' <- computeGraph cId NgramsTerms v
_ <- insertGraph cId uId' (HyperdataGraph $ Just graph')
pure graph'
Just graph' -> if graphVersion == Just v
then pure graph'
else do
graph'' <- computeGraph cId NgramsTerms v
_ <- updateHyperdata nId (HyperdataGraph $ Just graph'')
pure graph''
-- TODO use Database Monad only here ?
computeGraph :: CorpusId -> NgramsType -> Int -> GargServer (Get '[JSON] Graph)
computeGraph cId 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)
myCooc <- Map.filter (>1)
<$> getCoocByNgrams (Diagonal True)
<$> groupNodesByNgrams ngs
<$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)
graph <- liftIO $ cooc2graph 0 myCooc
pure $ set graph_metadata (Just metadata) graph
let graph' = set graph_metadata (Just metadata) graph
pure graph'
postGraph :: NodeId -> GargServer (Post '[JSON] [NodeId])
......@@ -91,8 +123,3 @@ postGraph = undefined
putGraph :: NodeId -> GargServer (Put '[JSON] Int)
putGraph = undefined
-- | Instances
src/Gargantext/Viz/Graph/Tools.hs
View file @ 5c9f1e5a
......@@ -15,10 +15,10 @@ Portability : POSIX
module Gargantext.Viz.Graph.Tools
where
--import Debug.Trace (trace)
import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Text (Text)
import Gargantext.Prelude
import Gargantext.Core.Statistics
......@@ -35,15 +35,17 @@ import qualified Data.Vector.Storable as Vec
import qualified Data.Map as Map
import qualified Data.List as List
type Threshold = Int
type Threshold = Double
cooc2graph :: Threshold -> (Map (Text, Text) Int) -> IO Graph
cooc2graph :: Threshold
-> (Map (Text, Text) Int)
-> IO Graph
cooc2graph threshold myCooc = do
let (ti, _) = createIndices myCooc
myCooc' = toIndex ti myCooc
matCooc = map2mat (0) (Map.size ti) $ Map.filter (>threshold) myCooc'
matCooc = map2mat 0 (Map.size ti) $ Map.filter (> 1) myCooc'
distanceMat = measureConditional matCooc
distanceMap = Map.filter (>0.01) $ mat2map distanceMat
distanceMap = Map.filter (> threshold) $ mat2map distanceMat
partitions <- case Map.size distanceMap > 0 of
True -> cLouvain distanceMap
......@@ -57,11 +59,12 @@ cooc2graph threshold myCooc = do
----------------------------------------------------------
-- | From data to Graph
data2graph :: [(Text, Int)] -> Map (Int, Int) Int
-> Map (Int, Int) Double
-> Map (Int, Int) Double
-> [LouvainNode]
-> IO Graph
data2graph :: [(Text, Int)]
-> Map (Int, Int) Int
-> Map (Int, Int) Double
-> Map (Int, Int) Double
-> [LouvainNode]
-> IO Graph
data2graph labels coocs bridge conf partitions = do
let community_id_by_node_id = Map.fromList [ (n, c) | LouvainNode n c <- partitions ]
......@@ -74,18 +77,24 @@ data2graph labels coocs bridge conf partitions = do
, node_x_coord = 0
, node_y_coord = 0
, node_attributes =
Attributes { clust_default = maybe 0 identity
Attributes { clust_default = maybe 0 identity
(Map.lookup n community_id_by_node_id) } }
)
| (l, n) <- labels
, Set.member n $ Set.fromList
$ List.concat
$ map (\((s,t),d) -> if d > 0 && s /=t then [s,t] else [])
$ Map.toList bridge
]
let edges = [ Edge { edge_source = cs (show s)
, edge_target = cs (show t)
, edge_weight = d
, edge_confluence = maybe (panic "E: data2graph edges") identity $ Map.lookup (s,t) conf
, edge_target = cs (show t)
, edge_weight = d
, edge_confluence = maybe 0 identity $ Map.lookup (s,t) conf
-- , edge_confluence = maybe (panic "E: data2graph edges") identity $ Map.lookup (s,t) conf
, edge_id = cs (show i) }
| (i, ((s,t), d)) <- zip ([0..]::[Integer]) (Map.toList bridge) ]
| (i, ((s,t), d)) <- zip ([0..]::[Integer]) (Map.toList bridge), s /= t, d > 0
]
pure $ Graph nodes edges Nothing
......
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