From 578d7d9809c18a096bb1c9a31125abccb79be782 Mon Sep 17 00:00:00 2001 From: Matt McCutchen Date: Tue, 19 Jul 2011 20:27:24 -0400 Subject: [PATCH] New features from Tuesday call: - Ability to fix matched pairs - Number of required reviews is per-paper (think of as fixing a paper to an outsider) - Different load tolerance for ERC --- program/Evaluation.hs | 2 +- program/Main.hs | 16 +++++++--- program/PMConfig.hs | 2 ++ program/PMDefaults.hs | 7 ++++- program/PMInstance.hs | 6 +++- program/PMInstanceGenerator.hs | 5 ++- program/ProposalMatcher.hs | 56 +++++++++++++++++++++------------- program/Test.hs | 4 ++- program/TestUtils.hs | 7 +++-- program/example.in | 14 ++++----- 10 files changed, 78 insertions(+), 41 deletions(-) diff --git a/program/Evaluation.hs b/program/Evaluation.hs index 201f176..1b4be42 100644 --- a/program/Evaluation.hs +++ b/program/Evaluation.hs @@ -12,7 +12,7 @@ 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 diff --git a/program/Main.hs b/program/Main.hs index e3dbfff..0bbfdda 100644 --- a/program/Main.hs +++ b/program/Main.hs @@ -3,6 +3,7 @@ import PMDefaults import ProposalMatcher import System.IO import Data.Array.IArray +import Data.Array.Unboxed import ArrayStuff import Text.CSV @@ -18,15 +19,22 @@ main = do incsv <- hGetContents stdin -- handle errors another day, or let the platform do it let Right inll = parseTSV "standard input" 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) `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 ! (2*j, i)) - let expA = funcArray ((0,0), (numRvrs-1,numProps-1)) (\(i,j) -> read $ pxarr ! (2*j+1, i)) - let theInst = PMInstance numRvrs numProps loadA prefA expA + 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 $ printTSV $ map (\(i, j) -> map show [i, j]) theMatching diff --git a/program/PMConfig.hs b/program/PMConfig.hs index 7e50fac..fe181fa 100644 --- a/program/PMConfig.hs +++ b/program/PMConfig.hs @@ -12,12 +12,14 @@ import IMinCostFlow data PMConfig = PMConfig { minCostFlow :: MinCostFlowImpl, reviewsEachProposal :: Int, + 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, diff --git a/program/PMDefaults.hs b/program/PMDefaults.hs index be000e8..b3e290b 100644 --- a/program/PMDefaults.hs +++ b/program/PMDefaults.hs @@ -23,6 +23,9 @@ minCostFlow = NaiveMinCostFlow.minCostFlow, -- The number of reviews each proposal should get. reviewsEachProposal = 4, +-- Applies to non-PC papers +pcReviewsEachProposal = 3, + -- === Interpretation of the preference values === expIsExpert = \x -> x >= 3, @@ -39,7 +42,9 @@ prefIsConflict = \p -> p <= -100, -- load of (relativeLoad * ceiling(numProps * reviewsEachProposal / -- totalRelativeLoad)). For now this is an additive constant; perhaps it should -- be proportional to the target load. -loadTolerance = 3, +loadTolerance = 2, + +ercLoadTolerance = 3, -- Cost to overload by one review. -- tx = 0 at target load, 1 at end of tolerance. diff --git a/program/PMInstance.hs b/program/PMInstance.hs index aba03b2..1cc8caa 100644 --- a/program/PMInstance.hs +++ b/program/PMInstance.hs @@ -15,7 +15,11 @@ data PMInstance = PMInstance { 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 + 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. diff --git a/program/PMInstanceGenerator.hs b/program/PMInstanceGenerator.hs index 47a5ce4..9cafacd 100644 --- a/program/PMInstanceGenerator.hs +++ b/program/PMInstanceGenerator.hs @@ -80,4 +80,7 @@ randomInstance cfg numRvrs numProps = do PTopic2 jt1 jt2 -> 1 + ((iTE ! jt1) + (iTE ! jt2)) / 2 in topicExp) - return $ PMInstance numRvrs numProps loadA prefA expA + -- 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 diff --git a/program/ProposalMatcher.hs b/program/ProposalMatcher.hs index 4a4b67b..c82855e 100644 --- a/program/ProposalMatcher.hs +++ b/program/ProposalMatcher.hs @@ -3,8 +3,10 @@ import Data.Array.IArray import Data.Graph.Inductive.Graph import Data.Graph.Inductive.Tree import Data.List +import Data.Either import ArrayStuff +import MonadStuff import PMInstance import PMConfig @@ -46,7 +48,7 @@ implies :: Bool -> Bool -> Bool x `implies` y = (not x) || y doReduction :: PMConfig -> PMInstance -> ReductionResult -doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA) = +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 @@ -60,7 +62,7 @@ doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA) = 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]) -- floor goes best with loadTolerance 2 targetLoad i = floor (widenInteger totalReviews * (rloadA ! i) / totalRelativeLoad) - 1 @@ -68,20 +70,21 @@ doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA) = 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)) + 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) @@ -90,44 +93,53 @@ doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA) = -- of interest; otherwise we'll fail to read its flow -- value in doMatching. let xp_ = expExpertness cfg xp - let k = if (isPC ! i) + let pn = propNode j $ if (isPC ! i) then xp_ + 3 -- Can assume it is a PC paper, otherwise it would conflict anyway. else xp_ - [(rvrNode i (prefBoringness cfg pref), - propNode j k, - REdge (edIdx (i, j)) + 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] -- 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 (reviewsEachProposal cfg - 1) 0) + 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 (reviewsEachProposal cfg - 2) 0) + 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 (reviewsEachProposal cfg - 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 (reviewsEachProposal cfg - 1) 0) | k <- [4 .. 5]] - let edgesR = [(propNode j k, propNode j (k - 3), REdge undefined 1 0) | k <- [4 .. 5]] + 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 1 (-(expertBonus cfg))) - let edgeH1 = (propNode j 1, sink, REdge undefined 1 0) + 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 (reviewsEachProposal cfg - 2) 0) - let edgeH = (propNode j 3, sink, REdge undefined (reviewsEachProposal cfg - 1) 0) + let edgeGRest = (propNode j 6, propNode j 3, REdge undefined (numPCReviews - 2) 0) + let edgeH = (propNode j 3, sink, REdge undefined (numPCReviews - 1) 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 @@ -135,13 +147,13 @@ doReduction cfg (PMInstance numRvrs numProps rloadA prefA expA) = -- 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 diff --git a/program/Test.hs b/program/Test.hs index d97edb6..2bb5f54 100644 --- a/program/Test.hs +++ b/program/Test.hs @@ -79,7 +79,9 @@ myExps = transposeArray $ listArray ((0,0), (myNumProps-1,myNumRvrs-1)) [ ] :: UArray (Int, Int) Wt --myInst = PMInstance myNumRvrs myNumProps (constArray (0, myNumRvrs-1) 1) myPrefs myExps -myInst = PMInstance myNumRvrs myNumProps (listArray (0, myNumRvrs-1) [1, 1, 1, 0.9, 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 diff --git a/program/TestUtils.hs b/program/TestUtils.hs index 8bc1e32..60b6f62 100644 --- a/program/TestUtils.hs +++ b/program/TestUtils.hs @@ -34,21 +34,22 @@ flowAnnotate g fa = (n1, n2, REdgeF i ca (fa ! i) co)) $ labEdges g) :: Gr () REdgeF showInstanceAsGraph :: PMInstance -> PMatching -> Gr String String -showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA expA) (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)) ++ ":" ++ show (expA ! (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 () diff --git a/program/example.in b/program/example.in index 5d46307..46c6ed8 100644 --- a/program/example.in +++ b/program/example.in @@ -1,7 +1,7 @@ -1 1 1 1 1 -25 50 25 -100 0 -2 2 1 3 1 --50 65 50 25 25 -0 3 2 2 2 -25 -25 0 0 25 -2 1 1 2 2 + 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 -- 2.34.1