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
|
rsc <- function(cv, threshold = "minimum", weights = NULL){
if(!is.null(weights)){
if(is.matrix(weights)){
weights <- as.numeric(weights[lower.tri(weights)])
}
if(is.vector(weights)){
if(length(weights) != length(cv$rmadvec)){
stop('weights must be a vector matching rmadvec')
}
}else{
stop('weights must be a vector matching rmadvec or p x p matrix')
}
}
## inputs
## cv = u ## a class cv_rsc or any other correlation matrix
## threshold = "minimum" ## "minimum", "minimum1se" or numeric in (0,1)
if(is(cv, "rsc_cv")){
## check threshold
if(is.numeric(threshold)){
if(length(threshold)>1){
stop("if a specific value for 'threshold' is chosen, this must be a single numeric value in (0,1)")
}else if(threshold <=0 | threshold >=1){
stop("if a specific value for 'threshold' is chosen, this must be a single numeric value in (0,1)")
}
}else{
if({threshold != "minimum"} & {threshold != "minimum1se"}){
stop("'threshold' must be one of the following: 'minimum', 'minimum1se', a numeric value in (0,1).")
}
if(threshold == "minimum"){
threshold <- cv$minimum
}else if(threshold == "minimum1se"){
threshold <- cv$minimum1se
}
}
# make a copy
rmadvec <- cv$rmadvec
## threshold the rmadvec
if(is.null(weights)){
rmadvec[ abs(rmadvec) < threshold ] <- 0
}else{
T <- abs(rmadvec) * weights
rmadvec[ T < threshold ] <- 0
}
nc <- length(rmadvec)
p <- {1 + sqrt( 1 + 8 * nc ) } / 2
R <- Matrix(1, nrow = p, ncol = p, sparse = TRUE)
R[lower.tri(R , diag = FALSE)] <- rmadvec
R <- forceSymmetric(R , uplo="L")
## attach dimnames if needed
if(!is.null(cv$varnames)){
dimnames(R)[[1]] <- dimnames(R)[[2]] <- cv$varnames
}
}else{
stop("'cv' must be a an object of class 'rsc_cv' obtained from 'rsc::rsc_cv'")
}
return(R)
}
|
