Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
197
Issues
197
List
Board
Labels
Milestones
Merge Requests
12
Merge Requests
12
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
ae55f357
Commit
ae55f357
authored
Jul 19, 2019
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[LEARN] moreLike func and apply.
parent
c9a2ffdd
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
95 additions
and
10 deletions
+95
-10
Learn.hs
src/Gargantext/Database/Learn.hs
+67
-0
Learn.hs
src/Gargantext/Text/Learn.hs
+28
-10
No files found.
src/Gargantext/Database/Learn.hs
0 → 100644
View file @
ae55f357
{-|
Module : Gargantext.Database.Learn
Description : Learn Small Data Analytics with big data connection (DB)
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
module
Gargantext.Database.Learn
where
import
Data.Text
(
Text
)
import
Data.Tuple
(
snd
)
import
Data.Maybe
import
Gargantext.Database.Facet
import
Gargantext.Database.Types.Node
import
Gargantext.Prelude
import
Gargantext.Text.Learn
import
qualified
Data.List
as
List
import
qualified
Data.Text
as
Text
import
Gargantext.Database.Schema.NodeNode
(
nodesToFavorite
)
import
Gargantext.API.Node
(
delDocs
,
Documents
(
..
))
import
Gargantext.Database.Utils
(
Cmd
)
import
Gargantext.Database.Schema.Node
(
HasNodeError
)
text
::
FacetDoc
->
(
NodeId
,
Text
)
text
(
FacetDoc
nId
_
_
h
_
_
)
=
(
nId
,
title
<>
""
<>
Text
.
take
100
abstr
)
where
title
=
maybe
""
identity
(
_hyperdataDocument_title
h
)
abstr
=
maybe
""
identity
(
_hyperdataDocument_abstract
h
)
--moreLike docs_fav docs_trash docs_test = do
data
FavTrash
=
IsFav
|
IsTrash
deriving
(
Eq
)
--{-
moreLike
::
HasNodeError
err
=>
FavTrash
->
CorpusId
->
Cmd
err
[(
NodeId
,
Maybe
Bool
)]
moreLike
ft
cId
=
do
let
b
=
if
(
==
)
ft
IsFav
then
True
else
False
docs_trash
<-
map
text
<$>
runViewDocuments
cId
True
Nothing
Nothing
Nothing
docs_fav
<-
map
text
<$>
filter
(
\
(
FacetDoc
_
_
_
_
f
_
)
->
f
==
True
)
<$>
runViewDocuments
cId
False
Nothing
Nothing
Nothing
docs_test
<-
map
text
<$>
filter
(
\
(
FacetDoc
_
_
_
_
f
_
)
->
f
==
False
)
<$>
runViewDocuments
cId
False
Nothing
Nothing
Nothing
let
priors
=
priorEventsWith
snd
b
(
List
.
zip
(
repeat
False
)
docs_fav
<>
List
.
zip
(
repeat
True
)
docs_trash
)
pure
$
filter
((
==
)
(
Just
$
not
b
)
.
snd
)
$
map
(
\
x
->
(
fst
x
,
detectDefaultWithPriors
snd
priors
x
))
docs_test
learnModify
::
HasNodeError
err
=>
FavTrash
->
CorpusId
->
[
NodeId
]
->
Cmd
err
[
Int
]
learnModify
favTrash
cId
ns
=
case
favTrash
of
IsFav
->
nodesToFavorite
$
map
(
\
n
->
(
cId
,
n
,
True
))
ns
IsTrash
->
delDocs
cId
(
Documents
ns
)
learnAndApply
::
HasNodeError
err
=>
FavTrash
->
CorpusId
->
Cmd
err
[
Int
]
learnAndApply
ft
cId
=
do
ids
<-
map
fst
<$>
moreLike
ft
cId
learnModify
ft
cId
ids
--}
src/Gargantext/Text/Learn.hs
View file @
ae55f357
...
@@ -7,6 +7,9 @@ Maintainer : team@gargantext.org
...
@@ -7,6 +7,9 @@ Maintainer : team@gargantext.org
Stability : experimental
Stability : experimental
Portability : POSIX
Portability : POSIX
TODO:
- generalize to byteString
Stop words and (how to learn it).
Stop words and (how to learn it).
Main type here is String.
Main type here is String.
...
@@ -30,7 +33,7 @@ import Data.String (String)
...
@@ -30,7 +33,7 @@ import Data.String (String)
import
Data.Text
(
Text
)
import
Data.Text
(
Text
)
import
Data.Text
(
pack
,
unpack
,
toLower
)
import
Data.Text
(
pack
,
unpack
,
toLower
)
import
Data.Tuple.Extra
(
both
)
import
Data.Tuple.Extra
(
both
,
second
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Core
(
Lang
(
..
),
allLangs
)
import
Gargantext.Core
(
Lang
(
..
),
allLangs
)
...
@@ -60,6 +63,30 @@ type CatProb a = Map a Double
...
@@ -60,6 +63,30 @@ type CatProb a = Map a Double
type
Events
a
=
Map
a
EventBook
type
Events
a
=
Map
a
EventBook
------------------------------------------------------------------------
detectStopDefault
::
Text
->
Maybe
Bool
detectStopDefault
=
undefined
detectBool
::
[(
Bool
,
Text
)]
->
Text
->
Maybe
Bool
detectBool
events
=
detectDefault
False
events
detectDefault
::
Ord
a
=>
a
->
[(
a
,
Text
)]
->
Text
->
Maybe
a
detectDefault
=
detectDefaultWith
identity
detectDefaultWith
::
Ord
a
=>
(
b
->
Text
)
->
a
->
[(
a
,
b
)]
->
b
->
Maybe
a
detectDefaultWith
f
d
events
=
detectDefaultWithPriors
f
ps
where
ps
=
priorEventsWith
f
d
events
detectDefaultWithPriors
::
Ord
b
=>
(
a
->
Text
)
->
Events
b
->
a
->
Maybe
b
detectDefaultWithPriors
f
priors
=
detectCat
99
priors
.
f
priorEventsWith
::
Ord
a
=>
(
t
->
Text
)
->
a
->
[(
a
,
t
)]
->
Events
a
priorEventsWith
f
d
e
=
toEvents
d
[
0
..
2
]
10
es
where
es
=
map
(
\
(
a
,
b
)
->
CatWord
a
(
unpack
$
toLower
$
f
b
))
e
------------------------------------------------------------------------
------------------------------------------------------------------------
detectLangDefault
::
Text
->
Maybe
Lang
detectLangDefault
::
Text
->
Maybe
Lang
detectLangDefault
=
detectCat
99
eventLang
detectLangDefault
=
detectCat
99
eventLang
...
@@ -76,15 +103,6 @@ detectLangDefault = detectCat 99 eventLang
...
@@ -76,15 +103,6 @@ detectLangDefault = detectCat 99 eventLang
--textSample DE = DE.textSample
--textSample DE = DE.textSample
--textSample SP = SP.textSample
--textSample SP = SP.textSample
--textSample CH = CH.textSample
--textSample CH = CH.textSample
detectStopDefault
::
Text
->
Maybe
Bool
detectStopDefault
=
undefined
detectDefault
::
[(
Bool
,
Text
)]
->
Text
->
Maybe
Bool
detectDefault
events
=
detectCat
99
(
priorEvents
events
)
where
priorEvents
events'
=
toEvents
True
[
0
..
2
]
10
(
map
(
\
(
a
,
b
)
->
CatWord
a
(
unpack
$
toLower
b
))
events'
)
------------------------------------------------------------------------
------------------------------------------------------------------------
detectCat
::
Ord
a
=>
Int
->
Events
a
->
Text
->
Maybe
a
detectCat
::
Ord
a
=>
Int
->
Events
a
->
Text
->
Maybe
a
detectCat
n
es
=
head
.
map
fst
.
(
detectCat'
n
es
)
.
unpack
detectCat
n
es
=
head
.
map
fst
.
(
detectCat'
n
es
)
.
unpack
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment