feat(allocations): fingerprints & ordinal ratings
This commit is contained in:
Gregor Kleen
parent
9f61452d0d
commit
60603cb6ec
@ -136,6 +136,9 @@ user-defaults:
|
||||
# This encodes the weight of the lecturer ratings on the same scale as the
|
||||
# centrally supplied priorities.
|
||||
allocation-grade-scale: 25
|
||||
# This encodes how many ordinal places lecturer ratings may move students up or
|
||||
# down when central priorities are supplied as ordered list.
|
||||
allocation-grade-ordinal-places: 3
|
||||
|
||||
instance-id: "_env:INSTANCE_ID:instance"
|
||||
ribbon: "_env:RIBBON:"
|
||||
|
||||
@ -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
|
||||
fingerprint AllocationFingerprint Maybe
|
||||
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
|
||||
|
||||
@ -1,8 +1,12 @@
|
||||
module Handler.Utils.Allocation
|
||||
( sinkAllocationPriorities
|
||||
( allocationDone
|
||||
, ordinalPriorities
|
||||
, sinkAllocationPriorities
|
||||
, computeAllocation
|
||||
, storeAllocationFingerprint
|
||||
, doAllocation
|
||||
, ppMatchingLog, storeMatchingLog
|
||||
, storeAllocationResult
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -12,12 +16,15 @@ import qualified Data.Map.Strict as Map
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Control.Monad.Trans.State.Strict (evalStateT)
|
||||
import qualified Control.Monad.State.Class as State (get, modify')
|
||||
|
||||
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 System.Random (mkStdGen)
|
||||
|
||||
import Utils.Allocation
|
||||
|
||||
@ -25,7 +32,21 @@ import qualified Data.Conduit.List as C
|
||||
|
||||
import Data.Generics.Product.Param
|
||||
|
||||
import qualified Crypto.Hash as Crypto
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import qualified Data.ByteArray as BA (convert)
|
||||
|
||||
|
||||
allocationDone :: AllocationId -> DB (Maybe UTCTime)
|
||||
allocationDone allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val allocId)
|
||||
return . E.max_ $ participant E.^. CourseParticipantRegistration
|
||||
|
||||
|
||||
ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m ()
|
||||
ordinalPriorities = transPipe (flip evalStateT 0) . C.mapM $ \matr -> singletonMap matr <$> (AllocationPriorityOrdinal <$> State.get <* State.modify' succ)
|
||||
|
||||
sinkAllocationPriorities :: AllocationId
|
||||
-> ConduitT (Map UserMatriculation AllocationPriority) Void DB ()
|
||||
sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio ->
|
||||
@ -38,10 +59,19 @@ sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio ->
|
||||
|
||||
|
||||
computeAllocation :: AllocationId
|
||||
-> DB (Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
|
||||
-> DB (AllocationFingerprint, 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'
|
||||
let users'' = users'
|
||||
& mapMaybe ( runMaybeT $ (,) <$> lift (allocationUserUser . entityVal)
|
||||
<*> ( (,) <$> lift (allocationUserTotalCourses . entityVal)
|
||||
<*> MaybeT (allocationUserPriority . entityVal)
|
||||
)
|
||||
)
|
||||
& Map.fromList
|
||||
& Map.filter ((> 0) . view _1)
|
||||
cloneCounts = Map.map (view _1) users''
|
||||
allocationPrio = view _2 . (Map.!) users''
|
||||
|
||||
courses' <- E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
@ -67,27 +97,35 @@ computeAllocation allocId = do
|
||||
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
|
||||
gradeOrdinalPlaces <- getsYesod $ view _appAllocationGradeOrdinalPlaces
|
||||
let centralNudge user cloneIndex grade = case allocationPrio user of
|
||||
AllocationPriorityNumeric{..}
|
||||
-> let allocationPriorities' = under vector (sortOn Down) allocationPriorities
|
||||
minPrio | Vector.null allocationPriorities' = 0
|
||||
| otherwise = Vector.last allocationPriorities'
|
||||
in AllocationPriorityComparisonNumeric . withNumericGrade . fromInteger . fromMaybe minPrio $ allocationPriorities Vector.!? fromIntegral cloneIndex
|
||||
AllocationPriorityOrdinal{..}
|
||||
| gradeOrdinalPlaces > 0
|
||||
-> let allocationOrdinal' = gradeScale / fromIntegral gradeOrdinalPlaces * fromIntegral allocationOrdinal
|
||||
in AllocationPriorityComparisonOrdinal (Down cloneIndex) $ withNumericGrade allocationOrdinal'
|
||||
AllocationPriorityOrdinal{..}
|
||||
-> AllocationPriorityComparisonOrdinal (Down cloneIndex) $ fromIntegral allocationOrdinal
|
||||
where
|
||||
allocationPrio = allocationUserPriority . entityVal =<< listToMaybe (filter ((== user) . allocationUserUser . entityVal) users')
|
||||
|
||||
withNumericGrade :: Rational -> Rational
|
||||
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
|
||||
in (+) numericGrade
|
||||
| otherwise
|
||||
= fromInteger
|
||||
= id
|
||||
|
||||
g <- liftIO newStdGen
|
||||
let
|
||||
fingerprint :: AllocationFingerprint
|
||||
fingerprint = Crypto.hash . toStrict $ Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
|
||||
|
||||
g = mkStdGen $ hash (BA.convert fingerprint :: ByteString)
|
||||
|
||||
let
|
||||
doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge
|
||||
@ -103,7 +141,13 @@ computeAllocation allocId = do
|
||||
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
|
||||
return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! allocationLoop Set.empty
|
||||
|
||||
|
||||
storeAllocationFingerprint :: AllocationId
|
||||
-> AllocationFingerprint
|
||||
-> DB ()
|
||||
storeAllocationFingerprint allocId fp = update allocId [ AllocationFingerprint =. Just fp ]
|
||||
|
||||
doAllocation :: AllocationId
|
||||
-> Set (UserId, CourseId)
|
||||
@ -131,3 +175,12 @@ storeMatchingLog allocationId (ppMatchingLog -> matchingLog) = do
|
||||
now <- liftIO getCurrentTime
|
||||
fId <- insert $ File "matchings.log" (Just $ encodeUtf8 matchingLog) now
|
||||
update allocationId [ AllocationMatchingLog =. Just fId ]
|
||||
|
||||
|
||||
storeAllocationResult :: AllocationId
|
||||
-> (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
|
||||
-> DB ()
|
||||
storeAllocationResult allocId (allocFp, allocMatchings, allocLog) = do
|
||||
storeAllocationFingerprint allocId allocFp
|
||||
doAllocation allocId allocMatchings
|
||||
storeMatchingLog allocId allocLog
|
||||
|
||||
@ -15,6 +15,7 @@ import Data.Time.Zones
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.Allocation (allocationDone)
|
||||
|
||||
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
@ -336,14 +337,12 @@ determineCrontab = execWriterT $ do
|
||||
}
|
||||
_other
|
||||
-> return ()
|
||||
lastResult <- fmap (E.unValue <=< listToMaybe) . lift . E.select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
|
||||
return . E.max_ $ participant E.^. CourseParticipantRegistration
|
||||
whenIsJust lastResult $ \lastResult' ->
|
||||
doneSince <- lift $ allocationDone nAllocation
|
||||
whenIsJust doneSince $ \doneSince' ->
|
||||
tell $ HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationAllocationResults{..})
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay lastResult'
|
||||
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay doneSince'
|
||||
, cronRepeat = CronRepeatNever
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = Left appNotificationExpiration
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
module Model.Types.Allocation
|
||||
( AllocationPriority(..)
|
||||
, AllocationPriorityComparison(..)
|
||||
, AllocationFingerprint
|
||||
, module Utils.Allocation
|
||||
) where
|
||||
|
||||
@ -11,12 +13,15 @@ import qualified Data.Csv as Csv
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Crypto.Hash (Digest, SHAKE128)
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
||||
|
||||
|
||||
data AllocationPriority
|
||||
= AllocationPriorityNumeric { allocationPriorities :: Vector Integer }
|
||||
| AllocationPriorityOrdinal { allocationOrdinal :: Natural }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
@ -28,9 +33,20 @@ deriveJSON defaultOptions
|
||||
} ''AllocationPriority
|
||||
derivePersistFieldJSON ''AllocationPriority
|
||||
|
||||
instance Binary 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
|
||||
|
||||
|
||||
data AllocationPriorityComparison
|
||||
= AllocationPriorityComparisonNumeric { allocationGradeScale :: Rational }
|
||||
| AllocationPriorityComparisonOrdinal { allocationCloneIndex :: Down Natural, allocationOrdinalScale :: Rational }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
type AllocationFingerprint = Digest (SHAKE128 128)
|
||||
|
||||
@ -218,6 +218,8 @@ instance PersistField ExamGrade where
|
||||
instance PersistFieldSql ExamGrade where
|
||||
sqlType _ = SqlNumeric 2 1
|
||||
|
||||
instance Binary ExamGrade
|
||||
|
||||
|
||||
newtype ExamGradeDefCenter = ExamGradeDefCenter { examGradeDefCenter :: Maybe ExamGrade }
|
||||
deriving (Eq, Read, Show, Generic, Typeable)
|
||||
|
||||
@ -131,6 +131,7 @@ data AppSettings = AppSettings
|
||||
, appTransactionLogIPRetentionTime :: NominalDiffTime
|
||||
|
||||
, appAllocationGradeScale :: Rational
|
||||
, appAllocationGradeOrdinalPlaces :: Natural
|
||||
|
||||
, appReloadTemplates :: Bool
|
||||
-- ^ Use the reload version of templates
|
||||
@ -429,6 +430,7 @@ instance FromJSON AppSettings where
|
||||
appTransactionLogIPRetentionTime <- o .: "ip-retention-time"
|
||||
|
||||
appAllocationGradeScale <- o .: "allocation-grade-scale" <|> fmap toRational (o .: "allocation-grade-scale" :: Aeson.Parser Scientific)
|
||||
appAllocationGradeOrdinalPlaces <- o .: "allocation-grade-ordinal-places"
|
||||
|
||||
appUserDefaults <- o .: "user-defaults"
|
||||
appAuthPWHash <- o .: "auth-pw-hash"
|
||||
|
||||
@ -785,6 +785,7 @@ fillDb = do
|
||||
, allocationRegisterByStaffTo = Nothing
|
||||
, allocationRegisterByCourse = Nothing
|
||||
, allocationOverrideDeregister = Just now
|
||||
, allocationFingerprint = Nothing
|
||||
, allocationMatchingLog = Nothing
|
||||
}
|
||||
insert_ $ AllocationCourse funAlloc pmo 100
|
||||
|
||||
Loading…
Reference in New Issue
Block a user