From 8761965e8e3f82cb89fa53cfa8f44767424adaa0 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Thu, 30 Jan 2020 23:04:36 +0100 Subject: [PATCH] Add option to mark worst features --- geval.cabal | 2 + src/GEval/Core.hs | 5 +- src/GEval/FeatureExtractor.hs | 19 ++++++ src/GEval/LineByLine.hs | 112 ++++++++++++++++++++++++++++++++-- src/GEval/OptionsParser.hs | 34 +++++++---- 5 files changed, 152 insertions(+), 20 deletions(-) diff --git a/geval.cabal b/geval.cabal index 8d8ffe4..be45559 100644 --- a/geval.cabal +++ b/geval.cabal @@ -108,6 +108,8 @@ library , singletons , ordered-containers , random + , rainbow + , hpqtypes default-language: Haskell2010 executable geval diff --git a/src/GEval/Core.hs b/src/GEval/Core.hs index b8a4ed3..1762fe2 100644 --- a/src/GEval/Core.hs +++ b/src/GEval/Core.hs @@ -195,7 +195,7 @@ getExpectedDirectory spec = fromMaybe outDirectory $ gesExpectedDirectory spec -- | Special command, not just running the regular evaluation. -- See OptionsParser.hs for more information. data GEvalSpecialCommand = Init - | LineByLine | WorstFeatures + | LineByLine | LineByLineWithWorstFeatures | WorstFeatures | Diff FilePath | MostWorseningFeatures FilePath | PrintVersion | JustTokenize | Submit | Validate | ListMetrics @@ -209,7 +209,8 @@ data GEvalOptions = GEvalOptions geoFilter :: Maybe String, geoSpec :: GEvalSpecification, geoBlackBoxDebugginsOptions :: BlackBoxDebuggingOptions, - geoGraphFile :: Maybe FilePath } + geoGraphFile :: Maybe FilePath, + geoMarkWorstFeatures :: Bool } defaultGEvalSpecification = GEvalSpecification { diff --git a/src/GEval/FeatureExtractor.hs b/src/GEval/FeatureExtractor.hs index 6fee40e..c2552e3 100644 --- a/src/GEval/FeatureExtractor.hs +++ b/src/GEval/FeatureExtractor.hs @@ -19,6 +19,7 @@ module GEval.FeatureExtractor FeatureNamespace(..), References(..), ReferencesData(..), + toTextualContent, filterExistentialFactors) where @@ -223,3 +224,21 @@ filterExistentialFactors :: [PeggedFactor] -> [PeggedExistentialFactor] filterExistentialFactors factors = catMaybes $ Prelude.map toExistential factors where toExistential (PeggedFactor namespace (SimpleExistentialFactor factor)) = Just $ PeggedExistentialFactor namespace factor toExistential _ = Nothing + +class WithTextualContent a where + toTextualContent :: a -> Maybe Text + +instance WithTextualContent PeggedFactor where + toTextualContent (PeggedFactor _ factor) = toTextualContent factor + +instance WithTextualContent SimpleFactor where + toTextualContent (SimpleExistentialFactor eFactor) = toTextualContent eFactor + toTextualContent (NumericalFactor _ _) = Nothing + +instance WithTextualContent ExistentialFactor where + toTextualContent (SimpleAtomicFactor aFactor) = toTextualContent aFactor + toTextualContent (BigramFactor _ _) = Nothing + +instance WithTextualContent AtomicFactor where + toTextualContent (TextFactor t) = Just t + toTextualContent (ShapeFactor _) = Nothing diff --git a/src/GEval/LineByLine.hs b/src/GEval/LineByLine.hs index 58b14ba..93d4305 100644 --- a/src/GEval/LineByLine.hs +++ b/src/GEval/LineByLine.hs @@ -9,6 +9,7 @@ module GEval.LineByLine (runLineByLine, + runLineByLineWithWorstFeatures, runWorstFeatures, runLineByLineGeneralized, runDiff, @@ -26,6 +27,8 @@ import GEval.Common import GEval.EvaluationScheme import Text.Tokenizer +import System.IO + import Data.Conduit.AutoDecompress (doNothing) import Data.Conduit @@ -35,12 +38,12 @@ import qualified Data.Conduit.Text as CT import Data.Text import Data.Text.Encoding import Data.Conduit.Rank -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Either (rights) import qualified Data.Vector as V -import Data.List (sortBy, sortOn, sort, concat, maximumBy) +import Data.List (sortBy, sortOn, sort, concat, maximumBy, intersperse) import Control.Monad.IO.Class import Control.Monad.Trans.Resource @@ -48,6 +51,7 @@ import Data.Conduit.Lift import Control.Monad.State.Strict import Data.Monoid ((<>)) +import Data.Monoid.Utils (mintercalate) import GEval.FeatureExtractor import GEval.BlackBoxDebugging @@ -71,6 +75,8 @@ import qualified Data.HashMap.Strict as H import qualified Data.Map.Strict as M import qualified Data.Set as S +import Rainbow (Chunk, (&), magenta, cyan, fore, bold, yellow, brightYellow, red, brightRed, chunk, chunksToByteStrings, byteStringMakerFromEnvironment, byteStringMakerFromHandle, ByteString) + data LineRecord = LineRecord Text Text Text Word32 MetricValue deriving (Eq, Show) @@ -99,7 +105,103 @@ runLineByLine ordering featureFilter spec bbdo = runLineByLineGeneralized orderi formatScore :: MetricValue -> Text formatScore = Data.Text.pack . printf "%f" -runFeatureFilter :: (Monad m, FeatureSource s) => Maybe String -> GEvalSpecification -> BlackBoxDebuggingOptions -> Maybe References -> ConduitT s s m () +data LineSpan = UnmarkedSpan Text | MarkedSpan Double Text + deriving (Eq, Show) + +runLineByLineWithWorstFeatures :: ResultOrdering -> Maybe String -> GEvalSpecification -> BlackBoxDebuggingOptions -> IO () +runLineByLineWithWorstFeatures ordering featureFilter spec bbdo = do + maker <- byteStringMakerFromEnvironment + let consum = CL.map (recordToBytes maker) .| CC.unlinesAscii .| CC.stdout + runLineByLineWithWorstFeaturesGeneralized ordering featureFilter spec bbdo consum + +recordToBytes :: (Chunk Text -> [ByteString] -> [ByteString]) -> SpanLineRecord -> ByteString +recordToBytes maker (SpanLineRecord inSpans expSpans outSpans score) = + mintercalate "\t" [lineToBytes maker inSpans, + lineToBytes maker expSpans, + lineToBytes maker outSpans, + encodeUtf8 $ formatScore score] + where formatScore :: MetricValue -> Text + formatScore = Data.Text.pack . printf "%f" + + +lineToBytes :: (Chunk Text -> [ByteString] -> [ByteString]) -> [LineSpan] -> ByteString +lineToBytes maker spans = + mconcat + $ chunksToByteStrings maker + $ Data.List.intersperse (chunk " ") + $ Prelude.map spanToRainbowChunk $ spans + +spanToRainbowChunk :: LineSpan -> Chunk Text +spanToRainbowChunk (UnmarkedSpan t) = chunk t +spanToRainbowChunk (MarkedSpan p t) = markedChunk p c + where c = chunk t + +markedChunk :: Double -> Chunk Text -> Chunk Text +markedChunk pValue c + | pValue < 0.000000000000001 = bold c & fore brightRed + | pValue < 0.000000000001 = c & fore red + | pValue < 0.000001 = c & fore magenta + | pValue < 0.001 = bold c + | otherwise = c + +markBadFeatures :: (M.Map PeggedFactor Double) -> (Maybe Tokenizer) -> BlackBoxDebuggingOptions -> Text -> Text -> [LineSpan] +markBadFeatures worstFeaturesMap mTokenizer bbdo field line = + catMaybes + $ Prelude.map (featureToLineSpan worstFeaturesMap) + $ extractFactors mTokenizer bbdo Nothing field line + +markBadFeaturesInTabbed :: (M.Map PeggedFactor Double) -> (Maybe Tokenizer) -> BlackBoxDebuggingOptions -> Text -> Text -> [LineSpan] +markBadFeaturesInTabbed worstFeaturesMap mTokenizer bbdo field line = + catMaybes + $ Prelude.map (featureToLineSpan worstFeaturesMap) + $ extractFactorsFromTabbed mTokenizer bbdo Nothing field line + + +doMarking worstFeaturesMap mTokenizer bbdo (LineRecord inpLine expLine outLine _ score) = + SpanLineRecord (markBadFeaturesInTabbed worstFeaturesMap mTokenizer bbdo "in" inpLine) + (markBadFeatures worstFeaturesMap mTokenizer bbdo "exp" expLine) + (markBadFeatures worstFeaturesMap mTokenizer bbdo "out" outLine) + score + +featureToLineSpan :: (M.Map PeggedFactor Double) -> PeggedFactor -> Maybe LineSpan +featureToLineSpan worstFeaturesMap pf = featureToLineSpan' (M.lookup pf worstFeaturesMap) pf + where featureToLineSpan' Nothing pf = UnmarkedSpan <$> toTextualContent pf + featureToLineSpan' (Just pValue) pf = MarkedSpan pValue <$> toTextualContent pf + +data SpanLineRecord = SpanLineRecord [LineSpan] [LineSpan] [LineSpan] MetricValue + deriving (Eq, Show) + +runLineByLineWithWorstFeaturesGeneralized :: ResultOrdering + -> Maybe String + -> GEvalSpecification + -> BlackBoxDebuggingOptions + -> ConduitT SpanLineRecord Void (ResourceT IO) r + -> IO r +runLineByLineWithWorstFeaturesGeneralized ordering featureFilter spec bbdo consum = do + hPutStrLn stderr "Looking for worst features..." + worstFeatures <- runLineByLineGeneralized ordering' spec (\mReferences -> worstFeaturesPipeline False spec bbdo mReferences (CL.take 100)) + let worstFeaturesMap = M.fromList + $ catMaybes + $ Prelude.map featureToFactor + $ Prelude.map (\(FeatureWithPValue feature pValue _ _) -> (feature, pValue)) worstFeatures + + runLineByLineGeneralized ordering spec (consum' worstFeaturesMap) + where consum' worstFeaturesMap = (\mReferences -> (runFeatureFilter featureFilter spec bbdo mReferences + .| CL.map (doMarking worstFeaturesMap mTokenizer bbdo) + .| consum)) + ordering' = forceSomeOrdering ordering + mTokenizer = gesTokenizer spec + +featureToFactor :: (Feature, Double) -> Maybe (PeggedFactor, Double) +featureToFactor ((UnaryFeature (PeggedExistentialFactor namespace (SimpleAtomicFactor factor))), p) = + Just (PeggedFactor namespace (SimpleExistentialFactor (SimpleAtomicFactor factor)), p) +featureToFactor _ = Nothing + +runFeatureFilter :: (Monad m, FeatureSource s) => Maybe String + -> GEvalSpecification + -> BlackBoxDebuggingOptions + -> Maybe References + -> ConduitT s s m () runFeatureFilter Nothing _ _ _ = doNothing runFeatureFilter (Just feature) spec bbdo mReferences = CC.map (\l -> (fakeRank, l)) .| featureExtractor mTokenizer bbdo mReferences @@ -121,8 +223,8 @@ worstFeaturesPipeline :: Bool -> GEvalSpecification -> BlackBoxDebuggingOptions -> Maybe References - -> ConduitT FeatureWithPValue Void (ResourceT IO) () - -> ConduitT LineRecord Void (ResourceT IO) () + -> ConduitT FeatureWithPValue Void (ResourceT IO) a + -> ConduitT LineRecord Void (ResourceT IO) a worstFeaturesPipeline reversed spec bbdo mReferences consum = rank (lessByMetric reversed $ gesMainMetric spec) .| evalStateC 0 (extractFeaturesAndPValues spec bbdo mReferences) .| CC.filter (\(FeatureWithPValue _ p _ _) -> not $ isNaN p) -- NaN values would poison sorting diff --git a/src/GEval/OptionsParser.hs b/src/GEval/OptionsParser.hs index e10d109..2c53239 100644 --- a/src/GEval/OptionsParser.hs +++ b/src/GEval/OptionsParser.hs @@ -121,6 +121,10 @@ optionsParser = GEvalOptions ( long "plot-graph" <> metavar "FILE-PATH" <> help "Plot an extra graph, applicable only for Probabilistic-MultiLabel/Soft-F-score (LOESS function for calibration)")) + <*> switch + ( long "mark-worst-features" + <> help "Mark worst features when in the line-by-line mode") + precisionArgParser :: Parser Int precisionArgParser = option auto @@ -322,6 +326,7 @@ runGEval'' opts = runGEval''' (geoSpecialCommand opts) (geoSpec opts) (geoBlackBoxDebugginsOptions opts) (geoGraphFile opts) + (geoMarkWorstFeatures opts) runGEval''' :: Maybe GEvalSpecialCommand -> ResultOrdering @@ -329,8 +334,9 @@ runGEval''' :: Maybe GEvalSpecialCommand -> GEvalSpecification -> BlackBoxDebuggingOptions -> Maybe FilePath + -> Bool -> IO (Maybe [(SourceSpec, [MetricResult])]) -runGEval''' Nothing _ _ spec _ mGraphFile = do +runGEval''' Nothing _ _ spec _ mGraphFile _ = do vals' <- geval spec let vals = map (\(s, val) -> (s, map getMetricValue val)) vals' case mGraphFile of @@ -339,37 +345,39 @@ runGEval''' Nothing _ _ spec _ mGraphFile = do mapM_ (\(ix, d) -> (plotGraph (getGraphFilename ix graphFile) d)) $ zip [0..] graphsData Nothing -> return () 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 featureFilter spec bbdo _ = do - runLineByLine ordering featureFilter spec bbdo +runGEval''' (Just LineByLine) ordering featureFilter spec bbdo _ markWorstFeatures = do + if markWorstFeatures + then runLineByLineWithWorstFeatures ordering featureFilter spec bbdo + else runLineByLine ordering featureFilter spec bbdo return Nothing -runGEval''' (Just WorstFeatures) ordering _ spec bbdo _ = do +runGEval''' (Just WorstFeatures) ordering _ spec bbdo _ _ = do runWorstFeatures ordering spec bbdo return Nothing -runGEval''' (Just (Diff otherOut)) ordering featureFilter spec bbdo _ = do +runGEval''' (Just (Diff otherOut)) ordering featureFilter spec bbdo _ _ = do runDiff ordering featureFilter otherOut spec bbdo return Nothing -runGEval''' (Just (MostWorseningFeatures otherOut)) ordering _ spec bbdo _ = do +runGEval''' (Just (MostWorseningFeatures otherOut)) ordering _ spec bbdo _ _ = do 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 -runGEval''' (Just Validate) _ _ spec _ _ = do +runGEval''' (Just Validate) _ _ spec _ _ _ = do validateChallenge spec return Nothing -runGEval''' (Just ListMetrics) _ _ _ _ _ = do +runGEval''' (Just ListMetrics) _ _ _ _ _ _ = do listMetrics return Nothing -runGEval''' (Just OracleItemBased) _ _ spec _ _ = do +runGEval''' (Just OracleItemBased) _ _ spec _ _ _ = do runOracleItemBased spec return Nothing