Skip to content

Commit d6ab4ad

Browse files
authored
Merge pull request #9 from psychelzh/add-summary
2 parents b2ff7a0 + 1cca41c commit d6ab4ad

File tree

6 files changed

+147
-0
lines changed

6 files changed

+147
-0
lines changed

NAMESPACE

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
11
# Generated by roxygen2: do not edit by hand
22

33
S3method(print,cpm)
4+
S3method(print,cpm_summary)
5+
S3method(summary,cpm)
46
export(cpm)
57
import(Rfast)

NEWS.md

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,9 @@
11
# cpmr (development version)
22

3+
## New features
4+
5+
* Added `summary` method to summarize the results of the CPM analysis.
6+
37
# cpmr 0.0.9
48

59
## New features

R/summary.R

Lines changed: 54 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,54 @@
1+
#' Summary of a cpm object.
2+
#'
3+
#' This function provides a summary of a \code{cpm} object, including the
4+
#' prediction performance and the selected edges.
5+
#'
6+
#' @rdname summary.cpm
7+
#' @param object An object of class \code{cpm}.
8+
#' @param edge_level A numeric value between 0 and 1 indicating the proportional
9+
#' threshold for edge selection.
10+
#' @param ... Other parameters passed to the function.
11+
#' @return A list of class \code{cpm_summary} containing two elements:
12+
#' \item{performance}{A matrix of prediction performance, including the
13+
#' correlation between the real and predicted values for both edges,
14+
#' positive edges only, and negative edges only.}
15+
#'
16+
#' \item{edges}{A logical vector indicating whether each edge is selected
17+
#' based on the edge_level.}
18+
#' @export
19+
summary.cpm <- function(object, edge_level = 0.5, ...) {
20+
# summary prediction performance
21+
performance <- stats::cor(object$real, object$pred)
22+
# summary edge selection
23+
edges <- if (!is.null(object$edges)) {
24+
if (length(dim(object$edges)) == 3) {
25+
object$edges <- apply(object$edges, 2:3, sum)
26+
}
27+
object$edges > edge_level * length(unique(object$folds))
28+
}
29+
structure(
30+
list(
31+
performance = performance,
32+
edges = edges,
33+
edge_level = edge_level
34+
),
35+
class = "cpm_summary"
36+
)
37+
}
38+
39+
#' @rdname summary.cpm
40+
#' @param x An object of class \code{cpm_summary}.
41+
#' @export
42+
print.cpm_summary <- function(x, ...) {
43+
cat("CPM summary:\n")
44+
cat(" Performance: \n")
45+
cat(sprintf(" Positive: %.3f\n", x$performance[, "pos"]))
46+
cat(sprintf(" Negative: %.3f\n", x$performance[, "neg"]))
47+
cat(sprintf(" Combined: %.3f\n", x$performance[, "both"]))
48+
if (!is.null(x$edges)) {
49+
cat(sprintf(" Edges selected by %.0f%% of folds:\n", x$edge_level * 100))
50+
cat(sprintf(" Positive: %.2f%%\n", mean(x$edges[, "pos"]) * 100))
51+
cat(sprintf(" Negative: %.2f%%\n", mean(x$edges[, "neg"]) * 100))
52+
}
53+
invisible(x)
54+
}

man/summary.cpm.Rd

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

tests/testthat/_snaps/summary.md

Lines changed: 39 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,39 @@
1+
# Works for basic summary
2+
3+
Code
4+
summary_result
5+
Output
6+
CPM summary:
7+
Performance:
8+
Positive: 0.897
9+
Negative: -0.119
10+
Combined: 0.809
11+
12+
---
13+
14+
Code
15+
summary_result
16+
Output
17+
CPM summary:
18+
Performance:
19+
Positive: 0.897
20+
Negative: -0.119
21+
Combined: 0.809
22+
Edges selected by 50% of folds:
23+
Positive: 0.50%
24+
Negative: 0.30%
25+
26+
---
27+
28+
Code
29+
summary_result
30+
Output
31+
CPM summary:
32+
Performance:
33+
Positive: 0.897
34+
Negative: -0.119
35+
Combined: 0.809
36+
Edges selected by 50% of folds:
37+
Positive: 0.50%
38+
Negative: 0.30%
39+

tests/testthat/test-summary.R

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
test_that("Works for basic summary", {
2+
withr::local_seed(123)
3+
conmat <- matrix(rnorm(10000), nrow = 10)
4+
behav <- rnorm(10)
5+
summary_result <- summary(cpm(conmat, behav))
6+
expect_s3_class(summary_result, "cpm_summary")
7+
expect_snapshot(summary_result)
8+
summary_result <- summary(cpm(conmat, behav, return_edges = "sum"))
9+
expect_s3_class(summary_result, "cpm_summary")
10+
expect_snapshot(summary_result)
11+
summary_result <- summary(cpm(conmat, behav, return_edges = "all"))
12+
expect_s3_class(summary_result, "cpm_summary")
13+
expect_snapshot(summary_result)
14+
})

0 commit comments

Comments
 (0)