diff --git a/Haggressive.cabal b/Haggressive.cabal --- a/Haggressive.cabal +++ b/Haggressive.cabal @@ -1,5 +1,5 @@ name: Haggressive -version: 0.1.0.1 +version: 0.1.0.2 synopsis: Aggression analysis for Tweets on Twitter description: Aggression analysis for Tweets on Twitter homepage: http://github.io/pold87/Haggressive @@ -12,8 +12,7 @@ cabal-version: >=1.10 -executable Haggressive - main-is: Hag.hs +library build-depends: base >= 4 && < 5, Haggressive, Cabal, @@ -29,8 +28,9 @@ directory, tokenize, PSQueue - hs-source-dirs: src-exe + hs-source-dirs: src-lib default-language: Haskell2010 + exposed-modules: Hag, Helpers, Preprocess, Tweets ghc-options: -fllvm test-suite tests diff --git a/src-exe/Hag.hs b/src-exe/Hag.hs deleted file mode 100644 --- a/src-exe/Hag.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} - - -{-| -Module : Hag -Description : Classify Tweets (aggressive vs. non_aggressive) and evaluate - classification performance. -License : None -Maintainer : Volker Strobel (volker.strobel87@gmail.com) -Stability : experimental -Portability : None - -This module is the main interface for Tweet classification. - --} -module Hag -( module Hag - ) where - -import qualified Data.ByteString.Lazy as L -import Data.Char -import Data.Csv -import Data.Either -import Data.List -import qualified Data.Map as M -import qualified Data.PSQueue as PS -import qualified Data.Text as T -import Data.Text.Encoding -import qualified Data.Text.IO as TI -import qualified Data.Vector as V -import Helpers -import NLP.Tokenize -import Preprocess -import qualified System.Directory as S -import System.Environment -import Tweets - - --- | Features are represented by a 'M.Map', where the keys are --- 'String's (e.g., the words in the message of a Tweet) and the --- values are 'Float's (e.g., the number of occurrence of a word) -type FeatureMap = M.Map String Float - --- | --- =IO and Parsing - --- |'parseCsv' parses a 'T.Text' input for fields in CSV format and --- returns a 'Vector' of 'Tweet's -parseCsv :: T.Text -> Either String (V.Vector Tweet) -parseCsv text = decodeWith - defaultDecodeOptions {decDelimiter = fromIntegral $ ord '\t' } - NoHeader - (L.fromStrict $ - encodeUtf8 text) - --- |Get directory contents of 'FilePath'. A better variant is at: -getFiles :: FilePath -> IO [FilePath] -getFiles dir = S.getDirectoryContents dir - >>= return . map (dir ++) . filter (`notElem` [".", ".."]) - --- |Extract features (the bag of unigrams) for one Tweet. --- Thereby, the Tweet will be (in order of application): --- * tokenized --- * converted to a 'V.Vector' --- * 'String's will be converted to lowercase --- * 'String's that are element of 'stopWords' are removed --- * Empty 'String's will be removed -extractFeatures :: Tweet -> FeatureMap -extractFeatures tweet = bagOfUnigrams - where - pre = V.filter (`notElem` ["USER", "RT"]) - . V.fromList - . tokenize - . tMessage - bagOfUnigrams = frequency - . V.filter (/= "") - . V.filter (`notElem` stopWords) - . V.map (map toLower) - . pre - $ tweet - --- |Calculate the 'frequency' of items in a 'V.Vector' and return them --- in a 'M.Map'. -frequency :: V.Vector String -> FeatureMap -frequency = V.foldl' countItem M.empty - --- |Insert an item into a 'M.Map'. Default value is 1 if the item is --- not existing. If the item is already existing, its frequency will --- be increased by 1. -countItem :: M.Map String Float -> String -> FeatureMap -countItem myMap item = M.insertWith (+) item 1 myMap - --- |Take a 'M.Map', consisting of --- key: 'Tweet' --- value: 'FeatureMap' --- and one Tweet and create a new 'M.Map' with the added features --- from the 'Tweet' -insertInMap :: M.Map Tweet FeatureMap - -> Tweet - -> M.Map Tweet FeatureMap -insertInMap oldMap tweet = M.insert tweet val oldMap - where val = extractFeatures tweet - --- | Compare two vectors of 'Tweet's, the first is the test vector, --- the second the train vector and return the all neighbors for each --- 'Tweet'. 'grandDict' is a 'M.Map', where each entry consits of a --- 'Tweet' and its features -getNeighbors :: (V.Vector Tweet, V.Vector Tweet) - -> V.Vector (Tweet, [PS.Binding Tweet Float]) -getNeighbors (v1,v2) = V.map (featureIntersection dictionary) v1 - where dictionary = V.foldl insertInMap M.empty v2 :: M.Map Tweet FeatureMap - --- | Take a dictionary and a 'Tweet' and return a pair of this 'Tweet' --- and all its nearest neighbors -featureIntersection :: M.Map Tweet FeatureMap - -> Tweet - -> (Tweet, [PS.Binding Tweet Float]) -featureIntersection tweetMap tweet = (tweet, mini) - where - mini = PS.fromList - $ M.elems - $ M.mapWithKey (mergeTweetFeatures cosineDistance tweet) tweetMap - --- |Take a distance function, 'Tweet' 1, 'Tweet' 2 and a dictionary as --- 'FeatureMap' and create a 'PS.Binding' between 'Tweet' 2 and the --- distance from this 'Tweet' to the other 'Tweet'. -mergeTweetFeatures :: (FeatureMap -> FeatureMap -> Float) - -> Tweet - -> Tweet - -> FeatureMap - -> PS.Binding Tweet Float - -mergeTweetFeatures distF t1 t2 _ = queue - where featuresT1 = extractFeatures t1 - featuresT2 = extractFeatures t2 - distance = distF featuresT1 featuresT2 - queue = t2 PS.:-> distance - --- |Take the features of two 'Tweet's and return the distance as --- 'Num'. -cosineDistance :: FeatureMap -> FeatureMap -> Float -cosineDistance t1 t2 = negate (mySum / (wordsInT1 * wordsInT2)) - where - wordsInT1 = M.foldl (+) 0 t1 - wordsInT2 = M.foldl (+) 0 t2 - intersection = M.elems $ M.intersectionWith (*) t1 t2 - mySum = foldl (+) 0 intersection - --- |Takes a dictionary and a mini dictionary (frequency of words in --- one Tweet) and calculates the idftf values for all words in the --- mini dictionary. -idftf :: FeatureMap -> FeatureMap -> FeatureMap -idftf grandDict miniDict = M.mapWithKey (iFrequency grandDict) miniDict - -iFrequency :: FeatureMap -> String -> Float -> Float -iFrequency dict word freq = freq * (log (totalNumberOfWords / freqWord)) - where freqWord = M.findWithDefault 1 word dict - totalNumberOfWords = M.foldl (+) 0 dict - --- | Calculate the amount of tweets where the predicted label matches --- the actual label. -compareLabels :: Int -> V.Vector (Tweet,[PS.Binding Tweet Float]) -> V.Vector Float -compareLabels k vec = V.map - (\(a,b) -> if (tLabel a) == getLabel k b then 1 else 0) - vec - -compareLabelsForScheme :: [V.Vector (Tweet,[PS.Binding Tweet Float])] -> Int -> [Float] -compareLabelsForScheme vecs k = map (getAccuracy . compareLabels k) vecs - - --- | Get the label for a 'Tweet' by looking at the k nearest --- neighbors. If there are more aggressive than non_aggressive --- 'Tweet's, the label will be aggressive, otherwise, it will be --- non-aggressive. -getLabel :: Int -> [PS.Binding Tweet Float] -> String -getLabel k queue = if agg >= nonAgg then "aggressive" else "non_aggressive" - where -- tweets = queueTake k queue - tweets = take k queue - labels = map (tLabel . PS.key) tweets - agg = length $ filter (== "aggressive") labels - nonAgg = length $ filter (== "non_aggressive") labels - --- | Get sum total of a vector of floats (i.e., the number of --- correctly classified tweets) and return the accuracy -getAccuracy :: V.Vector Float -> Float -getAccuracy vec = (V.foldl (+) 0 vec) / fromIntegral (V.length vec) - -main :: IO () -main = do - -- Retrieve command line args - (dir:_) <- getArgs - - -- Get list of files in directory dir - files <- getFiles dir - - -- Read content of all files into list, one Text per item - csvs <- mapM TI.readFile $ sort files - - let - -- Add quotation marks for CSV parsing - processedCsvs = map preprocess csvs - - -- Create Tweets from Text - r = map parseCsv processedCsvs - - -- If parsing was successful, extract Right elements from the - -- Either list - tweets = rights r - - -- Create a leave-one-out cross-validation scheme - scheme = mkCrossValScheme tweets - - -- Get all neighbors for all tweets for all schemes - allNeighbors = map getNeighbors scheme - - -- k should be in {1..100} - ks = [1..100] - - -- Compare all training tweets to test tweets for all ks - comparedTweets = map (compareLabelsForScheme allNeighbors) ks - - -- Prepare for CSV - results = encode comparedTweets - - -- Create header - -- header = encode - -- $ map (("fold_" ++) . show) ([1..10] :: [Integer]) - - -- Write output to a file - -- L.writeFile "resultsK.csv" $ header `L.append` results - L.writeFile "resultsK.csv" $ results diff --git a/src-lib/Hag.hs b/src-lib/Hag.hs new file mode 100644 --- /dev/null +++ b/src-lib/Hag.hs @@ -0,0 +1,232 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} + + +{-| +Module : Hag +Description : Classify Tweets (aggressive vs. non_aggressive) and evaluate + classification performance. +License : None +Maintainer : Volker Strobel (volker.strobel87@gmail.com) +Stability : experimental +Portability : None + +This module is the main interface for Tweet classification. + +-} +module Hag +( module Hag + ) where + +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Csv +import Data.Either +import Data.List +import qualified Data.Map as M +import qualified Data.PSQueue as PS +import qualified Data.Text as T +import Data.Text.Encoding +import qualified Data.Text.IO as TI +import qualified Data.Vector as V +import Helpers +import NLP.Tokenize +import Preprocess +import qualified System.Directory as S +import System.Environment +import Tweets + + +-- | Features are represented by a 'M.Map', where the keys are +-- 'String's (e.g., the words in the message of a Tweet) and the +-- values are 'Float's (e.g., the number of occurrence of a word) +type FeatureMap = M.Map String Float + +-- | +-- =IO and Parsing + +-- |'parseCsv' parses a 'T.Text' input for fields in CSV format and +-- returns a 'Vector' of 'Tweet's +parseCsv :: T.Text -> Either String (V.Vector Tweet) +parseCsv text = decodeWith + defaultDecodeOptions {decDelimiter = fromIntegral $ ord '\t' } + NoHeader + (L.fromStrict $ + encodeUtf8 text) + +-- |Get directory contents of 'FilePath'. A better variant is at: +getFiles :: FilePath -> IO [FilePath] +getFiles dir = S.getDirectoryContents dir + >>= return . map (dir ++) . filter (`notElem` [".", ".."]) + +-- |Extract features (the bag of unigrams) for one Tweet. +-- Thereby, the Tweet will be (in order of application): +-- * tokenized +-- * converted to a 'V.Vector' +-- * 'String's will be converted to lowercase +-- * 'String's that are element of 'stopWords' are removed +-- * Empty 'String's will be removed +extractFeatures :: Tweet -> FeatureMap +extractFeatures tweet = bagOfUnigrams + where + pre = V.filter (`notElem` ["USER", "RT"]) + . V.fromList + . tokenize + . tMessage + bagOfUnigrams = frequency + . V.filter (/= "") + . V.filter (`notElem` stopWords) + . V.map (map toLower) + . pre + $ tweet + +-- |Calculate the 'frequency' of items in a 'V.Vector' and return them +-- in a 'M.Map'. +frequency :: V.Vector String -> FeatureMap +frequency = V.foldl' countItem M.empty + +-- |Insert an item into a 'M.Map'. Default value is 1 if the item is +-- not existing. If the item is already existing, its frequency will +-- be increased by 1. +countItem :: M.Map String Float -> String -> FeatureMap +countItem myMap item = M.insertWith (+) item 1 myMap + +-- |Take a 'M.Map', consisting of +-- key: 'Tweet' +-- value: 'FeatureMap' +-- and one Tweet and create a new 'M.Map' with the added features +-- from the 'Tweet' +insertInMap :: M.Map Tweet FeatureMap + -> Tweet + -> M.Map Tweet FeatureMap +insertInMap oldMap tweet = M.insert tweet val oldMap + where val = extractFeatures tweet + +-- | Compare two vectors of 'Tweet's, the first is the test vector, +-- the second the train vector and return the all neighbors for each +-- 'Tweet'. 'grandDict' is a 'M.Map', where each entry consits of a +-- 'Tweet' and its features +getNeighbors :: (V.Vector Tweet, V.Vector Tweet) + -> V.Vector (Tweet, [PS.Binding Tweet Float]) +getNeighbors (v1,v2) = V.map (featureIntersection dictionary) v1 + where dictionary = V.foldl insertInMap M.empty v2 :: M.Map Tweet FeatureMap + +-- | Take a dictionary and a 'Tweet' and return a pair of this 'Tweet' +-- and all its nearest neighbors +featureIntersection :: M.Map Tweet FeatureMap + -> Tweet + -> (Tweet, [PS.Binding Tweet Float]) +featureIntersection tweetMap tweet = (tweet, mini) + where + mini = PS.fromList + $ M.elems + $ M.mapWithKey (mergeTweetFeatures cosineDistance tweet) tweetMap + +-- |Take a distance function, 'Tweet' 1, 'Tweet' 2 and a dictionary as +-- 'FeatureMap' and create a 'PS.Binding' between 'Tweet' 2 and the +-- distance from this 'Tweet' to the other 'Tweet'. +mergeTweetFeatures :: (FeatureMap -> FeatureMap -> Float) + -> Tweet + -> Tweet + -> FeatureMap + -> PS.Binding Tweet Float + +mergeTweetFeatures distF t1 t2 _ = queue + where featuresT1 = extractFeatures t1 + featuresT2 = extractFeatures t2 + distance = distF featuresT1 featuresT2 + queue = t2 PS.:-> distance + +-- |Take the features of two 'Tweet's and return the distance as +-- 'Num'. +cosineDistance :: FeatureMap -> FeatureMap -> Float +cosineDistance t1 t2 = negate (mySum / (wordsInT1 * wordsInT2)) + where + wordsInT1 = M.foldl (+) 0 t1 + wordsInT2 = M.foldl (+) 0 t2 + intersection = M.elems $ M.intersectionWith (*) t1 t2 + mySum = foldl (+) 0 intersection + +-- |Takes a dictionary and a mini dictionary (frequency of words in +-- one Tweet) and calculates the idftf values for all words in the +-- mini dictionary. +idftf :: FeatureMap -> FeatureMap -> FeatureMap +idftf grandDict miniDict = M.mapWithKey (iFrequency grandDict) miniDict + +iFrequency :: FeatureMap -> String -> Float -> Float +iFrequency dict word freq = freq * (log (totalNumberOfWords / freqWord)) + where freqWord = M.findWithDefault 1 word dict + totalNumberOfWords = M.foldl (+) 0 dict + +-- | Calculate the amount of tweets where the predicted label matches +-- the actual label. +compareLabels :: Int -> V.Vector (Tweet,[PS.Binding Tweet Float]) -> V.Vector Float +compareLabels k vec = V.map + (\(a,b) -> if (tLabel a) == getLabel k b then 1 else 0) + vec + +compareLabelsForScheme :: [V.Vector (Tweet,[PS.Binding Tweet Float])] -> Int -> [Float] +compareLabelsForScheme vecs k = map (getAccuracy . compareLabels k) vecs + + +-- | Get the label for a 'Tweet' by looking at the k nearest +-- neighbors. If there are more aggressive than non_aggressive +-- 'Tweet's, the label will be aggressive, otherwise, it will be +-- non-aggressive. +getLabel :: Int -> [PS.Binding Tweet Float] -> String +getLabel k queue = if agg >= nonAgg then "aggressive" else "non_aggressive" + where -- tweets = queueTake k queue + tweets = take k queue + labels = map (tLabel . PS.key) tweets + agg = length $ filter (== "aggressive") labels + nonAgg = length $ filter (== "non_aggressive") labels + +-- | Get sum total of a vector of floats (i.e., the number of +-- correctly classified tweets) and return the accuracy +getAccuracy :: V.Vector Float -> Float +getAccuracy vec = (V.foldl (+) 0 vec) / fromIntegral (V.length vec) + +main :: IO () +main = do + -- Retrieve command line args + (dir:_) <- getArgs + + -- Get list of files in directory dir + files <- getFiles dir + + -- Read content of all files into list, one Text per item + csvs <- mapM TI.readFile $ sort files + + let + -- Add quotation marks for CSV parsing + processedCsvs = map preprocess csvs + + -- Create Tweets from Text + r = map parseCsv processedCsvs + + -- If parsing was successful, extract Right elements from the + -- Either list + tweets = rights r + + -- Create a leave-one-out cross-validation scheme + scheme = mkCrossValScheme tweets + + -- Get all neighbors for all tweets for all schemes + allNeighbors = map getNeighbors scheme + + -- k should be in {1..100} + ks = [1..100] + + -- Compare all training tweets to test tweets for all ks + comparedTweets = map (compareLabelsForScheme allNeighbors) ks + + -- Prepare for CSV + results = encode comparedTweets + + -- Create header + -- header = encode + -- $ map (("fold_" ++) . show) ([1..10] :: [Integer]) + + -- Write output to a file + -- L.writeFile "resultsK.csv" $ header `L.append` results + L.writeFile "resultsK.csv" $ results diff --git a/src-lib/Helpers.hs b/src-lib/Helpers.hs new file mode 100644 --- /dev/null +++ b/src-lib/Helpers.hs @@ -0,0 +1,41 @@ +module Helpers + (mkCrossValScheme + , queueTake + , stopWords) + where + +import qualified Data.PSQueue as PS +import qualified Data.Vector as V +import Debug.Trace +import System.IO.Unsafe + +-- | 'FilePath' of the 'stopWords' that are removed before the +-- dictionary is created +stopWordsFile :: FilePath +stopWordsFile = "dutch-stop-words.txt" + +-- | Read the 'stopWords' from the 'stopWordsFile' +stopWords :: [String] +stopWords = lines file + where file = unsafePerformIO $ readFile stopWordsFile + +-- | Make a cross-validation scheme from a list of vectors +mkCrossValScheme :: (Eq a) => [V.Vector a] -> [(V.Vector a,V.Vector a)] +mkCrossValScheme xs = map (leaveOneOut xs) xs + +-- | Create pair of a list of vectors and a vector that specifies +-- which vector should be left out +leaveOneOut :: (Eq a) => [V.Vector a] -> V.Vector a -> (V.Vector a,V.Vector a) +leaveOneOut all test = (test, V.concat $ filter (/= test) all) + +-- | Take the first k elements of a queue +queueTake :: (Ord k, Ord p, Show k) => Int -> PS.PSQ k p -> [k] +queueTake k queue = queueTake' k queue [] + +-- | Helper function for 'queueTake' +queueTake' :: (Ord k, Ord p) => Int -> PS.PSQ k p -> [k] -> [k] +queueTake' 0 _ acc = acc +queueTake' k queue acc = case mini of + Nothing -> [] + Just m -> queueTake' (k - 1) (PS.deleteMin queue) (PS.key m:acc) + where mini = PS.findMin queue diff --git a/src-lib/Preprocess.hs b/src-lib/Preprocess.hs new file mode 100644 --- /dev/null +++ b/src-lib/Preprocess.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} + +module Preprocess + (preprocess) + where + +import qualified Data.Text as T + +preprocess :: T.Text -> T.Text +preprocess txt = T.cons '\"' $ T.snoc escaped '\"' + where escaped = T.concatMap escaper txt + +escaper :: Char -> T.Text +escaper c + | c == '\t' = "\"\t\"" + | c == '\n' = "\"\n\"" + | c == '\"' = "\"\"" + | otherwise = T.singleton c diff --git a/src-lib/Tweets.hs b/src-lib/Tweets.hs new file mode 100644 --- /dev/null +++ b/src-lib/Tweets.hs @@ -0,0 +1,36 @@ +module Tweets + (filterByLabel +, Tweet(..)) where + +import Control.Applicative ((<$>), (<*>), (<|>)) +import Control.Monad (mzero) +import Data.Csv +import qualified Data.PSQueue as PS +import qualified Data.Vector as V + +-- | Parsing Record to Tweet +instance FromRecord Tweet where + parseRecord v + | V.length v == 5 = Tweet <$> + v.! 0 <*> + v.! 1 <*> + v.! 2 <*> + v.! 3 <*> + v.! 4 + | otherwise = mzero + +-- | A Tweet consists of a category, a user, a date, a time, and a +-- message +data Tweet = Tweet { tLabel :: String + , tUser :: String + , tDate :: String + , tTime :: String + , tMessage :: String + } deriving (Show, Eq, Ord) + + +-- | Filter 'Tweet's by label +filterByLabel :: V.Vector Tweet -> String -> V.Vector Tweet +filterByLabel tweets label = V.filter (\t -> tLabel t == label) tweets + +