make the Zipf distribution exponent and the number of topics configurable.
import PMInstance
import IMinCostFlow
+-- A PMConfig structure has a bunch of configuration values used by
+-- many functions in PMInstanceGenerator, ProposalMatcher, and Evaluation, which
+-- take a PMConfig as their first argument. Module PMDefaults defines a sane
+-- default configuration `pmDefaults'; it can be used as-is or individual fields
+-- can be overridden, e.g., pmDefaults{loadTolerance = 2} . See module
+-- PMDefaults for documentation of each field.
data PMConfig = PMConfig {
minCostFlow :: MinCostFlowImpl,
reviewsEachProposal :: Int,
marginalVeryBoringCost :: Wt -> Wt,
assignmentCost :: Wt -> Wt,
knowledgeableBonus :: Wt,
- expertBonus :: Wt
+ expertBonus :: Wt,
+ numTopics :: Int,
+ topicZipfExponent :: Wt
}
import qualified NaiveMinCostFlow
import qualified CS2MinCostFlow
+-- A default set of configuration values; see module PMConfig.
pmDefaults = PMConfig {
-- === Choose a min-cost flow implementation (timings on mattlaptop2) ===
knowledgeableBonus = 1000,
-- Bonus for an additional expert review.
-expertBonus = 1000
+expertBonus = 1000,
+
+-- === Parameters for the random-instance generator ===
+
+-- Number of topics.
+numTopics = 20,
+
+-- Exponent of the Zipf distribution used to choose topics for each proposal.
+topicZipfExponent = -0.5
}
module PMInstanceGenerator where
import PMInstance
+import PMConfig
import System.Random
import RandomizedMonad
import Data.Array.IArray
import ArrayStuff
-numTopics = 20
-
-- Expertise on each of the topics
data ReviewerInfo = ReviewerInfo {
riTopicExpertness :: Array Int Double,
riConflicts :: [Int]
}
-randomReviewerInfo numProps = do
+randomReviewerInfo cfg numProps = do
-- "Older" reviewers are more likely to be expert on topics.
age <- mrandomR (0.5, 1.0)
- expns <- indRandomArray (0, numTopics-1) $
+ expns <- indRandomArray (0, numTopics cfg - 1) $
withProb [(0.15 * age, return 2), (0.4 * age, return 1)] (return 0)
-- Samir: "Its often the case that each reviewer has a COI with say
-- one proposal submitted either by their University (different faculty)
piDifficulty :: Wt
}
-randomProposalInfo = do
+randomTopic cfg = withWeight $
+ map (\i -> (numAsWt (i+1) ** topicZipfExponent cfg, return i))
+ [0 .. numTopics cfg - 1]
+
+randomProposalInfo cfg = do
topics <- do
- t1 <- mrandomR (0, numTopics-1)
+ t1 <- randomTopic cfg
withProb [(0.5, return $ PTopic1 t1)] (do
- t2 <- filterRandomized (/= t1) $ mrandomR (0, numTopics-1)
+ t2 <- filterRandomized (/= t1) $ randomTopic cfg
return $ PTopic2 t1 t2
)
diff <- mrandomR (3, 5)
else if expertness == 1 then 5
else 3
-randomInstance :: Int -> Int -> Randomized PMInstance
-randomInstance numRvrs numProps = do
- reviewerInfos <- indRandomArray (0, numRvrs-1) $ randomReviewerInfo numProps
+randomInstance :: PMConfig -> Int -> Int -> Randomized PMInstance
+randomInstance cfg numRvrs numProps = do
+ reviewerInfos <- indRandomArray (0, numRvrs-1) $ randomReviewerInfo cfg numProps
:: Randomized (Array Int ReviewerInfo)
- proposalInfos <- indRandomArray (0, numProps-1) $ randomProposalInfo
+ proposalInfos <- indRandomArray (0, numProps-1) $ randomProposalInfo cfg
:: Randomized (Array Int ProposalInfo)
let loadA = constArray (0, numRvrs-1) 1
let prefA = funcArray ((0, 0), (numRvrs-1, numProps-1)) (\(i,j) ->
msplit,
runRandom1, runRandom, runRandomStd, runRandomNewStd,
mrandomR, mrandom,
- withProb,
+ withProb, withWeight,
filterRandomized,
indReplicateRandom, indRepeatRandom, indRandomArray
) where
val <- mrandom
chooseCase val ifCs elseR
+-- Like withProb, but without an else case and with the "probabilities" scaled
+-- so that they sum to 1.
+withWeight :: [(Double, Randomized a)] -> Randomized a
+withWeight ifCs = do
+ val <- mrandomR (0, sum (map fst ifCs))
+ chooseCase val (tail ifCs) (snd (head ifCs))
+
-- Keep trying until we get what we want.
filterRandomized :: (a -> Bool) -> Randomized a -> Randomized a
filterRandomized f ra = do
l1 /\ l2 = (l1 \\ l2, l2 \\ l1)
-- Evaluation!
-runEvaluation nr np = do
- let inst = runRandom myGen $ randomInstance nr np
+runEvaluation cfg nr np = do
+ let inst = runRandom myGen $ randomInstance cfg nr np
putStr (show inst ++ "\n")
- let m0 = doMatching pmDefaults{loadTolerance = 0} inst
+ let m0 = doMatching cfg{loadTolerance = 0} inst
putStr ("Matching with load tolerance 0:\n" ++ show m0 ++ "\n")
- let m1 = doMatching pmDefaults{loadTolerance = 1} inst
+ let m1 = doMatching cfg{loadTolerance = 1} inst
putStr ("Matching with load tolerance 1:\n" ++ show m1 ++ "\n")
putStr ("Differences:\n" ++ show (m0 /\ m1) ++ "\n")
- let e0 = evaluateMatching pmDefaults{loadTolerance = 0} inst m0
+ let e0 = evaluateMatching cfg{loadTolerance = 0} inst m0
putStr ("Evaluation of first matching:\n" ++ show e0 ++ "\n")
- let e1 = evaluateMatching pmDefaults{loadTolerance = 1} inst m1
+ let e1 = evaluateMatching cfg{loadTolerance = 1} inst m1
putStr ("Evaluation of second matching:\n" ++ show e1 ++ "\n")
putStr ("Evaluation differences:\n" ++
show (sortedDiffEvaluations e0 e1) ++ "\n")