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
|
combine_duplicated_labels <- function(x){
dl <- duplicated_labels(x)
l <- labels(x)
for(i in seq_along(dl)){
old_val <- dl[[i]]
new_val <- old_val[1]
drop_val <- old_val[-1]
x[x %in% old_val] <- new_val
drop <- l@values %in% drop_val
l@.Data <- l@.Data[!drop]
l@values <- l@values[!drop]
labels(x) <- l
}
x
}
prefix_duplicated_labels <- function(x,
pattern="%d. %s",
...){
dl <- duplicated_labels(x)
if(length(dl)){
l <- labels(x)
dedup_lab <- sprintf(pattern,l@values,l@.Data)
l@.Data <- dedup_lab
labels(x) <- l
}
x
}
postfix_duplicated_labels <- function(x,
pattern="%s (%d)",
...){
dl <- duplicated_labels(x)
l <- labels(x)
for(i in seq_along(dl)){
dup_lab <- names(dl)[i]
dup_val <- dl[[i]]
ii <- match(dup_val,l@values)
dedup_lab <- sprintf(pattern,dup_lab,dup_val)
l@.Data[ii] <- dedup_lab
}
labels(x) <- l
x
}
deduplicate_labels <- function(x,...) UseMethod("deduplicate_labels")
deduplicate_labels.default <- function(x,...) return(x)
deduplicate_labels.item <- function(x,method=c("combine codes",
"prefix values",
"postfix values"),...){
method <- match.arg(method)
# browser()
switch(method,
"combine codes"=combine_duplicated_labels(x),
"prefix values"=prefix_duplicated_labels(x,...),
"postfix values"=postfix_duplicated_labels(x,...))
}
deduplicate_labels.item.list <- function(x,...){
n <- ncol(x)
for(i in 1:n){
x.i <- x[[i]]
if(inherits(x.i,"item") &&
length(labels(x.i)) &&
length(duplicated_labels(x.i))){
x.i <- deduplicate_labels.item(x.i,...)
x@.Data[[i]] <- x.i
}
}
x
}
|
