Make the instance generator select proposal topics from a Zipf distribution, and

make the Zipf distribution exponent and the number of topics configurable.

diff --git a/program/PMConfig.hs b/program/PMConfig.hs
index 20a380f..ecbe1cb 100644 (file)
--- a/program/PMConfig.hs
+++ b/program/PMConfig.hs
@@ -3,6 +3,12 @@ module PMConfig where
 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,
@@ -17,5 +23,7 @@ data PMConfig = PMConfig {
        marginalVeryBoringCost :: Wt -> Wt,
        assignmentCost :: Wt -> Wt,
        knowledgeableBonus :: Wt,
-       expertBonus :: Wt
+       expertBonus :: Wt,
+       numTopics :: Int,
+       topicZipfExponent :: Wt
 }

diff --git a/program/PMDefaults.hs b/program/PMDefaults.hs
index aa68aac..a68d182 100644 (file)
--- a/program/PMDefaults.hs
+++ b/program/PMDefaults.hs
@@ -5,6 +5,7 @@ import PMConfig
 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) ===
@@ -58,6 +59,14 @@ assignmentCost = \pref -> (numAsWt 10 + pref) ^ 2,
 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
 
 }

diff --git a/program/PMInstanceGenerator.hs b/program/PMInstanceGenerator.hs
index 97a546a..0f78b02 100644 (file)
--- a/program/PMInstanceGenerator.hs
+++ b/program/PMInstanceGenerator.hs
@@ -1,22 +1,21 @@
 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)
@@ -35,11 +34,15 @@ data ProposalInfo = ProposalInfo {
        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)
@@ -49,11 +52,11 @@ expertnessToPref expertness = if expertness == 0 then 7
        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) ->

diff --git a/program/RandomizedMonad.hs b/program/RandomizedMonad.hs
index 62e8808..22b98aa 100644 (file)
--- a/program/RandomizedMonad.hs
+++ b/program/RandomizedMonad.hs
@@ -3,7 +3,7 @@ module RandomizedMonad (
        msplit,
        runRandom1, runRandom, runRandomStd, runRandomNewStd,
        mrandomR, mrandom,
-       withProb,
+       withProb, withWeight,
        filterRandomized,
        indReplicateRandom, indRepeatRandom, indRandomArray
 ) where
@@ -70,6 +70,13 @@ withProb ifCs elseR = do
        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

diff --git a/program/TestUtils.hs b/program/TestUtils.hs
index acee1c7..96a170c 100644 (file)
--- a/program/TestUtils.hs
+++ b/program/TestUtils.hs
@@ -88,17 +88,17 @@ goGraph theGraph =
 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")