-----------------------------------------------------------------------------
-- Copyright 2020, Ideas project team. This file is distributed under the
-- terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
module Domain.Hypothesis.BuggyRules 
   ( buggyRules
   , buggyTValueSided, buggyRValueSided, buggyZValueSided
   , buggyTValueTestValue, buggyRValueTestValue, buggyZValueTestValue
   , buggyChiValueSided, buggyChiValueTestValue
   ) where

import Control.Monad
import Data.List
import Domain.Hypothesis.Common
import Domain.Math.Data.Relation
import Domain.Math.Expr hiding ((.*.), (./.))
import Domain.Math.Numeric.Views
import Domain.Hypothesis.Rules
import Domain.Statistics.ComponentSet
import Domain.Statistics.Views
import Ideas.Common.Library

----------------------------------------------------------
-- Buggy rules

-- Transform the steps described below into a rule, the pattern is factored out.
-- The list can be freely appended with new buggy rules
buggyRules:: [Rule ComponentSet]
buggyRules =
  let _pat (f, name, descr) = (describe descr . buggyRule name) f
      _name_common x = "buggy.component." ++ x
  in map _pat
    [ ( wrongHARule
      , _name_common "ha"
      , "Choosing wrong alternative hypothesis"
      )
    , ( wrongAlphaRule
      , _name_common "alpha"
      , "Buggy rule for adding the wrong alpha"
      )
    , ( wrongDf
      , _name_common "df"
      , "Buggy rule for adding the wrong degrees of freedom"
      )
    ] ++ [buggyHypothesesSampleMean, buggyHASampleMean, buggyH0SampleMean]
      ++ buggyRulesTest
      ++ [ buggyTestZValueRule, buggyTestTValueRule
         , buggyTValuePositive
         , buggyZValueAlpha, buggyZValueSided, buggyZValueTestValue
         , buggyTValueAlpha, buggyTValueSided, buggyTValueDf, buggyTValueTestValue
         , buggyRValueAlpha, buggyRValueSided, buggyRValueDf, buggyRValueTestValue
         , buggyFValueAlpha, buggyFValueDf, buggyFValueTestValue
         , buggyChiValueAlpha, buggyChiValueSided, buggyChiValueDf, buggyChiValueTestValue
         , buggyTestValueCritical
         ]

alphaValues :: [Double]
alphaValues = [0.01, 0.05, 0.10]

alphaChiValues :: [Double]
alphaChiValues = [0.10, 0.05, 0.025, 0.01, 0.005]

sidedValues :: [Sided]
sidedValues = [TwoSided, LeftSided, RightSided]

incorrectDf :: Double -> [Double]
incorrectDf correctDf = [correctDf - 1, correctDf + 1, correctDf + 2]

confusingTestValue :: ComponentSet -> [Double]
confusingTestValue cs = do 
   r <- inferTestValue cs 
   matchM doubleView (rightHandSide r)

buggyTestValueCritical :: Rule ComponentSet
buggyTestValueCritical =
  describe "Buggy rule for confusing the test value with critical value" $
  buggyRule "buggy.component.test-value.critical" f
  where
    f :: ComponentSet -> Maybe ComponentSet
    f cs = do
      guard (derived cs `doesNotContain` TestValue)
      test  <- inferTestChoice cs
      var   <- inferVar cs
      alpha <- getExpr SignificanceLevel cs >>= match doubleView
      crit  <- 
         case test of
            Anova -> do
               (dfBetween, dfWithin) <- inferDfBetweenWithin cs
               computeCriticalF dfBetween dfWithin alpha
            ZTest -> do
               sided <- inferSidedness cs
               return $ computeCriticalZ sided alpha
            RPearson -> do
               sided <- inferSidedness cs
               df    <- inferDf cs >>= match doubleView
               return $ computeCriticalR sided alpha df
            _ | isTTest test -> do
               sided <- inferSidedness cs
               df    <- inferDf cs >>= match doubleView
               return $ computeCriticalT sided alpha df
            _ -> Nothing
      return $ append TestValue (CRelation $ var .==. toExpr crit) cs

------------------------------------------------------

buggyZValueAlpha :: Rule ComponentSet
buggyZValueAlpha =
  describe "Buggy rule for looking up a z-value with wrong alpha" .
  buggyRule "buggy.component.critical.z-value.alpha" $
     inferCriticalZWith $ \sided alpha ->
        [ computeCriticalZ sided a | a <- alphaValues, a /= alpha ]

buggyZValueSided :: Rule ComponentSet
buggyZValueSided =
  describe "Buggy rule for looking up a z-value with wrong sidedness" .
  buggyRule "buggy.component.critical.z-value.sided" $
     inferCriticalZWith $ \sided alpha ->
        [ computeCriticalZ s alpha | s <- sidedValues, s /= sided ]

buggyZValueTestValue :: Rule ComponentSet
buggyZValueTestValue =
  describe "Buggy rule for confusing z-value with test-value" .
  buggyRule "buggy.component.critical.z-value.test-value" $ \cs -> 
     inferCriticalZWith (\_ _ -> confusingTestValue cs) cs

------------------------------------------------------

buggyTValueAlpha :: Rule ComponentSet
buggyTValueAlpha =
  describe "Buggy rule for looking up a t-value with wrong alpha" .
  buggyRule "buggy.component.critical.t-value.alpha" $
     inferCriticalTWith $ \sided alpha df ->
        [ computeCriticalT sided a df | a <- alphaValues, a /= alpha ]

buggyTValueSided :: Rule ComponentSet
buggyTValueSided =
  describe "Buggy rule for looking up a t-value with wrong sidedness" .
  buggyRule "buggy.component.critical.t-value.sided" $
     inferCriticalTWith $ \sided alpha df ->
        [ computeCriticalT s alpha df | s <- sidedValues, s /= sided ]

buggyTValueDf :: Rule ComponentSet
buggyTValueDf =
  describe "Buggy rule for looking up a t-value with wrong df" .
  buggyRule "buggy.component.critical.t-value.df" $
     inferCriticalTWith $ \sided alpha df ->
        [ computeCriticalT sided alpha dfWrong | dfWrong <- incorrectDf df ]

buggyTValueTestValue :: Rule ComponentSet
buggyTValueTestValue =
  describe "Buggy rule for confusing t-value with test-value" .
  buggyRule "buggy.component.critical.t-value.test-value" $ \cs -> 
     inferCriticalTWith (\_ _ _ -> confusingTestValue cs) cs

------------------------------------------------------

buggyRValueAlpha :: Rule ComponentSet
buggyRValueAlpha =
  describe "Buggy rule for looking up a r-value with wrong alpha" .
  buggyRule "buggy.component.critical.r-value.alpha" $
     inferCriticalRWith $ \sided alpha df ->
        [ computeCriticalR sided a df | a <- alphaValues, a /= alpha ]

buggyRValueSided :: Rule ComponentSet
buggyRValueSided =
  describe "Buggy rule for looking up a r-value with wrong sidedness" .
  buggyRule "buggy.component.critical.r-value.sided" $
     inferCriticalRWith $ \sided alpha df ->
        [ computeCriticalR s alpha df | s <- sidedValues, s /= sided ]

buggyRValueDf :: Rule ComponentSet
buggyRValueDf =
  describe "Buggy rule for looking up a r-value with wrong df" .
  buggyRule "buggy.component.critical.r-value.df" $
     inferCriticalRWith $ \sided alpha df ->
        [ computeCriticalR sided alpha dfWrong | dfWrong <- incorrectDf df ]

buggyRValueTestValue :: Rule ComponentSet
buggyRValueTestValue =
  describe "Buggy rule for confusing r-value with test-value" .
  buggyRule "buggy.component.critical.r-value.test-value" $ \cs -> 
     inferCriticalRWith (\_ _ _ -> confusingTestValue cs) cs

------------------------------------------------------

buggyFValueAlpha :: Rule ComponentSet
buggyFValueAlpha =
  describe "Buggy rule for looking up f-value with wrong alpha" .
  buggyRule "buggy.component.critical.f-value.alpha" $
     inferCriticalFWith $ \dfBetween dfWithin alpha ->
        [ result
        | a <- [0.01, 0.05], a /= alpha 
        , result <- computeCriticalF dfBetween dfWithin a 
        ]

buggyFValueDf :: Rule ComponentSet
buggyFValueDf =
  describe "Buggy rule for looking up f-value with wrong df" .
  buggyRule "buggy.component.critical.f-value.df" $
     inferCriticalFWith $ \dfBetween dfWithin alpha ->
        [ result
        | dfB <- [dfBetween, 2]
        , dfW <- [dfWithin, 40]
        , dfBetween /= dfB || dfWithin /= dfW
        , result <- computeCriticalF dfB dfW alpha
        ]

buggyFValueTestValue :: Rule ComponentSet
buggyFValueTestValue =
  describe "Buggy rule for confusing f-value with test-value" .
  buggyRule "buggy.component.critical.f-value.test-value" $ \cs -> 
     inferCriticalFWith (\_ _ _ -> confusingTestValue cs) cs

------------------------------------------------------

buggyChiValueSided :: Rule ComponentSet
buggyChiValueSided =
  describe "Buggy rule for looking up a chi-value with wrong sidedness" .
  buggyRule "buggy.component.critical.chi-value.sided" $
     inferCriticalChiWith $ \sided alpha df ->
        [ result
        | s <- sidedValues
        , s /= sided 
        , result <- computeCriticalChi s alpha df 
        ]

buggyChiValueAlpha :: Rule ComponentSet
buggyChiValueAlpha =
  describe "Buggy rule for looking up chi-value with wrong alpha" .
  buggyRule "buggy.component.critical.chi-value.alpha" $
     inferCriticalChiWith $ \sided alpha df ->
        [ result
        | a <- alphaChiValues, a /= alpha 
        , result <- computeCriticalChi sided a df
        ]

buggyChiValueDf :: Rule ComponentSet
buggyChiValueDf =
  describe "Buggy rule for looking up chi-value with wrong df" .
  buggyRule "buggy.component.critical.chi-value.df" $
     inferCriticalChiWith $ \sided alpha df ->
        [ result 
        | dfWrong <- incorrectDf df 
        , result  <- computeCriticalChi sided alpha dfWrong 
        ]

buggyChiValueTestValue :: Rule ComponentSet
buggyChiValueTestValue =
  describe "Buggy rule for confusing chi-value with test-value" .
  buggyRule "buggy.component.critical.chi-value.test-value" $ \cs -> 
     inferCriticalChiWith (\_ _ _ -> confusingTestValue cs) cs

------------------------------------------------------

buggyHypothesesSampleMean :: Rule ComponentSet
buggyHypothesesSampleMean =
  describe "Buggy rule for adding one or two hypotheses using sample mean instead of population mean" $ 
  buggyRule "buggy.component.hypotheses-samplemean" f
  where
    f :: ComponentSet -> [ComponentSet]
    f cs = do
      guard (derived cs `doesNotContain` NullHypothesis)
      guard (derived cs `doesNotContain` AlternativeHypothesis)
      ha <- getRelation AlternativeHypothesis cs
      let h0 = h0FromHA ha
      sm <- getExpr SampleMean cs
      rtp <- nub [EqualTo, relationType h0]
      let h0'     = makeType rtp (leftHandSide h0) (rightHandSide h0)
          buggyH0 = makeType rtp (leftHandSide h0) sm
          buggyHA = makeType (relationType ha) (leftHandSide ha) sm
          results = 
             [ append AlternativeHypothesis (CRelation buggyHA) $
               append NullHypothesis (CRelation buggyH0) cs
             , append AlternativeHypothesis (CRelation ha) $
               append NullHypothesis (CRelation buggyH0) cs
             , append AlternativeHypothesis (CRelation buggyHA) $
               append NullHypothesis (CRelation h0') cs
             ]
      results

buggyH0SampleMean :: Rule ComponentSet
buggyH0SampleMean =
  describe "Buggy rule for adding h0 using sample mean instead of population mean" $ 
  buggyRule "buggy.component.h0-samplemean" f
  where
    f :: ComponentSet -> [ComponentSet]
    f cs = do
      guard (derived cs `doesNotContain` NullHypothesis)
      ha <- getRelation AlternativeHypothesis cs
      let h0 = h0FromHA ha
      sm <- getExpr SampleMean cs
      rtp <- nub [EqualTo, relationType h0]
      let buggyH0 = makeType rtp (leftHandSide h0) sm
      return $ append NullHypothesis (CRelation buggyH0) cs

buggyHASampleMean :: Rule ComponentSet
buggyHASampleMean =
  describe "Buggy rule for adding ha using sample mean instead of population mean" $ 
  buggyRule "buggy.component.ha-samplemean" f
  where
    f :: ComponentSet -> Maybe ComponentSet
    f cs = do
      guard (derived cs `doesNotContain` AlternativeHypothesis)
      ha <- getRelation AlternativeHypothesis cs
      sm <- getExpr SampleMean cs
      let buggyHA = makeType (relationType ha) (leftHandSide ha) sm
      return $ append AlternativeHypothesis (CRelation buggyHA) cs

buggyTestZValueRule :: Rule ComponentSet
buggyTestZValueRule =
  describe "Standard error instead of standard deviation" $
  buggyRule "buggy.component.test-z-value" f
  where
    f :: ComponentSet -> Maybe ComponentSet
    f cs = do
      guard (cs `doesNotContain` TestValue)
      let expr = (Var "M" - Var "mu") / Var "sigma"
      val  <- match doubleView (getSubstitution cs |-> expr)
      var  <- inferVar cs
      return $ append TestValue (CRelation (var .==. toExpr val)) cs

-- see buggyTestZValueRule: only difference is 's' instead of 'sigma'
buggyTestTValueRule :: Rule ComponentSet
buggyTestTValueRule =
  describe "Standard error instead of standard deviation" $ 
  buggyRule "buggy.component.test-t-value" f
  where
    f :: ComponentSet -> Maybe ComponentSet
    f cs = do
      guard (cs `doesNotContain` TestValue)
      let expr = (Var "M" - Var "mu") / Var "s"
      val  <- match doubleView (getSubstitution cs |-> expr)
      var  <- inferVar cs
      return $ append TestValue (CRelation (var .==. toExpr val)) cs

buggyTValuePositive :: Rule ComponentSet
buggyTValuePositive =
  buggyRule "buggy.component.critical.t-value-positive" f
 where
   f :: ComponentSet -> Maybe ComponentSet
   f cs = do
      cs' <- apply lookupTValueRule cs
      rel <- getRelation Critical cs'
      val <- match doubleView (rightHandSide rel)
      guard (val < 0)
      return $ append Critical (CRelation $ Var "tcrit" .==. toExpr (abs val)) cs

buggyRulesTest :: [Rule ComponentSet]
buggyRulesTest =
   [ buggyRule (makeId wrong correct) (wrongTest wrong correct)
   | wrong   <- types
   , correct <- types
   , wrong /= correct
   ]
 where
   types = [TTestOne, TTestTwo, TTestPaired, ZTest]
   makeId t1 t2 = "buggy.component." ++ show t1 ++ ".should-be-" ++ show t2

wrongTest :: TestType -> TestType -> ComponentSet -> Maybe ComponentSet
wrongTest wrong correct cs = do
   guard (derived cs `doesNotContain` TestChoice)
   let tests = validTests cs
   guard (correct `elem` tests)
   return $ append TestChoice (CChoice $ TestType wrong) cs

-- Wrong sidedness in alternative hypothesis (due to sample mean)
wrongHARule :: ComponentSet -> Maybe ComponentSet
wrongHARule cs =
  let relFromMean :: Double -> Double -> RelationType
      relFromMean mean mu
        | mean < mu = LessThanOrEqualTo
        | otherwise = GreaterThanOrEqualTo
  in do
    guard (cs `doesNotContain` AlternativeHypothesis)
    ha <- getRelation AlternativeHypothesis cs -- used to be Claim
    let h0    = h0FromHA ha
        h0Rel = relationType h0
    guard (h0Rel == EqualTo)
    let lhs = leftHandSide  ha
        rhs = rightHandSide ha
    rhs' <- match doubleView rhs
    mean <- match doubleView =<< getExpr SampleMean cs
    let rel = relFromMean mean rhs'
    return . append AlternativeHypothesis
      (CRelation (makeType rel lhs rhs)) $ cs

wrongAlphaRule :: ComponentSet -> Maybe ComponentSet
wrongAlphaRule cs = do
  guard (cs `doesNotContain` SignificanceLevel)
  return $ append SignificanceLevel (CExpr $ Number 0.1) cs

-- | Use the wrong df: t-tests are swapped so n instead of n-1 or n_1 + n_2 - 1
-- instead of n_1 + n_2 - 2
wrongDf :: ComponentSet -> Maybe ComponentSet
wrongDf cs =
  let dfWrong :: TestType -> Maybe Expr
      dfWrong TTestOne    = Just (Var "n")
      dfWrong TTestPaired = Just (Var "n")
      dfWrong TTestTwo    = Just (Var "n1" + Var "n2" - 1)
      dfWrong _           = Nothing
  in do
    guard (cs `doesNotContain` Df)
    test <- inferTestChoice cs
    df   <- dfWrong test
    return $ append Df (CExpr df) cs