module Bayes.Script
( taskConcepts
, emptyConcepts
, aggregateConcepts
, aggregateConcepts'
, findEvidence
, addModelToLatestRequest
) where
import Bayes.Evidence
import Bayes.EliminationOrdering ( minFactorOrder )
import Bayes.Inference ( infer, toEvidence )
import Bayes.Network
import Data.List hiding (insert)
import Data.Maybe
import Data.Function ( on )
import Control.Monad ( (>=>) )
import Database.HDBC
import Database.HDBC.Sqlite3
import Ideas.Common.Id ( showId )
import qualified Ideas.Text.XML as XML ( fromXML, XML, parseXML, findChild )
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Task.Network.StudentModel as StudentModel
import Recognize.Data.MathStoryProblem (Task(Task), singleNetwork)
import Bayes.Probability
import Database.Data
import Main.Tasks ( tasks, findTaskFuzzy )
addModelToLatestRequest :: Connection -> IO ()
addModelToLatestRequest conn = do
r <- fromMaybe (error "No request to add model to.") <$> latestRecord conn
let xmlInput = either (error "Could not read XML") id . XML.parseXML $ r ! "input"
(sID, tID) = fromMaybe mempty . collectIDs $ xmlInput
inputIDs = intercalate "," . map fst . fromMaybe mempty . collectInputs $ xmlInput
reqnr = r ! "rowid" :: Int
ev <- findEvidence $ r ! "output"
let partialModel = taskConcepts tID ev
partialModels <- latestPartialModels conn sID
let studentModel = aggregateConcepts $ (tID, partialModel) : partialModels
insertRecord conn studentsTable
( insert "studentid" sID
. insert "taskid" tID
. insert "inputs" inputIDs
. insert "requestnr" reqnr
. insert "evidence" ev
. insert "studentmodel" studentModel
. insert "partialmodel" partialModel
$ mempty )
commit conn
findEvidence :: Monad m => XML.XML -> m Evidence
findEvidence = XML.findChild "diagnosis" >=> XML.findChild "evidence" >=> XML.fromXML
taskConcepts :: TaskID -> Evidence -> Evidence
taskConcepts tID ev =
let nw = maybe (error $ "no such task " ++ tID) (\(Task t) -> singleNetwork t) $ findTaskFuzzy tID
in filterEvidence isConcept . toEvidence nw $ infer nw ev minFactorOrder (S.filter isConcept (nodeIds nw))
emptyConcepts :: [ (TaskID, Evidence) ]
emptyConcepts = flip map tasks $ \t -> let tID = showId t in (tID, taskConcepts tID mempty)
aggregateConcepts' :: [ (TaskID, Evidence) ] -> Evidence
aggregateConcepts' precalculatedTaskConcepts
= toEvidence StudentModel.network
. M.map ((\x->[x,1-x]) . bayesAverage)
. M.fromListWith (++) $
[ (concept, [fromDouble . fromRational $ probability])
| Task t <- tasks
, let taskConcepts' = fromJust . lookup (showId t) $ precalculatedTaskConcepts ++ emptyConcepts
, (taskConcept, stateLabel, probability) <- allProbabilities taskConcepts'
, stateLabel == "Yes" || stateLabel == "State0" || stateLabel == "Correct" || stateLabel == "Correctr"
, concept <- maybeToList . getConcept $ taskConcept
]
aggregateConcepts :: [ (TaskID, Evidence) ] -> Evidence
aggregateConcepts p = aggregateConcepts' p `mappend` mconcat (map snd . nubBy ((==) `on` fst) $ p ++ emptyConcepts)
bayesAverage :: [Probability] -> Probability
bayesAverage ps = sum ps / fromIntegral (length ps)
getConcept :: String -> Maybe String
getConcept ct =
let cs = takeWhile (/= '_') $ ct
in if cs `S.member` nodeIds StudentModel.network
then Just cs
else Nothing
isConcept :: String -> Bool
isConcept = isJust . getConcept