Classifying Earnings Calls with Naive Bayes

Generate Dataset

let labelEar (earVal : float) thresh : Class = 
    if earVal >= thresh then Positive
    elif earVal <= -thresh then Negative
    else Neutral

let trainRaw, testRaw = 
    myEars
    |> Array.choose (fun xs -> 
        match xs.Ear with
        | Some ear -> 
            let document = xs.EarningsCall.Transcript |> String.concat(" ")
            let label : Class = labelEar ear 0.05
            if label <> Neutral then Some (document, label)
            else None
        | None -> None)
    |> fun xs -> 
        let cutoff = float xs.Length * 0.8
        xs.[.. int cutoff], xs.[int cutoff + 1 ..]

trainRaw.Length
testRaw.Length

AdHoc blacklists :

1. Identifying proper nouns with NLTK database
2. Fetching company names using requests

/// Names
let nltkNames = 
    System.IO.File.ReadLines("data-cache\NamesNLTK.txt")
    |> Seq.map (fun xs -> xs.ToLowerInvariant())
    |> Set

Preprocessing Text

Tokenize documents

// Tokenize all documents
let tokenizeDocumentWith (nGram : int)
                         (rawDocument : string) 
                         : Token [] = 
    rawDocument.ToLowerInvariant().Split(" ")
    // Blacklist filter
    |> Array.filter (nltkNames.Contains >> not)
    |> String.concat(" ")
    // Normalize
    |> getOnlyWords
    |> expandContractions
    // Tokenize
    |> nGrams nGram
    // Stop words removal
    |> Array.choose removeStopWords
    // Empty string removal
    |> Array.filter (fun xs -> xs.Length <> 0)

let tokenizeDocuments (tokenizer : Tokenizer)
                      (labelledRawDocuments : (string * Class) []) 
                      : LabelledDocument [] = 
    labelledRawDocuments
    |> Array.Parallel.map (fun (doc, label) -> 
        tokenizer doc, label)

Bag of words representation

// Top Tokens from sample
let getTopNTokens (sampleMaxTokens : int)
                  (labelledDocuments : LabelledDocument []) 
                  : Set<Token> = 
    labelledDocuments
    |> Array.collect fst
    |> Array.countBy id
    |> Array.sortByDescending snd
    |> Array.truncate sampleMaxTokens
    |> Array.map fst
    |> Set

// Generate bag of words using only top tokens
let getTopTokenBow (topTokens : Set<Token>)
                   (document : Document) 
                   : BagOfWords = 
    document
    |> Array.countBy id
    |> Array.filter (fun (token, _) -> topTokens.Contains token)
    |> Array.sortByDescending snd

let generateTopTokenBows (topTokens : Set<Token>)
                         (labelledDocuments : LabelledDocument []) 
                         : LabelledBagOfWords [] =
    labelledDocuments
    |> Array.Parallel.map (fun (doc, label) -> 
        getTopTokenBow topTokens doc, label)

Preprocess text

type TextVectorizer = 
    { NGram : int 
      MaxSampleTokens : int}

let vectorizeTrainTest (textPreprocessor : TextVectorizer)
                       (rawDocumentsTrain : (string * Class) []) 
                       (rawDocumentsTest : (string * Class) [])
                       : LabelledBagOfWords [] * LabelledBagOfWords [] = 

    // Tokenize documents (nGrams)
    let tokenizer = 
        tokenizeDocumentWith textPreprocessor.NGram

    let tokenizedTrain, tokenizedTest = 
        tokenizeDocuments tokenizer rawDocumentsTrain,
        tokenizeDocuments tokenizer rawDocumentsTest
   
    // Generate bag of words using most frequent tokens
    let topTokens = 
        getTopNTokens textPreprocessor.MaxSampleTokens tokenizedTrain
    
    generateTopTokenBows topTokens tokenizedTrain,
    generateTopTokenBows topTokens tokenizedTest

Training the Naive Bayes classifier

Class Priors

let getPriors (labelledBows : LabelledBagOfWords []) 
              : Map<Class, Prior> = 
    
    let n = labelledBows.Length
    
    labelledBows
    |> Array.groupBy snd
    |> Array.map (fun (label, labelFreqs) -> 
        let prior =  (float (labelFreqs.Length)/(float n))
        label, prior)
    |> Map

Aggregate Token Counts by Class -> Class Bag of Words

let getClassBagofWords 
    (labelledBow : LabelledBagOfWords [])
    : (Class * Token * Count) [] = 
    
    labelledBow
    |> Array.groupBy snd
    |> Array.collect (fun (c, classBagOfWords) -> 
        classBagOfWords
        |> Array.filter (fun (_, label) -> label=c)
        |> Array.collect fst
        |> Array.groupBy fst
        |> Array.map (fun (token, tokenCounts) -> 
            c, token, Array.sumBy snd tokenCounts))

Token Likelihoods by Class

let computeTokenLikilihoods 
    (classBagOfWords : (Class * Token * Count) [])
    (vocabN : Count) 
    : (Class * Token * Likelihood) [] = 
    
    classBagOfWords
    |> Array.groupBy (fun (_, token, _) -> token)
    |> Array.collect (fun (_, xs) -> 
        /// Compute total token counts within all classes
        let totalTokenCounts = 
            xs
            |> Array.sumBy (fun (_, _, counts) -> counts)
        /// Compute token likelihood for all classes (Laplace corrected)
        xs
        |> Array.map (fun (c, token, counts) -> 
            let tokenLikelihood = 
                float (counts + 1) / float (totalTokenCounts + vocabN)
            (c, token, tokenLikelihood)))

let getClassLikelihoodsMap (tokenLikelihoods :  (Class * Token * Likelihood) []) 
                           : Map<Class, Map<Token, Likelihood>> = 
    tokenLikelihoods
    |> Array.groupBy (fun (c, _, _) -> c)
    |> Array.map (fun (c, xs) -> 
        c, 
        xs
        |> Array.map (fun (_, token, counts) -> token, counts)
        |> Map)
    |> Map

let getTokenLikelihoods (labelledBows : LabelledBagOfWords [])
                        : Map<Class, Map<Token, Likelihood>> = 
    
    let classBagOfWords = 
        getClassBagofWords labelledBows

    let vocabN = 
        classBagOfWords
        |> Array.distinctBy (fun (_, token, _) -> token)
        |> Array.length

    computeTokenLikilihoods classBagOfWords vocabN
    |> getClassLikelihoodsMap

Building the Naive Bayes Classifier

type NbClassifierInfo = 
    { Priors : Map<Class, Prior>
      Likelihoods : Map<Class, Map<Token, Likelihood>>}

let trainNbClassifier (labelledBows : LabelledBagOfWords []) 
                      : NbClassifierInfo = 
    { Priors = getPriors labelledBows
      Likelihoods = getTokenLikelihoods labelledBows}

Classifying new Documents

/// Fetch token scores from bag of words
let getTokenScores 
    (tokenLikelihoods : Map<Token, Likelihood>)
    (bow : BagOfWords) 
    : TokenScore [] = 
    
    bow
    |> Array.choose (fun (token, count) -> 
        match tokenLikelihoods.TryFind token with
        | Some likelihood -> 
            Some (log (likelihood ** float count))
        | None -> None)

/// Computes final score by adding token scores, prior
let computeDocumentScore 
    (prior : Prior)
    (tokenScores : TokenScore []) 
    : DocumentScore =
    
    tokenScores
    |> Array.fold (+) (log prior)

/// Computes document scores and classifies document
let classifyBagOfWords 
    (nbClassifierInfo : NbClassifierInfo)
    (bow : BagOfWords)
    : Class =
    
    nbClassifierInfo.Priors
    |> Map.toArray
    |> Array.choose (fun (c, prior) -> 
        match nbClassifierInfo.Likelihoods.TryFind c with
        | Some tokenLikelihoods ->
            bow
            |> getTokenScores tokenLikelihoods  
            |> computeDocumentScore prior
            |> fun docScore -> Some (c, docScore)
        | None -> None)   
    |> Array.maxBy snd
    |> fst

Evaluate

let evaluate (nbClassifierInfo : NbClassifierInfo)
             (labelledBows : LabelledBagOfWords [])
             : Accuracy =
    
    let classifyBow = classifyBagOfWords nbClassifierInfo
   
    labelledBows
    |> PSeq.averageBy (fun (bow, label) ->  
        if classifyBow bow = label then 1. 
        else 0.)

Model 1

let tp1 = {NGram=2; MaxSampleTokens=5000}
let trainBow, testBow = vectorizeTrainTest tp1 trainRaw testRaw

let fittedClassifier = trainNbClassifier trainBow

let trainEval = evaluate fittedClassifier trainBow
let testEval = evaluate fittedClassifier testBow