#' Prints a transfer-entropy result
#'
#' @param x a transfer_entropy
#' @param digits the number of digits to display, defaults to 4
#' @param boot if the bootstrapped results should be printed, defaults to TRUE
#' @param probs numeric vector of quantiles for the bootstraps
#' @param ... additional arguments, currently not in use
#' @param tex if the data should be outputted as a TeX-string
#' @param ref the reference string of the LaTeX table (label) applies only if table = TRUE and tex = TRUE, defaults to FALSE
#' @param file a file where the results are printed to
#' @param table if the table environment should be printed as well (only applies if tex = TRUE), defaults to TRUE
#'
#' @return invisible the text
#' @export
#'
#' @examples
#' # construct two time-series
#' set.seed(1234567890)
#' n <- 500
#' x <- rep(0, n + 1)
#' y <- rep(0, n + 1)
#'
#' for (i in seq(n)) {
#' x[i + 1] <- 0.2 * x[i] + rnorm(1, 0, 2)
#' y[i + 1] <- x[i] + rnorm(1, 0, 2)
#' }
#'
#' x <- x[-1]
#' y <- y[-1]
#'
#' # Calculate Shannon's Transfer Entropy
#' te_result <- transfer_entropy(x, y, nboot = 100)
#'
#' print(te_result)
#'
#' # change the number of digits
#' print(te_result, digits = 10)
#'
#' # disable boot-print
#' print(te_result, boot = FALSE)
#'
#' # specify the quantiles of the bootstraps
#' print(te_result, probs = c(0, 0.1, 0.4, 0.5, 0.6, 0.9, 1))
#'
#' # get LaTeX output:
#' print(te_result, tex = TRUE)
#'
#' # set the reference label for LaTeX table
#' print(te_result, tex = TRUE, ref = "tab:te_result")
#'
#' \dontrun{
#' # file output
#' print(te_result, file = "te_result_file.txt")
#' print(te_result, tex = TRUE, file = "te_result_file.tex")
#' }
print.transfer_entropy <- function(x, digits = 4, boot = TRUE,
probs = c(0, 0.25, 0.5, 0.75, 1),
tex = FALSE,
ref = NA,
file = NA,
table = TRUE,
...) {
# the number of chars per reported value
# crate the header
val_names <- c("TE", "Eff. TE", "Std.Err.", "p-value", "sig")
header_names <- c("Direction", val_names)
n_digits <- max(max(nchar(val_names)), digits + 2)
header_lengths <- c(9, rep(n_digits, ncol(x$coef)), 5)
header <- paste(mapply(function(l, t) sprintf(sprintf("%%%ss", l), t),
l = header_lengths, t = header_names
),
collapse = ifelse(tex, " & ", " ")
)
line <- paste0(rep("-", max(nchar(header)), 59), collapse = "")
# 59 chars in the p-value footnote
# create the bootstrapped output:
if (!is.matrix(x$boot)) {
boot_res <- c(
line,
"For calculation of standard errors and p-values set nboot > 0"
)
} else if (!boot) {
boot_res <- NULL
} else {
quants <- t(apply(x$boot, 1, function(b) quantile(b, probs = probs)))
rownames(quants) <- c("X->Y", "Y->X")
probs_nam <- paste0(probs * 100, "%")
boot_hd_nam <- c("Direction", probs_nam)
boot_hd_len <- c(
9,
rep(
max(nchar(probs_nam), digits + 2),
length(probs)
)
)
boot_hd <- paste(mapply(function(l, t) sprintf(sprintf("%%%ss", l), t),
l = boot_hd_len, t = boot_hd_nam
),
collapse = ifelse(tex, " & ", " ")
)
line_width <- max(nchar(header), nchar(boot_hd), 59)
# 59 chars in the p-value footnote
line <- paste(rep("-", line_width), collapse = "")
if (tex) {
boot_res <- c(
" \\begin{subtable}[t]{\\linewidth}",
" \\centering",
" \\vspace{0pt}",
" \\caption{Panel B: Bootstrapped TE Quantiles}",
" \\begin{tabular}{rrrrrr}",
" \\toprule",
paste(" ", gsub("%", "\\\\%", boot_hd), " \\\\"),
" \\midrule",
paste(" ",
textify_mat(quants, digits = digits, width = boot_hd_len, stars = FALSE, tex = tex)),
" \\bottomrule",
sprintf(" \\multicolumn{6}{l}{Number of Replications: %d}", ncol(x$boot)),
" \\end{tabular}",
" \\end{subtable}"
)
} else {
boot_res <- c(
line,
sprintf("Bootstrapped TE Quantiles (%s replications):", ncol(x$boot)),
line,
boot_hd,
line,
textify_mat(quants, digits = digits, width = boot_hd_len, stars = FALSE)
)
}
}
if (tex) {
if (!is.na(ref) && ref == FALSE) ref <- NA
text <- c(
"% Make sure to include the following packages:",
"% \\usepackage{booktabs}",
"% \\usepackage{subcaption}",
"",
"% Table created by the RTransferEntropy Package",
sprintf("%% Time of creation: %s", Sys.time()),
"",
ifelse(table, "\\begin{table}", ""),
ifelse(table, sprintf(" \\caption{%s Transfer Entropy Result}", fupper(x$entropy)), ""),
ifelse(!is.na(ref) && table, sprintf(" \\label{%s}", ref), ""),
" \\begin{subtable}[t]{\\linewidth}",
" \\centering",
" \\vspace{0pt}",
" \\caption{Panel A: Transfer Entropy Estimates}",
" \\begin{tabular}{rrrrrl}",
" \\toprule",
paste(" ", header, " \\\\"),
" \\midrule",
paste(" ", textify_mat(x$coef, digits, header_lengths, tex = tex)),
" \\bottomrule",
ifelse(x$entropy == "shannon",
"",
sprintf(" \\multicolumn{6}{l}{Q: %s} \\\\", x$q)),
sprintf(" \\multicolumn{6}{l}{Number of Observations: %d} \\\\", x$nobs),
" \\multicolumn{6}{l}{p-values: \\textless 0.001 '***', \\textless 0.01 '**', \\textless 0.05 '*', \\textless 0.1 '.' } \\\\",
" \\end{tabular}",
" \\end{subtable}",
"",
boot_res,
ifelse(table, "\\end{table}", "")
)
} else {
text <- c(
paste(fupper(x$entropy), "Transfer Entropy Results:"),
line,
header,
line,
textify_mat(x$coef, digits, header_lengths),
boot_res,
line,
paste0(
sprintf("Number of Observations: %s", x$nobs),
ifelse(x$entropy == "renyi", sprintf("\nQ: %s", x$q), "")
),
line,
"p-values: < 0.001 '***', < 0.01 '**', < 0.05 '*', < 0.1 '.'"
)
}
text <- paste(text, collapse = "\n")
if (is.na(file)) {
cat(text, "\n")
} else {
writeLines(text, file)
message("TE Result has been written to file: ", file)
}
return(invisible(text))
}
# mat the matrix that contains the coefficients
# n the number of digits for the coefficients
# w the width of each number-field, defaults to 10
# stars if the last row represents the p-values and we want to calc the ***
textify_mat <- function(mat, digits, width = 10, stars = TRUE, tex = FALSE) {
# the first element is the direction (text)
nr_fmt <- sprintf("%%%s.%sf", width[-1], digits)
txt_fmt <- sprintf("%%%ss", width[1])
if (stars) {
if (ncol(mat) + 1 != length(nr_fmt)) {
stop("width has to have the same lenghts as the num of columns of mat + 1")
}
star_fmt <- sprintf("%%%ss", width[length(width)])
nr_fmt <- nr_fmt[-length(nr_fmt)]
}
clp <- ifelse(tex, " & ", " ")
# for each row, for each col, paste the number in the right format and
# add the stars at the end
txt <- apply(mat, 1, function(row_el) {
res <- mapply(function(x, fmt) sprintf(fmt, x), x = row_el, fmt = nr_fmt)
if (stars) {
r <- paste(c(res, sprintf(star_fmt, star(row_el[length(row_el)]))),
collapse = clp
)
} else {
r <- paste(res, collapse = clp)
}
if (tex) r <- paste(r, " \\\\")
return(r)
})
if (tex) names(txt) <- gsub("->", " \\\\textgreater ", names(txt))
paste(sprintf(txt_fmt, names(txt)), txt, sep = clp)
}
#' Prints a summary of a transfer-entropy result
#'
#' @param object a transfer_entropy
#' @param digits the number of digits to display, defaults to 4
#' @param probs numeric vector of quantiles for the bootstraps
#' @param ... additional arguments, passed to \code{\link[stats]{printCoefmat}}
#'
#' @return invisible the object
#' @export
#'
#' @examples
#' # construct two time-series
#' set.seed(1234567890)
#' n <- 500
#' x <- rep(0, n + 1)
#' y <- rep(0, n + 1)
#'
#' for (i in seq(n)) {
#' x[i + 1] <- 0.2 * x[i] + rnorm(1, 0, 2)
#' y[i + 1] <- x[i] + rnorm(1, 0, 2)
#' }
#'
#' x <- x[-1]
#' y <- y[-1]
#'
#' # Calculate Shannon's Transfer Entropy
#' te_result <- transfer_entropy(x, y, nboot = 100)
#'
#' summary(te_result)
summary.transfer_entropy <- function(object, digits = 4,
probs = c(0, 0.25, 0.5, 0.75, 1), ...) {
cat(sprintf("%s's Transfer Entropy\n\n", fupper(object$entropy)))
cat("Coefficients:\n")
printCoefmat(object$coef, ...)
if (!is.matrix(object$boot)) {
boot_res <- c(NULL)
} else {
quants <- t(apply(object$boot, 1, function(b) quantile(b, probs = probs)))
rownames(quants) <- c("X->Y", "Y->X")
probs_nam <- paste0(probs * 100, "%")
boot_hd_nam <- c("Direction", probs_nam)
boot_hd_len <- c(
9,
rep(
max(nchar(probs_nam), digits + 2),
length(probs)
)
)
boot_hd <- paste(mapply(function(l, t) sprintf(sprintf("%%%ss", l), t),
l = boot_hd_len, t = boot_hd_nam
),
collapse = " "
)
boot_res <- c(
sprintf(
"\nBootstrapped TE Quantiles (%s replications):",
ncol(object$boot)
),
boot_hd,
textify_mat(quants, digits = digits, width = boot_hd_len, stars = FALSE)
)
boot_res <- paste(boot_res, collapse = "\n")
cat(boot_res, "\n")
}
cat(sprintf("\nNumber of Observations: %i%s",
object$nobs,
ifelse(object$entropy == "renyi",
sprintf("\nQ: %s", object$q),
"")))
return(invisible(object))
}
#' Checks if an object is a transfer_entropy
#'
#' @param x an object
#'
#' @return a boolean value if x is a transfer_entropy
#' @export
#'
#' @examples
#' # see ?transfer_entropy
is.transfer_entropy <- function(x) {
inherits(x, "transfer_entropy")
}
#' Extract the Coefficient Matrix from a transfer_entropy
#'
#' @param object a transfer_entropy
#' @param ... additional arguments, currently not in use
#'
#' @return a Matrix containing the coefficients
#' @export
#'
#' @examples
#' set.seed(1234567890)
#' n <- 500
#' x <- rep(0, n + 1)
#' y <- rep(0, n + 1)
#'
#' for (i in seq(n)) {
#' x[i + 1] <- 0.2 * x[i] + rnorm(1, 0, 2)
#' y[i + 1] <- x[i] + rnorm(1, 0, 2)
#' }
#'
#' x <- x[-1]
#' y <- y[-1]
#'
#' te_result <- transfer_entropy(x, y, nboot = 100)
#' coef(te_result)
coef.transfer_entropy <- function(object, ...) {
if (!is.transfer_entropy(object)) stop("object must be a transfer_entropy")
return(object$coef)
}
# for some p-values (x) return the stars
star <- function(x) {
ifelse(is.null(x) || is.na(x), "",
ifelse(x < 0.001, "***",
ifelse(x < 0.01, "**",
ifelse(x < 0.05, "*",
ifelse(x < 0.1, ".", "")
)
)
)
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.