-
Notifications
You must be signed in to change notification settings - Fork 1
/
Interpretations.R
113 lines (86 loc) · 3.72 KB
/
Interpretations.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
### This file contains info about "known" humdrum interpretations,
### meaning standardized exclusive and tandem interpretations like
### **kern and *C:
### For exclusive interpretations, we get a regular expression
### describing the kinds of tokens we expect to see in that interpretation.
### For tandem interpretations, we get a regular expression that indicates
### different versions of the same tandem interpretation information:
### for instance "*clefG2" and "*clefF4" are both examples of the same type
### of tandem information.
#' @rdname readHumdrum
#' @export
knownInterpretations <- data.table::fread(system.file('extdata', 'KnownInterpretations.tsv', package = 'humdrumR'))
# Preprocess self-referential {}s in the file KnownInterperations.tsv
for (i in seq_along(knownInterpretations$RE)) {
knownREs <- list2env(as.list(setNames(knownInterpretations$RE, knownInterpretations$Name)))
knownInterpretations$RE[i] <- glue::glue(knownInterpretations$RE[i],
.envir = knownREs,
.open = '<<', .close = '>>')
}
#' @export
getRE <- function(pattern = NULL, types = c('Tandem', 'Exclusive', 'Atomic'), strict = FALSE) {
known <- knownInterpretations[knownInterpretations$Type %in% types, ]
if (is.null(pattern)) return(known$Name)
interpPattern <- tolower(pattern)
hits <- sapply(interpPattern,
\(pat) {
hits <- which(pat == tolower(known$Name))
if (length(hits) == 0) hits <- pmatch(pat, tolower(known$Name))
hits
})
res <- known$RE[hits]
if (strict) {
ressplit <- strsplit(unlist(res), split = '\\|')
res <- sapply(ressplit, \(re) paste(paste0('^(', re, ')$'), collapse = '|'))
}
names(res) <- pattern # interpPattern
res[is.na(res)] <- pattern[is.na(res)]
res
}
#' @export
getREexclusive <- function(pattern) {
checks(pattern, xcharacter)
exclusive <- knownInterpretations[knownInterpretations$RE == getRE(pattern), ]$Exclusive
if (length(exclusive) == 0L || exclusive == "") NULL else exclusive
}
matchKnownExclusive <- function(strs) {
#' @export
checks(strs, xcharacter)
sapply(knownInterpretations[knownInterpretations$Type == 'Exclusive', ], stringr::str_detect, string = strs)
}
matchKnownTandem <- function(strs) {
#' @export
checks(strs, xcharacter)
knownTand <- knownInterpretations[knownInterpretations$Type == 'Tandem', ]
output <- sapply(knownTand$RE, stringr::str_detect, string = strs, simplify = TRUE)
dim(output) <- c(length(strs), nrow(knownTand))
colnames(output) <- knownTand$Name
rownames(output) <- strs
output
}
isKnownTandem <- function(strs) {
#' @export
checks(strs, xcharacter)
rowSums(matchKnownTandem(strs)) > 0L
}
generalizeTandem <- function(strs) {
checks(strs, xcharacter)
hits <- matchKnownTandem(strs)
misses <- rowSums(hits) == 0
output <- setNames(strs, strs)
hit.arr.ind <- which(hits[!misses, , drop = FALSE], arr.ind = TRUE)
hit.arr.ind <- hit.arr.ind[order(hit.arr.ind[ , 'row']), , drop = FALSE ]
output <- knownInterpretations[knownInterpretations$Type == 'Tandem' , ]$RE[hit.arr.ind[ , 'col']]
setNames(output, strs)
}
#' @export
idTandem <- function(strs) {
checks(strs, xcharacter)
hits <- matchKnownTandem(strs)
misses <- rowSums(hits) == 0
output <- setNames(strs, strs)
hit.arr.ind <- which(hits[!misses, , drop = FALSE], arr.ind = TRUE)
hit.arr.ind <- hit.arr.ind[order(hit.arr.ind[ , 'row']), , drop = FALSE ]
output[!misses] <- knownInterpretations[knownInterpretations$Type == 'Tandem', ]$Name[hit.arr.ind[ , 'col']]
output
}