| 1 |
# Plotting an ordered set goes through qeviz. These functions keep the API |
|
| 2 |
# ONA has always had -- plot() on a set, then edges(), nodes() and units() |
|
| 3 |
# chained onto it -- and translate each call into the matching qe_*() call. |
|
| 4 |
# The returned object is a qeviz `qe_plot` with the class "enaplot" in front, |
|
| 5 |
# so every qeviz chain function (qe_edges(), qe_group(), qe_axes(), |
|
| 6 |
# qe_export_html(), ...) works on it as well. |
|
| 7 | ||
| 8 |
#' Plot an ONA set |
|
| 9 |
#' |
|
| 10 |
#' Creates a [qeviz::qe_plot()] for an ordered set. The plot starts empty: |
|
| 11 |
#' add the mean network with [edges()], the code nodes with [nodes()] and the |
|
| 12 |
#' unit points with [units()]. Any qeviz chain function can be used on the |
|
| 13 |
#' result too, for example `qe_edges("FirstGame", compare = "SecondGame")`.
|
|
| 14 |
#' |
|
| 15 |
#' @param x An `ena.ordered.set` from [model()]. |
|
| 16 |
#' @param y Ignored (present for the `plot()` generic). |
|
| 17 |
#' @param ... Passed to [qeviz::qe_plot()] (e.g. `title`, `width`, `height`, |
|
| 18 |
#' `range`). |
|
| 19 |
#' @param dimensions The two dimensions to plot, by name (e.g. |
|
| 20 |
#' `c("SVD2", "SVD3")`). Default: the first two.
|
|
| 21 |
#' @param group_col Metadata column that groups the units, used for qeviz's |
|
| 22 |
#' group means and `qe_edges(group =)`. Default: `"Condition"` when the set |
|
| 23 |
#' has that column, otherwise none. |
|
| 24 |
#' @param scale_points Whether qeviz rescales the points to the extent of the |
|
| 25 |
#' nodes. Default `FALSE`: ONA's node positions are already fitted to the |
|
| 26 |
#' points, so both are drawn as they are in the set. |
|
| 27 |
#' @param legacy Draw the plot the way ONA 0.1 did: axes fixed at |
|
| 28 |
#' `c(-max_axis_marker, max_axis_marker)` with the axis cross shown, and |
|
| 29 |
#' edge widths and node sizes in data units (a weight of 1 is as wide as one |
|
| 30 |
#' unit of the axes). Default `FALSE`: qeviz fits the axes to the plot and |
|
| 31 |
#' draws a weight of 1 as 4% of the plot width. Use it to keep figures |
|
| 32 |
#' comparable with ones made before plotting moved to qeviz. |
|
| 33 |
#' @param max_axis_marker Half the axis range when `legacy = TRUE`. |
|
| 34 |
#' |
|
| 35 |
#' @return An object of classes `enaplot` and `qe_plot`. |
|
| 36 |
#' @seealso [edges()], [nodes()], [units()], [qeviz::qe_plot()] |
|
| 37 |
#' @export |
|
| 38 |
'plot.ena.ordered.set' <- function(x, y, ..., dimensions = NULL, group_col = NULL, |
|
| 39 |
scale_points = FALSE, legacy = FALSE, |
|
| 40 |
max_axis_marker = 3) {
|
|
| 41 | 17x |
if (missing(group_col) && "Condition" %in% colnames(x$points)) {
|
| 42 | 17x |
group_col <- "Condition" |
| 43 |
} |
|
| 44 | 17x |
args <- list(x, ..., dims = dimensions, group_col = group_col, scale_points = scale_points) |
| 45 | 17x |
if (legacy) {
|
| 46 | 3x |
args$range <- max_axis_marker |
| 47 | 3x |
args$view_padding <- 1 |
| 48 |
} |
|
| 49 | 17x |
p <- do.call(qeviz::qe_plot, args) |
| 50 | 17x |
p <- qeviz::qe_group(p, show = FALSE) |
| 51 | 17x |
if (legacy) {
|
| 52 | 3x |
p <- qeviz::qe_axes(p) |
| 53 |
} |
|
| 54 | 17x |
attr(p, "model") <- x |
| 55 | 17x |
attr(p, "dimensions") <- c(p$model$x_col, p$model$y_col) |
| 56 |
# In data units, a weight of 1 spans one axis unit of the 2 * max_axis_marker |
|
| 57 |
# wide plot. |
|
| 58 | 17x |
attr(p, "edge_width") <- if (legacy) 1 / (2 * max_axis_marker) else NULL |
| 59 | 17x |
class(p) <- c("enaplot", class(p))
|
| 60 | 17x |
p |
| 61 |
} |
|
| 62 | ||
| 63 |
# Every chain function accepts the set itself as well as a plot of it. |
|
| 64 |
as_enaplot <- function(x, fn) {
|
|
| 65 | 23x |
if (inherits(x, "enaplot")) return(x) |
| 66 | 2x |
if (inherits(x, "ena.ordered.set")) return(plot(x)) |
| 67 | 1x |
stop(fn, "() needs an ONA set or a plot of one (see plot.ena.ordered.set)", call. = FALSE) |
| 68 |
} |
|
| 69 | ||
| 70 |
# A network as one weight per edge column, named "A & B": a vector is used as |
|
| 71 |
# is, rows of line weights (the whole table or a subset such as |
|
| 72 |
# `set$line.weights$Condition$FirstGame`) are averaged. |
|
| 73 |
mean_network <- function(weights) {
|
|
| 74 | 1x |
if (is.numeric(weights) && is.null(dim(weights))) return(weights) |
| 75 | 11x |
weights <- response_rows(weights) |
| 76 | 11x |
m <- as.matrix(weights) |
| 77 | 11x |
if (!is.numeric(m)) {
|
| 78 | ! |
df <- as.data.frame(weights, check.names = FALSE) |
| 79 | ! |
m <- as.matrix(df[, vapply(df, is.numeric, logical(1)), drop = FALSE]) |
| 80 |
} |
|
| 81 | 11x |
colMeans(m) |
| 82 |
} |
|
| 83 | ||
| 84 |
#' Draw a network's edges |
|
| 85 |
#' |
|
| 86 |
#' Adds a directed edge network to the plot through [qeviz::qe_edges()]. By |
|
| 87 |
#' default it is the mean network of every unit in the set; `weights` draws |
|
| 88 |
#' another network, typically one group's rows of `set$line.weights`. Node |
|
| 89 |
#' sizes follow the drawn network (each node's diameter is the summed width |
|
| 90 |
#' of the edges directed at it, plus its self-connection). |
|
| 91 |
#' |
|
| 92 |
#' @param x An `ena.ordered.set`, or a plot of one from [plot.ena.ordered.set()]. |
|
| 93 |
#' @param ... Passed to [qeviz::qe_edges()] (e.g. `threshold`, `name`, |
|
| 94 |
#' `color_scale`, `self_size`, `edge_width`; a legacy plot sets |
|
| 95 |
#' `edge_width` to its data-unit scale unless given here). |
|
| 96 |
#' @param weights The network to draw: a numeric vector of edge weights in the |
|
| 97 |
#' set's edge-column order, or rows of line weights to average (e.g. |
|
| 98 |
#' `set$line.weights$Condition$FirstGame`). Default: the mean of all units. |
|
| 99 |
#' @param edge_color One colour, or `c(positive, negative)` colours for the |
|
| 100 |
#' edge weights. |
|
| 101 |
#' @param multiplier Magnifies the edge widths and node sizes of the plot (the |
|
| 102 |
#' plot is labelled with the factor). |
|
| 103 |
#' @param nodes Node positions to draw the edges between, in place of the |
|
| 104 |
#' set's (a table like `set$rotation$nodes`). |
|
| 105 |
#' |
|
| 106 |
#' @return The plot, with the network added. |
|
| 107 |
#' @export |
|
| 108 |
edges <- function(x, ..., weights = NULL, edge_color = c("#FF0000", "#0000FF"),
|
|
| 109 |
multiplier = 1, nodes = NULL) {
|
|
| 110 | 13x |
p <- as_enaplot(x, "edges") |
| 111 | 12x |
set <- attr(p, "model") |
| 112 | 12x |
w <- mean_network(if (is.null(weights)) set$line.weights else weights) |
| 113 | 12x |
args <- list(p, ..., weights = w, colors = edge_color, |
| 114 | 12x |
magnify = if (multiplier != 1) multiplier else NULL) |
| 115 | 12x |
if (is.null(args$edge_width)) {
|
| 116 | 11x |
args$edge_width <- attr(p, "edge_width") |
| 117 |
} |
|
| 118 | 12x |
p <- do.call(qeviz::qe_edges, args) |
| 119 | 12x |
if (!is.null(nodes)) {
|
| 120 | ! |
p <- qeviz::qe_nodes(p, positions = nodes) |
| 121 |
} |
|
| 122 | 12x |
attr(p, "edge_weights") <- w |
| 123 | 12x |
p |
| 124 |
} |
|
| 125 | ||
| 126 |
#' Draw the code nodes |
|
| 127 |
#' |
|
| 128 |
#' Shows the code nodes through [qeviz::qe_nodes()]. Nodes are drawn whenever |
|
| 129 |
#' a network is, so this is only needed to show them without one, to move |
|
| 130 |
#' them, or to hide their labels. |
|
| 131 |
#' |
|
| 132 |
#' @param x An `ena.ordered.set`, or a plot of one from [plot.ena.ordered.set()]. |
|
| 133 |
#' @param ... Passed to [qeviz::qe_nodes()] (e.g. `labels`, `sizes`, |
|
| 134 |
#' `unconnected`). |
|
| 135 |
#' @param node_labels Whether to label the nodes with their codes. |
|
| 136 |
#' @param nodes Node positions in place of the set's (a table like |
|
| 137 |
#' `set$rotation$nodes`). |
|
| 138 |
#' @param node_position_multiplier Scales `nodes` (or the set's positions) |
|
| 139 |
#' before drawing. |
|
| 140 |
#' |
|
| 141 |
#' @return The plot, with the nodes shown. |
|
| 142 |
#' @export |
|
| 143 |
nodes <- function(x, ..., node_labels = TRUE, nodes = NULL, node_position_multiplier = 1) {
|
|
| 144 | 4x |
p <- as_enaplot(x, "nodes") |
| 145 | 4x |
positions <- nodes |
| 146 | 4x |
if (node_position_multiplier != 1) {
|
| 147 | 1x |
if (is.null(positions)) positions <- attr(p, "model")$rotation$nodes |
| 148 | 1x |
positions <- as.data.frame(positions, check.names = FALSE) |
| 149 | 1x |
num <- vapply(positions, is.numeric, logical(1)) |
| 150 | 1x |
positions[num] <- positions[num] * node_position_multiplier |
| 151 |
} |
|
| 152 | 4x |
p <- qeviz::qe_nodes(p, show = "always", positions = positions, ...) |
| 153 | 4x |
if (!node_labels) {
|
| 154 | 1x |
p <- qeviz::qe_labels(p, nodes = "off") |
| 155 |
} |
|
| 156 | 4x |
p |
| 157 |
} |
|
| 158 | ||
| 159 |
#' Draw the units' points and their mean |
|
| 160 |
#' |
|
| 161 |
#' Adds the units' points as a point set ([qeviz::qe_points()]) and their mean |
|
| 162 |
#' with its confidence interval as a group mean ([qeviz::qe_group()]). Call it |
|
| 163 |
#' once per group of units to compare, with `points` and `points_color`. |
|
| 164 |
#' |
|
| 165 |
#' @param x An `ena.ordered.set`, or a plot of one from [plot.ena.ordered.set()]. |
|
| 166 |
#' @param ... Passed to [qeviz::qe_points()] (e.g. `size`, `labels`). |
|
| 167 |
#' @param points The points to draw, default all of `set$points`; a subset such |
|
| 168 |
#' as `set$points$Condition$FirstGame` draws one group. |
|
| 169 |
#' @param points_color Colour of the points and their mean. |
|
| 170 |
#' @param show_points Whether to draw the points. |
|
| 171 |
#' @param show_mean Whether to draw their mean. |
|
| 172 |
#' @param with_ci Whether to draw the mean's 95% confidence interval. |
|
| 173 |
#' @param point_shape `"circle"`, `"square"`, `"triangle"` or `"diamond"`. |
|
| 174 |
#' @param name Name of the point set; default `"points 1"`, `"points 2"`, ... |
|
| 175 |
#' @param label Label of the mean; default `"mean 1"`, `"mean 2"`, ... |
|
| 176 |
#' |
|
| 177 |
#' @return The plot, with the points and mean added. |
|
| 178 |
#' @export |
|
| 179 |
units <- function(x, ..., points = NULL, points_color = "#FF0000", |
|
| 180 |
show_points = TRUE, show_mean = TRUE, with_ci = TRUE, |
|
| 181 |
point_shape = "circle", name = NULL, label = NULL) {
|
|
| 182 | 9x |
p <- as_enaplot(x, "units") |
| 183 | 9x |
pts <- response_rows(if (is.null(points)) attr(p, "model")$points else points) |
| 184 | 9x |
if (show_points) {
|
| 185 | 9x |
p <- qeviz::qe_points(p, points = pts, color = points_color, shape = point_shape, |
| 186 | 9x |
name = name, ...) |
| 187 |
} |
|
| 188 | 9x |
if (show_mean) {
|
| 189 | 9x |
p <- qeviz::qe_group(p, points = pts, color = points_color, label = label, |
| 190 | 9x |
intervals = if (with_ci) "box" else "none") |
| 191 |
} |
|
| 192 | 9x |
p |
| 193 |
} |
|
| 194 | ||
| 195 |
#' Print an ONA plot |
|
| 196 |
#' |
|
| 197 |
#' Renders the plot in the viewer or browser, as [qeviz::qe_plot()] objects |
|
| 198 |
#' print. |
|
| 199 |
#' |
|
| 200 |
#' @param x An `enaplot` from [plot.ena.ordered.set()]. |
|
| 201 |
#' @param ... Passed on to qeviz's print method. |
|
| 202 |
#' |
|
| 203 |
#' @return `x`, invisibly. |
|
| 204 |
#' @export |
|
| 205 |
'print.enaplot' <- function(x, ...) {
|
|
| 206 | ! |
NextMethod() |
| 207 |
} |
| 1 |
#' Re-class vector as ena.co.occurrence |
|
| 2 |
#' |
|
| 3 |
#' @param x Vector to re-class |
|
| 4 |
#' |
|
| 5 |
#' @return re-classed vector |
|
| 6 |
#' @export |
|
| 7 |
as.ena.co.occurrence <- function(x) {
|
|
| 8 | ! |
if(is.factor(x)) {
|
| 9 | ! |
x = as.character(x) |
| 10 |
} |
|
| 11 | ! |
class(x) = c("ena.co.occurrence", class(x))
|
| 12 | ! |
x |
| 13 |
} |
|
| 14 | ||
| 15 |
# Direction helpers ---------------------------------------------------------- |
|
| 16 |
# |
|
| 17 |
# The original ONA model() stacked one row per unit per direction and tagged |
|
| 18 |
# them with an ENA_DIRECTION column ("ground"/"response"). Since model() became
|
|
| 19 |
# a wrapper around rENA::model(), an ordered set has one row per unit and no |
|
| 20 |
# such column. The plot code keeps working with both shapes by |
|
| 21 |
# going through these helpers: when the column is absent every row is treated |
|
| 22 |
# as the "response" direction, which is what the original produced by default |
|
| 23 |
# (rotation_on = "response"). |
|
| 24 |
# |
|
| 25 |
# rENA's `$` method on ena.matrix objects raises an error for an absent column |
|
| 26 |
# rather than returning NULL, so the column is always checked by name first. |
|
| 27 |
has_direction <- function(x) {
|
|
| 28 | 20x |
"ENA_DIRECTION" %in% colnames(x) |
| 29 |
} |
|
| 30 | ||
| 31 |
n_directions <- function(x) {
|
|
| 32 | ! |
if (has_direction(x)) length(unique(x$ENA_DIRECTION)) else 1L |
| 33 |
} |
|
| 34 | ||
| 35 |
direction_rows <- function(x, direction) {
|
|
| 36 | 20x |
if (!has_direction(x)) {
|
| 37 | 20x |
if (direction == "response") return(x) |
| 38 | ! |
return(x[0, ]) |
| 39 |
} |
|
| 40 | ! |
x[x$ENA_DIRECTION == direction, ] |
| 41 |
} |
|
| 42 | ||
| 43 |
response_rows <- function(x) {
|
|
| 44 | 20x |
direction_rows(x, "response") |
| 45 |
} |
| 1 |
##' Calculate correlations between SVD and centroid differences in ONA model |
|
| 2 |
##' |
|
| 3 |
##' Computes Pearson and Spearman correlations between pairwise differences of points and centroids along specified dimensions in an Epistemic Network Analysis (ENA) model. |
|
| 4 |
##' |
|
| 5 |
##' @param enaset An ENA set object containing points and model centroids (typically output from ENA model fitting). |
|
| 6 |
##' @param pts Optional data frame of points to use. If NULL, points are selected from `enaset$points` matching the specified direction. |
|
| 7 |
##' @param cts Optional data frame or matrix of centroids to use. If NULL, centroids are taken from `enaset$model$centroids`. |
|
| 8 |
##' @param dims Integer vector specifying which dimensions to use for the correlation (default: c(1,2)). |
|
| 9 |
##' @param direction Character string specifying which direction(s) to include from `enaset$points$ENA_DIRECTION` (default: "response"). |
|
| 10 |
##' |
|
| 11 |
##' @return A data frame with Pearson and Spearman correlations for each specified dimension. |
|
| 12 |
##' @export |
|
| 13 |
correlations <- function(enaset, pts = NULL, cts = NULL, dims = c(1:2), direction = "response") {
|
|
| 14 | 2x |
if(is.null(pts) || is.null(cts)) {
|
| 15 |
# Not every ordered set carries an ENA_DIRECTION column -- a model with one |
|
| 16 |
# row per unit has no directions to separate. Check for the column by name |
|
| 17 |
# rather than reading it: filtering on an absent column would drop every |
|
| 18 |
# row, and rENA's `$.ena.points` raises an error rather than returning NULL. |
|
| 19 | 2x |
if("ENA_DIRECTION" %in% colnames(enaset$points)) {
|
| 20 | ! |
rows <- enaset$points$ENA_DIRECTION %in% direction |
| 21 |
} else {
|
|
| 22 | 2x |
rows <- rep(TRUE, nrow(enaset$points)) |
| 23 |
} |
|
| 24 | 2x |
pts <- enaset$points[rows, ] |
| 25 | 2x |
cts <- enaset$model$centroids[, ] |
| 26 |
} |
|
| 27 | ||
| 28 | 2x |
pComb = combn(nrow(pts), 2) |
| 29 | 2x |
point1 = pComb[1,] |
| 30 | 2x |
point2 = pComb[2,] |
| 31 | ||
| 32 | 2x |
points = as.matrix(pts) |
| 33 | 2x |
centroids = as.matrix(cts) |
| 34 | 2x |
svdDiff = matrix(points[point1, dims] - points[point2, dims], ncol=length(dims), nrow=length(point1)) |
| 35 | 2x |
optDiff = matrix(centroids[point1, dims] - centroids[point2, dims], ncol=length(dims), nrow=length(point1)) |
| 36 | ||
| 37 |
# svdDiff/optDiff have one column per requested dimension, so index them by |
|
| 38 |
# position rather than by the caller's dimension number. Indexing by `dims` |
|
| 39 |
# only works for the default c(1,2); any other pair reads past the end. |
|
| 40 | 2x |
corrs = as.data.frame(mapply(function(method) {
|
| 41 | 4x |
sapply(seq_along(dims), function(dim) {
|
| 42 | 8x |
cor(as.numeric(svdDiff[,dim]), as.numeric(optDiff[,dim]), method=method) |
| 43 |
}); |
|
| 44 | 2x |
}, c("pearson","spearman")))
|
| 45 | ||
| 46 | 2x |
return(corrs); |
| 47 |
} |
| 1 |
### |
|
| 2 |
#' ona writeup |
|
| 3 |
#' |
|
| 4 |
#' @description provide writeup of the provided model |
|
| 5 |
#' |
|
| 6 |
#' @param enaset ENAset to view methods of |
|
| 7 |
#' @param tool c("rENA","webENA")
|
|
| 8 |
#' @param tool.version as.character(packageVersion(tool)) |
|
| 9 |
#' @param comparison character string representing the comparison used, c(NULL, "parametric", "non-parametric"). Default NULL |
|
| 10 |
#' @param comparison.groups Groups that were used for the comparison |
|
| 11 |
#' @param sig.dig Integer for the number of digits to round to |
|
| 12 |
#' @param output_dir Where to save the output file |
|
| 13 |
#' @param type c("file","stream") File will save to a file in output_dir, Stream returns the contents directly
|
|
| 14 |
#' @param theory Logical indicating whether to include theory in the writeup |
|
| 15 |
#' @param methods Logical indicating whether to include methods in the writeup |
|
| 16 |
#' @param params additional parameters for rmarkdown::render |
|
| 17 |
#' @param output_file character |
|
| 18 |
#' @param output_format character |
|
| 19 |
#' |
|
| 20 |
#' @importFrom utils packageVersion |
|
| 21 |
#' |
|
| 22 |
#' @export |
|
| 23 |
#' |
|
| 24 |
#' @return String representing the methods used to generate the model |
|
| 25 |
ona.writeup <- function( |
|
| 26 |
enaset, |
|
| 27 |
tool = "ona", tool.version = as.character(packageVersion(tool)), |
|
| 28 |
comparison = NULL, comparison.groups = NULL, sig.dig = 2, |
|
| 29 |
output_dir = getwd(), type = c("file","stream"), theory = T, methods = T,
|
|
| 30 |
params = NULL, output_file = NULL, output_format = NULL |
|
| 31 |
) {
|
|
| 32 | ! |
if(is.null(enaset$`_function.params`$weight.by)) |
| 33 | ! |
enaset$`_function.params`$weight.by <- enaset$`_function.params`$args$weight.by |
| 34 | ||
| 35 | ! |
type = match.arg(type, choices = c("file","stream"), several.ok = FALSE)
|
| 36 | ||
| 37 | ! |
if(type == "file") {
|
| 38 | ! |
output_format = "word_document" |
| 39 |
} |
|
| 40 | ||
| 41 | ! |
file = rmarkdown::render(system.file("rmd","methods_ona.rmd", package="ona"), output_dir = output_dir,
|
| 42 | ! |
knit_root_dir = output_dir, intermediates_dir = output_dir, quiet = TRUE, |
| 43 | ! |
params = params, output_file = output_file |
| 44 | ! |
,output_format = output_format |
| 45 |
# ,output_format = ifelse(type == "file", rENA::methods_report, rENA::methods_report_stream) |
|
| 46 |
) |
|
| 47 | ||
| 48 | ! |
if(type == "file") |
| 49 | ! |
file |
| 50 | ! |
else if (type == "stream" && endsWith(file, ".plain")) |
| 51 | ! |
readChar(file, file.info(file)$size) |
| 52 |
} |
|
| 53 | ||
| 54 |
#' @title methods_report |
|
| 55 |
#' @description Output format for methods report in R Markdown (Word/docx) |
|
| 56 |
#' @param toc Logical; include a table of contents (default: FALSE). |
|
| 57 |
#' @param toc_depth Integer; depth of table of contents (default: 3). |
|
| 58 |
#' @param fig_width Numeric; width (in inches) of figures (default: 5). |
|
| 59 |
#' @param fig_height Numeric; height (in inches) of figures (default: 4). |
|
| 60 |
#' @param keep_md Logical; keep the intermediate markdown file (default: FALSE). |
|
| 61 |
#' @param md_extensions Character vector of additional markdown extensions to use (default: NULL). |
|
| 62 |
#' @param pandoc_args Character vector of additional Pandoc command line arguments (default: NULL). |
|
| 63 |
#' |
|
| 64 |
#' @return An R Markdown output format object for use with `rmarkdown::render` (Word/docx output). |
|
| 65 |
#' @export |
|
| 66 |
methods_report <- function(toc = FALSE, |
|
| 67 |
toc_depth = 3, |
|
| 68 |
fig_width = 5, |
|
| 69 |
fig_height = 4, |
|
| 70 |
keep_md = FALSE, |
|
| 71 |
md_extensions = NULL, |
|
| 72 |
pandoc_args = NULL) {
|
|
| 73 | ||
| 74 |
# knitr options and hooks |
|
| 75 | ! |
knitr <- rmarkdown::knitr_options( |
| 76 | ! |
opts_chunk = list(dev = 'png', |
| 77 | ! |
dpi = 96, |
| 78 | ! |
fig.width = fig_width, |
| 79 | ! |
fig.height = fig_height) |
| 80 |
) |
|
| 81 | ||
| 82 |
# build pandoc args |
|
| 83 | ! |
args <- c("--standalone")
|
| 84 | ||
| 85 |
# table of contents |
|
| 86 | ! |
args <- c(args, rmarkdown::pandoc_toc_args(toc, toc_depth)) |
| 87 | ||
| 88 |
# pandoc args |
|
| 89 | ! |
args <- c(args, pandoc_args) |
| 90 | ||
| 91 | ! |
preserved_chunks <- character() |
| 92 | ||
| 93 |
# pre_processor <- function(metadata, input_file, runtime, knit_meta, |
|
| 94 |
# files_dir, output_dir) {
|
|
| 95 |
# preserved_chunks <<- extract_preserve_chunks(input_file, knitr::extract_raw_output) |
|
| 96 |
# NULL |
|
| 97 |
# } |
|
| 98 | ||
| 99 |
# post_processor <- function(metadata, input_file, output_file, clean, verbose) {
|
|
| 100 |
# output_str <- readLines(output_file, encoding = 'UTF-8') |
|
| 101 |
# output_res <- knitr::restore_raw_output(output_str, preserved_chunks) |
|
| 102 |
# if (!identical(output_str, output_res)) |
|
| 103 |
# writeLines(enc2utf8(output_res), output_file, useBytes = TRUE) |
|
| 104 |
# output_file |
|
| 105 |
# } |
|
| 106 | ||
| 107 |
# return output format |
|
| 108 | ! |
rmarkdown::output_format( |
| 109 | ! |
knitr = knitr, |
| 110 | ! |
pandoc = rmarkdown::pandoc_options(to = "docx", |
| 111 | ! |
from = rmarkdown::from_rmarkdown(extensions = md_extensions), |
| 112 | ! |
args = args), |
| 113 | ! |
keep_md = keep_md |
| 114 |
# ,pre_processor = pre_processor, |
|
| 115 |
# post_processor = post_processor |
|
| 116 |
) |
|
| 117 |
} |
|
| 118 | ||
| 119 |
#' @title methods_report_stream |
|
| 120 |
#' @description Output format for methods report in R Markdown (plain text stream) |
|
| 121 |
#' @param toc Logical; include a table of contents (default: FALSE). |
|
| 122 |
#' @param toc_depth Integer; depth of table of contents (default: 3). |
|
| 123 |
#' @param fig_width Numeric; width (in inches) of figures (default: 5). |
|
| 124 |
#' @param fig_height Numeric; height (in inches) of figures (default: 4). |
|
| 125 |
#' @param keep_md Logical; keep the intermediate markdown file (default: FALSE). |
|
| 126 |
#' @param md_extensions Character vector of additional markdown extensions to use (default: NULL). |
|
| 127 |
#' @param pandoc_args Character vector of additional Pandoc command line arguments (default: NULL). |
|
| 128 |
#' |
|
| 129 |
#' @return An R Markdown output format object for use with `rmarkdown::render` (plain text output). |
|
| 130 |
#' @export |
|
| 131 |
methods_report_stream <- function(toc = FALSE, |
|
| 132 |
toc_depth = 3, |
|
| 133 |
fig_width = 5, |
|
| 134 |
fig_height = 4, |
|
| 135 |
keep_md = FALSE, |
|
| 136 |
md_extensions = NULL, |
|
| 137 |
pandoc_args = NULL) {
|
|
| 138 | ||
| 139 |
# knitr options and hooks |
|
| 140 | ! |
knitr <- rmarkdown::knitr_options( |
| 141 | ! |
opts_chunk = list(dev = 'png', |
| 142 | ! |
dpi = 96, |
| 143 | ! |
fig.width = fig_width, |
| 144 | ! |
fig.height = fig_height) |
| 145 |
) |
|
| 146 | ||
| 147 |
# build pandoc args |
|
| 148 | ! |
args <- c("--standalone")
|
| 149 | ||
| 150 |
# table of contents |
|
| 151 | ! |
args <- c(args, rmarkdown::pandoc_toc_args(toc, toc_depth)) |
| 152 | ||
| 153 |
# pandoc args |
|
| 154 | ! |
args <- c(args, pandoc_args) |
| 155 | ||
| 156 | ! |
preserved_chunks <- character() |
| 157 | ||
| 158 |
# return output format |
|
| 159 | ! |
rmarkdown::output_format( |
| 160 | ! |
knitr = knitr, |
| 161 | ! |
pandoc = rmarkdown::pandoc_options(to = "plain", |
| 162 | ! |
from = rmarkdown::from_rmarkdown(extensions = md_extensions), |
| 163 | ! |
args = args), |
| 164 | ! |
keep_md = keep_md |
| 165 |
) |
|
| 166 |
} |
| 1 |
# R-level wrappers replacing the former C++ exports in src/optim.cpp. |
|
| 2 |
# These preserve backward compatibility for any code calling these functions |
|
| 3 |
# directly as ona::accum_stanza_window(), ona::vector_to_ut(), etc. |
|
| 4 | ||
| 5 |
#' Accumulate Stanza Window (directed, full-square output) |
|
| 6 |
#' |
|
| 7 |
#' For each row, accumulates co-occurrences over a backward stanza window. |
|
| 8 |
#' Preserves directionality: the output columns are the n_codes x n_codes |
|
| 9 |
#' adjacency matrix in column-major order, ground codes as rows and response |
|
| 10 |
#' codes as columns, so 0-based column (j*n_codes + i) represents code i |
|
| 11 |
#' (context/ground) co-occurring with code j (current row/response). |
|
| 12 |
#' Returns a matrix with \code{n_codes²} columns (full square adjacency).
|
|
| 13 |
#' |
|
| 14 |
#' Delegates to \code{\link[tma]{accumulate_stanza}(ordered = TRUE)}.
|
|
| 15 |
#' |
|
| 16 |
#' @param df A data frame of code columns (one row per utterance) |
|
| 17 |
#' @param windowSize Number of prior rows in the window (default 1; use |
|
| 18 |
#' \code{Inf} for all prior rows in the stanza)
|
|
| 19 |
#' @param binary Logical; binarise non-zero co-occurrences (default TRUE) |
|
| 20 |
#' @return Numeric matrix with \code{nrow(df)} rows and \code{ncol(df)²} columns
|
|
| 21 |
#' @importFrom tma accumulate_stanza |
|
| 22 |
#' @export |
|
| 23 |
accum_stanza_window <- function(df, windowSize = 1, binary = TRUE) {
|
|
| 24 | 4x |
INT_MAX <- .Machine$integer.max |
| 25 | 4x |
wb <- if (is.infinite(windowSize) || windowSize >= INT_MAX) INT_MAX |
| 26 | 4x |
else as.integer(windowSize) |
| 27 | 4x |
as.data.frame( |
| 28 | 4x |
tma::accumulate_stanza(as.matrix(df), window_back = wb, |
| 29 | 4x |
window_forward = 0L, binary = binary, |
| 30 | 4x |
ordered = TRUE) |
| 31 |
) |
|
| 32 |
} |
|
| 33 | ||
| 34 |
#' Upper Triangle from Vector (numeric) |
|
| 35 |
#' |
|
| 36 |
#' Compute pairwise products \code{v[i] * v[j]} for all \code{i < j}.
|
|
| 37 |
#' Thin wrapper around \code{\link[rENA]{vector_to_ut}}.
|
|
| 38 |
#' |
|
| 39 |
#' @param v Numeric vector or single-row matrix of code values |
|
| 40 |
#' @return Numeric row vector of pairwise products (length choose_two(length(v))) |
|
| 41 |
#' @export |
|
| 42 |
vector_to_ut <- function(v) {
|
|
| 43 | ! |
rENA::vector_to_ut(v) |
| 44 |
} |
|
| 45 | ||
| 46 |
#' Least-squares node positions for directed ENA |
|
| 47 |
#' |
|
| 48 |
#' Thin wrapper around \code{\link[rENA]{directed_node_positions}}.
|
|
| 49 |
#' |
|
| 50 |
#' @param line_weights Numeric matrix (units x connections) |
|
| 51 |
#' @param points Numeric matrix of rotated points (units x dims) |
|
| 52 |
#' @param numDims Number of dimensions |
|
| 53 |
#' @return List with nodes, centroids, weights, points |
|
| 54 |
#' @export |
|
| 55 |
directed_node_positions <- function(line_weights, points, numDims) {
|
|
| 56 | ! |
rENA::directed_node_positions(line_weights, points, numDims) |
| 57 |
} |
|
| 58 | ||
| 59 |
#' Directed node positions with ground+response rows combined |
|
| 60 |
#' |
|
| 61 |
#' Thin wrapper around |
|
| 62 |
#' \code{\link[rENA]{directed_node_positions_with_ground_response_added}}.
|
|
| 63 |
#' |
|
| 64 |
#' @param line_weights Numeric matrix (units x connections) |
|
| 65 |
#' @param points Numeric matrix of rotated points (units x dims) |
|
| 66 |
#' @param numDims Number of dimensions |
|
| 67 |
#' @return List with nodes, centroids, weights, points |
|
| 68 |
#' @export |
|
| 69 |
directed_node_positions_with_ground_response_added <- function(line_weights, |
|
| 70 |
points, |
|
| 71 |
numDims) {
|
|
| 72 | ! |
rENA::directed_node_positions_with_ground_response_added(line_weights, |
| 73 | ! |
points, numDims) |
| 74 |
} |
| 1 |
#' Normalize and optimize a directed (ordered) network accumulation |
|
| 2 |
#' |
|
| 3 |
#' Thin wrapper around \code{\link[rENA]{model}} that applies the ONA-specific
|
|
| 4 |
#' defaults: SVD rotation, zero-network exclusion from centering, and |
|
| 5 |
#' center-to-origin post-processing. |
|
| 6 |
#' |
|
| 7 |
#' @param x An \code{ena.ordered.set} produced by
|
|
| 8 |
#' \code{\link[rENA]{accumulate}(ordered = TRUE)} or
|
|
| 9 |
#' \code{tma::accumulate_contexts}.
|
|
| 10 |
#' @param ... Additional arguments forwarded to \code{rENA::model}.
|
|
| 11 |
#' @param rotate.using Character. \code{"svd"} (default) for standard principal
|
|
| 12 |
#' components rotation; \code{"mean"} for means rotation.
|
|
| 13 |
#' @param rotation.params Additional parameters for the rotation function |
|
| 14 |
#' (passed as \code{rotate_params} to \code{rENA::model}). Required with
|
|
| 15 |
#' \code{rotate.using = "mean"}: \code{list(list(a, b))}, the two groups whose
|
|
| 16 |
#' means define the first dimension, as logical vectors over the units or |
|
| 17 |
#' as unit names. |
|
| 18 |
#' @param rotation.set Optional rotation to reuse instead of fitting one: a |
|
| 19 |
#' fitted \code{ena.ordered.set} (its \code{$rotation} is used), that
|
|
| 20 |
#' \code{$rotation} list, or an rENA \code{ENARotationSet}. The data are
|
|
| 21 |
#' normalised and centred as usual, projected with the supplied rotation |
|
| 22 |
#' matrix, and the supplied node positions are kept rather than |
|
| 23 |
#' re-optimised, so new units can be placed in an existing model's space. |
|
| 24 |
#' @param center_to_origin Logical. When \code{TRUE} (default) the projected
|
|
| 25 |
#' space is translated so the mean of all points is at the origin. |
|
| 26 |
#' |
|
| 27 |
#' @return An \code{ena.ordered.set} with calculated points and node positions.
|
|
| 28 |
#' @export |
|
| 29 |
model <- function( |
|
| 30 |
x, ..., |
|
| 31 |
rotate.using = "svd", |
|
| 32 |
rotation.params = NULL, |
|
| 33 |
rotation.set = NULL, |
|
| 34 |
center_to_origin = TRUE |
|
| 35 |
) {
|
|
| 36 | 30x |
rotate_fun <- if (rotate.using == "mean") {
|
| 37 | 3x |
if (is.null(rotation.params)) {
|
| 38 | ! |
stop("rotate.using = \"mean\" needs rotation.params: the two groups ",
|
| 39 | ! |
"whose means define the first dimension, as list(list(a, b)) ", |
| 40 | ! |
"with a and b logical vectors over the units or unit names.", |
| 41 | ! |
call. = FALSE) |
| 42 |
} |
|
| 43 | 3x |
rENA::ena.rotate.by.mean |
| 44 |
} else {
|
|
| 45 | 27x |
rENA::ena.rotate.by.svd |
| 46 |
} |
|
| 47 | ||
| 48 | 30x |
rotate_params <- if (!is.null(rotation.params)) rotation.params else list() |
| 49 | ||
| 50 | 30x |
if (!is.null(rotation.set)) {
|
| 51 |
# Custom rotation, as in ONA 0.1.1: normalise and centre this data, then |
|
| 52 |
# project it with the supplied rotation and keep the supplied node |
|
| 53 |
# positions instead of re-optimising them. A fitted set's $rotation, the |
|
| 54 |
# fitted set itself, or an ENARotationSet all work; rENA::model() has no |
|
| 55 |
# equivalent path, so the steps are spelled out here. |
|
| 56 | 5x |
rotation.set <- as_rotation_set(rotation.set) |
| 57 | ||
| 58 | 4x |
x <- rENA::sphere_norm(x) |
| 59 | 4x |
x <- rENA::center(x, exclude_zero_networks = TRUE) |
| 60 | ||
| 61 | 4x |
x$rotation.matrix <- rotation.set$rotation.matrix |
| 62 | 4x |
x$rotation$rotation.matrix <- rotation.set$rotation.matrix |
| 63 | 4x |
x$rotation$nodes <- rotation.set$nodes |
| 64 | 4x |
x$rotation$eigenvalues <- rotation.set$eigenvalues |
| 65 | ||
| 66 | 4x |
x <- rENA::project(x) |
| 67 | ||
| 68 | 4x |
if (isTRUE(center_to_origin)) {
|
| 69 | 4x |
x <- center_points_to_origin(x) |
| 70 |
} |
|
| 71 |
} else {
|
|
| 72 | 25x |
x <- rENA::model( |
| 73 | 25x |
x, ..., |
| 74 | 25x |
rotate_fun = rotate_fun, |
| 75 | 25x |
rotate_params = rotate_params, |
| 76 | 25x |
exclude_zero_networks = TRUE, |
| 77 | 25x |
center_to_origin = center_to_origin |
| 78 |
) |
|
| 79 |
} |
|
| 80 | ||
| 81 | 29x |
return(x) |
| 82 |
} |
|
| 83 | ||
| 84 |
# Accept the ways a rotation can be handed to model(): a fitted set (use its |
|
| 85 |
# $rotation), that $rotation list, or an rENA ENARotationSet. Anything with a |
|
| 86 |
# rotation.matrix qualifies; nodes and eigenvalues are optional. |
|
| 87 |
as_rotation_set <- function(rotation.set) {
|
|
| 88 | 5x |
if (is(rotation.set, "ena.set") && !is.null(rotation.set$rotation)) {
|
| 89 | 1x |
rotation.set <- rotation.set$rotation |
| 90 |
} |
|
| 91 | 5x |
if (is.null(rotation.set$rotation.matrix)) {
|
| 92 | 1x |
stop("rotation.set must carry a rotation.matrix: pass a fitted set, its $rotation, or an ENARotationSet")
|
| 93 |
} |
|
| 94 | 4x |
rotation.set |
| 95 |
} |
|
| 96 | ||
| 97 |
# Translate the projected space so the mean of all points sits at the origin, |
|
| 98 |
# moving the node positions with it. Same as the center_to_origin step inside |
|
| 99 |
# rENA::model(), for the custom-rotation path that does not go through it. |
|
| 100 |
center_points_to_origin <- function(x) {
|
|
| 101 | 4x |
dim_cols <- which(!rENA::find_meta_cols(x$points)) |
| 102 | 4x |
pt_means <- colMeans(as.matrix(x$points[, dim_cols, with = FALSE])) |
| 103 | 4x |
x$points[, c(dim_cols) := lapply(.SD, function(col) col - mean(col)), .SDcols = dim_cols] |
| 104 | 4x |
if (!is.null(x$rotation$nodes)) {
|
| 105 | 4x |
node_dim_cols <- which(colnames(x$rotation$nodes) %chin% names(pt_means)) |
| 106 | 4x |
x$rotation$nodes[, c(node_dim_cols) := Map(`-`, .SD, as.list(pt_means[colnames(x$rotation$nodes)[node_dim_cols]])), |
| 107 | 4x |
.SDcols = node_dim_cols] |
| 108 |
} |
|
| 109 | 4x |
x |
| 110 |
} |
| 1 |
### |
|
| 2 |
#' ONA rotation by mean difference |
|
| 3 |
#' |
|
| 4 |
#' Computes a dimensional reduction (rotation) such that the first dimension |
|
| 5 |
#' passes through the means of two groups. Subsequent dimensions use SVD on |
|
| 6 |
#' the deflated data. Thin wrapper around \code{\link[rENA]{ena.rotate.by.mean}};
|
|
| 7 |
#' kept for backward compatibility with existing ONA scripts. |
|
| 8 |
#' |
|
| 9 |
#' @param x A matrix or \code{ena.points} data table of ENA points
|
|
| 10 |
#' (typically centered and normalized). Metadata columns are stripped |
|
| 11 |
#' automatically via \code{as.matrix}.
|
|
| 12 |
#' @param groups A list of length 2 (or more), each element being a length-2 |
|
| 13 |
#' list \code{list(a, b)} where \code{a} and \code{b} are logical vectors or
|
|
| 14 |
#' character unit IDs identifying the two groups. |
|
| 15 |
#' @param codes Character vector of code names corresponding to columns of |
|
| 16 |
#' \code{x}; used to label the rows of the returned rotation matrix.
|
|
| 17 |
#' |
|
| 18 |
#' @return A list with \code{rotation}, \code{codes}, \code{eigenvalues}, and
|
|
| 19 |
#' \code{node.positions = NULL}.
|
|
| 20 |
#' @export |
|
| 21 |
### |
|
| 22 |
ona.rotate.by.mean <- function(x, groups, codes) {
|
|
| 23 |
# Construct a minimal enaset-compatible list so we can delegate to |
|
| 24 |
# rENA::ena.rotate.by.mean (means_rotation, in rENA's libena). |
|
| 25 | 1x |
data_matrix <- as.matrix(x) # as.matrix.ena.matrix strips metadata columns |
| 26 | 1x |
enaset <- list( |
| 27 | 1x |
model = list(points.for.projection = data_matrix), |
| 28 | 1x |
points.normed.centered = NULL, |
| 29 | 1x |
connection.counts = list(ENA_UNIT = x$ENA_UNIT), |
| 30 | 1x |
line.weights = data_matrix, |
| 31 | 1x |
rotation = list(codes = codes) |
| 32 |
) |
|
| 33 | 1x |
rENA::ena.rotate.by.mean(enaset, groups = groups) |
| 34 |
} |
| 1 |
.onLoad <- function(libname, pkgname) {
|
|
| 2 | ! |
utils::globalVariables(c( |
| 3 | ! |
"%chin%",".BY",".I",".SD",":=","ENA_DIRECTION","as.data.table","code","col2rgb", |
| 4 | ! |
"color_adjusted","combn","data.table","distance","hsv","is","label","node_1","node_2", |
| 5 | ! |
"prcomp","rgb2hsv","set","t.test","value","var","variable" |
| 6 |
)) |
|
| 7 |
} |
|
| 8 | ||
| 9 |
.onAttach <- function(libname, pkgname) {
|
|
| 10 | 2x |
packageStartupMessage("For the latest features and updates, install from https://cran.qe-libs.org");
|
| 11 | 2x |
invisible(); |
| 12 |
} |