Advise-me-0.1: app/DatabaseBuilder.hs
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, CPP #-}
{-|
Module : Main
Description : Program for re-building the Advise-Me database offline.
Intended to be used seperately from the main software. It can do the following:
- Remove double requests and merge those requests which provide inputs for
subtasks of the same task.
- Rerun the domain reasoner.
- Rerun the student models.
-}
module Main (main) where
import qualified GHC.IO.Encoding as E
import Data.Time.Clock (UTCTime)
import Data.Time.Format (parseTimeM, defaultTimeLocale)
import Data.List (sortBy, nubBy, foldl', intercalate, isPrefixOf, nub)
import Data.Char (isSpace)
import Data.Function (on)
import Data.Monoid ((<>))
import Data.Maybe (fromJust, fromMaybe, isJust)
import Control.Monad (unless, when, forM_, forM)
import Control.Applicative ((<**>))
import Control.Arrow ((&&&))
import Database.HDBC.Sqlite3 (connectSqlite3, setBusyTimeout, Connection)
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Control.Monad.State.Lazy as S
import qualified Options.Applicative as O
import qualified Ideas.Text.XML as XML
--import qualified Ideas.Text.XML.Interface as XML
import qualified Ideas.Text.UTF8 as WorkaroundUTF8
import qualified Database.HDBC as SQL
import qualified Data.ByteString.Char8 as Char8
import qualified Data.Text.Encoding as T ( decodeLatin1 )
import Ideas.Common.Id (showId)
import Util.NumberRange (NumberRange, range)
import Util.List (concatMapM, index)
import Util.String (split, replace, trim, splitOn, strToLower)
import Main.Tasks (tasks)
import Main.ParserCSV (readFileCSV)
import Service.AdviseMe (runDomainReasoner)
import Bayes.Script ( findEvidence, taskConcepts, aggregateConcepts )
import Bayes.Evidence (Evidence, evStates)
import Database.Data
import System.FilePath ( (</>) )
#ifdef XLSX
import Database.HumanAssessment ( readEvidence, tally', getSpreadsheet, getHumanMachineFiles, Tally(..), Match(..) )
#endif
-------------------------------------------------------------------------------
-- * Interface
data Arguments = Arguments
{ inDBs :: [FilePath]
, outDB :: FilePath
, appendFlag :: Bool
, generatedEvidence :: Maybe FilePath
#ifdef XLSX
, replaceEvidenceArg :: [FilePath]
#endif
, taskFilterArg :: Maybe [String]
, trimFlag :: Bool
, collapseFlag :: Bool
, fixNumbersFlag :: Bool
, drFlag :: Bool
, smFlag :: Bool
, writeFinalModelsFlag :: Bool
#ifdef XLSX
, writeHumanAssessmentTableFlag :: [FilePath]
#endif
, fixEncodingFlag :: Bool
, fixPepiteFlag :: Bool
, anonymizeFlag :: Bool
}
cli :: IO Arguments
cli = O.execParser $ O.info (args <**> infoArgs <**> O.helper) info
where
info :: O.InfoMod Arguments
info = O.progDesc "Advise-Me database rebuilder"
infoArgs =
O.infoOption
( "Available tasks: " ++ intercalate ", " taskIDs )
( O.short 'l' <>
O.long "list-tasks" <>
O.help "List available task IDs"
)
args :: O.Parser Arguments
args = Arguments
<$>
( O.many . O.strOption $
O.short 'i' <> O.long "input" <>
O.help "Input database(s)"
)
<*>
( O.strOption $
O.short 'o' <> O.long "output" <>
O.help "Output database"
)
<*>
( O.switch $
O.short 'a' <> O.long "append" <>
O.help "Whether to overwrite or append to an existing table"
)
<*>
( O.optional . O.strOption $
O.short 'g' <> O.long "generate" <>
O.help "Generate simulated students from evidence for tasks in CSV files"
)
#ifdef XLSX
<*>
( O.many . O.strOption $
O.long "replace-evidence" <>
O.help "Replace evidence for existing students with evidence from human-assessed spreadsheet"
)
#endif
<*>
( fmap (fmap $ map trim . split ',') . O.optional . O.strOption $
O.long "filter" <>
O.help "Put requests in the given order; discard all others (expects comma-seperated list of task IDs)"
)
<*>
( O.switch $
O.long "no-empty" <>
O.help "Discard input that consist solely of whitespace"
)
<*>
( O.switch $
O.long "collapse" <>
O.help "Merge subtask requests and keep only final input"
)
<*>
( O.switch $
O.long "fix-numbers" <>
O.help "Update answers to tasks in which numbers have changed; this is a hack to test for regressions with old data"
)
<*>
( O.switch $
O.long "evidence" <>
O.help "Rerun the domain reasoner (implies --models)"
)
<*>
( O.switch $
O.long "models" <>
O.help "Rerun the task- and student models"
)
<*>
( O.switch $
O.long "models-table" <>
O.help "Add a table that details the final student models"
)
#ifdef XLSX
<*>
( O.many . O.strOption $
O.long "human-assessment-table" <>
O.help "Add a table detailing human assessments based on the given spreadsheet(s)"
)
#endif
<*>
( O.switch $
O.long "fix-encoding" <>
O.help "Fix encoding issues: transforms input in ISO-8859-1 to UTF-8"
)
<*>
( O.switch $
O.long "fix-pepite" <>
O.help "Fix incorrect Pépite requests"
)
<*>
( O.switch $
O.long "anonymize" <>
O.help "Anonymize student data"
)
main :: IO ()
main = do
E.setLocaleEncoding E.utf8
arg <- cli
let filterFlag = isJust . taskFilterArg
taskFilter = fromMaybe [] $ taskFilterArg arg
inConns <- mapM connectSqlite3 (inDBs arg)
-- Test if a students table already exist
(anyStudentsTable, allStudentsTable) <- do
hasTable <- map ("students" `elem`) <$> mapM SQL.getTables inConns
return (or hasTable, and hasTable)
-- Check for nonsensical commands
unless (smFlag arg `implies` (allStudentsTable || drFlag arg)) $
error "Cannot run student modeller without evidence. Either run --evidence or make sure your input databases already contain students tables."
unless ((filterFlag arg) `implies`
(not anyStudentsTable || smFlag arg)) $
error "Your flags imply that requests may be changed, but your database contains a students table. Also run --models to make sure the models stay consistent."
forM_ taskFilter $ \tID ->
when (not $ tID `elem` taskIDs) $
error $ "Task ID \"" ++ tID ++ "\" is not recognized."
-- Determine the order in which the requests are sent
let sortRequests
| filterFlag arg = return . sortBy
(\x y -> compareFilter taskFilter x y
<> compareTimes x y)
| otherwise = return . sortBy compareAppearance
-- Obtain requests from all databases and perform operations
processedRecords <- concatMapM allRecords inConns
>>= task "fix encoding"
fixEncoding (fixEncodingFlag arg)
>>= task "filling in missing information"
decorateRequests True
>>= task "removing rectanglearea_old"
(return . filter (\r -> r ! "taskid" /= "rectanglearea_old")) True
>>= task "filtering tasks"
(filterTasks taskFilter) (filterFlag arg)
>>= task "Anonymizing data"
anonymize (anonymizeFlag arg)
>>= task "fix Pépite"
fixPepite (fixPepiteFlag arg)
>>= task "collapsing multiple requests for same task"
collapseRequests (collapseFlag arg)
>>= task "trimming empty inputs from requests"
trimEmptyRequests (trimFlag arg)
>>= task "changing numbers in old task answers"
changeNumbersInOldRequests (fixNumbersFlag arg)
>>= task "determining request order"
sortRequests True
>>= task "domain reasoner"
domainReasoner (drFlag arg)
#ifdef XLSX
>>= task "replacing evidence, drawing from human assessments"
(replaceEvidence $ replaceEvidenceArg arg) (length (replaceEvidenceArg arg) > 0)
#endif
>>= task "student modeller"
studentModeller (smFlag arg || drFlag arg)
-- Obtain generated evidence
generatedRecords <- maybe (return []) simulateStudents (generatedEvidence arg)
-- Combine both
records <-
task "numbering requests"
(return . addRequestNumbers) True (processedRecords ++ generatedRecords)
-- Output connection
conn <- connectSqlite3 (outDB arg)
setBusyTimeout conn 200
-- Always write requests table
unless (appendFlag arg) $ dropTable conn requestsTable
createTable conn requestsTable
insertRecords conn requestsTable records
-- Write students table if we have enough information
when (allStudentsTable || drFlag arg || null records) $ do
unless (appendFlag arg) $ dropTable conn studentsTable
createTable conn studentsTable
insertRecords conn studentsTable records
-- Write final models table
when (writeFinalModelsFlag arg) $
addModelsTable conn records
#ifdef XLSX
-- Write final models table
let humanAssessments = writeHumanAssessmentTableFlag arg
let allObserved = foldl (\m r -> M.insertWith mappend (r!"studentid",r!"taskid") (r ! "evidence") m) mempty records
when (not $ null humanAssessments) $ do
tallies <- forM humanAssessments $ \path -> do
xlsx <- getSpreadsheet path
tally' xlsx allObserved
writeHumanAssessmentTable conn . mconcat . concat . map M.elems $ tallies
#endif
-- Finalize
SQL.commit conn
SQL.disconnect conn
mapM_ SQL.disconnect inConns
-- | Auxiliary: List all possible task IDs.
taskIDs :: [String]
taskIDs = map showId tasks
-- | Auxiliary: Logical material implication.
implies :: Bool -> Bool -> Bool
x `implies` y = not x || y
-- | Since there is no way I can see to uniquely identify a record logged by
-- Ideas, we add request numbers in the following way. This should happen last,
-- so that we can be certain that the request numbers really correspond to the
-- correct requests. (In fact, identifying by row ID's will also work since
-- they should correspond one to one in the live database.)
addRequestNumbers :: [SqlRecord] -> [SqlRecord]
addRequestNumbers = zipWith (insert "requestnr") [1 :: Int ..]
-------------------------------------------------------------------------------
-- * Sorting functions
-- | Compare records by the index of their task ID w.r.t. the given list.
compareFilter :: [TaskID] -> SqlRecord -> SqlRecord -> Ordering
compareFilter taskFilter = compare `on` (index taskFilter . (! "taskid"))
-- | Compare records by their logged time.
compareTimes :: SqlRecord -> SqlRecord -> Ordering
compareTimes = compare `on` ((! "time") :: SqlRecord -> UTCTime)
-- | Compare records by their order of appearance in the original database.
compareAppearance :: SqlRecord -> SqlRecord -> Ordering
compareAppearance = compare `on` ((! "rowid") :: SqlRecord -> Integer)
-------------------------------------------------------------------------------
-- * Processing steps
--
-- Note, in general, that due to laziness the logging messages might not
-- correspond to actual running time. Perhaps a proper debugging logger would
-- be helpful.
-- | Decorate processing function with information and possibly skip the
-- function.
task :: String
-> ([SqlRecord] -> IO [SqlRecord])
-> Bool
-> ([SqlRecord] -> IO [SqlRecord])
task report function True rows = do
putStrLn $ "Running: " ++ report ++ "…"
function rows
task report _ False rows = do
putStrLn $ "Skipping: " ++ report ++ "."
return rows
-- | Discard records for all requests for tasks that are not given as an
-- argument.
filterTasks :: [String] -> [SqlRecord] -> IO [SqlRecord]
filterTasks tIDs = return . filter (\r -> r ! "taskid" `elem` tIDs)
-- | There are three seperate issues that have affected the encoding of pilot
-- data:
--
-- 1. When parsing XML, some HTML entities get transformed to their unescaped
-- Unicode character counterpart.
-- 2. When parsing XML, Unicode characters wreak havoc.
-- 3. When writing XML, it is encoded as ISO-8859-1 rather than UTF-8. This
-- causes issues since data written to the Sqlite database is assumed to be
-- UTF-8.
--
-- See issue #239 for a description on how these interplay.
--
-- Since the pilot data has already been collected, this function re-encodes
-- the wrongly encoded Unicode characters, after which they are replaced with
-- corresponding HTML entities. For future data, this should not be necessary:
-- we should always use UTF-8, we should never auto-unescape, and we should
-- either always expect escaped characters, or understand Unicode.
fixEncoding :: [SqlRecord] -> IO [SqlRecord]
fixEncoding records = do
forM records $ \record ->
let input = addCodepoints . fixEntities . T.unpack . T.decodeLatin1 . Char8.pack $ record ! "input"
in do
--mapM putChar (filter (\x -> not $ x == '\10' || x >= ' ' || x <= '~') input)
return . insert "input" input $ record
where
-- | Temporary solution to solve issue #240 & #253. The issue was that
-- parseXML expects a string without actual Unicode characters - not a
-- bytestring, but one that only contains Unicode code points nonetheless,
-- which it will try to decode. This is wrong and should change in later
-- versions of IDEAS, but for now we will encode the string to avoid issues.
addCodepoints :: String -> String
addCodepoints = id --WorkaroundUTF8.encode
-- | Fix HTML entities DWO sent wrong. (see issue #242)
fixEntities :: String -> String
fixEntities = flip (foldr ($)) $ map (uncurry replace)
[ ("<;","<") -- This is super hacky, but so is the problem itself
, ("<","<")
]
-- | Add identifying information that is not logged by Ideas. Clearly, this is
-- not an ideal solution, but it will do for now.
decorateRequests :: [SqlRecord] -> IO [SqlRecord]
decorateRequests = mapM $ \record ->
let input = record ! "input"
(sID,tID) = fromJust . collectIDs $ input
iIDs = intercalate "," . map fst . fromJust . collectInputs $ input
rID = range [record ! "rowid"]
in return
. insert "inputs" iIDs
. insert "studentid" sID
. insert "taskid" tID
. insert "original" rID
$ record
-- | Translate student IDs to anonymized IDs.
anonymize :: [SqlRecord] -> IO [SqlRecord]
anonymize records =
let translation :: M.Map String String
translation = M.fromList $ zip (nub $ map (! "studentid") records) (map show [1..])
in forM records $ \record -> do
let sID' = translation M.! (record ! "studentid")
return $ insert "studentid" sID'
. insert "input" (setID sID' $ record ! "input")
. insert "output" (setID sID' $ record ! "output")
$ record
where
setID :: String -> XML.XML -> XML.XML
setID sID = XML.foldXML (\t as cs -> XML.makeXML t . mconcat $ map (mkAttr' sID) as ++ map (either XML.string XML.builder) cs) id id
mkAttr' :: String -> XML.Attribute -> XML.XMLBuilder
mkAttr' sID ("userid" XML.:= _) = "userid" XML..=. sID
mkAttr' sID ("user" XML.:= _) = "user" XML..=. sID
mkAttr' sID (n XML.:= a) = n XML..=. a
-- | Collapse subtasks, such that every student/task pair has only a single
-- request, namely, a merger of all requests for that pair.
collapseRequests :: [SqlRecord] -> IO [SqlRecord]
collapseRequests records = do
--forM records $ \record -> do
-- mapM (\x -> putStrLn $ show x ++ show (fromEnum x)) (record ! "input" :: String)
-- print $ XML.parseXML (record ! "input")
-- Extract decorated records and reinsert the XML
let collapsed = map (uncurry $ insert "input") . M.elems
-- Map student/task pairs to decorated records
. foldl' (\m e -> M.insertWith merger (getKey e) e m) M.empty
-- Decorate each record with its XML, to avoid re-parsing it on every merge
. map ((! "input") &&& id)
$ records
putStrLn $ "Collapsed " ++ show (length records) ++ " records into " ++ show (length collapsed) ++ "."
return collapsed
where
merger (newXML, r1) (oldXML, r2) = (fromJust $ mergeRequest newXML oldXML, mergeIDs r1 r2)
getKey :: (XML.XML, SqlRecord) -> (StudentID, TaskID)
getKey = fromJust . collectIDs . fst
-- keep the rightmost record but merge its id with the left record
mergeIDs :: SqlRecord -> SqlRecord -> SqlRecord
mergeIDs x y = insert "original" (x ! "original" <> y ! "original" :: NumberRange) x
-- Merge two request XMLs such that the result contains the inputs of both,
-- but is otherwise identical to the one in the first argument.
mergeRequest :: Monad m => XML.XML -> XML.XML -> m XML.XML
mergeRequest new old = do
new' <- collectInputs new
old' <- collectInputs old
return . replaceInputs new
. map (Right . snd)
. sortBy (compare `on` fst)
. nubBy ((==) `on` fst)
$ new' ++ old'
mkAttr (n XML.:= a) = n XML..=. a
mkContent f = either XML.string (XML.builder . f)
-- | Auxiliary: Remove the inputs from a request and replace them with the
-- given inputs.
replaceInputs :: XML.XML -> [Either String XML.XML] -> XML.XML
replaceInputs xml inputs = XML.foldXML foldRequest id id xml
where
mkXML :: XML.Name -> [XML.Attribute] -> [Either String XML.XML] -> XML.XML
mkXML t as cs = XML.makeXML t . mconcat $ map mkAttr as ++ map (mkContent id) cs
foldRequest "request" as cs = XML.makeXML "request" . mconcat $ map mkAttr as ++ map (mkContent $ XML.foldXML foldSolution id id) cs
foldRequest t as cs = mkXML t as cs
foldSolution "solution" as cs = XML.makeXML "solution" . mconcat $ map mkAttr as ++ map (mkContent id) inputs
foldSolution t as cs = mkXML t as cs
-- | Trim requests that are empty or consist exclusively of whitespace.
trimEmptyRequests :: [SqlRecord] -> IO [SqlRecord]
trimEmptyRequests records = do
let trimmed = [ insert "input" (replaceInputs request $ map Right inputs') record
| record <- records
, let request = record ! "input"
, inputs <- map snd <$> collectInputs request
, let inputs' = filter (not . isEmpty . XML.content) inputs
, not (null inputs') ]
putStrLn $ "Trimmed " ++ show (length records) ++ " records into " ++ show (length trimmed)
return trimmed
where
isEmpty :: [Either String XML.XML] -> Bool
isEmpty (Left s:xs) = all isSpace s && isEmpty xs
isEmpty (Right _:_) = False
isEmpty [] = True
-- | Sometimes, tasks are updated just to the extent that the numbers change.
-- In order for the tests for those tasks to remain usable, we change the input
-- fo the pilot data in such a way that any number that would have been
-- recognized beforehand is changed to the new number. Of course, this is far
-- from bulletproof, but the data will be worth more than if we didn't do it.
changeNumbersInOldRequests :: [SqlRecord] -> IO [SqlRecord]
changeNumbersInOldRequests = return . map maybeChange
where
maybeChange :: SqlRecord -> SqlRecord
maybeChange r | condition "carrental" "2019-01-01" r = adjust "input" carrental . adjust "original" (++"*") $ r
| condition "matryoshka" "2019-01-01" r = adjust "input" matryoshka . adjust "original" (++"*") $ r
| otherwise = r
condition :: TaskID -> String -> SqlRecord -> Bool
condition tID day r =
r ! "taskid" == tID &&
r ! "time" < (fromJust $ parseTimeM False defaultTimeLocale "%Y-%m-%d" day :: UTCTime)
carrental :: String -> String
carrental string = foldr (uncurry replace) string
[ ("93.8", "92.0")
, ("93,8", "92,0")
, ("19.5", "20.0")
, ("19,5", "20,0")
, ("42.95", "43.0")
, ("42,95", "43,0")
, ("23.45", "23.0")
, ("23,45", "23,0")]
matryoshka :: String -> String
matryoshka string = replace " 6 " " 5 " string
-- | Fix input in Pépite database, where requests don't always conform to what
-- IDEAS expects (see issues #257 and #258).
-- This is unreadable, but it's just a hack for the FR-201905* pilots
fixPepite :: [SqlRecord] -> IO [SqlRecord]
fixPepite records = do
forM records $ \record -> do
let input = record ! "input"
source <- collectSource input
if source /= "pepite"
then return record
else do
(_, tID) <- collectIDs input
inputs <- map snd <$> collectInputs input
let inputs' = ($ inputs) $ stripv0 .
case tID of
"makingasquare" -> transformIDs [("1","01")]
"matryoshka" -> transformIDs [("1","02")]
"carrental" -> transformIDs [("1","03")]
"pattern" -> transformIDs [("1","04")]
"magictrick" -> transformIDs [("1","05")]
"rectanglearea" -> transformIDs [("1","06a"), ("2","06b"), ("3","06c")] . separate
"theatrerate" -> transformIDs [("1","07a"),("3","07b")]
"areaandexpression" -> fixMatrix
"areaofatriangle" -> transformIDs [("1","09a"), ("2","09b"),("3","09c")] . separate
"vpattern" -> transformIDs [("1","10")]
let input' = replaceInputs input $ map Right inputs'
return $ insert "input" input' record
where
-- | Remove occurrences of the string "v0"
stripv0 :: [XML.XML] -> [XML.XML]
stripv0 = map (XML.foldXML (\t as cs -> XML.makeXML t . mconcat $ map mkAttr as ++ map (either (XML.string . replace "v0" "") XML.builder) cs) id id )
-- Turn string like 000100010 into expected inputs. Third and last boolean are meaningless.
fixMatrix :: [XML.XML] -> [XML.XML]
fixMatrix [] = []
fixMatrix [xml] =
let string = XML.getData xml
in map (\(i,v) -> XML.makeXML "input" . mconcat $ [ "id" XML..=. ['0','8',i], (if v == '1' then XML.string "true" else XML.string "false")]) $
if length string == 9 && all (`elem` ['0','1']) string
then zip ['a'..] (take 2 string ++ take 5 (drop 3 string))
else []
-- | Change names of inputs according to given translation.
transformIDs :: [(InputID, InputID)] -> [XML.XML] -> [XML.XML]
transformIDs ids = map $ \xml ->
let f t as cs = XML.makeXML t . mconcat $ map (mkAttr . g) as ++ map (mkContent id) cs
g ("id" XML.:= i) = "id" XML.:= fromMaybe "no-identifier" (lookup i ids)
g other = other
in XML.foldXML f id id xml
-- | Separate inputs at the word "question" and give them a corresponding
-- ID.
separate :: [XML.XML] -> [XML.XML]
separate xmls =
case xmls of
[xml] ->
map (
XML.makeXML (XML.name xml)
. mconcat
. (\(i,cs) -> ("id" XML..=. i) : map (either XML.string XML.builder) cs)
)
. reverse
. sepAtQuestion [("1",[])]
$ XML.content xml
_ -> error "There shouldn't be more than one child to be separated"
where
sepAtQuestion :: [(InputID, [Either String XML.XML])] -> [Either String XML.XML] -> [(InputID, [Either String XML.XML])]
sepAtQuestion all@((identifier,content):rest) elements = case elements of
[] -> all
Right x:xs -> sepAtQuestion ((identifier,content ++ [Right x]):rest) xs
Left x:xs -> case strToLower x `splitOn` "question" of
("","") -> all
("", y') -> sepAtQuestion all (Left y':xs)
(x', y') -> case dropWhile isSpace y' of
'3':z' -> sepAtQuestion (("3",[]):(identifier,content ++ [Left x']):rest) (Left z':xs)
'2':z' -> sepAtQuestion (("2",[]):(identifier,content ++ [Left x']):rest) (Left z':xs)
'1':z' -> sepAtQuestion ((identifier,content ++ [Left x']):rest) (Left z':xs)
z' -> sepAtQuestion ((identifier,content ++ [Left x']):rest) (Left z':xs)
-- | Process the records through the AdviseMe Domain Reasoner and update the
-- 'output' and 'evidence' columns accordingly.
--
-- TODO: Also update the responsetime column.
domainReasoner :: [SqlRecord] -> IO [SqlRecord]
domainReasoner = mapM $ \record -> do
reply <- runDomainReasoner $ record ! "input"
evidence <-
if hasError reply
then do
putStrLn $ "Warning: Ideas replied with an error: \n" ++ reply
return mempty
else do
xmlReply <- either fail return $ XML.parseXML reply
findEvidence xmlReply
return . insert "output" reply
. insert "evidence" evidence
$ record
-- | Crude way of establishing whether IDEAS' reply contained an error.
hasError :: String -> Bool
hasError = ("<reply result=\"error\"" `isPrefixOf`)
-- | Replace evidence in records with evidence extracted from spreadsheets
-- (only if XLSX flag is set).
replaceEvidence :: [FilePath] -> [SqlRecord] -> IO [SqlRecord]
#ifdef XLSX
replaceEvidence paths records = do
evidenceTable <- foldr (M.unionWith (<>)) mempty <$> mapM readEvidence paths
return . flip map records $ \record ->
maybe record (flip (insert "evidence") record)
(M.lookup (record ! "studentid", record ! "taskid") evidenceTable)
#else
replaceEvidence = undefined
#endif
-- | Build the student model for every record.
studentModeller :: [SqlRecord] -> IO [SqlRecord]
studentModeller records = flip S.evalStateT mempty $
forM records $ \r -> do
let sID = r ! "studentid" :: String
tID = r ! "taskid" :: String
ev = r ! "evidence" :: Evidence
otherPartialModels <- S.gets (M.findWithDefault mempty sID)
let partialModel = taskConcepts tID ev
let allPartialModels' = M.insert tID partialModel otherPartialModels
let studentModel = aggregateConcepts (M.toList allPartialModels')
S.modify $ M.insert sID allPartialModels'
return . insert "studentmodel" studentModel
. insert "partialmodel" partialModel
$ r
-- | Record all final models in a seperate table.
addModelsTable :: Connection -> [SqlRecord] -> IO ()
addModelsTable conn records = do
dropTable conn modelsTable
createTable conn modelsTable
insertRecords conn modelsTable (map asModel finalRecords')
where
-- Only keep the final record of each student
finalRecords'
= filter (\r -> (/= "") . SQL.fromSql $ r ! "studentmodel")
. reverse
. nubBy ((==) `on` ((! "studentid") :: SqlRecord -> String))
. reverse
$ records
nodeNames = map fst . evStates . SQL.fromSql $ head finalRecords' ! "studentmodel"
-- Turn a student record into a model record
asModel rec = M.fromList $
("studentid", rec ! "studentid") :
(map (fmap SQL.toSql) . evStates . SQL.fromSql $ rec ! "studentmodel")
modelsTable = SqlTable
{ tableName = "final_models"
, columns = ("studentid", "TEXT") : map (\x -> (x, "REAL")) nodeNames
}
#ifdef XLSX
-- | Record human assessments in a separate table.
writeHumanAssessmentTable :: Connection -> Tally -> IO ()
writeHumanAssessmentTable conn tally = do
dropTable conn assessmentTable
createTable conn assessmentTable
insertRecords conn assessmentTable (map asMatch $ expectedPresence tally ++ expectedAbsence tally ++ mismatchState tally)
where
-- Turn a student record into a model record
asMatch m = M.fromList $
[("studentid", SQL.toSql $ locStudent m)
, ("taskid", SQL.toSql $ locTask m)
, ("nodeid", SQL.toSql $ locNode m)
, ("expected", SQL.toSql $ expectation m)
, ("observed", SQL.toSql $ observation m)]
assessmentTable = SqlTable
{ tableName = "assessment"
, columns = [("studentid", "TEXT"), ("taskid", "TEXT"), ("nodeid", "TEXT"), ("expected","TEXT"), ("observed","TEXT")]
}
#endif
-------------------------------------------------------------------------------
-- | Make simulated students out of a CSV file with columns containing evidence
-- for every (!) task.
simulateStudents :: FilePath -> IO [SqlRecord]
simulateStudents file = do
putStrLn "Generating entries for simulated evidence..."
(keys:values) <- readFileCSV file
let sIDs = map (("simulation" ++) . show) [1 :: Int ..]
let students = zip sIDs $ map (M.fromList . zip keys) values
studentModeller
[ insert "studentid" sID
. insert "taskid" tID
. insert "evidence" (row M.! tID)
. insert "input" "generated student"
$ defaultEntry [studentsTable, requestsTable]
| tID <- filter (/= "rectanglearea_old") taskIDs
, (sID, row) <- students ]