refactor(study-features): cleanup
This commit is contained in:
Gregor Kleen
parent
0e027b129e
commit
5cd2d39f10
@ -17,9 +17,11 @@ BtnHijack: Sitzung übernehmen
|
||||
BtnSave: Speichern
|
||||
PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert.
|
||||
BtnHandIn: Abgeben
|
||||
BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
|
||||
BtnCandidatesDeleteConflicts: Konflikte löschen
|
||||
BtnCandidatesDeleteAll: Alle Beobachtungen löschen
|
||||
BtnNameCandidatesInfer: Studienfach-Namens-Zuordnung automatisch lernen
|
||||
BtnNameCandidatesDeleteConflicts: Namenskonflikte löschen
|
||||
BtnNameCandidatesDeleteAll: Alle Namens-Beobachtungen löschen
|
||||
BtnParentCandidatesInfer: Unterstudiengangs-Zuordnung automatisch lernen
|
||||
BtnParentCandidatesDeleteAll: Alle Unterstudiengangs-Beobachtungen löschen
|
||||
BtnResetTokens: Authorisierungs-Tokens invalidieren
|
||||
BtnLecInvAccept: Annehmen
|
||||
BtnLecInvDecline: Ablehnen
|
||||
@ -764,10 +766,11 @@ NoStudyTermsKnown: Keine Studiengänge bekannt
|
||||
StudyFeaturesDegrees: Abschlüsse
|
||||
StudyFeaturesTerms: Studiengänge
|
||||
StudyFeaturesNameCandidates: Namens-Kandidaten
|
||||
StudyFeaturesParentCandidates: Eltern-Kandidaten
|
||||
StudyFeatureInference: Studiengangschlüssel-Inferenz
|
||||
StudyFeatureInferenceNoConflicts: Keine Konflikte beobachtet
|
||||
StudyFeatureInferenceConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
|
||||
StudyFeaturesParentCandidates: Kandidaten für Unterstudiengänge
|
||||
StudyFeatureNameInference: Studiengangschlüssel-Inferenz
|
||||
StudyFeatureParentInference: Unterstudiengang-Inferenz
|
||||
StudyFeatureInferenceNoNameConflicts: Keine Konflikte beobachtet
|
||||
StudyFeatureInferenceNameConflictsHeading: Studiengangseinträge mit beobachteten Konflikten
|
||||
StudyFeatureAge: Fachsemester
|
||||
StudyFeatureDegree: Abschluss
|
||||
FieldPrimary: Hauptfach
|
||||
@ -788,13 +791,16 @@ StudyTermsShort: Studiengangkürzel
|
||||
StudyTermsChangeSuccess: Zuordnung Studiengänge aktualisiert
|
||||
StudyDegreeChangeSuccess: Zuordnung Abschlüsse aktualisiert
|
||||
StudyCandidateIncidence: Synchronisation
|
||||
AmbiguousCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
|
||||
AmbiguousNameCandidatesRemoved n@Int: #{show n} #{pluralDE n "uneindeutiger Kandidat" "uneindeutige Kandiaten"} entfernt
|
||||
RedundantNameCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Namenskandidat" "bekannte Namenskandiaten"} entfernt
|
||||
RedundantParentCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Elternkandidat" "bekannte Elternkandiaten"} entfernt
|
||||
RedundantStandaloneCandidatesRemoved n@Int: #{show n} bereits #{pluralDE n "bekannter Einzelstudiengangskandidat" "bekannte Einzelstudiengangskandiaten"} entfernt
|
||||
CandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
|
||||
NoCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
|
||||
AllIncidencesDeleted: Alle Beobachtungen wurden gelöscht.
|
||||
NameCandidatesInferred n@Int: #{show n} neue #{pluralDE n "Studiengangszuordnung" "Studiengangszuordnungen"} inferiert
|
||||
NoNameCandidatesInferred: Keine neuen Studienganszuordnungen inferiert
|
||||
ParentCandidatesInferred n@Int: #{show n} #{pluralDE n "neuer Unterstudiengang" "neue Unterstudiengänge"} inferiert
|
||||
NoParentCandidatesInferred: Keine neuen Unterstudiengänge inferiert
|
||||
AllNameIncidencesDeleted: Alle Namens-Beobachtungen wurden gelöscht.
|
||||
AllParentIncidencesDeleted: Alle Unterstudiengang-Beobachtungen wurden gelöscht.
|
||||
IncidencesDeleted n@Int: #{show n} #{pluralDE n "Beobachtung" "Beobachtungen"} gelöscht
|
||||
StudyTermIsNew: Neu
|
||||
StudyFeatureConflict: Es wurden Konflikte in der Studiengang-Zuordnung gefunden
|
||||
|
||||
@ -17,9 +17,11 @@ BtnHijack: Hijack session
|
||||
BtnSave: Save
|
||||
PressSaveToSave: Changes will only be saved after clicking "Save".
|
||||
BtnHandIn: Hand in submission
|
||||
BtnCandidatesInfer: Infer mapping
|
||||
BtnCandidatesDeleteConflicts: Delete conflicts
|
||||
BtnCandidatesDeleteAll: Delete all observations
|
||||
BtnNameCandidatesInfer: Infer name-mapping
|
||||
BtnNameCandidatesDeleteConflicts: Delete name-conflicts
|
||||
BtnNameCandidatesDeleteAll: Delete all name-observations
|
||||
BtnParentCandidatesInfer: Infer parent-relation
|
||||
BtnParentCandidatesDeleteAll: Delete all parent-observations
|
||||
BtnResetTokens: Invalidate tokens
|
||||
BtnLecInvAccept: Accept
|
||||
BtnLecInvDecline: Decline
|
||||
@ -762,9 +764,10 @@ StudyFeaturesDegrees: Degrees
|
||||
StudyFeaturesTerms: Terms of Study
|
||||
StudyFeaturesNameCandidates: Name candidates
|
||||
StudyFeaturesParentCandidates: Parent candidates
|
||||
StudyFeatureInference: Infer field of study mapping
|
||||
StudyFeatureInferenceNoConflicts: No observed conflicts
|
||||
StudyFeatureInferenceConflictsHeading: Fields of study with observed conflicts
|
||||
StudyFeatureNameInference: Infer field of study mapping
|
||||
StudyFeatureParentInference: Infer field of study parent relation
|
||||
StudyFeatureInferenceNoNameConflicts: No observed conflicts
|
||||
StudyFeatureInferenceNameConflictsHeading: Fields of study with observed conflicts
|
||||
StudyFeatureAge: Semester
|
||||
StudyFeatureDegree: Degree
|
||||
FieldPrimary: Major
|
||||
@ -785,13 +788,16 @@ StudyTermsShort: Field shorthand
|
||||
StudyTermsChangeSuccess: Successfully updated fields of study
|
||||
StudyDegreeChangeSuccess: Successfully updated degrees
|
||||
StudyCandidateIncidence: Synchronisation
|
||||
AmbiguousCandidatesRemoved n: Successfully removed #{n} ambiguous #{pluralEN n "candidate" "candidates"}
|
||||
AmbiguousNameCandidatesRemoved n: Successfully removed #{n} ambiguous #{pluralEN n "candidate" "candidates"}
|
||||
RedundantNameCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "name-candidate" "name-candidates"}
|
||||
RedundantParentCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "parent-candidate" "parent-candidates"}
|
||||
RedundantStandaloneCandidatesRemoved n: Successfully removed #{n} rendundant #{pluralEN n "standalone-candidate" "standalone-candidates"}
|
||||
CandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"}
|
||||
NoCandidatesInferred: No new mappings inferred
|
||||
AllIncidencesDeleted: Successfully deleted all observations
|
||||
NameCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "mapping" "mappings"}
|
||||
NoNameCandidatesInferred: No new name-mappings inferred
|
||||
AllNameIncidencesDeleted: Successfully deleted all name observations
|
||||
AllParentIncidencesDeleted: Successfully deleted all parent-relation observations
|
||||
ParentCandidatesInferred n: Successfully inferred #{n} field #{pluralEN n "parent-relation" "parent-reliations"}
|
||||
NoParentCandidatesInferred: No new parent-relations inferred
|
||||
IncidencesDeleted n: Successfully deleted #{show n} #{pluralEN n "observation" "observations"}
|
||||
StudyTermIsNew: New
|
||||
StudyFeatureConflict: Observed conflicts in field mapping
|
||||
|
||||
@ -20,6 +20,7 @@ module Database.Esqueleto.Utils
|
||||
, maybe
|
||||
, SqlProject(..)
|
||||
, (->.)
|
||||
, fromSqlKey
|
||||
, module Database.Esqueleto.Utils.TH
|
||||
) where
|
||||
|
||||
@ -250,3 +251,6 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.E
|
||||
|
||||
(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
|
||||
(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t
|
||||
|
||||
fromSqlKey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value Int64)
|
||||
fromSqlKey = E.veryUnsafeCoerceSqlExprValue
|
||||
|
||||
@ -18,41 +18,53 @@ import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter)
|
||||
import qualified Handler.Utils.TermCandidates as Candidates
|
||||
|
||||
|
||||
-- BEGIN - Buttons needed only for StudyTermNameCandidateManagement
|
||||
data ButtonAdminStudyTerms
|
||||
= BtnCandidatesInfer
|
||||
| BtnCandidatesDeleteConflicts
|
||||
| BtnCandidatesDeleteAll
|
||||
data ButtonAdminStudyTermsNames
|
||||
= BtnNameCandidatesInfer
|
||||
| BtnNameCandidatesDeleteConflicts
|
||||
| BtnNameCandidatesDeleteAll
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonAdminStudyTerms
|
||||
instance Finite ButtonAdminStudyTerms
|
||||
instance Universe ButtonAdminStudyTermsNames
|
||||
instance Finite ButtonAdminStudyTermsNames
|
||||
|
||||
nullaryPathPiece ''ButtonAdminStudyTerms camelToPathPiece
|
||||
embedRenderMessage ''UniWorX ''ButtonAdminStudyTerms id
|
||||
nullaryPathPiece ''ButtonAdminStudyTermsNames $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsNames id
|
||||
|
||||
instance Button UniWorX ButtonAdminStudyTerms where
|
||||
btnClasses BtnCandidatesInfer = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnCandidatesDeleteConflicts = [BCIsButton, BCDanger]
|
||||
btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||
-- END Button needed only here
|
||||
instance Button UniWorX ButtonAdminStudyTermsNames where
|
||||
btnClasses BtnNameCandidatesInfer = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnNameCandidatesDeleteConflicts = [BCIsButton, BCDanger]
|
||||
btnClasses BtnNameCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||
|
||||
data ButtonAdminStudyTermsParents
|
||||
= BtnParentCandidatesInfer
|
||||
| BtnParentCandidatesDeleteAll
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonAdminStudyTermsParents
|
||||
instance Finite ButtonAdminStudyTermsParents
|
||||
|
||||
nullaryPathPiece ''ButtonAdminStudyTermsParents $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
|
||||
|
||||
instance Button UniWorX ButtonAdminStudyTermsParents where
|
||||
btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
|
||||
|
||||
|
||||
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
|
||||
getAdminFeaturesR = postAdminFeaturesR
|
||||
postAdminFeaturesR = do
|
||||
uid <- requireAuthId
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("infer-button" :: Text) (buttonForm :: Form ButtonAdminStudyTerms)
|
||||
let btnForm = wrapForm btnWdgt def
|
||||
((nameBtnResult, nameBtnWdgt), nameBtnEnctype) <- runFormPost $ identifyForm ("infer-names-button" :: Text) buttonForm
|
||||
let nameBtnForm = wrapForm nameBtnWdgt def
|
||||
{ formAction = Just $ SomeRoute AdminFeaturesR
|
||||
, formEncoding = btnEnctype
|
||||
, formEncoding = nameBtnEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
infConflicts <- case btnResult of
|
||||
FormSuccess BtnCandidatesInfer -> do
|
||||
(infConflicts, infAmbiguous, (infRedundantNames, infRedundantParents, infRedundantStandalone), infAccepted) <- Candidates.inferHandler
|
||||
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
|
||||
infNameConflicts <- case nameBtnResult of
|
||||
FormSuccess BtnNameCandidatesInfer -> do
|
||||
(infConflicts, infAmbiguous, infRedundantNames, infAccepted) <- Candidates.inferNamesHandler
|
||||
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousNameCandidatesRemoved $ length infAmbiguous
|
||||
unless (null infRedundantNames) . addMessageI Info . MsgRedundantNameCandidatesRemoved $ length infRedundantNames
|
||||
unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents
|
||||
unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
|
||||
-- unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
|
||||
unless (null infConflicts) $ do
|
||||
let badKeys = map entityKey infConflicts
|
||||
setSessionJson SessionConflictingStudyTerms badKeys
|
||||
@ -62,27 +74,49 @@ postAdminFeaturesR = do
|
||||
setSessionJson SessionNewStudyTerms newKeys
|
||||
|
||||
if | null infAccepted
|
||||
-> addMessageI Info MsgNoCandidatesInferred
|
||||
-> addMessageI Info MsgNoNameCandidatesInferred
|
||||
| otherwise
|
||||
-> addMessageI Success . MsgCandidatesInferred $ length infAccepted
|
||||
-> addMessageI Success . MsgNameCandidatesInferred $ length infAccepted
|
||||
redirect AdminFeaturesR
|
||||
FormSuccess BtnCandidatesDeleteConflicts -> do
|
||||
FormSuccess BtnNameCandidatesDeleteConflicts -> do
|
||||
runDB $ do
|
||||
confs <- Candidates.conflicts
|
||||
incis <- Candidates.getIncidencesFor $ map entityKey confs
|
||||
confs <- Candidates.nameConflicts
|
||||
incis <- Candidates.getNameIncidencesFor $ map entityKey confs
|
||||
deleteWhere [StudyTermNameCandidateIncidence <-. (E.unValue <$> incis)]
|
||||
deleteWhere [StudySubTermParentCandidateIncidence <-. (E.unValue <$> incis)]
|
||||
deleteWhere [StudyTermStandaloneCandidateIncidence <-. (E.unValue <$> incis)]
|
||||
addMessageI Success $ MsgIncidencesDeleted $ length incis
|
||||
redirect AdminFeaturesR
|
||||
FormSuccess BtnCandidatesDeleteAll -> do
|
||||
FormSuccess BtnNameCandidatesDeleteAll -> do
|
||||
runDB $ do
|
||||
deleteWhere ([] :: [Filter StudyTermNameCandidate])
|
||||
deleteWhere ([] :: [Filter StudySubTermParentCandidate])
|
||||
deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
|
||||
addMessageI Success MsgAllIncidencesDeleted
|
||||
addMessageI Success MsgAllNameIncidencesDeleted
|
||||
redirect AdminFeaturesR
|
||||
_other -> runDB Candidates.conflicts
|
||||
_other -> runDB Candidates.nameConflicts
|
||||
|
||||
((parentsBtnResult, parentsBtnWdgt), parentsBtnEnctype) <- runFormPost $ identifyForm ("infer-parents-button" :: Text) buttonForm
|
||||
let parentsBtnForm = wrapForm parentsBtnWdgt def
|
||||
{ formAction = Just $ SomeRoute AdminFeaturesR
|
||||
, formEncoding = parentsBtnEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
formResult parentsBtnResult $ \case
|
||||
BtnParentCandidatesInfer -> do
|
||||
(infRedundantParents, infAccepted) <- Candidates.inferParentsHandler
|
||||
unless (null infRedundantParents) . addMessageI Info . MsgRedundantParentCandidatesRemoved $ length infRedundantParents
|
||||
|
||||
let newKeys = map (studySubTermsChild . entityVal) infAccepted
|
||||
setSessionJson SessionNewStudyTerms newKeys
|
||||
|
||||
if | null infAccepted
|
||||
-> addMessageI Info MsgNoParentCandidatesInferred
|
||||
| otherwise
|
||||
-> addMessageI Success . MsgParentCandidatesInferred $ length infAccepted
|
||||
redirect AdminFeaturesR
|
||||
BtnParentCandidatesDeleteAll -> do
|
||||
runDB $ do
|
||||
deleteWhere ([] :: [Filter StudySubTermParentCandidate])
|
||||
addMessageI Success MsgAllParentIncidencesDeleted
|
||||
redirect AdminFeaturesR
|
||||
|
||||
|
||||
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
|
||||
badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
|
||||
@ -100,7 +134,7 @@ postAdminFeaturesR = do
|
||||
(,,,,)
|
||||
<$> mkDegreeTable
|
||||
<*> mkStudytermsTable (Set.fromList newStudyTermKeys)
|
||||
(Set.fromList $ fromMaybe (map entityKey infConflicts) badStudyTermKeys)
|
||||
(Set.fromList $ fromMaybe (map entityKey infNameConflicts) badStudyTermKeys)
|
||||
(Set.fromList schools)
|
||||
<*> mkCandidateTable
|
||||
<*> pure schools
|
||||
|
||||
@ -25,6 +25,7 @@ import qualified Data.Map as Map
|
||||
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
||||
|
||||
@ -45,28 +46,44 @@ instance Exception FailedCandidateInference
|
||||
-- * list of problems, ie. StudyTerms that contradict observed incidences
|
||||
-- * list of redundants, i.e. redundant observed incidences
|
||||
-- * list of accepted, i.e. newly accepted key/name pairs
|
||||
inferHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],_,[(StudyTermsId,Text)])
|
||||
inferHandler = runDB $ inferAcc mempty
|
||||
inferNamesHandler :: Handler ([Entity StudyTerms],[TermCandidateIncidence],[Entity StudyTermNameCandidate],[(StudyTermsId,Text)])
|
||||
inferNamesHandler = runDB $ inferAcc mempty
|
||||
where
|
||||
inferAcc (accAmbiguous, accRedundants, accAccepted) =
|
||||
handle (\(FailedCandidateInference fails) -> (fails, accAmbiguous, accRedundants, accAccepted') <$ E.transactionUndo) $ do
|
||||
(infAmbis, infReds, infAccs) <- inferStep
|
||||
if null infAccs
|
||||
then return ([], accAmbiguous, infReds <> accRedundants, accAccepted')
|
||||
else do
|
||||
if
|
||||
| null infAccs ->
|
||||
return ([], accAmbiguous, infReds <> accRedundants, accAccepted')
|
||||
| otherwise -> do
|
||||
E.transactionSave -- commit transaction if there are no problems
|
||||
inferAcc (infAmbis <> accAmbiguous, infReds <> accRedundants, infAccs <> accAccepted)
|
||||
where
|
||||
accAccepted' = over (traversed . _1) StudyTermsKey' accAccepted
|
||||
|
||||
inferStep = do
|
||||
ambiguous <- removeAmbiguous
|
||||
redundants <- removeRedundant
|
||||
accepted <- acceptSingletons
|
||||
problems <- conflicts
|
||||
ambiguous <- removeAmbiguousNames
|
||||
redundants <- removeRedundantNames
|
||||
accepted <- acceptSingletonNames
|
||||
problems <- nameConflicts
|
||||
unless (null problems) $ throwM $ FailedCandidateInference problems
|
||||
return (ambiguous, redundants, accepted)
|
||||
|
||||
inferParentsHandler :: Handler ([Entity StudySubTermParentCandidate], [Entity StudySubTerms])
|
||||
inferParentsHandler = runDB $ inferAcc mempty
|
||||
where
|
||||
inferAcc (infReds', infAccs') = do
|
||||
(infReds, infAccs) <- inferStep
|
||||
if
|
||||
| null infAccs ->
|
||||
return (infReds' <> infReds, infAccs')
|
||||
| otherwise ->
|
||||
inferAcc (infReds' <> infReds, infAccs' <> infAccs)
|
||||
inferStep = do
|
||||
redundants <- removeRedundantParents
|
||||
accepted <- acceptSingletonParents
|
||||
return (redundants, accepted)
|
||||
|
||||
{-
|
||||
Candidate 1 11 "A"
|
||||
Candidate 1 11 "B"
|
||||
@ -88,8 +105,8 @@ as a fix we simply eliminate all observations that have the same name twice, see
|
||||
-- | remove candidates with ambiguous observations,
|
||||
-- ie. candidates that have duplicated term names with differing keys
|
||||
-- which may happen in rare cases
|
||||
removeAmbiguous :: DB [TermCandidateIncidence]
|
||||
removeAmbiguous = do
|
||||
removeAmbiguousNames :: DB [TermCandidateIncidence]
|
||||
removeAmbiguousNames = do
|
||||
ambiList <- E.select $ E.from $ \candidate -> do
|
||||
E.groupBy ( candidate E.^. StudyTermNameCandidateIncidence
|
||||
, candidate E.^. StudyTermNameCandidateKey
|
||||
@ -103,38 +120,60 @@ removeAmbiguous = do
|
||||
return ambiSet
|
||||
|
||||
|
||||
removeRedundant :: DB ([Entity StudyTermNameCandidate], [Entity StudySubTermParentCandidate], [Entity StudyTermStandaloneCandidate])
|
||||
removeRedundant = (,,) <$> removeRedundantNames <*> removeRedundantParents <*> removeRedundantStandalone
|
||||
where
|
||||
-- | remove known StudyTerm from candidates that have the _exact_ name,
|
||||
-- ie. if a candidate contains a known key, we remove it and its associated fullname
|
||||
-- only save if ambiguous candidates haven been removed
|
||||
removeRedundantNames :: DB [Entity StudyTermNameCandidate]
|
||||
removeRedundantNames = do
|
||||
redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
|
||||
E.on $ E.just (candidate E.^. StudyTermNameCandidateKey) E.==. sterm E.?. StudyTermsKey
|
||||
E.&&. E.just (candidate E.^. StudyTermNameCandidateName) E.==. E.joinV (sterm E.?. StudyTermsName)
|
||||
return candidate
|
||||
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
|
||||
forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} ->
|
||||
deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence )
|
||||
: ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ]
|
||||
||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ])
|
||||
return redundants
|
||||
-- | remove known StudyTerm from candidates that have the _exact_ name,
|
||||
-- ie. if a candidate contains a known key, we remove it and its associated fullname
|
||||
-- only save if ambiguous candidates haven been removed
|
||||
removeRedundantNames :: DB [Entity StudyTermNameCandidate]
|
||||
removeRedundantNames = do
|
||||
redundants <- E.select $ E.distinct $ E.from $ \(candidate `E.InnerJoin` sterm) -> do
|
||||
E.on $ candidate E.^. StudyTermNameCandidateKey E.==. sterm E.^. StudyTermsKey
|
||||
E.&&. ( E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm E.^. StudyTermsName
|
||||
E.||. E.exists (E.from $ \(subTerm `E.InnerJoin` sterm2) -> do
|
||||
E.on $ subTerm E.^. StudySubTermsParent E.==. sterm E.^. StudyTermsId
|
||||
E.&&. subTerm E.^. StudySubTermsChild E.==. sterm2 E.^. StudyTermsId
|
||||
E.where_ $ E.just (candidate E.^. StudyTermNameCandidateName) E.==. sterm2 E.^. StudyTermsName
|
||||
)
|
||||
)
|
||||
return candidate
|
||||
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
|
||||
forM_ redundants $ \Entity{entityVal=StudyTermNameCandidate{..}} ->
|
||||
deleteWhere $ ( StudyTermNameCandidateIncidence ==. studyTermNameCandidateIncidence )
|
||||
: ([ StudyTermNameCandidateKey ==. studyTermNameCandidateKey ]
|
||||
||. [ StudyTermNameCandidateName ==. studyTermNameCandidateName ])
|
||||
return redundants
|
||||
|
||||
removeRedundantParents :: DB [Entity StudySubTermParentCandidate]
|
||||
removeRedundantParents = return []
|
||||
removeRedundantParents :: DB [Entity StudySubTermParentCandidate]
|
||||
removeRedundantParents = do
|
||||
redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` subTerm) -> do
|
||||
E.on $ candidate E.^. StudySubTermParentCandidateKey E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsChild)
|
||||
E.&&. candidate E.^. StudySubTermParentCandidateParent E.==. E.veryUnsafeCoerceSqlExprValue (subTerm E.^. StudySubTermsParent)
|
||||
return candidate
|
||||
forM_ redundants $ \(Entity _ StudySubTermParentCandidate{..}) ->
|
||||
E.delete . E.from $ \candidate ->
|
||||
E.where_ $ candidate E.^. StudySubTermParentCandidateIncidence E.==. E.val studySubTermParentCandidateIncidence
|
||||
E.&&. ( candidate E.^. StudySubTermParentCandidateParent `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey]
|
||||
E.||. candidate E.^. StudySubTermParentCandidateKey `E.in_` E.valList [studySubTermParentCandidateParent, studySubTermParentCandidateKey]
|
||||
)
|
||||
return redundants
|
||||
|
||||
removeRedundantStandalone :: DB [Entity StudyTermStandaloneCandidate]
|
||||
removeRedundantStandalone = do
|
||||
redundants <- E.select . E.distinct . E.from $ \(candidate `E.InnerJoin` sterm) -> do
|
||||
E.on $ candidate E.^. StudyTermStandaloneCandidateKey E.==. sterm E.^. StudyTermsKey
|
||||
E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultDegree)
|
||||
E.&&. E.not_ (E.isNothing $ sterm E.^. StudyTermsDefaultType)
|
||||
return candidate
|
||||
deleteWhere [ StudyTermStandaloneCandidateId <-. map entityKey redundants ]
|
||||
return redundants
|
||||
|
||||
removeRedundantStandalone :: DB [Entity StudyTermStandaloneCandidate]
|
||||
removeRedundantStandalone = return []
|
||||
|
||||
-- | Search for single candidates and memorize them as StudyTerms.
|
||||
-- Should be called after @removeRedundant@ to increase success chances and reduce cost; otherwise memory heavy!
|
||||
-- Does not delete the used candidates, user @removeRedundant@ for this later on.
|
||||
-- Esqueleto does not provide the INTERESECT operator, thus
|
||||
-- we load the table into Haskell and operate there. Memory usage problem? StudyTermsCandidate may become huge.
|
||||
acceptSingletons :: DB [(STKey,Text)]
|
||||
acceptSingletons = do
|
||||
acceptSingletonNames :: DB [(STKey,Text)]
|
||||
acceptSingletonNames = do
|
||||
knownKeys <- fmap unStudyTermsKey <$> selectKeysList [StudyTermsName !=. Nothing] [Asc StudyTermsKey]
|
||||
-- let knownKeysSet = Set.fromAscList knownKeys
|
||||
-- In case of memory problems, change next lines to conduit proper:
|
||||
@ -161,13 +200,17 @@ acceptSingletons = do
|
||||
|
||||
-- filter candidates having a unique possibility left
|
||||
fixedKeys :: [(STKey,Text)]
|
||||
fixedKeys = Map.foldlWithKey' combFixed [] keyCandidates
|
||||
|
||||
combFixed :: [(STKey,Text)] -> STKey -> Set Text -> [(STKey,Text)]
|
||||
combFixed acc k s | Set.size s == 1 -- possibly redundant
|
||||
, [n] <- Set.elems s = (k,n):acc
|
||||
-- empty sets should not occur here , if LDAP is consistent. Maybe raise a warning?!
|
||||
| otherwise = acc
|
||||
fixedKeys = fst $ Map.foldlWithKey' combFixed mempty keyCandidates
|
||||
where
|
||||
combFixed :: ([(STKey,Text)], Set STKey) -> STKey -> Set Text -> ([(STKey,Text)], Set STKey)
|
||||
combFixed (acc, bad) k s
|
||||
| Set.member k bad
|
||||
= (acc, bad)
|
||||
| maybe False (`Set.notMember` s) (lookup k acc)
|
||||
= (filter (\(k', _) -> k /= k') acc, Set.insert k bad)
|
||||
| [n] <- Set.elems s
|
||||
= ((k,n) : acc, bad)
|
||||
| otherwise = (acc, bad)
|
||||
|
||||
-- registerFixed :: (STKey, Text) -> DB (Key StudyTerms)
|
||||
registerFixed :: (STKey, Text) -> DB ()
|
||||
@ -178,10 +221,49 @@ acceptSingletons = do
|
||||
forM_ fixedKeys registerFixed
|
||||
return fixedKeys
|
||||
|
||||
acceptSingletonParents :: DB [Entity StudySubTerms]
|
||||
acceptSingletonParents = do
|
||||
candidates <- map entityVal <$> selectList [] []
|
||||
|
||||
let
|
||||
groupedCandidates :: Map STKey (Map UUID (Set STKey))
|
||||
groupedCandidates = foldl' groupFun mempty candidates
|
||||
where
|
||||
groupFun :: Map STKey (Map UUID (Set STKey)) -> StudySubTermParentCandidate -> Map STKey (Map UUID (Set STKey))
|
||||
groupFun m StudySubTermParentCandidate{..} =
|
||||
Map.insertWith (Map.unionWith Set.union)
|
||||
studySubTermParentCandidateKey
|
||||
(Map.singleton studySubTermParentCandidateIncidence $ Set.singleton studySubTermParentCandidateParent)
|
||||
m
|
||||
|
||||
parentCandidates :: Map STKey (Set STKey)
|
||||
parentCandidates = Map.map (setIntersections . Map.elems) groupedCandidates
|
||||
|
||||
fixedParents :: [(STKey, STKey)]
|
||||
fixedParents = fst $ Map.foldlWithKey' combFixed mempty parentCandidates
|
||||
where
|
||||
combFixed :: ([(STKey, STKey)], Set STKey) -> STKey -> Set STKey -> ([(STKey, STKey)], Set STKey)
|
||||
combFixed (acc, bad) k s
|
||||
| Set.member k bad
|
||||
= (acc, bad)
|
||||
| maybe False (`Set.notMember` s) (lookup k acc)
|
||||
= (filter (\(k', _) -> k /= k') acc, Set.insert k bad)
|
||||
| [p] <- Set.elems s
|
||||
= ((k, p) : acc, bad)
|
||||
| otherwise = (acc, bad)
|
||||
|
||||
inserted <- forM fixedParents $ \(key, parent) ->
|
||||
insertUnique $ StudySubTerms
|
||||
{ studySubTermsChild = StudyTermsKey' key
|
||||
, studySubTermsParent = StudyTermsKey' parent
|
||||
}
|
||||
|
||||
mapM getJustEntity $ catMaybes inserted
|
||||
|
||||
|
||||
-- | all existing StudyTerms that are contradiced by current observations
|
||||
conflicts :: DB [Entity StudyTerms]
|
||||
conflicts = E.select $ E.from $ \studyTerms -> do
|
||||
nameConflicts :: DB [Entity StudyTerms]
|
||||
nameConflicts = E.select $ E.from $ \studyTerms -> do
|
||||
E.where_ $ E.not_ $ E.isNothing $ studyTerms E.^. StudyTermsName
|
||||
E.where_ $ E.exists $ E.from $ \candidateOne -> do
|
||||
E.where_ $ candidateOne E.^. StudyTermNameCandidateKey E.==. studyTerms E.^. StudyTermsKey
|
||||
@ -194,12 +276,18 @@ conflicts = E.select $ E.from $ \studyTerms -> do
|
||||
E.where_ $ E.joinV (termsTwo E.?. StudyTermsName) E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
|
||||
E.||. E.isNothing (E.joinV $ termsTwo E.?. StudyTermsName)
|
||||
)
|
||||
E.||. E.exists ( E.from $ \(subTerms `E.InnerJoin` termsTwo) -> do
|
||||
E.on $ subTerms E.^. StudySubTermsParent E.==. studyTerms E.^. StudyTermsId
|
||||
E.&&. subTerms E.^. StudySubTermsChild E.==. termsTwo E.^. StudyTermsId
|
||||
E.where_ $ termsTwo E.^. StudyTermsName E.==. E.just (candidateTwo E.^. StudyTermNameCandidateName)
|
||||
E.||. E.isNothing (termsTwo E.^. StudyTermsName)
|
||||
)
|
||||
return studyTerms
|
||||
|
||||
|
||||
-- | retrieve all incidence keys having containing a certain @StudyTermKey @
|
||||
getIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence]
|
||||
getIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
|
||||
getNameIncidencesFor :: [StudyTermsId] -> DB [E.Value TermCandidateIncidence]
|
||||
getNameIncidencesFor stks = E.select $ E.distinct $ E.from $ \candidate -> do
|
||||
E.where_ $ candidate E.^. StudyTermNameCandidateKey `E.in_` E.valList stks'
|
||||
return $ candidate E.^. StudyTermNameCandidateIncidence
|
||||
where
|
||||
|
||||
@ -8,23 +8,27 @@ $newline never
|
||||
_{MsgStudyFeaturesTerms}
|
||||
^{studytermsTable}
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgStudyFeatureNameInference}
|
||||
<p>
|
||||
$if null infNameConflicts
|
||||
_{MsgStudyFeatureInferenceNoNameConflicts}
|
||||
$else
|
||||
<h3>_{MsgStudyFeatureInferenceNameConflictsHeading}
|
||||
<ul>
|
||||
$forall Entity _ (StudyTerms ky _ nm _ _) <- infNameConflicts
|
||||
<li>
|
||||
#{show ky} - #{foldMap id nm}
|
||||
^{nameBtnForm}
|
||||
|
||||
<h2>
|
||||
_{MsgStudyFeaturesNameCandidates}
|
||||
^{candidateTable}
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgStudyFeatureParentInference}
|
||||
^{parentsBtnForm}
|
||||
|
||||
<h2>
|
||||
_{MsgStudyFeaturesParentCandidates}
|
||||
^{parentCandidateTable}
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgStudyFeatureInference}
|
||||
<p>
|
||||
$if null infConflicts
|
||||
_{MsgStudyFeatureInferenceNoConflicts}
|
||||
$else
|
||||
<h3>_{MsgStudyFeatureInferenceConflictsHeading}
|
||||
<ul>
|
||||
$forall Entity _ (StudyTerms ky _ nm _ _) <- infConflicts
|
||||
<li>
|
||||
#{show ky} - #{foldMap id nm}
|
||||
^{btnForm}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user