module HAHP.Validation.Tree where
import Control.Parallel.Strategies
import Data.List (group, sort, sortBy)
import Data.Maybe
import HAHP.Data
import HAHP.Validation.Unique
import Numeric.LinearAlgebra.HMatrix
validateInputAHPTree :: AHPTree -> [TreeError]
validateInputAHPTree ahpTree = validate' ahpTree inputTestsList
validateAHPTree :: AHPTree -> [TreeError]
validateAHPTree ahpTree = validate' ahpTree testsList
validate' :: AHPTree -> [AHPTree -> Maybe TreeError] -> [TreeError]
validate' ahpTree checks = catMaybes $ concat $ parMap rseq (recursiveValidator ahpTree) checks
inputTestsList :: [AHPTree -> Maybe TreeError]
inputTestsList = [ squareMatrixTest
, parentSizeMatchChildrenTest
, unitaryDiagTest
, nullDivisionTest
, positivePreferenceTest
, inverseTest
, childrenUnicityTest
, leavesUnicityTest
]
testsList :: [AHPTree -> Maybe TreeError]
testsList = [ consistencyTest
]
recursiveValidator :: AHPTree
-> (AHPTree -> Maybe TreeError)
-> [Maybe TreeError]
recursiveValidator ahpTree testFnt =
case ahpTree of
AHPTree {} -> currentValidity : childrenValidity
where currentValidity = testFnt ahpTree
childrenValidity = concat $ parMap rseq (`recursiveValidator` testFnt) (children ahpTree)
AHPLeaf {} -> [Nothing]
consistencyTest :: AHPTree -> Maybe TreeError
consistencyTest ahpTree =
case consistencyValue ahpTree of
Nothing -> Just NotComputedConsistencyError { ahpTree = ahpTree }
Just x -> if isMatrixConsistent x validationConsistencyThreshold
then Nothing
else Just ConsistencyError { ahpTree = ahpTree
, consistencyThreshold = validationConsistencyThreshold
, consistency = x
}
validationConsistencyThreshold = 0.1
isMatrixConsistent :: Double -> Double -> Bool
isMatrixConsistent consistency threshold
| consistency < threshold = True
| otherwise = False
childrenUnicityTest :: AHPTree -> Maybe TreeError
childrenUnicityTest ahpTree =
if null repeatedChildrenNames
then Nothing
else Just ChildrenUnicityError { ahpTree = ahpTree
, repeatedChildrenNames = repeatedChildrenNames
}
where repeatedChildrenNames = repeated . map name . children $ ahpTree
leavesUnicityTest :: AHPTree -> Maybe TreeError
leavesUnicityTest ahpTree =
if null repeatedLeavesNames
then Nothing
else Just LeavesUnicityError { ahpTree = ahpTree
, repeatedLeavesNames = repeatedLeavesNames
}
where repeatedLeavesNames = repeated . map name . getTreeLeaves $ ahpTree
parentSizeMatchChildrenTest :: AHPTree -> Maybe TreeError
parentSizeMatchChildrenTest ahpTree =
if parentSize == childrenSize
then Nothing
else Just ParentChildrenSizeMismatchError { ahpTree = ahpTree
, errorParentSize = parentSize
, errorChildrenSize = childrenSize
}
where parentSize = rows . preferenceMatrix $ ahpTree
childrenSize = length . children $ ahpTree
inverseTest :: AHPTree -> Maybe TreeError
inverseTest ahpTree =
if all (inverseTest' . preferenceMatrix $ ahpTree) indices
then Nothing
else Just InverseError {ahpTree = ahpTree}
where indices = [ (i, j)
| i <- [1..matrixSize1]
, j <- [1..matrixSize1]
, j > i
]
matrixSize = fromIntegral . rows . preferenceMatrix $ ahpTree
inverseTest' :: Matrix Double -> (Int, Int) -> Bool
inverseTest' matrix (i, j) = m_ij == (1 / m_ji)
where
m_ij :: Double
m_ij = matrix `atIndex` (i, j)
m_ji :: Double
m_ji = matrix `atIndex` (j, i)
nullDivisionTest :: AHPTree -> Maybe TreeError
nullDivisionTest ahpTree =
if 0 `notElem` matrixvalues
then Nothing
else Just NullDivisionError {ahpTree = ahpTree}
where matrixvalues = concat . toLists . preferenceMatrix $ ahpTree
positivePreferenceTest :: AHPTree -> Maybe TreeError
positivePreferenceTest ahpTree =
if all (> 0) matrixValues
then Nothing
else Just PositivePreferenceError {ahpTree = ahpTree}
where matrixValues = concat . toLists . preferenceMatrix $ ahpTree
squareMatrixTest :: AHPTree -> Maybe TreeError
squareMatrixTest ahpTree =
if rows matrix == cols matrix
then Nothing
else Just SquareMatrixError { ahpTree = ahpTree
, errorRows = rows matrix
, errorCols = cols matrix
}
where matrix = preferenceMatrix ahpTree
unitaryDiagTest :: AHPTree -> Maybe TreeError
unitaryDiagTest ahpTree =
if all (== 1) diagonalValues
then Nothing
else Just NotUnitaryDiagError {ahpTree = ahpTree}
where diagonalValues = toList . takeDiag . preferenceMatrix $ ahpTree