Skip to content

Commit 17f5f7c

Browse files
smeekessmeekes
committed
Set irrelevant specs to NULL
1 parent a8badb0 commit 17f5f7c

File tree

2 files changed

+95
-72
lines changed

2 files changed

+95
-72
lines changed

‎R/auxiliary.R‎

Lines changed: 40 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,35 @@ do_tests_and_bootstrap <- function(data, boot_sqt_test, boot_ur_test, level, boo
5555
range_nonmiss <- inputs$range_nonmiss
5656
joint <- inputs$joint
5757

58+
list_inputs <- inputs
59+
if (!(bootstrap %in% c("MBB", "BWB", "DWB"))) {
60+
list_inputs$l <- NULL
61+
}
62+
if (bootstrap != "AWB") {
63+
list_inputs$ar_AWB <- NULL
64+
}
65+
if (!union) {
66+
list_inputs$union_quantile <- NULL
67+
dc_vector <- c("no deterministics", "intercept", "intercept and trend")
68+
list_inputs$deterministics <- dc_vector[dc + 1]
69+
detr_name_vector <- c("ADF", "ADF-QD")
70+
detr_vector <- c("OLS", "QD")
71+
list_inputs$name <- detr_name_vector[detr_int]
72+
list_inputs$detrend <- detr_vector[detr_int]
73+
} else {
74+
list_inputs$union_quantile <- level
75+
list_inputs$deterministics <- NULL
76+
list_inputs$name <- "Union"
77+
list_inputs$detrend <- NULL
78+
}
79+
if (min_lag == max_lag) {
80+
list_inputs$criterion <- NULL
81+
list_inputs$criterion_scale <- NULL
82+
} else {
83+
list_inputs$criterion <- criterion
84+
list_inputs$criterion_scale <- criterion_scale
85+
}
86+
5887
# Dimensions
5988
n <- nrow(data)
6089
N <- ncol(data)
@@ -68,11 +97,11 @@ do_tests_and_bootstrap <- function(data, boot_sqt_test, boot_ur_test, level, boo
6897
u_boot[is.nan(u_boot)] <- NA
6998
res <- panel_est$res
7099
ar_est <- panel_est$par[-1, , drop = FALSE]
71-
t_star <- bootstrap_cpp(B = B, boot = boot, u = u_boot, e = res, l = l, s = s_DWB, ar = ar_AWB,
72-
ar_est = ar_est, y0 = matrix(0, ncol = N), pmin = min_lag,
73-
pmax = max_lag, ic = ic, dc = dc, detr = detr_int,
74-
ic_scale = criterion_scale, h_rs = h_rs,
75-
range = range_nonmiss, joint = joint, show_progress = show_progress,
100+
t_star <- bootstrap_cpp(B = B, boot = boot, u = u_boot, e = res, l = l, s = s_DWB,
101+
ar = ar_AWB, ar_est = ar_est, y0 = matrix(0, ncol = N),
102+
pmin = min_lag, pmax = max_lag, ic = ic, dc = dc, detr = detr_int,
103+
ic_scale = criterion_scale, h_rs = h_rs, range = range_nonmiss,
104+
joint = joint, show_progress = show_progress,
76105
do_parallel = do_parallel)
77106

78107
tests_and_params <- adf_tests_panel_cpp(data, pmin = min_lag, pmax = max_lag, ic = ic,
@@ -86,7 +115,8 @@ do_tests_and_bootstrap <- function(data, boot_sqt_test, boot_ur_test, level, boo
86115
if (N > 1) {
87116
test_stats_star <- union_tests_cpp(t_star, scaling)
88117
test_stats <- union_tests_cpp(array(tests_i,
89-
dim = c(1, length(dc) * length(detr_int), N)), scaling)
118+
dim = c(1, length(dc) * length(detr_int), N)),
119+
scaling)
90120
} else {
91121
test_stats_star <- union_test_cpp(t_star[, , 1], scaling)
92122
test_stats <- union_test_cpp(array(tests_i,
@@ -98,7 +128,7 @@ do_tests_and_bootstrap <- function(data, boot_sqt_test, boot_ur_test, level, boo
98128
}
99129
out <- list("y" = data, "p_vec" = p_vec, "t_star" = t_star, "test_stats_star" = test_stats_star,
100130
"tests_i" = tests_i, "param_i" = params_i,"test_stats" = test_stats,
101-
"level" = level, "dc" = dc, "detr" = detr, "inputs" = inputs)
131+
"level" = level, "dc" = dc, "detr" = detr, "inputs" = list_inputs)
102132

103133
return(out)
104134
}
@@ -213,17 +243,16 @@ check_inputs <- function(data, boot_sqt_test, boot_ur_test, level, bootstrap, B,
213243
stop("The argument deterministics should be equal to either none, intercept, trend:
214244
(none: no deterministics, intercept: intercept only, trend: intercept and trend)")
215245
}
216-
dc <- 0*(deterministics=="none") + 1*(deterministics=="intercept") + 2*(deterministics=="trend")
217-
dc <- sort(dc)
218-
dc_boot <- max(dc)
246+
dc <- 0*(deterministics=="none") + 1*(deterministics=="intercept") +
247+
2*(deterministics=="trend")
248+
dc_boot <- dc
219249
if (is.null(detrend)) {
220250
warning("No detrending specification set. Using OLS detrending.")
221251
detrend <- "OLS"
222252
} else if(any(!is.element(detrend, c("OLS", "QD")))| length(detrend) > 1) {
223253
stop("The argument detrend should be equal to either OLS, QD")
224254
}
225255
detr_int <- 1*(detrend=="OLS") + 2*(detrend=="QD")
226-
detr_int <- sort(detr_int)
227256
}
228257

229258
if (is.null(block_length)) {

‎R/bootURtests.R‎

Lines changed: 55 additions & 61 deletions
Original file line numberDiff line numberDiff line change
@@ -112,13 +112,17 @@ boot_ur <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999, block_l
112112
}
113113

114114
spec <- list("bootstrap" = bootstrap, "B" = B, "block_length" = inputs$inputs$l,
115-
"ar_AWB" = inputs$inputs$ar_AWB, "level" = level, "union" = union, "union_quantile" = union_quantile,
116-
"deterministics" = deterministics, "detrend" = detrend, "min_lag" = min_lag,
117-
"max_lag" = inputs$inputs$p_max, "criterion" = criterion, "criterion_scale" = criterion_scale)
118-
115+
"ar_AWB" = inputs$inputs$ar_AWB, "level" = level,
116+
"union" = union, "union_quantile" = inputs$inputs$union_quantile,
117+
"deterministics" = inputs$inputs$deterministics,
118+
"detrend" = inputs$inputs$detrend, "min_lag" = min_lag,
119+
"max_lag" = inputs$inputs$p_max, "criterion" = inputs$inputs$criterion,
120+
"criterion_scale" = inputs$inputs$criterion_scale)
121+
119122
# Results
120123
if (union) { # Union test
121-
iADFout <- iADF_cpp(test_i = inputs$test_stats, t_star = inputs$test_stats_star, level = inputs$level)
124+
iADFout <- iADF_cpp(test_i = inputs$test_stats, t_star = inputs$test_stats_star,
125+
level = inputs$level)
122126
iADFout <- cbind(rep(NA, nrow(iADFout)), iADFout)
123127
if (NCOL(data) > 1) {
124128
rownames(iADFout) <- var_names
@@ -133,13 +137,6 @@ boot_ur <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999, block_l
133137
rownames(iADFout) <- var_names
134138
colnames(iADFout) <- c("gamma", "statistic", "p.value")
135139
}
136-
switch(deterministics,
137-
"trend" = deterministics <- "intercept and trend",
138-
"intercept" = deterministics <- "intercept",
139-
"none" = deterministics <- "no deterministics")
140-
switch(detrend,
141-
"OLS" = detrend <- "ADF",
142-
"QD" = detrend <- "ADF-QD")
143140
}
144141

145142
if (!is.null(level)) {
@@ -148,12 +145,13 @@ boot_ur <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999, block_l
148145
rej_H0 <- NULL
149146
}
150147

151-
152148
if (NCOL(data) > 1) {
153-
if(union){
149+
if (union) {
154150
method_name <- paste(bootstrap, "Bootstrap Union test on each individual series (no multiple testing correction)")
155-
}else{
156-
method_name <- paste(bootstrap, "Bootstrap", detrend, " test ( with" , deterministics,") on each individual series (no multiple testing correction)")
151+
} else {
152+
method_name <- paste(bootstrap, "Bootstrap", inputs$inputs$name,
153+
" test ( with" , inputs$inputs$deterministics,
154+
") on each individual series (no multiple testing correction)")
157155
}
158156
boot_ur_output <- list(method = method_name, data.name = data_name,
159157
null.value = c("gamma" = 0), alternative = "less",
@@ -170,15 +168,18 @@ boot_ur <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999, block_l
170168
attr(iADFtstat, "names") <- "tstat"
171169
p_val <- drop(iADFout[1, 3])
172170
attr(p_val, "names") <- "p-value"
173-
174-
if(union){
171+
172+
if (union) {
175173
method_name <- paste(bootstrap, "Bootstrap Union test on a single time series")
176-
}else{
177-
method_name <- paste(bootstrap, "Bootstrap", detrend, " test ( with" , deterministics,") on a single time series")
174+
} else {
175+
method_name <- paste(bootstrap, "Bootstrap", inputs$inputs$detrend,
176+
" test ( with" , inputs$inputs$deterministics,
177+
") on a single time series")
178178
}
179179
boot_ur_output <- list(method = method_name, data.name = var_names,
180180
null.value = c("gamma" = 0), alternative = "less",
181-
estimate = param, statistic = iADFtstat, p.value = p_val, specifications = spec)
181+
estimate = param, statistic = iADFtstat, p.value = p_val,
182+
specifications = spec)
182183
class(boot_ur_output) <- c("bootUR", "htest")
183184
}
184185

@@ -421,9 +422,11 @@ boot_fdr <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999, block_
421422
}
422423

423424
spec <- list("bootstrap" = bootstrap, "B" = B, "block_length" = inputs$inputs$l,
424-
"ar_AWB" = inputs$inputs$ar_AWB, "FDR_level" = FDR_level, "union" = union, "deterministics" = deterministics,
425-
"detrend" = detrend, "min_lag" = min_lag, "max_lag" = inputs$inputs$p_max, "criterion" = criterion,
426-
"criterion_scale" = criterion_scale)
425+
"ar_AWB" = inputs$inputs$ar_AWB, "FDR_level" = FDR_level, "union" = union,
426+
"deterministics" = inputs$inputs$deterministics,
427+
"detrend" = inputs$inputs$detrend, "min_lag" = min_lag,
428+
"max_lag" = inputs$inputs$p_max, "criterion" = inputs$inputs$criterion,
429+
"criterion_scale" = inputs$inputs$criterion_scale)
427430

428431
if (union) { # Union Tests
429432
bFDRout <- FDR_cpp(test_i = inputs$test_stats, t_star = inputs$test_stats_star,
@@ -436,14 +439,8 @@ boot_fdr <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999, block_
436439
t_star = inputs$t_star[ , 1,], level = inputs$level)
437440
estimates <- t(inputs$param_i)
438441
tstats <- drop(inputs$tests_i[1, ])
439-
switch(deterministics,
440-
"trend" = deterministics <- "intercept and trend",
441-
"intercept" = deterministics <- "intercept",
442-
"none" = deterministics <- "no deterministics")
443-
switch(detrend,
444-
"OLS" = detrend <- "ADF",
445-
"QD" = detrend <- "ADF-QD")
446-
method_name <- paste(bootstrap, "Bootstrap", detrend, " tests ( with" , deterministics,") with False Discovery Rate control")
442+
method_name <- paste(bootstrap, "Bootstrap", inputs$inputs$name, " tests ( with" ,
443+
inputs$inputs$deterministics, ") with False Discovery Rate control")
447444
}
448445
rej_H0 <- matrix(bFDRout$rej_H0 == 1, nrow = NCOL(data))
449446
rownames(rej_H0) <- var_names
@@ -457,7 +454,8 @@ boot_fdr <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999, block_
457454
fdr_output <- list(method = method_name, data.name = data_name,
458455
null.value = c("gamma" = 0), alternative = "less",
459456
estimate = estimates, statistic = tstats, p.value = p_vals,
460-
rejections = rej_H0, details = FDR_seq, series.names = var_names, specifications = spec)
457+
rejections = rej_H0, details = FDR_seq, series.names = var_names,
458+
specifications = spec)
461459
class(fdr_output) <- c("bootUR", "mult_htest")
462460

463461
return(fdr_output)
@@ -549,10 +547,12 @@ boot_sqt <- function(data, data_name = NULL, steps = 0:NCOL(data), bootstrap = "
549547
}
550548

551549
spec <- list("steps" = steps, "bootstrap" = bootstrap, "B" = B, "block_length" = inputs$inputs$l,
552-
"ar_AWB" = inputs$inputs$ar_AWB, "SQT_level" = SQT_level, "union" = union, "deterministics" = deterministics,
553-
"detrend" = detrend, "min_lag" = min_lag, "max_lag" = inputs$inputs$p_max, "criterion" = criterion,
554-
"criterion_scale" = criterion_scale)
555-
550+
"ar_AWB" = inputs$inputs$ar_AWB, "SQT_level" = SQT_level, "union" = union,
551+
"deterministics" = inputs$inputs$deterministics,
552+
"detrend" = inputs$inputs$detrend, "min_lag" = min_lag,
553+
"max_lag" = inputs$inputs$p_max, "criterion" = inputs$inputs$criterion,
554+
"criterion_scale" = inputs$inputs$criterion_scale)
555+
556556
if (union) { # Union Tests
557557
BSQTout <- BSQT_cpp(pvec = inputs$p_vec, test_i = inputs$test_stats,
558558
t_star = inputs$test_stats_star, level = inputs$level)
@@ -564,15 +564,10 @@ boot_sqt <- function(data, data_name = NULL, steps = 0:NCOL(data), bootstrap = "
564564
t_star = inputs$t_star[ , 1,], level = inputs$level)
565565
estimates <- t(inputs$param_i)
566566
tstats <- drop(inputs$tests_i[1, ])
567-
switch(deterministics,
568-
"trend" = deterministics <- "intercept and trend",
569-
"intercept" = deterministics <- "intercept",
570-
"none" = deterministics <- "no deterministics")
571-
switch(detrend,
572-
"OLS" = detrend <- "ADF",
573-
"QD" = detrend <- "ADF-QD")
574-
method_name <- paste(bootstrap, "Bootstrap Sequential Quantile", detrend, " test ( with" , deterministics,")")
575-
567+
method_name <- paste(bootstrap, "Bootstrap Sequential Quantile",
568+
inputs$inputs$name, " test ( with" ,
569+
inputs$inputs$deterministics,")")
570+
576571
}
577572
rej_H0 <- matrix(BSQTout$rej_H0 == 1, nrow = NCOL(data))
578573
rownames(rej_H0) <- var_names
@@ -586,7 +581,8 @@ boot_sqt <- function(data, data_name = NULL, steps = 0:NCOL(data), bootstrap = "
586581
sqt_output <- list(method = method_name, data.name = data_name,
587582
null.value = c("gamma" = 0), alternative = "less",
588583
estimate = estimates, statistic = tstats, p.value = p_vals,
589-
rejections = rej_H0, details = BSQT_seq, series.names = var_names, specifications = spec)
584+
rejections = rej_H0, details = BSQT_seq, series.names = var_names,
585+
specifications = spec)
590586
class(sqt_output) <- c("bootUR", "mult_htest")
591587
return(sqt_output)
592588
}
@@ -654,12 +650,15 @@ boot_panel <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999,
654650
if (is.null(data_name)) {
655651
data_name <- deparse(substitute(data))
656652
}
657-
653+
658654
spec <- list("bootstrap" = bootstrap, "B" = B, "block_length" = inputs$inputs$l,
659-
"ar_AWB" = inputs$inputs$ar_AWB,"union" = union, "union_quantile" = union_quantile,
660-
"deterministics" = deterministics, "detrend" = detrend, "min_lag" = min_lag,
661-
"max_lag" = inputs$inputs$p_max, "criterion" = criterion, "criterion_scale" = criterion_scale)
662-
655+
"ar_AWB" = inputs$inputs$ar_AWB,"union" = union,
656+
"union_quantile" = inputs$inputs$union_quantile,
657+
"deterministics" = inputs$inputs$deterministics,
658+
"detrend" = inputs$inputs$detrend, "min_lag" = min_lag,
659+
"max_lag" = inputs$inputs$p_max, "criterion" = inputs$inputs$criterion,
660+
"criterion_scale" = inputs$inputs$criterion_scale)
661+
663662
if (union) { # Union Test
664663
GM_test <- mean(inputs$test_stats)
665664
t_star <- rowMeans(inputs$test_stats_star)
@@ -669,14 +668,8 @@ boot_panel <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999,
669668
GM_test <- rowMeans(inputs$tests_i)
670669
t_star <- apply(inputs$t_star, 1:2, mean)
671670
p_val <- sapply(1, function(i){mean(t_star[, i] < GM_test[i])})
672-
switch(deterministics,
673-
"trend" = deterministics <- "intercept and trend",
674-
"intercept" = deterministics <- "intercept",
675-
"none" = deterministics <- "no deterministics")
676-
switch(detrend,
677-
"OLS" = detrend <- "ADF",
678-
"QD" = detrend <- "ADF-QD")
679-
method_name <- paste("Panel", bootstrap, "Bootstrap Group-Mean", detrend, " test ( with" , deterministics,")")
671+
method_name <- paste("Panel", bootstrap, "Bootstrap Group-Mean", inputs$inputs$name,
672+
" test ( with" , inputs$inputs$deterministics,")")
680673
}
681674

682675
attr(GM_test, "names") <- "tstat"
@@ -685,7 +678,8 @@ boot_panel <- function(data, data_name = NULL, bootstrap = "AWB", B = 1999,
685678
attr(p_val, "names") <- "p-value"
686679
panel_output <- list(method = method_name, data.name = data_name,
687680
null.value = c("gamma" = 0), alternative = "less",
688-
estimate = gamma_hat, statistic = GM_test, p.value = p_val, specifications = spec)
681+
estimate = gamma_hat, statistic = GM_test, p.value = p_val,
682+
specifications = spec)
689683
class(panel_output) <- c("bootUR", "htest")
690684
return(panel_output)
691685
}

0 commit comments

Comments
 (0)