feat(allocations): auxilliaries for allocation-algo

config/settings.yml

@@ -130,5 +130,11 @@ user-defaults:
   download-files:   false
   warning-days:     1209600
 
+# During central allocations lecturer-given ratings of applications (as
+# ExamGrades) are combined with a central priority.
+# This encodes the weight of the lecturer ratings on the same scale as the
+# centrally supplied priorities.
+allocation-grade-scale: 25
+
 instance-id: "_env:INSTANCE_ID:instance"
 ribbon: "_env:RIBBON:"

models/allocations.model

@@ -21,6 +21,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
     registerByCourse    UTCTime Maybe   -- course registration dates are ignored until this day has passed or always prohibited
     overrideDeregister  UTCTime Maybe   -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
     -- overrideVisible not needed, since courses are always visible
+    matchingLog         FileId Maybe
     TermSchoolAllocationShort  term school shorthand    -- shorthand must be unique within school and semester
     TermSchoolAllocationName   term school name         -- name must be unique within school and semester
     deriving Show Eq Ord Generic
@@ -35,6 +36,7 @@ AllocationUser
     allocation          AllocationId
     user                UserId
     totalCourses        Natural          -- number of total allocated courses for this user must be <= than this number
+    priority            AllocationPriority Maybe
     UniqueAllocationUser allocation user
 
 AllocationDeregister -- self-inflicted user-deregistrations from an allocated course

models/courses.model

@@ -51,7 +51,7 @@ CourseParticipant                      -- course enrolement
     user         UserId
     registration UTCTime               -- time of last enrolement for this course
     field        StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
-    allocated    Bool default=false    -- participant was centrally allocated
+    allocated    AllocationId Maybe    -- participant was centrally allocated
     UniqueParticipant user course
 -- Replace the last two by the following, once an audit log is available
 -- CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student

src/Handler/Allocation/Register.hs

@@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do
       { allocationUserAllocation = aId
       , allocationUserUser = uid
       , allocationUserTotalCourses = arfTotalCourses
+      , allocationUserPriority = Nothing
       }
       [ AllocationUserTotalCourses =. arfTotalCourses
       ]

src/Handler/Course/ParticipantInvite.hs

@@ -38,7 +38,7 @@ instance IsInvitableJunction CourseParticipant where
   data InvitableJunction CourseParticipant = JunctionParticipant
     { jParticipantRegistration :: UTCTime
     , jParticipantField        :: Maybe StudyFeaturesId
-    , jParticipantAllocated    :: Bool
+    , jParticipantAllocated    :: Maybe AllocationId
     } deriving (Eq, Ord, Read, Show, Generic, Typeable)
   data InvitationDBData CourseParticipant = InvDBDataParticipant
     -- no data needed in DB to manage participant invitation
@@ -90,7 +90,7 @@ participantInvitationConfig = InvitationConfig{..}
       now <- liftIO getCurrentTime
       studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
           (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
-      return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False
+      return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing
     invitationInsertHook _ _ CourseParticipant{..} _ act = do
       res <- act
       audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
@@ -193,7 +193,7 @@ registerUser cid uid = exceptT tell tell $ do
   void . lift . lift . insert $ CourseParticipant
     { courseParticipantCourse = cid
     , courseParticipantUser = uid
-    , courseParticipantAllocated = False
+    , courseParticipantAllocated = Nothing
     , ..
     }
   lift . lift . audit $ TransactionCourseParticipantEdit cid uid

src/Handler/Course/Register.hs

@@ -197,7 +197,7 @@ postCRegisterR tid ssh csh = do
         = return $ Just ()
       mkRegistration = do
         audit $ TransactionCourseParticipantEdit cid uid
-        insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False
+        insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing
 
       deleteApplications = do
         appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
@@ -222,7 +222,7 @@ postCRegisterR tid ssh csh = do
           delete $ partId
           audit $ TransactionCourseParticipantDeleted cid uid
 
-          when courseParticipantAllocated $ do
+          when (is _Just courseParticipantAllocated) $ do
             now <- liftIO getCurrentTime
             insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
 

src/Handler/Course/User.hs

@@ -150,7 +150,7 @@ postCUserR tid ssh csh uCId = do
             | otherwise
             = Nothing
       pId <- runDB $ do
-        pId <- insertUnique $ CourseParticipant cid uid now field False
+        pId <- insertUnique $ CourseParticipant cid uid now field Nothing
         when (is _Just pId) $
           audit $ TransactionCourseParticipantEdit cid uid
         return pId

src/Handler/Exam/AddUser.hs

@@ -147,7 +147,7 @@ postEAddUserR tid ssh csh examn = do
         { courseParticipantCourse = cid
         , courseParticipantUser = uid
         , courseParticipantRegistration = now
-        , courseParticipantAllocated = False
+        , courseParticipantAllocated = Nothing
         , ..
         }
       lift . lift . audit $ TransactionCourseParticipantEdit cid uid

src/Handler/Exam/RegistrationInvite.hs

@@ -97,7 +97,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
         (True , _    ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) 
     invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
       whenIsJust mField $ \cpField -> do
-        insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
+        insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing
         audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
       
       let doAudit = audit $ TransactionExamRegister eid examRegistrationUser

src/Handler/Exam/Users.hs

@@ -742,7 +742,7 @@ postEUsersR tid ssh csh examn = do
                       , courseParticipantUser = examUserCsvActUser
                       , courseParticipantRegistration = now
                       , courseParticipantField = examUserCsvActCourseField
-                      , courseParticipantAllocated = False
+                      , courseParticipantAllocated = Nothing
                       }
                     audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
                     insert_ ExamRegistration

src/Handler/Utils/Allocation.hs

@@ -0,0 +1,133 @@
+module Handler.Utils.Allocation
+  ( sinkAllocationPriorities
+  , computeAllocation
+  , doAllocation
+  , ppMatchingLog, storeMatchingLog
+  ) where
+
+import Import
+
+import qualified Data.Map.Strict as Map
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Data.List (genericLength, elemIndex)
+import qualified Data.Vector as Vector
+import Data.Vector.Lens (vector)
+import qualified Data.Set as Set
+
+import System.Random (newStdGen)
+
+import Utils.Allocation
+
+import qualified Data.Conduit.List as C
+
+import Data.Generics.Product.Param
+
+
+sinkAllocationPriorities :: AllocationId
+                         -> ConduitT (Map UserMatriculation AllocationPriority) Void DB ()
+sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio ->
+  E.update $ \allocationUser -> do
+    E.set allocationUser [ AllocationUserPriority E.=. E.val (Just prio) ]
+    E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val allocId
+    E.where_ . E.exists . E.from $ \user ->
+      E.where_ $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser
+           E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr)
+
+  
+computeAllocation :: AllocationId
+                  -> DB (Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
+computeAllocation allocId = do
+  users' <- selectList [ AllocationUserAllocation ==. allocId ] []
+  let cloneCounts = Map.filter (> 0) . Map.fromList $ (allocationUserUser . entityVal &&& allocationUserTotalCourses . entityVal) <$> users'
+
+  courses' <- E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
+    E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
+     E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId
+
+    let participants = E.sub_select . E.from $ \participant -> do
+          E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+          E.where_ . E.not_ . E.exists . E.from $ \lecturer -> do
+            E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+                 E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser
+          return E.countRows
+
+    return ( allocationCourse
+           , E.maybe E.nothing (\c -> E.just $ c E.-. participants) (course E.^. CourseCapacity)
+           , allocationCourse E.^. AllocationCourseMinCapacity E.-. participants
+           )
+  let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses'
+
+  applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] []
+  let applications'' = applications' & filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal)
+      preferences = Map.fromList $ do
+        Entity _ CourseApplication{..} <- applications''
+        return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints))
+
+  gradeScale <- getsYesod $ view _appAllocationGradeScale
+  let centralNudge user (fromIntegral -> cloneIndex) grade
+        | Just AllocationPriorityNumeric{..} <- allocationPrio
+        = let allocationPriorities' = under vector (sortOn Down) allocationPriorities
+              minPrio | Vector.null allocationPriorities' = 0
+                      | otherwise = Vector.last allocationPriorities'
+           in withNumericGrade . fromMaybe minPrio $ allocationPriorities Vector.!? cloneIndex
+        | otherwise
+        = withNumericGrade 0
+        where
+          allocationPrio = allocationUserPriority . entityVal =<< listToMaybe (filter ((== user) . allocationUserUser . entityVal) users')
+
+          withNumericGrade
+            | Just grade' <- grade
+            = let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades)
+                  passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
+                  numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
+               in (+) numericGrade . fromInteger
+            | otherwise
+            = fromInteger
+
+  g <- liftIO newStdGen
+
+  let
+    doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge
+      where
+        capacities'  = Map.filterWithKey (\    c  _ -> Set.notMember c cs) capacities
+        preferences' = Map.filterWithKey (\(_, c) _ -> Set.notMember c cs) preferences
+
+    allocationLoop cs
+      | not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin
+      | otherwise           = (allocs, mLog)
+      where
+        (allocs, mLog) = doAllocationWithout cs
+        belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) ->
+          guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse
+
+  return $!! allocationLoop Set.empty
+
+doAllocation :: AllocationId
+             -> Set (UserId, CourseId)
+             -> DB ()
+doAllocation allocId regs = do
+  now <- liftIO getCurrentTime
+  forM_ regs $ \(uid, cid) -> do
+    mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
+    void . insertUnique $ CourseParticipant cid uid now mField (Just allocId)
+
+ppMatchingLog :: ( MonoFoldable mono
+                 , Element mono ~ MatchingLog UserId CourseId Natural
+                 )
+              => mono -> Text
+ppMatchingLog = unlines . map (tshow . pretty) . otoList
+  where
+    pretty = over (param @1) fromSqlKey
+           . over (param @2) fromSqlKey
+
+storeMatchingLog :: ( MonoFoldable mono
+                    , Element mono ~ MatchingLog UserId CourseId Natural
+                    )
+                 => AllocationId -> mono -> DB ()
+storeMatchingLog allocationId (ppMatchingLog -> matchingLog) = do
+  now <- liftIO getCurrentTime
+  fId <- insert $ File "matchings.log" (Just $ encodeUtf8 matchingLog) now
+  update allocationId [ AllocationMatchingLog =. Just fId ]

src/Handler/Utils/Csv.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Handler.Utils.Csv
-  ( decodeCsv
+  ( decodeCsv, decodeCsvPositional
   , encodeCsv
   , encodeDefaultOrderedCsv
   , respondCsv, respondCsvDB
@@ -35,9 +35,17 @@ import qualified Data.ByteString.Lazy as LBS
 
 import qualified Data.Attoparsec.ByteString.Lazy as A
 
+import Control.Monad.Except (ExceptT)
+
 
 decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m ()
-decodeCsv = transPipe throwExceptT $ do
+decodeCsv = decodeCsv' fromNamedCsv
+
+decodeCsvPositional :: (MonadThrow m, FromRecord csv, MonadLogger m) => HasHeader -> ConduitT ByteString csv m ()
+decodeCsvPositional hdr = decodeCsv' (\opts -> fromCsv opts hdr)
+
+decodeCsv' :: (MonadThrow m, MonadLogger m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString csv (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m ()
+decodeCsv' fromCsv' = transPipe throwExceptT $ do
   testBuffer <- accumTestBuffer LBS.empty
   mapM_ leftover $ LBS.toChunks testBuffer
 
@@ -45,7 +53,7 @@ decodeCsv = transPipe throwExceptT $ do
         & guessDelimiter testBuffer
   $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|]
   
-  fromNamedCsv decodeOptions
+  fromCsv' decodeOptions
   where
     testBufferSize = 4096
     accumTestBuffer acc

src/Model/Migration.hs

@@ -550,6 +550,17 @@ customMigrations = Map.fromListWith (>>)
         UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
       |]
     )
+  , ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|]
+    , whenM (tableExists "course_participant") $ do
+        queryRes <- [sqlQQ|SELECT (EXISTS (SELECT 1 FROM "course_participant" WHERE "allocated" <> false))|]
+        case queryRes of
+          [Single False] ->
+            [executeQQ|
+              ALTER TABLE "course_participant" DROP COLUMN  "allocated";
+              ALTER TABLE "course_participant" ADD COLUMN "allocated" bigint;
+            |]
+          _other -> error "Cannot reconstruct course_participant.allocated"
+    )
   ]
 
 

src/Model/Types.hs

@@ -13,3 +13,4 @@ import Model.Types.Sheet as Types
 import Model.Types.Submission as Types
 import Model.Types.Misc as Types
 import Model.Types.School as Types
+import Model.Types.Allocation as Types

src/Model/Types/Allocation.hs

@@ -0,0 +1,34 @@
+module Model.Types.Allocation
+  ( AllocationPriority(..)
+  , module Utils.Allocation
+  ) where
+
+import Import.NoModel
+import Utils.Allocation (MatchingLog(..))
+import Model.Types.Common
+
+import qualified Data.Csv as Csv
+import qualified Data.Vector as Vector
+
+import qualified Data.Map.Strict as Map
+
+
+data AllocationPriority
+  = AllocationPriorityNumeric { allocationPriorities :: Vector Integer }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 2
+  , allNullaryToStringTag = False
+  , sumEncoding = TaggedObject "mode" "value"
+  , unwrapUnaryRecords = False
+  , tagSingleConstructors = True
+  } ''AllocationPriority
+derivePersistFieldJSON ''AllocationPriority
+
+instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where
+  parseRecord v = parseNumeric
+    where
+      parseNumeric
+        | Vector.length v >= 1 = Map.singleton <$> v Csv..! 0 <*> (AllocationPriorityNumeric <$> mapM Csv.parseField (Vector.tail v))
+        | otherwise = mzero

src/Settings.hs

@@ -38,7 +38,7 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
 import Data.Time (NominalDiffTime, nominalDay)
 
-import Data.Scientific (toBoundedInteger)
+import Data.Scientific (Scientific, toBoundedInteger)
 import Data.Word (Word16)
 
 import qualified Data.Text as Text
@@ -130,6 +130,8 @@ data AppSettings = AppSettings
 
     , appTransactionLogIPRetentionTime :: NominalDiffTime
 
+    , appAllocationGradeScale :: Rational
+
     , appReloadTemplates        :: Bool
     -- ^ Use the reload version of templates
     , appMutableStatic          :: Bool
@@ -426,6 +428,8 @@ instance FromJSON AppSettings where
 
         appTransactionLogIPRetentionTime <- o .:  "ip-retention-time"
 
+        appAllocationGradeScale   <- o .: "allocation-grade-scale" <|> fmap toRational (o .: "allocation-grade-scale" :: Aeson.Parser Scientific)
+
         appUserDefaults           <- o .:  "user-defaults"
         appAuthPWHash             <- o .:  "auth-pw-hash"
 

src/Utils/Allocation.hs

@@ -29,12 +29,16 @@ type StudentIndex = Int
 type CloneIndex = Int
 
 data MatchingLog student course cloneIndex
-  = MatchingConsider student cloneIndex
+  = MatchingConsider
-  | MatchingApply student cloneIndex course
+    { mlStudent :: student, mlClone :: cloneIndex }
-  | MatchingNoApplyCloneInstability student cloneIndex course
+  | MatchingApply
-  | MatchingLostSpot student cloneIndex course
+    { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
+  | MatchingNoApplyCloneInstability
+    { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
+  | MatchingLostSpot
+    { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
+instance (NFData student, NFData course, NFData cloneIndex) => NFData (MatchingLog student course cloneIndex)
 
 computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'.
                    ( RandomGen randomGen

src/Utils/Lens.hs

@@ -206,6 +206,8 @@ makeLenses_ ''UserFunction
 makeLenses_ ''CourseUserExamOfficeOptOut
 
 makeLenses_ ''CourseNewsFile
+
+makeLenses_ ''AllocationCourse
   
 
 -- makeClassy_ ''Load

test/Database.hs

@@ -469,7 +469,7 @@ fillDb = do
   insert_ $ SheetEdit gkleen now feste
   keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now keine
-  void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf False)
+  void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing)
     [(fhamann   , Nothing)
     ,(maxMuster , Just sfMMs)
     ,(tinaTester, Just sfTTc)
@@ -592,7 +592,7 @@ fillDb = do
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
   void . insert $ Lecturer jost pmo CourseAssistant
-  void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf False)
+  void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing)
     [(fhamann   , Nothing)
     ,(maxMuster , Just sfMMp)
     ,(tinaTester, Just sfTTb)
@@ -779,6 +779,7 @@ fillDb = do
     , allocationRegisterByStaffTo = Nothing
     , allocationRegisterByCourse = Nothing
     , allocationOverrideDeregister = Just now
+    , allocationMatchingLog = Nothing
     }
   insert_ $ AllocationCourse funAlloc pmo 100
   insert_ $ AllocationCourse funAlloc ffp 2