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
|
######################
### proximity database
######################
### check functions
.function_or_character <-
function(x)
{
if (!is.character(x) && !is.function(x))
stop("Need function or function name.")
}
.abcd_and_binary <-
function(x)
{
if (x$abcd && (x$type != "binary"))
stop(paste(dQuote("abcd"), "mode only available for binary measures."))
}
### create registry
pr_DB <- registry(registry_class = "pr_DB",
entry_class = "proxy_registry_entry",
validity_FUN = ".abcd_and_binary")
## create fields
pr_DB$set_field("FUN", is_mandatory = TRUE, validity_FUN = ".function_or_character")
pr_DB$set_field("distance", type = "logical", default = TRUE)
pr_DB$set_field("PREFUN", validity_FUN = ".function_or_character")
pr_DB$set_field("POSTFUN", validity_FUN = ".function_or_character")
pr_DB$set_field("convert", validity_FUN = ".function_or_character")
pr_DB$set_field("type", type = c("binary", "nominal", "ordinal", "metric", "other"),
default = "other")
pr_DB$set_field("loop", type = "logical", default = TRUE)
pr_DB$set_field("C_FUN", type = "logical", default = FALSE)
pr_DB$set_field("PACKAGE", type = "character", default = "proxy")
pr_DB$set_field("abcd", type = "logical", default = FALSE)
pr_DB$set_field("formula", type = "character")
pr_DB$set_field("reference", type = "character")
pr_DB$set_field("description", type = "character")
### summary and print methods
summary.pr_DB <-
function(object, verbosity = c("short", "long"), ...)
{
if (length(object) < 1)
return(object)
verbosity <- match.arg(verbosity)
object <-
switch(verbosity,
short = list(names = object$get_field_entries("names", unlist = FALSE),
distance = object$get_field_entries("distance")),
long = list(names = object$get_field_entries("names", unlist = FALSE),
distance = object$get_field_entries("distance"),
type = object$get_field_entries("type"),
formula = object$get_field_entries("formula"))
)
structure(object, class = "summary.pr_DB")
}
print.summary.pr_DB <- function(x, ...)
{
distance <- c("Similarity", "Distance")[x[[2]] + 1]
if (length(x) > 2)
x[[3]][is.na(x[[3]])] <- "other"
for (i in unique(distance)) {
ind <- which(distance == i)
if (length(ind) > 0) {
writeLines(paste("*", i, "measures:"))
if (length(x) > 2) {
for (k in ind)
writeLines(paste(" ", paste(x[[1]][[k]], collapse = "/"),
" (", x[[3]][k], ") = ", x[[4]][k], sep = ""))
} else {
tmp <- sort(sapply(x[[1]][ind], function(i) i[1]))
writeLines(strwrap(paste(tmp, collapse = ", ")))
}
}
writeLines("")
}
}
|
