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
|
## annotation ###########################################################################
setMethod("annotation","ANY",function(x)attr(x,"annotation"))
setMethod("annotation","item",function(x)x@annotation)
setMethod("annotation<-",signature(x="ANY",value="NULL"),function(x,value){
attr(x,"annotation") <- NULL
x
})
setMethod("annotation<-",signature(x="ANY",value="character"),function(x,value){
value <- new("annotation",structure(as.character(value),names=names(value)))
callGeneric(x,value)
})
setMethod("annotation<-",signature(x="item",value="annotation"),function(x,value){
x@annotation <- value
x
})
setMethod("annotation<-",signature(x="ANY",value="annotation"),function(x,value){
attr(x,"annotation") <- value
x
})
description <- function(x){
d <- annotation(x)["description"]
if(!length(d)) return(NULL)
if(is.na(d)) NULL else unname(d)
}
setGeneric("description",function(x)standardGeneric("description"))
description.data.frame <- function(x){
dict <- lapply(x,attr,"label")
structure(dict,class="descriptions")
}
setMethod("description","data.frame",description.data.frame)
setMethod("description","tbl_df",description.data.frame)
"description<-" <- function(x,value){
annotation(x)["description"] <- value
x
}
wording <- function(x){
wdng <- annotation(x)["wording"]
if(is.na(wdng)) NULL else unname(wdng)
}
"wording<-" <- function(x,value){
annotation(x)["wording"] <- value
x
}
setMethod("show","annotation",function(object){
if(length(object)){
annot.out <- character()
for(i in seq_len(length(object))){
annot.i <- object[i]
nm.i <- trimws(names(annot.i))
annot.i <- strwrap(annot.i,width=getOption("width")-8)
annot.i <- c(paste(" ",annot.i),"")
if(nzchar(nm.i)){
annot.i <- c(
paste(nm.i,":",sep=""),
annot.i
)
}
annot.out <- c(annot.out,annot.i)
}
writeLines(annot.out)
}
})
|
