type MatchingEvaluation = Array Int Wt
+-- FIXME this is not really ported to separate preference and expertise
+
evaluateMatching :: PMConfig -> PMInstance -> PMatching -> MatchingEvaluation
-evaluateMatching cfg inst@(PMInstance numRvrs numProps rloadA prefA) (PMatching matching) =
+evaluateMatching cfg inst@(PMInstance numRvrs numProps rloadA prefA _ _ _) (PMatching matching) =
let reviewersByProposal = accumArray (flip (:)) []
(0, numProps-1) $ map (\(i,j) -> (j,i)) matching
:: Array Int [Int] in
incsv <- hGetContents stdin
-- handle errors another day, or let the platform do it
let inll = parseTSV incsv
- let loadList = head inll
+ let loadList = tail (head inll)
let numRvrs = length loadList
let loadA = listArray (0, numRvrs-1) (map read loadList)
- let numProps = length (tail inll)
+ let numProps = length (tail inll) `div` 2
-- explicit type on the next line appears to be necessary
let pxarr = listOfListsToArray2D (tail inll) :: Array (Int,Int) String
-- careful, we end up transposing the array in here
- let prefA = funcArray ((0,0), (numRvrs-1,numProps-1)) (\(i,j) -> read (pxarr ! (j, i)))
- let theInst = PMInstance numRvrs numProps loadA prefA
+ let prefFixA = funcArray ((0,0), (numRvrs-1,numProps-1)) (\(i,j) ->
+ let
+ cell = pxarr ! (2*j, i+1)
+ (fix, pstr) = if last cell == '*' then (True, init cell) else (False, cell)
+ pref = read pstr
+ in (pref, fix)) :: Array (Int,Int) (Wt,Bool)
+ let prefA = amap2 fst prefFixA; fixA = amap2 snd prefFixA
+ let expA = funcArray ((0,0), (numRvrs-1,numProps-1)) (\(i,j) -> read $ pxarr ! (2*j+1, i+1))
+ let pnrA = funcArray (0, numProps-1) (\j -> read $ pxarr ! (2*j, 0))
+ let theInst = PMInstance numRvrs numProps loadA prefA expA fixA pnrA
let PMatching theMatching = doMatching pmDefaults theInst
hPutStr stdout $ formatTSV $ map (\(i, j) -> map show [i, j]) theMatching
data PMConfig = PMConfig {
minCostFlow :: MinCostFlowImpl,
reviewsEachProposal :: Int,
- prefIsExpert :: Wt -> Bool,
- prefIsKnowledgeable :: Wt -> Bool,
+ pcReviewsEachProposal :: Int,
+ expIsExpert :: Wt -> Bool,
+ expIsKnowledgeable :: Wt -> Bool,
prefIsBoring :: Wt -> Bool,
prefIsVeryBoring :: Wt -> Bool,
prefIsConflict :: Wt -> Bool,
loadTolerance :: Int,
+ ercLoadTolerance :: Int,
marginalLoadCost :: Wt -> Wt,
marginalBoringCost :: Wt -> Wt,
marginalVeryBoringCost :: Wt -> Wt,
-- A naive implementation that is slow for all but the smallest instances
-- (30s on a 20x50 example).
-minCostFlow = NaiveMinCostFlow.minCostFlow,
+--minCostFlow = NaiveMinCostFlow.minCostFlow,
-- Uses CS2 (http://www.igsystems.com/cs2/), which requires a license for
-- non-research use but is faster (<1s on a 20x50 example, 64s on a 60x500
-- example). Configure the path to cs2.exe in CS2MinCostFlow.hs. Remember to
-- compile CS2 with -DPRINT_ANS, or this won't work!
---minCostFlow = CS2MinCostFlow.minCostFlow,
+minCostFlow = CS2MinCostFlow.minCostFlow,
-- The number of reviews each proposal should get.
-reviewsEachProposal = 3,
+reviewsEachProposal = 4,
+
+-- Applies to non-PC papers
+pcReviewsEachProposal = 3,
-- === Interpretation of the preference values ===
-prefIsExpert = \p -> p <= 10,
-prefIsKnowledgeable = \p -> p <= 20,
+expIsExpert = \x -> x >= 3,
+expIsKnowledgeable = \x -> x >= 2,
-prefIsBoring = \p -> p > 15,
-prefIsVeryBoring = \p -> p > 25,
+prefIsBoring = \p -> p < 50,
+prefIsVeryBoring = \p -> p < 0,
-prefIsConflict = \p -> p >= 40,
+prefIsConflict = \p -> p <= -100,
-- === Tuning parameters for the matcher ===
-- load of (relativeLoad * ceiling(numProps * reviewsEachProposal /
-- totalRelativeLoad)). For now this is an additive constant; perhaps it should
-- be proportional to the target load.
-loadTolerance = 1,
+loadTolerance = 2,
+
+ercLoadTolerance = 3,
-- Cost to overload by one review.
-- tx = 0 at target load, 1 at end of tolerance.
-- Cost to make a review. Used by the evaluator too.
-- I'm using quadratic cost functions as a first attempt.
-assignmentCost = \pref -> (widenInteger 10 + pref) ^ 2,
+assignmentCost = \pref -> (widenInteger 10 + prefNewToOld pref) ^ 2,
-- Bonus for a first knowledgeable or expert review.
-knowledgeableBonus = 1000,
+knowledgeableBonus = 3000,
-- Bonus for an additional expert review.
-expertBonus = 1000,
+expertBonus = 3000,
-- === Parameters for the random-instance generator ===
type Wt = Double -- Can be any RealFrac.
widenInteger x = fromInteger (toInteger x)
-data PMInstance = PMInstance
- Int -- numReviewers
- Int -- numProposals
- (UArray Int Wt) -- ! reviewer -> relative load
- (UArray (Int, Int) Wt) -- ! (reviewer, proposal) -> pref
- deriving Eq
+data PMInstance = PMInstance {
+ -- I feel like I am in C, having to namespace these! I guess one
+ -- solution would be to have a typeclass for every field name. A
+ -- specialized solution might desugar to that.
+ pmiNumReviewers :: Int,
+ pmiNumProposals :: Int,
+ pmiRLoad :: UArray Int Wt,
+ pmiRPPref :: UArray (Int, Int) Wt, -- preference: -100 (COI), -99 to 100
+ pmiRPExp :: UArray (Int, Int) Wt, -- expertise: 0 to 3
+ -- New 2011-07-19
+ -- Should we "jam" all three values that are functions of (i, j)?
+ pmiRPFix :: UArray (Int, Int) Bool,
+ pmiPNumReviews :: UArray Int Int
+}
+
+-- Let us shoehorn in the new pref scale.
+prefOldToNew p' = 100 - 5 * p'
+prefNewToOld p = 20 - 0.2 * p
instance Show PMInstance where
- show (PMInstance numRvrs numProps loadA prefA) =
- let theRvrs = [0..numRvrs-1]; theProps = [0..numProps-1] in
- "Instance with " ++ show numRvrs ++ " reviewers and " ++ show numProps ++ " proposals:\n" ++ formatTable (
+ show pmi =
+ let theRvrs = [0..pmiNumReviewers pmi - 1]; theProps = [0..pmiNumProposals pmi - 1] in
+ "Instance with " ++ show (pmiNumReviewers pmi) ++ " reviewers and " ++ show (pmiNumProposals pmi) ++ " proposals:\n" ++ formatTable (
( "" : map (\i -> "R#" ++ show i ) theRvrs) :
- ( "RLoad" : map (\i -> show (loadA ! i) ) theRvrs) :
- map (\j -> ("P#" ++ show j) : map (\i -> show (prefA ! (i, j))) theRvrs) theProps
+ ( "RLoad" : map (\i -> show (pmiRLoad pmi ! i) ) theRvrs) :
+ map (\j -> ("P#" ++ show j) : map (\i -> show (pmiRPPref pmi ! (i, j)) ++ ":" ++ show (pmiRPExp pmi ! (i, j))) theRvrs) theProps
)
newtype PMatching = PMatching [(Int, Int)]
PTopic1 jt1 -> expertnessToPref (iTE ! jt1)
PTopic2 jt1 jt2 -> (expertnessToPref (iTE ! jt1)
+ expertnessToPref (iTE ! jt2)) / 2
- in if isConflict then 40 else topicPref * jD - 4)
- return $ PMInstance numRvrs numProps loadA prefA
+ -- Use a formula designed for the old pref scale with the new.
+ in if isConflict then -100 else prefOldToNew (topicPref * jD - 4))
+ let expA = funcArray ((0, 0), (numRvrs-1, numProps-1)) (\(i,j) ->
+ let
+ ReviewerInfo iTE iC = reviewerInfos ! i
+ ProposalInfo jT jD = proposalInfos ! j
+ isConflict = elem j iC
+ topicExp = case jT of
+ PTopic1 jt1 -> 1 + (iTE ! jt1)
+ PTopic2 jt1 jt2 -> 1 + ((iTE ! jt1)
+ + (iTE ! jt2)) / 2
+ in topicExp)
+ -- defaults
+ let fixA = constArray ((0,0), (numRvrs-1,numProps-1)) False
+ let pnrA = constArray (0, numProps-1) (reviewsEachProposal cfg)
+ return $ PMInstance numRvrs numProps loadA prefA expA fixA pnrA
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Tree
import Data.List
+import Data.Either
+import ArrayStuff
+import MonadStuff
import PMInstance
import PMConfig
prefBoringness cfg p = if prefIsVeryBoring cfg p then 2
else if prefIsBoring cfg p then 1 else 0
-prefExpertness cfg p = if prefIsExpert cfg p then 2
- else if prefIsKnowledgeable cfg p then 1 else 0
+expExpertness cfg x = if expIsExpert cfg x then 2
+ else if expIsKnowledgeable cfg x then 1 else 0
data REdge = REdge {
reIdx :: Int,
let (imax, ies) = indexEdges (i+1) es in
(imax, (v1, v2, re{ reIdx = i }) : ies)
+implies :: Bool -> Bool -> Bool
+x `implies` y = (not x) || y
+
doReduction :: PMConfig -> PMInstance -> ReductionResult
-doReduction cfg (PMInstance numRvrs numProps rloadA prefA) =
+doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA fixA pnrA) =
let
+ -- Need to figure out who is PC/ERC
+ isPC = (funcArray (0, numRvrs-1) (\i -> (rloadA ! i) == 1)) :: Array Int Bool
+ isPCPaper = (funcArray (0, numProps-1) (\j -> all (\i -> (isPC ! i) `implies` (prefIsConflict cfg $ (prefA ! (i, j)))) [0 .. numRvrs - 1])) :: Array Int Bool
source = 0
sink = 1
rvrNode i boringness = 2 + 3*i + boringness
- propNode j expertness = 2 + 3*numRvrs + 3*j + expertness
- numNodes = 2 + 3*numRvrs + 3*numProps
+ -- We will waste a lot of nodes. Who cares, no one will visit them.
+ propNode j k = 2 + 3*numRvrs + 7*j + k
+ numNodes = 2 + 3*numRvrs + 7*numProps
edIdx (i, j) = i*numProps + j
in
let
- totalReviews = (reviewsEachProposal cfg) * numProps
+ totalReviews = sum $ elems pnrA -- (reviewsEachProposal cfg) * numProps
totalRelativeLoad = foldl (+) 0 (map (rloadA !) [0 .. numRvrs - 1])
- targetLoad i = ceiling (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad)
+ -- floor goes best with loadTolerance 2
+ targetLoad i = floor (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad) - 1
-- Edge groups A through H are indicated in the figure in the paper.
edgesABC = do
i <- [0 .. numRvrs - 1]
let tl = targetLoad i
+ let lt = if isPC ! i then loadTolerance cfg else ercLoadTolerance cfg
let freeEdgeA = (source, rvrNode i 0, REdge undefined tl 0)
let nonfreeEdgesA = do
- l <- [tl .. tl + (loadTolerance cfg) - 1]
- let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger (loadTolerance cfg))
- [(source, rvrNode i 0, REdge undefined 1 costA)]
+ l <- [tl .. tl + lt - 1]
+ let costA = marginalLoadCost cfg ((widenInteger (l - tl) + 1/2) / widenInteger lt)
+ return (source, rvrNode i 0, REdge undefined 1 costA)
let edgesBC = do
- l <- [0 .. tl + (loadTolerance cfg) - 1]
+ l <- [0 .. tl + lt - 1]
let costB = marginalBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
let edgeB = (rvrNode i 0, rvrNode i 1, REdge undefined 1 costB)
let costC = marginalVeryBoringCost cfg ((widenInteger l + 1/2) / widenInteger tl)
let edgeC = (rvrNode i 1, rvrNode i 2, REdge undefined 1 costC)
[edgeB, edgeC]
[freeEdgeA] ++ nonfreeEdgesA ++ edgesBC
- edgesD = do
+ edgesDFix = do
i <- [0 .. numRvrs - 1]
j <- [0 .. numProps - 1]
let pref = prefA ! (i, j)
+ let xp = expA ! (i, j)
-- We must generate an edge even if there is a conflict
-- of interest; otherwise we'll fail to read its flow
-- value in doMatching.
- [(rvrNode i (prefBoringness cfg pref),
- propNode j (prefExpertness cfg pref),
- REdge (edIdx (i, j))
+ let xp_ = expExpertness cfg xp
+ let pn = propNode j $ if (isPC ! i)
+ then xp_ + 3 -- Can assume it is a PC paper, otherwise it would conflict anyway.
+ else xp_
+ let rn = rvrNode i (prefBoringness cfg pref)
+ if fixA ! (i, j)
+ -- Max flow will emulate one unit of flow through the edge,
+ -- at a cost of increasing the total flow value by 1.
+ then [Right (rn, sink, REdge undefined 1 0),
+ Right (source, pn, REdge undefined 1 0)]
+ else [Left (rn, pn, REdge (edIdx (i, j))
(if prefIsConflict cfg pref then 0 else 1)
(assignmentCost cfg pref))]
+ edgesD = lefts edgesDFix
+ edgesFix = rights edgesDFix
edgesEFGH = do
j <- [0 .. numProps - 1]
- let edgeE = (propNode j 2, propNode j 0, REdge undefined 1 (-(expertBonus cfg)))
- let edgeF = (propNode j 2, propNode j 1, REdge undefined (reviewsEachProposal cfg) 0)
- let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
- let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (reviewsEachProposal cfg - 1) 0)
- let edgeH = (propNode j 0, sink, REdge undefined (reviewsEachProposal cfg) 0)
- [edgeE, edgeF, edgeGFirst, edgeGRest, edgeH]
+ -- This is now different...
+ let numReviews = pnrA ! j
+ if isPCPaper ! j
+ then do -- Mostly traditional.
+ -- Expert bonus
+ let edgeFFirst = (propNode j 2, propNode j 1, REdge undefined 1 (-(expertBonus cfg)))
+ let edgeFRest = (propNode j 2, propNode j 1, REdge undefined (numReviews - 1) 0)
+ -- Second kowledgeable bonus
+ let edgeGFirst = (propNode j 1, propNode j 0, REdge undefined 1 (-(knowledgeableBonus cfg)))
+ let edgeGRest = (propNode j 1, propNode j 0, REdge undefined (numReviews - 2) 0)
+ -- Require one knowledgeable
+ let edgeH1 = (propNode j 1, sink, REdge undefined 1 0)
+ let edgeH = (propNode j 0, sink, REdge undefined (numReviews - 1) 0)
+ [edgeFFirst, edgeFRest, edgeGFirst, edgeGRest, edgeH1, edgeH]
+ else do -- New gadget; man, a lot of edges
+ let numPCReviews = pcReviewsEachProposal cfg
+ if numReviews < numPCReviews then fail "numReviews for paper < numPCReviews" else nop
+ -- Structure to distribute knowledgeable PC members
+ let edgesP = [(propNode j k, propNode j 6, REdge undefined numPCReviews 0) | k <- [4 .. 5]]
+ let edgesR = [(propNode j k, propNode j (k - 3), REdge undefined (numReviews - numPCReviews) 0) | k <- [4 .. 5]]
+ -- "Designated knowledgeable" with expert bonus
+ let edgeF = (propNode j 2, propNode j 1, REdge undefined (numReviews - numPCReviews) (-(expertBonus cfg)))
+ let edgeH1 = (propNode j 1, sink, REdge undefined (numReviews - numPCReviews) 0)
+ -- "Designated PC" with knowledgeable bonus
+ let edgeGFirst = (propNode j 6, propNode j 3, REdge undefined 1 (-(knowledgeableBonus cfg)))
+ let edgeGRest = (propNode j 6, propNode j 3, REdge undefined (numPCReviews - 1) 0)
+ let edgeH = (propNode j 3, sink, REdge undefined (numPCReviews) 0)
+ edgesP ++ edgesR ++ [edgeF, edgeH1, edgeGFirst, edgeGRest, edgeH]
theNodes = [(x, ()) | x <- [0 .. numNodes - 1]]
-- Index the non-D edges
- unindexedEdges = edgesABC ++ edgesEFGH
+ unindexedEdges = edgesABC ++ edgesFix ++ edgesEFGH
(imax, reindexedEdges) = indexEdges (numRvrs*numProps) unindexedEdges
theEdges = edgesD ++ reindexedEdges
in
-- Returns a list of reviews as ordered pairs (reviewer#, proposal#).
doMatching :: PMConfig -> PMInstance -> PMatching
-doMatching cfg inst@(PMInstance numRvrs numProps _ _) =
+doMatching cfg inst@(PMInstance numRvrs numProps _ _ _ fixA _) =
let ReductionResult graph source sink idxBounds edIdx = doReduction cfg inst in
let flowArray = minCostFlow cfg idxBounds reIdx reCap reCost graph (source, sink) in
let pairs = do
i <- [0 .. numRvrs - 1]
j <- [0 .. numProps - 1]
- if flowArray ! edIdx (i, j) == 1
+ if fixA ! (i, j) || flowArray ! edIdx (i, j) == 1
then [(i, j)]
else []
in
./match is a front-end that reads an instance from stdin and prints the matching
to stdout.
+<<< FIXME: Adapt the following for popl2012 branch >>>
Input: A tab-separated array with one column per reviewer. The first row gives
the relative loads of the reviewers. Thereafter, each row gives the preference
values (1 to 39, 40 = conflict of interest) of all reviewers for a single
(myNumRvrs, myNumProps) = (5, 3)
-myPrefs = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) [
- 15, 10, 15, 40, 20,
+myPrefs = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) $
+ map prefOldToNew [
+ 40, 40, 40, 30, 40,
30, 7, 10, 15, 15,
15, 25, 20, 20, 15
] :: UArray (Int, Int) Wt
-myInst = PMInstance myNumRvrs myNumProps (constArray (0, myNumRvrs-1) 1) myPrefs
+-- This data is pretty made-up... ~ 2011-07-11
+myExps = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) [
+ 2, 2, 1, 3, 1,
+ 0, 3, 2, 2, 2,
+ 2, 1, 1, 2, 2
+ ] :: UArray (Int, Int) Wt
+
+--myInst = PMInstance myNumRvrs myNumProps (constArray (0, myNumRvrs-1) 1) myPrefs myExps
+myFix = constArray ((0,0), (myNumRvrs-1,myNumProps-1)) False
+myPNR = constArray (0, myNumProps-1) (reviewsEachProposal pmDefaults)
+myInst = PMInstance myNumRvrs myNumProps (listArray (0, myNumRvrs-1) [1, 1, 1, 0.9, 1]) myPrefs myExps myFix myPNR
rdnResult = doReduction pmDefaults myInst
ReductionResult rrg rrso rrsi rreib rredi = rdnResult
(n1, n2, REdgeF i ca (fa ! i) co)) $ labEdges g) :: Gr () REdgeF
showInstanceAsGraph :: PMInstance -> PMatching -> Gr String String
-showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA) (PMatching matchedPairs) =
+showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA expA fixA pnrA) (PMatching matchedPairs) =
let
rvrNode i = i
propNode j = numRvrs + j
numNodes = numRvrs + numProps
theNodes = map (\i -> (rvrNode i, "R#" ++ show i ++
" (RLoad " ++ show (rloadA ! i) ++ ")")) [0..numRvrs-1] ++
- map (\j -> (propNode j, "P#" ++ show j)) [0..numProps-1]
+ map (\j -> (propNode j, "P#" ++ show j ++ "[" ++ show (pnrA ! j) ++ "]")) [0..numProps-1]
parenthesizeIf False s = s
parenthesizeIf True s = "(" ++ s ++ ")"
theEdges = do
i <- [0..numRvrs-1]
j <- [0..numProps-1]
return (rvrNode i, propNode j,
- parenthesizeIf (elem (i, j) matchedPairs) $ show (prefA ! (i, j)))
+ parenthesizeIf (elem (i, j) matchedPairs) $
+ show (prefA ! (i, j)) ++ ":" ++ show (expA ! (i, j)) ++ (if fixA ! (i, j) then "*" else ""))
in mkGraph theNodes theEdges
goFile :: String -> IO ()
-- First generate graphviz code.
let gvCode = graphviz' theGraph in do
-- Then have `dot' convert it to postscript in a file.
- (rH, wH) <- createHandlePipe
pt <- epochTime
let fname = "graph-" ++ show pt ++ ".ps"
- dotPid <- runProcess "dot" ["-Tps", "-o", fname]
- Nothing Nothing (Just rH) Nothing Nothing
- forkIO (do
- hPutStr wH gvCode
- hClose wH)
+ (Just wH, _, _, dotPid) <- createProcess (proc "dot" ["-Tps", "-o", fname]) {std_in = CreatePipe}
+ hPutStr wH gvCode
+ hClose wH
waitForProcess dotPid
-- Then open the file.
goFile fname
-1 1 1 1 1
-15 10 15 40 20
-30 7 10 15 15
-15 25 20 20 15
+ 1 1 1 1 1
+4 25* 50 25 -100 0
+ 2 2 1 3 1
+4 -50 65 50 25 25
+ 0 3 2 2 2
+4 25 -25 0 0 25
+ 2 1 1 2 2
Matt McCutchen's Web Site / match / match.git / commitdiff