Skip to content

Commit 0936ecd

Browse files
itsrainingdataitsrainingdata
committed
Initial implementation of b/w lists; compiles+runs but untested
1 parent e3b70dd commit 0936ecd

File tree

7 files changed

+142
-23
lines changed

7 files changed

+142
-23
lines changed

‎R/RcppExports.R‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,11 @@
11
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
22
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
33

4-
gridCCDr <- function(cors, init_betas, nj, indexj, aj, lambdas, params, verbose) {
5-
.Call(`_ccdrAlgorithm_gridCCDr`, cors, init_betas, nj, indexj, aj, lambdas, params, verbose)
4+
gridCCDr <- function(cors, init_betas, nj, indexj, aj, lambdas, weights, params, verbose) {
5+
.Call(`_ccdrAlgorithm_gridCCDr`, cors, init_betas, nj, indexj, aj, lambdas, weights, params, verbose)
66
}
77

8-
singleCCDr <- function(cors, init_betas, nj, indexj, aj, lambda, params, verbose) {
9-
.Call(`_ccdrAlgorithm_singleCCDr`, cors, init_betas, nj, indexj, aj, lambda, params, verbose)
8+
singleCCDr <- function(cors, init_betas, nj, indexj, aj, lambda, weights, params, verbose) {
9+
.Call(`_ccdrAlgorithm_singleCCDr`, cors, init_betas, nj, indexj, aj, lambda, weights, params, verbose)
1010
}
1111

‎R/ccdrAlgorithm-bwlist.R‎

Lines changed: 63 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,63 @@
1+
#
2+
# ccdrAlgorithm-bwlist.R
3+
# ccdrAlgorithm
4+
#
5+
# Created by Bryon Aragam (local) on 8/11/17.
6+
# Copyright (c) 2014-2017 Bryon Aragam. All rights reserved.
7+
#
8+
9+
#
10+
# PACKAGE CCDRALGORITHM: Helper methods for black/white lists
11+
#
12+
# CONTENTS:
13+
# names_to_indices
14+
# rows_to_list
15+
# bwlist_check
16+
# bwlist_to_weights
17+
#
18+
19+
### Just a wrapper for match with a better name
20+
names_to_indices <- function(v, names){
21+
match(v, names)
22+
} # END NAMES_TO_INDICES
23+
24+
rows_to_list <- function(m){
25+
lapply(1:nrow(m), function(j) m[j,])
26+
} # END ROWS_TO_LIST
27+
28+
bwlist_check <- function(bwlist, names){
29+
if(!is.matrix(bwlist) || ncol(bwlist) != 2){
30+
stop("Input must be a matrix with exactly 2 columns!")
31+
}
32+
33+
if(any(is.na(bwlist))){
34+
stop("Input cannot have missing values!")
35+
}
36+
37+
if(is.character(bwlist)){
38+
bwlist <- as.vector(bwlist)
39+
bwlist <- names_to_indices(bwlist, names)
40+
bwlist <- matrix(bwlist, ncol = 2)
41+
}
42+
43+
storage.mode(bwlist) <- "integer"
44+
rows_to_list(bwlist)
45+
} # END BWLIST_CHECK
46+
47+
bwlist_to_weights <- function(black, white, nnode){
48+
weights <- matrix(1L, ncol = nnode, nrow = nnode)
49+
50+
if(!is.null(white)){
51+
for(k in 1:length(white)){
52+
weights[white[[k]][1], white[[k]][2]] <- 0L
53+
}
54+
}
55+
56+
if(!is.null(black)){
57+
for(k in 1:length(black)){
58+
weights[black[[k]][1], black[[k]][2]] <- -1L
59+
}
60+
}
61+
62+
weights
63+
} # END BWLIST_TO_WEIGHTS

‎R/ccdrAlgorithm-main.R‎

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -80,6 +80,8 @@ ccdr.run <- function(data,
8080
betas,
8181
lambdas = NULL,
8282
lambdas.length = NULL,
83+
whitelist = NULL,
84+
blacklist = NULL,
8385
gamma = 2.0,
8486
error.tol = 1e-4,
8587
max.iters = NULL,
@@ -100,6 +102,8 @@ ccdr.run <- function(data,
100102
betas = betas,
101103
lambdas = lambdas,
102104
lambdas.length = lambdas.length,
105+
whitelist = whitelist,
106+
blacklist = blacklist,
103107
gamma = gamma,
104108
error.tol = error.tol,
105109
rlam = NULL,
@@ -122,6 +126,8 @@ ccdr_call <- function(data,
122126
betas,
123127
lambdas,
124128
lambdas.length,
129+
whitelist,
130+
blacklist,
125131
gamma,
126132
error.tol,
127133
rlam,
@@ -227,6 +233,23 @@ ccdr_call <- function(data,
227233
max.iters <- sparsebnUtils::default_max_iters(pp)
228234
}
229235

236+
### White/black lists
237+
# Be careful about handling various NULL cases
238+
if(!is.null(whitelist)) whitelist <- bwlist_check(whitelist, nodes)
239+
if(!is.null(blacklist)) blacklist <- bwlist_check(blacklist, nodes)
240+
241+
if(!is.null(whitelist) && !is.null(blacklist)){
242+
if(length(intersect(whitelist, blacklist)) > 0){
243+
badinput <- vapply(intersect(whitelist, blacklist), function(x) sprintf("\t[%s]\n", paste(x, collapse = ",")), FUN.VALUE = "vector")
244+
badinput <- paste(badinput, collapse = "")
245+
msg <- sprintf("Duplicate entries found in blacklist and whitelist: \n%s", badinput)
246+
stop(msg)
247+
}
248+
}
249+
250+
weights <- bwlist_to_weights(blacklist, whitelist, nnode = pp)
251+
252+
### Pre-process correlation data
230253
t1.cor <- proc.time()[3]
231254
# cors <- cor(data)
232255
# cors <- cors[upper.tri(cors, diag = TRUE)]
@@ -242,6 +265,7 @@ ccdr_call <- function(data,
242265
as.integer(indexj),
243266
betas,
244267
as.numeric(lambdas),
268+
as.integer(weights),
245269
as.numeric(gamma),
246270
as.numeric(error.tol),
247271
as.integer(max.iters),
@@ -277,6 +301,7 @@ ccdr_gridR <- function(cors,
277301
indexj = NULL,
278302
betas,
279303
lambdas,
304+
weights,
280305
gamma,
281306
eps,
282307
maxIters,
@@ -308,6 +333,7 @@ ccdr_gridR <- function(cors,
308333
indexj,
309334
betas,
310335
lambdas[i],
336+
weights,
311337
gamma = gamma,
312338
eps = eps,
313339
maxIters = maxIters,
@@ -346,6 +372,7 @@ ccdr_singleR <- function(cors,
346372
indexj = NULL,
347373
betas,
348374
lambda,
375+
weights,
349376
gamma,
350377
eps,
351378
maxIters,
@@ -391,6 +418,11 @@ ccdr_singleR <- function(cors,
391418
if(!is.numeric(lambda)) stop("lambda must be numeric!")
392419
if(lambda < 0) stop("lambda must be >= 0!")
393420

421+
### Check weights
422+
if(length(weights) != pp*pp) stop("weights must have length p^2!")
423+
if(!is.numeric(weights)) stop("weights must be numeric!")
424+
if(weights < -1 || weights > 1) stop("weights out of bounds!")
425+
394426
### Check gamma
395427
if(!is.numeric(gamma)) stop("gamma must be numeric!")
396428
if(gamma < 0 && gamma != -1) stop("gamma must be >= 0 (MCP) or = -1 (Lasso)!")
@@ -416,6 +448,7 @@ ccdr_singleR <- function(cors,
416448
indexj,
417449
aj,
418450
lambda,
451+
weights,
419452
c(gamma, eps, maxIters, alpha),
420453
verbose = verbose)
421454
t2.ccdr <- proc.time()[3]

‎man/ccdr.run.Rd‎

Lines changed: 3 additions & 2 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎src/RcppExports.cpp‎

Lines changed: 10 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -6,8 +6,8 @@
66
using namespace Rcpp;
77

88
// gridCCDr
9-
List gridCCDr(NumericVector cors, List init_betas, IntegerVector nj, IntegerVector indexj, NumericVector aj, NumericVector lambdas, NumericVector params, int verbose);
10-
RcppExport SEXP _ccdrAlgorithm_gridCCDr(SEXP corsSEXP, SEXP init_betasSEXP, SEXP njSEXP, SEXP indexjSEXP, SEXP ajSEXP, SEXP lambdasSEXP, SEXP paramsSEXP, SEXP verboseSEXP) {
9+
List gridCCDr(NumericVector cors, List init_betas, IntegerVector nj, IntegerVector indexj, NumericVector aj, NumericVector lambdas, IntegerVector weights, NumericVector params, int verbose);
10+
RcppExport SEXP _ccdrAlgorithm_gridCCDr(SEXP corsSEXP, SEXP init_betasSEXP, SEXP njSEXP, SEXP indexjSEXP, SEXP ajSEXP, SEXP lambdasSEXP, SEXP weightsSEXP, SEXP paramsSEXP, SEXP verboseSEXP) {
1111
BEGIN_RCPP
1212
Rcpp::RObject rcpp_result_gen;
1313
Rcpp::RNGScope rcpp_rngScope_gen;
@@ -17,15 +17,16 @@ BEGIN_RCPP
1717
Rcpp::traits::input_parameter< IntegerVector >::type indexj(indexjSEXP);
1818
Rcpp::traits::input_parameter< NumericVector >::type aj(ajSEXP);
1919
Rcpp::traits::input_parameter< NumericVector >::type lambdas(lambdasSEXP);
20+
Rcpp::traits::input_parameter< IntegerVector >::type weights(weightsSEXP);
2021
Rcpp::traits::input_parameter< NumericVector >::type params(paramsSEXP);
2122
Rcpp::traits::input_parameter< int >::type verbose(verboseSEXP);
22-
rcpp_result_gen = Rcpp::wrap(gridCCDr(cors, init_betas, nj, indexj, aj, lambdas, params, verbose));
23+
rcpp_result_gen = Rcpp::wrap(gridCCDr(cors, init_betas, nj, indexj, aj, lambdas, weights, params, verbose));
2324
return rcpp_result_gen;
2425
END_RCPP
2526
}
2627
// singleCCDr
27-
List singleCCDr(NumericVector cors, List init_betas, IntegerVector nj, IntegerVector indexj, NumericVector aj, double lambda, NumericVector params, int verbose);
28-
RcppExport SEXP _ccdrAlgorithm_singleCCDr(SEXP corsSEXP, SEXP init_betasSEXP, SEXP njSEXP, SEXP indexjSEXP, SEXP ajSEXP, SEXP lambdaSEXP, SEXP paramsSEXP, SEXP verboseSEXP) {
28+
List singleCCDr(NumericVector cors, List init_betas, IntegerVector nj, IntegerVector indexj, NumericVector aj, double lambda, IntegerVector weights, NumericVector params, int verbose);
29+
RcppExport SEXP _ccdrAlgorithm_singleCCDr(SEXP corsSEXP, SEXP init_betasSEXP, SEXP njSEXP, SEXP indexjSEXP, SEXP ajSEXP, SEXP lambdaSEXP, SEXP weightsSEXP, SEXP paramsSEXP, SEXP verboseSEXP) {
2930
BEGIN_RCPP
3031
Rcpp::RObject rcpp_result_gen;
3132
Rcpp::RNGScope rcpp_rngScope_gen;
@@ -35,16 +36,17 @@ BEGIN_RCPP
3536
Rcpp::traits::input_parameter< IntegerVector >::type indexj(indexjSEXP);
3637
Rcpp::traits::input_parameter< NumericVector >::type aj(ajSEXP);
3738
Rcpp::traits::input_parameter< double >::type lambda(lambdaSEXP);
39+
Rcpp::traits::input_parameter< IntegerVector >::type weights(weightsSEXP);
3840
Rcpp::traits::input_parameter< NumericVector >::type params(paramsSEXP);
3941
Rcpp::traits::input_parameter< int >::type verbose(verboseSEXP);
40-
rcpp_result_gen = Rcpp::wrap(singleCCDr(cors, init_betas, nj, indexj, aj, lambda, params, verbose));
42+
rcpp_result_gen = Rcpp::wrap(singleCCDr(cors, init_betas, nj, indexj, aj, lambda, weights, params, verbose));
4143
return rcpp_result_gen;
4244
END_RCPP
4345
}
4446

4547
static const R_CallMethodDef CallEntries[] = {
46-
{"_ccdrAlgorithm_gridCCDr", (DL_FUNC) &_ccdrAlgorithm_gridCCDr, 8},
47-
{"_ccdrAlgorithm_singleCCDr", (DL_FUNC) &_ccdrAlgorithm_singleCCDr, 8},
48+
{"_ccdrAlgorithm_gridCCDr", (DL_FUNC) &_ccdrAlgorithm_gridCCDr, 9},
49+
{"_ccdrAlgorithm_singleCCDr", (DL_FUNC) &_ccdrAlgorithm_singleCCDr, 9},
4850
{NULL, NULL, 0}
4951
};
5052

0 commit comments

Comments
 (0)