feat(stopwords): removeWords and removeStopwords functions as pre-processors

feat(confidence, WIP): calculate confidence of each classification
This commit is contained in:
Mahdi Dibaiee 2016-08-08 10:02:26 +04:30
parent ea1f05f001
commit 099c25e166
3 changed files with 742 additions and 52 deletions

View File

@ -14,26 +14,20 @@ module Main
test <- readFile "examples/doc-classifier-data/data-reuters-test" test <- readFile "examples/doc-classifier-data/data-reuters-test"
classes <- map (filter (/= ' ')) . lines <$> readFile "examples/doc-classifier-data/data-classes" classes <- map (filter (/= ' ')) . lines <$> readFile "examples/doc-classifier-data/data-classes"
sws <- lines <$> readFile "examples/stopwords"
let intClasses = [0..length classes - 1] let intClasses = [0..length classes - 1]
-- let intClasses = [0, 1] documents = cleanDocuments $ removeWords sws $ createDocuments classes dataset
documents = cleanDocuments $ createDocuments classes dataset
-- documents = [Document "Chinese Beijing Chinese" 0,
-- Document "Chinese Chinese Shanghai" 0,
-- Document "Chinese Macao" 0,
-- Document "Japan Tokyo Chinese" 1]
-- testDocuments = [Document "Chinese Chinese Chinese Japan Tokyo" 0]
testDocuments = cleanDocuments $ createDocuments classes test testDocuments = cleanDocuments $ createDocuments classes test
devTestDocuments = take 30 testDocuments devTestDocuments = take 30 testDocuments
-- devTestDocuments = [Document "Chinese Chinese Chinese Tokyo Japan" 0]
nb = train documents intClasses nb = train documents intClasses
results = map (\(Document text c) -> (c, run text nb)) testDocuments results = map (\(Document text c) -> (c, run text nb)) testDocuments
-- results = map (\(Document text c) -> (c, run text nb)) devTestDocuments -- results = map (\(Document text c) -> (c, run text nb)) devTestDocuments
-- print (text $ head documents) print (text $ head documents)
let showResults (c, r) = putStrLn (classes !! c ++ " ~ " ++ classes !! r) let showResults (c, (r, confidence)) = putStrLn (classes !! c ++ " ~ " ++ classes !! r)
mapM_ showResults results mapM_ showResults results
putStrLn $ "Recall: " ++ show (recall results) putStrLn $ "Recall: " ++ show (recall results)

665
examples/stopwords Normal file
View File

@ -0,0 +1,665 @@
a
able
about
above
abst
accordance
according
accordingly
across
act
actually
added
adj
affected
affecting
affects
after
afterwards
again
against
ah
all
almost
alone
along
already
also
although
always
am
among
amongst
an
and
announce
another
any
anybody
anyhow
anymore
anyone
anything
anyway
anyways
anywhere
apparently
approximately
are
aren
arent
arise
around
as
aside
ask
asking
at
auth
available
away
awfully
b
back
be
became
because
become
becomes
becoming
been
before
beforehand
begin
beginning
beginnings
begins
behind
being
believe
below
beside
besides
between
beyond
biol
both
brief
briefly
but
by
c
ca
came
can
cannot
can't
cause
causes
certain
certainly
co
com
come
comes
contain
containing
contains
could
couldnt
d
date
did
didn't
different
do
does
doesn't
doing
done
don't
down
downwards
due
during
e
each
ed
edu
effect
eg
eight
eighty
either
else
elsewhere
end
ending
enough
especially
et
et-al
etc
even
ever
every
everybody
everyone
everything
everywhere
ex
except
f
far
few
ff
fifth
first
five
fix
followed
following
follows
for
former
formerly
forth
found
four
from
further
furthermore
g
gave
get
gets
getting
give
given
gives
giving
go
goes
gone
got
gotten
h
had
happens
hardly
has
hasn't
have
haven't
having
he
hed
hence
her
here
hereafter
hereby
herein
heres
hereupon
hers
herself
hes
hi
hid
him
himself
his
hither
home
how
howbeit
however
hundred
i
id
ie
if
i'll
im
immediate
immediately
importance
important
in
inc
indeed
index
information
instead
into
invention
inward
is
isn't
it
itd
it'll
its
itself
i've
j
just
k
keep keeps
kept
kg
km
know
known
knows
l
largely
last
lately
later
latter
latterly
least
less
lest
let
lets
like
liked
likely
line
little
'll
look
looking
looks
ltd
m
made
mainly
make
makes
many
may
maybe
me
mean
means
meantime
meanwhile
merely
mg
might
million
miss
ml
more
moreover
most
mostly
mr
mrs
much
mug
must
my
myself
n
na
name
namely
nay
nd
near
nearly
necessarily
necessary
need
needs
neither
never
nevertheless
new
next
nine
ninety
no
nobody
non
none
nonetheless
noone
nor
normally
nos
not
noted
nothing
now
nowhere
o
obtain
obtained
obviously
of
off
often
oh
ok
okay
old
omitted
on
once
one
ones
only
onto
or
ord
other
others
otherwise
ought
our
ours
ourselves
out
outside
over
overall
owing
own
p
page
pages
part
particular
particularly
past
per
perhaps
placed
please
plus
poorly
possible
possibly
potentially
pp
predominantly
present
previously
primarily
probably
promptly
proud
provides
put
q
que
quickly
quite
qv
r
ran
rather
rd
re
readily
really
recent
recently
ref
refs
regarding
regardless
regards
related
relatively
research
respectively
resulted
resulting
results
right
run
s
said
same
saw
say
saying
says
sec
section
see
seeing
seem
seemed
seeming
seems
seen
self
selves
sent
seven
several
shall
she
shed
she'll
shes
should
shouldn't
show
showed
shown
showns
shows
significant
significantly
similar
similarly
since
six
slightly
so
some
somebody
somehow
someone
somethan
something
sometime
sometimes
somewhat
somewhere
soon
sorry
specifically
specified
specify
specifying
still
stop
strongly
sub
substantially
successfully
such
sufficiently
suggest
sup
sure t
take
taken
taking
tell
tends
th
than
thank
thanks
thanx
that
that'll
thats
that've
the
their
theirs
them
themselves
then
thence
there
thereafter
thereby
thered
therefore
therein
there'll
thereof
therere
theres
thereto
thereupon
there've
these
they
theyd
they'll
theyre
they've
think
this
those
thou
though
thoughh
thousand
throug
through
throughout
thru
thus
til
tip
to
together
too
took
toward
towards
tried
tries
truly
try
trying
ts
twice
two
u
un
under
unfortunately
unless
unlike
unlikely
until
unto
up
upon
ups
us
use
used
useful
usefully
usefulness
uses
using
usually
v
value
various
've
very
via
viz
vol
vols
vs
w
want
wants
was
wasnt
way
we
wed
welcome
we'll
went
were
werent
we've
what
whatever
what'll
whats
when
whence
whenever
where
whereafter
whereas
whereby
wherein
wheres
whereupon
wherever
whether
which
while
whim
whither
who
whod
whoever
whole
who'll
whom
whomever
whos
whose
why
widely
willing
wish
with
within
without
wont
words
world
would
wouldnt
www
x
y
yes
yet
you
youd
you'll
your
youre
yours
yourself
yourselves
you've
z
zero

View File

@ -12,6 +12,9 @@ module Sibe.NaiveBayes
stdev, stdev,
cleanText, cleanText,
cleanDocuments, cleanDocuments,
ngram,
removeWords,
removeStopwords,
) )
where where
import Data.List import Data.List
@ -21,7 +24,7 @@ module Sibe.NaiveBayes
import Data.Maybe import Data.Maybe
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Text.Regex.PCRE import Text.Regex.PCRE
import Data.Char (isSpace) import Data.Char (isSpace, isNumber)
import NLP.Stemmer import NLP.Stemmer
type Class = Int; type Class = Int;
@ -36,6 +39,7 @@ module Sibe.NaiveBayes
, megadoc :: String , megadoc :: String
, cd :: [(Class, [Document])] , cd :: [(Class, [Document])]
, cw :: [(Class, [(String, Int)])] , cw :: [(Class, [(String, Int)])]
, cgram :: [(Class, [(String, Int)])]
} deriving (Eq, Show, Read) } deriving (Eq, Show, Read)
train :: [Document] -> [Class] -> NB train :: [Document] -> [Class] -> NB
@ -49,7 +53,9 @@ module Sibe.NaiveBayes
cd = zip classes (map classDocs classes) cd = zip classes (map classDocs classes)
-- (class, [(word, count)]) -- (class, [(word, count)])
cw = zip classes $ l (map classWordsCounts classes) cw = zip classes $ map classWordsCounts classes
cgram = zip classes $ map classNGramCounts classes
in NB { documents = documents in NB { documents = documents
, classes = cls , classes = cls
@ -57,44 +63,60 @@ module Sibe.NaiveBayes
, megadoc = megadoc , megadoc = megadoc
, cd = cd , cd = cd
, cw = cw , cw = cw
, cgram = cgram
} }
where where
concatDocs = concatMap (\(Document text _) -> text ++ " ") concatDocs = concatMap (\(Document text _) -> text ++ " ")
classDocs x = filter ((==x) . c) documents classDocs x = filter ((==x) . c) documents
classMegadoc x = concatMap (\(Document text _) -> text ++ " ") (classDocs x) classMegadoc = concatMap (\(Document text _) -> text ++ " ") . classDocs
classWords x = words (classMegadoc x) classWords = words . classMegadoc
classNGram n = ngram n . classMegadoc classNGram = concatMap (\(Document text _) -> text ++ " ") . ngram 2 . classDocs
classVocabulary x = ordNub (classWords x) classNGramWords = words . classNGram
classVocabulary = ordNub . classWords
classPrior x = genericLength (classDocs x) / genericLength documents classPrior x = genericLength (classDocs x) / genericLength documents
countWordInDoc d w = genericLength (filter (==w) d) countWordInDoc d w = genericLength (filter (==w) d)
classWordsCounts x = wordsCount ws voc =
let voc = classVocabulary x zip voc $ map (countWordInDoc ws) voc
in zip voc $ map (countWordInDoc (classWords x)) voc classWordsCounts x = wordsCount (classWords x) (classVocabulary x)
classNGramCounts x = wordsCount (classNGramWords x) (ordNub $ classNGramWords x)
ngram :: Int -> String -> [String] ngram :: Int -> [Document] -> [Document]
ngram n text = ngram n documents =
map (\(Document text c) -> Document (helper text) c) documents
where
helper text =
let ws = words text let ws = words text
in map (\(i, w) -> unwords $ w:((take (n - 1) . drop (i+1)) ws)) (zip [0..] ws) pairs = zip [0..] ws
grams = map (\(i, w) -> concat . intersperse "_" $ w:((take (n - 1) . drop (i+1)) ws)) pairs
in unwords ("<b>":grams)
run :: String -> NB -> Class run :: String -> NB -> (Class, Double)
run text (NB documents classes vocabulary megadoc cd cw) = run txt (NB documents classes vocabulary megadoc cd cw cgram) =
let scores = map (score . fst) classes let scores = map (score . fst) classes
in argmax scores index = argmax scores
m = maximum scores
confidence = m / sum scores
in (index, 0)
where where
score c = score c =
let prior = snd (classes !! c) let prior = snd (classes !! c)
in prior * product (map (prob c) (words text))
-- below is the formula according to Multinominal Naive Bayes, but it seems
-- using a uniform prior probability seems to work better
-- in prior * product (map (prob c) (words txt))
in product (map (prob c) (words txt))
prob c w = prob c w =
let tctM = find ((==w) . fst) (snd (cw !! c)) let tctM = find ((== w) . fst) (snd (cw !! c))
tct = (snd . fromJust) tctM tct = if isJust tctM then (snd . fromJust) tctM else 0
cvoc = (genericLength . snd) (cw !! c) cvoc = sum $ map snd (snd (cw !! c))
voc = vocabulary voc = vocabulary
in gram = find ((==w) . last . splitOn "_" . fst) (snd (cgram !! c))
if isJust tctM then pg = if isJust gram then (snd . fromJust) gram else 0
realToFrac (tct + 1) / realToFrac (cvoc + voc) -- in realToFrac (tct * pg + 1) / realToFrac (cvoc + voc) -- uncomment to enable ngrams
else in realToFrac (tct + 1) / realToFrac (cvoc + voc)
1 / realToFrac (cvoc + voc)
argmax :: (Ord a) => [a] -> Int argmax :: (Ord a) => [a] -> Int
argmax x = fst $ maximumBy (\(_, a) (_, b) -> a `compare` b) (zip [0..] x) argmax x = fst $ maximumBy (\(_, a) (_, b) -> a `compare` b) (zip [0..] x)
@ -113,7 +135,8 @@ module Sibe.NaiveBayes
let puncs = filter (`notElem` ['!', '"', '#', '$', '%', '(', ')', '.', '?']) (trim string) let puncs = filter (`notElem` ['!', '"', '#', '$', '%', '(', ')', '.', '?']) (trim string)
spacify = foldl (\acc x -> replace x ' ' acc) puncs [',', '/', '-', '\n', '\r'] spacify = foldl (\acc x -> replace x ' ' acc) puncs [',', '/', '-', '\n', '\r']
stemmed = unwords $ map (stem Porter) (words spacify) stemmed = unwords $ map (stem Porter) (words spacify)
in stemmed nonumber = filter (not . isNumber) stemmed
in (unwords . words) nonumber
where where
trim = f . f trim = f . f
where where
@ -124,11 +147,21 @@ module Sibe.NaiveBayes
cleanDocuments :: [Document] -> [Document] cleanDocuments :: [Document] -> [Document]
cleanDocuments documents = cleanDocuments documents =
let cleaned = map (\(Document text c) -> Document (cleanText text) c) documents let cleaned = map (\(Document text c) -> Document (cleanText text) c) documents
wc = wordCounts (concatDocs cleaned) in cleaned
removeWords :: [String] -> [Document] -> [Document]
removeWords ws documents =
map (\(Document text c) -> Document (rm ws text) c) documents
where
rm list text =
unwords $ filter (`notElem` list) (words text)
removeStopwords :: Int -> [Document] -> [Document]
removeStopwords i documents =
let wc = wordCounts (concatDocs documents)
wlist = sortBy (\(_, a) (_, b) -> b `compare` a) wc wlist = sortBy (\(_, a) (_, b) -> b `compare` a) wc
stopwords = l $ map fst (take 30 wlist) stopwords = map fst (take i wlist)
wstopwords = map (\(Document text c) -> Document (removeWords stopwords text) c) cleaned in removeWords stopwords documents
in wstopwords
where where
vocabulary x = ordNub (words x) vocabulary x = ordNub (words x)
countWordInDoc d w = genericLength (filter (==w) d) countWordInDoc d w = genericLength (filter (==w) d)
@ -136,9 +169,6 @@ module Sibe.NaiveBayes
let voc = vocabulary x let voc = vocabulary x
in zip voc $ map (countWordInDoc (words x)) voc in zip voc $ map (countWordInDoc (words x)) voc
removeWords list text =
unwords $ filter (`notElem` list) (words text)
concatDocs = concatMap (\(Document text _) -> text ++ " ") concatDocs = concatMap (\(Document text _) -> text ++ " ")
l :: (Show a) => a -> a l :: (Show a) => a -> a
@ -151,37 +181,38 @@ module Sibe.NaiveBayes
go s (x:xs) = if x `Set.member` s then go s xs go s (x:xs) = if x `Set.member` s then go s xs
else x : go (Set.insert x s) xs else x : go (Set.insert x s) xs
accuracy :: [(Int, Int)] -> Double accuracy :: [(Int, (Int, Double))] -> Double
accuracy results = accuracy results =
let correct = filter (uncurry (==)) results let pairs = map (\(a, b) -> (a, fst b)) results
correct = filter (uncurry (==)) pairs
in genericLength correct / genericLength results in genericLength correct / genericLength results
recall :: [(Int, Int)] -> Double recall :: [(Int, (Int, Double))] -> Double
recall results = recall results =
let classes = ordNub (map fst results) let classes = ordNub (map fst results)
s = sum (map rec classes) / genericLength classes s = sum (map rec classes) / genericLength classes
in s in s
where where
rec a = rec a =
let t = genericLength $ filter (\(c, r) -> c == r && c == a) results let t = genericLength $ filter (\(c, (r, _)) -> c == r && c == a) results
y = genericLength $ filter (\(c, r) -> c == a) results y = genericLength $ filter (\(c, (r, _)) -> c == a) results
in t / y in t / y
precision :: [(Int, Int)] -> Double precision :: [(Int, (Int, Double))] -> Double
precision results = precision results =
let classes = ordNub (map fst results) let classes = ordNub (map fst results)
s = sum (map prec classes) / genericLength classes s = sum (map prec classes) / genericLength classes
in s in s
where where
prec a = prec a =
let t = genericLength $ filter (\(c, r) -> c == r && c == a) results let t = genericLength $ filter (\(c, (r, _)) -> c == r && c == a) results
y = genericLength $ filter (\(c, r) -> r == a) results y = genericLength $ filter (\(c, (r, _)) -> r == a) results
in in
if y == 0 if y == 0
then 0 then 0
else t / y else t / y
fmeasure :: [(Int, Int)] -> Double fmeasure :: [(Int, (Int, Double))] -> Double
fmeasure results = fmeasure results =
let r = recall results let r = recall results
p = precision results p = precision results