Add --min-frequency for black box debugging

geval.cabal

@@ -1,5 +1,5 @@
 name:                geval
-version:             1.11.3.0
+version:             1.12.0.0
 synopsis:            Machine learning evaluation tools
 description:         Please see README.md
 homepage:            http://github.com/name/project
@@ -37,6 +37,7 @@ library
                      , GEval.WER
                      , Text.Tokenizer
                      , GEval.Annotation
+                     , GEval.BlackBoxDebugging
                      , Paths_geval
   build-depends:       base >= 4.7 && < 5
                      , cond

src/GEval/BlackBoxDebugging.hs

@@ -0,0 +1,7 @@
+module GEval.BlackBoxDebugging
+  (BlackBoxDebuggingOptions(..))
+  where
+
+data BlackBoxDebuggingOptions = BlackBoxDebuggingOptions {
+  bbdoMinFrequency :: Integer
+}

src/GEval/Core.hs

@@ -86,6 +86,7 @@ import GEval.WER
 import Data.Conduit.AutoDecompress
 import Text.Tokenizer
 import GEval.Annotation
+import GEval.BlackBoxDebugging
 
 import qualified Data.HashMap.Strict as M
 import qualified Data.Vector as V
@@ -280,7 +281,8 @@ data ResultOrdering = KeepTheOriginalOrder | FirstTheWorst | FirstTheBest
 data GEvalOptions = GEvalOptions
                     { geoSpecialCommand :: Maybe GEvalSpecialCommand,
                       geoResultOrdering :: ResultOrdering,
-                      geoSpec :: GEvalSpecification }
+                      geoSpec :: GEvalSpecification,
+                      geoBlackBoxDebugginsOptions :: BlackBoxDebuggingOptions }
 
 data GEvalException = NoExpectedFile FilePath
                       | NoOutFile FilePath

src/GEval/LineByLine.hs

@@ -42,6 +42,7 @@ import Control.Monad.State.Strict
 import Data.Monoid ((<>))
 
 import GEval.FeatureExtractor
+import GEval.BlackBoxDebugging
 
 import Data.Word
 
@@ -71,14 +72,15 @@ runLineByLine ordering spec = runLineByLineGeneralized ordering spec consum
          formatScore :: MetricValue -> Text
          formatScore = Data.Text.pack . printf "%f"
 
-runWorstFeatures :: ResultOrdering -> GEvalSpecification -> IO ()
+runWorstFeatures :: ResultOrdering -> GEvalSpecification -> BlackBoxDebuggingOptions -> IO ()
-runWorstFeatures ordering spec = runLineByLineGeneralized ordering' spec (worstFeaturesPipeline False spec)
+runWorstFeatures ordering spec bbdo = runLineByLineGeneralized ordering' spec (worstFeaturesPipeline False spec bbdo)
   where ordering' = forceSomeOrdering ordering
 
 
-worstFeaturesPipeline :: Bool -> GEvalSpecification -> ConduitT LineRecord Void (ResourceT IO) ()
+
-worstFeaturesPipeline reversed spec = rank (lessByMetric reversed $ gesMainMetric spec)
+worstFeaturesPipeline :: Bool -> GEvalSpecification -> BlackBoxDebuggingOptions -> ConduitT LineRecord Void (ResourceT IO) ()
-                                      .| evalStateC 0 (extractFeaturesAndPValues spec)
+worstFeaturesPipeline reversed spec bbdo = rank (lessByMetric reversed $ gesMainMetric spec)
+                                      .| evalStateC 0 (extractFeaturesAndPValues spec bbdo)
                                       .| gobbleAndDo (sortBy featureOrder)
                                       .| CL.map (encodeUtf8 . formatFeatureWithPValue)
                                       .| CC.unlinesAscii
@@ -99,11 +101,11 @@ forceSomeOrdering :: ResultOrdering -> ResultOrdering
 forceSomeOrdering FirstTheBest = FirstTheBest
 forceSomeOrdering KeepTheOriginalOrder = FirstTheWorst
 
-extractFeaturesAndPValues :: Monad m => GEvalSpecification -> ConduitT (Double, LineRecord) FeatureWithPValue (StateT Integer m) ()
+extractFeaturesAndPValues :: Monad m => GEvalSpecification -> BlackBoxDebuggingOptions -> ConduitT (Double, LineRecord) FeatureWithPValue (StateT Integer m) ()
-extractFeaturesAndPValues spec =
+extractFeaturesAndPValues spec bbdo =
   totalCounter
   .| featureExtractor spec
-  .| uScoresCounter
+  .| uScoresCounter (bbdoMinFrequency bbdo)
 
 
 data RankedFeature = RankedFeature Feature Double MetricValue
@@ -131,22 +133,27 @@ featureExtractor spec = CC.map extract .| CC.concat
               extractUnigramFeaturesFromTabbed mTokenizer "in" inLine,
               extractUnigramFeatures mTokenizer "out" outLine]
         mTokenizer = gesTokenizer spec
-uScoresCounter :: Monad m => ConduitT RankedFeature FeatureWithPValue (StateT Integer m) ()
+
-uScoresCounter = CC.map (\(RankedFeature feature r score) -> (feature, (r, score, 1)))
+uScoresCounter :: Monad m => Integer -> ConduitT RankedFeature FeatureWithPValue (StateT Integer m) ()
-                 .| gobbleAndDo countUScores
+uScoresCounter minFreq = CC.map (\(RankedFeature feature r score) -> (feature, (r, score, 1)))
-                 .| pValueCalculator
+                         .| gobbleAndDo countUScores
+                         .| lowerFreqFiltre
+                         .| pValueCalculator minFreq
   where countUScores l =
            M.toList
            $ M.fromListWith (\(r1, s1, c1) (r2, s2, c2) -> ((r1 + r2), (s1 + s2), (c1 + c2))) l
+        lowerFreqFiltre = CC.filter (\(_, (_, _, c)) -> c >= minFreq)
 
-pValueCalculator :: Monad m => ConduitT (Feature, (Double, MetricValue, Integer)) FeatureWithPValue (StateT Integer m) ()
+pValueCalculator :: Monad m => Integer -> ConduitT (Feature, (Double, MetricValue, Integer)) FeatureWithPValue (StateT Integer m) ()
-pValueCalculator = do
+pValueCalculator minFreq = do
   firstVal <- await
   case firstVal of
-    Just i -> do
+    Just i@(_, (_, _, c)) -> do
       total <- lift get
-      yield $ calculatePValue total i
+      if total - c >= minFreq
-      CC.map $ calculatePValue total
+        then yield $ calculatePValue total i
+        else return ()
+      CC.filter (\(_, (_, _, c)) -> total - c >= minFreq) .| CC.map (calculatePValue total)
     Nothing -> return ()
 
 calculatePValue :: Integer -> (Feature, (Double, MetricValue, Integer)) -> FeatureWithPValue
@@ -225,8 +232,8 @@ runDiff ordering otherOut spec = runDiffGeneralized ordering otherOut spec consu
         formatScoreDiff :: Double -> Text
         formatScoreDiff = Data.Text.pack . printf "%f"
 
-runMostWorseningFeatures :: ResultOrdering -> FilePath -> GEvalSpecification -> IO ()
+runMostWorseningFeatures :: ResultOrdering -> FilePath -> GEvalSpecification -> BlackBoxDebuggingOptions -> IO ()
-runMostWorseningFeatures ordering otherOut spec = runDiffGeneralized ordering' otherOut spec consum
+runMostWorseningFeatures ordering otherOut spec bbdo = runDiffGeneralized ordering' otherOut spec consum
   where ordering' = forceSomeOrdering ordering
         reversed = case ordering of
           KeepTheOriginalOrder -> False
@@ -234,7 +241,7 @@ runMostWorseningFeatures ordering otherOut spec = runDiffGeneralized ordering' o
           FirstTheBest -> True
         consum :: ConduitT (LineRecord, LineRecord) Void (ResourceT IO) ()
         consum = CC.map prepareFakeLineRecord
-                 .| (worstFeaturesPipeline reversed spec)
+                 .| (worstFeaturesPipeline reversed spec bbdo)
         prepareFakeLineRecord :: (LineRecord, LineRecord) -> LineRecord
         prepareFakeLineRecord (LineRecord _ _ _ _ scorePrev, LineRecord inp exp out c score) =
           LineRecord inp exp out c (score - scorePrev)

src/GEval/OptionsParser.hs

@@ -26,6 +26,7 @@ import GEval.Core
 import GEval.CreateChallenge
 import GEval.LineByLine
 import GEval.Submit (submit)
+import GEval.BlackBoxDebugging
 
 import Data.Conduit.SmartSource
 
@@ -88,6 +89,7 @@ optionsParser = GEvalOptions
           <> help "When in line-by-line or diff mode, sort the results from the best to the worst"))
         <|> pure KeepTheOriginalOrder)
    <*> specParser
+   <*> blackBoxDebuggingOptionsParser
 
 precisionArgParser :: Parser Int
 precisionArgParser = option auto
@@ -162,6 +164,15 @@ specParser = GEvalSpecification
         )
       )
 
+blackBoxDebuggingOptionsParser :: Parser BlackBoxDebuggingOptions
+blackBoxDebuggingOptionsParser = BlackBoxDebuggingOptions
+  <$> option auto
+    ( long "min-frequency"
+      <> metavar "N"
+      <> help "Minimum frequency for the worst features"
+      <> value 1
+      <> showDefault)
+
 singletonMaybe :: Maybe a -> Maybe [a]
 singletonMaybe (Just x) = Just [x]
 singletonMaybe Nothing = Nothing
@@ -228,34 +239,41 @@ attemptToReadOptsFromConfigFile args opts = do
 
 
 runGEval'' :: GEvalOptions -> IO (Maybe [(SourceSpec, [MetricValue])])
-runGEval'' opts = runGEval''' (geoSpecialCommand opts) (geoResultOrdering opts) (geoSpec opts)
+runGEval'' opts = runGEval''' (geoSpecialCommand opts)
+                              (geoResultOrdering opts)
+                              (geoSpec opts)
+                              (geoBlackBoxDebugginsOptions opts)
 
-runGEval''' :: Maybe GEvalSpecialCommand -> ResultOrdering -> GEvalSpecification -> IO (Maybe [(SourceSpec, [MetricValue])])
+runGEval''' :: Maybe GEvalSpecialCommand
-runGEval''' Nothing _ spec = do
+              -> ResultOrdering
+              -> GEvalSpecification
+              -> BlackBoxDebuggingOptions
+              -> IO (Maybe [(SourceSpec, [MetricValue])])
+runGEval''' Nothing _ spec _ = do
   vals <- geval spec
   return $ Just vals
-runGEval''' (Just Init) _ spec = do
+runGEval''' (Just Init) _ spec _ = do
   initChallenge spec
   return Nothing
-runGEval''' (Just PrintVersion) _ _ = do
+runGEval''' (Just PrintVersion) _ _ _ = do
   putStrLn ("geval " ++ showVersion version)
   return Nothing
-runGEval''' (Just LineByLine) ordering spec = do
+runGEval''' (Just LineByLine) ordering spec _ = do
   runLineByLine ordering spec
   return Nothing
-runGEval''' (Just WorstFeatures) ordering spec = do
+runGEval''' (Just WorstFeatures) ordering spec bbdo = do
-  runWorstFeatures ordering spec
+  runWorstFeatures ordering spec bbdo
   return Nothing
-runGEval''' (Just (Diff otherOut)) ordering spec = do
+runGEval''' (Just (Diff otherOut)) ordering spec _ = do
   runDiff ordering otherOut spec
   return Nothing
-runGEval''' (Just (MostWorseningFeatures otherOut)) ordering spec = do
+runGEval''' (Just (MostWorseningFeatures otherOut)) ordering spec bbdo = do
-  runMostWorseningFeatures ordering otherOut spec
+  runMostWorseningFeatures ordering otherOut spec bbdo
   return Nothing
-runGEval''' (Just JustTokenize) _ spec = do
+runGEval''' (Just JustTokenize) _ spec _ = do
   justTokenize (gesTokenizer spec)
   return Nothing
-runGEval''' (Just Submit) _ spec = do
+runGEval''' (Just Submit) _ spec _ = do
   submit (gesGonitoHost spec) (gesToken spec) (gesGonitoGitAnnexRemote spec)
   return Nothing