muttest report

35%
n / p to jump between mutants
Mutation plan 14 mutators
Mutator Killed Survived No coverage Errors Total Score
* → / 0 5 0 0 5 0%
/ → * 0 4 0 0 4 0%
>= → <= 0 2 0 0 2 0%
>= → > 0 2 0 0 2 0%
|| → && 0 1 0 0 1 0%
> → >= 1 16 0 0 17 5%
- → + 2 8 0 0 10 20%
> → < 4 13 0 0 17 23%
< → <= 1 2 0 0 3 33%
< → > 1 2 0 0 3 33%
&& → || 6 8 0 0 14 42%
== → != 13 12 0 0 25 52%
+ → - 17 11 0 0 28 60%
!= → == 3 1 0 0 4 75%
R/mutator-boolean.R 1 killed score 100%
1 #' Mutate a boolean literal
2 #'
3 #' Replaces a boolean constant (`TRUE`, `FALSE`, `T`, or `F`) with another one.
4 #'
5 #' @param from The literal to be replaced. One of `"TRUE"`, `"FALSE"`, `"T"`, `"F"`.
6 #' @param to The literal to replace with.
7 #'
8 #' @examples
9 #' boolean_literal("TRUE", "FALSE")
10 #' boolean_literal("FALSE", "TRUE")
11 #' boolean_literal("T", "F")
12 #' boolean_literal("F", "T")
13 #'
14 #' @export
15 boolean_literal <- function(from, to) {
16 allowed <- c("TRUE", "FALSE", "T", "F")
17 checkmate::assert_choice(from, allowed)
18 checkmate::assert_choice(to, allowed)
19 # TRUE/FALSE are dedicated AST nodes; T/F are plain identifiers in tree-sitter-r
20 query <- if (from %in% c("TRUE", "FALSE")) {
21 node_type <- if (from == "TRUE") "true" else "false" 1 mutant
killed == → !=
- node_type <- if (from == "TRUE") "true" else "false" + node_type <- if (from != "TRUE") "true" else "false"
22 sprintf("(%s) @target", node_type)
23 } else {
24 sprintf("(identifier) @target (#eq? @target \"%s\")", from)
25 }
26 Mutator$new(from = from, to = to, query = query)
27 }
R/mutator-condition.R 1 killed score 100%
1 condition_query <- function(statements) {
2 parts <- vapply(statements, function(s) {
3 node <- switch(s,
4 "if" = "if_statement",
5 "while" = "while_statement",
6 stop("Unknown statement type: ", s, ". Must be 'if' or 'while'.")
7 )
8 sprintf("(%s condition: (_) @target)", node)
9 }, character(1))
10 if (length(parts) == 1) parts else paste0("[", paste(parts, collapse = " "), "]") 1 mutant
killed == → !=
- if (length(parts) == 1) parts else paste0("[", paste(parts, collapse = " "), "]") + if (length(parts) != 1) parts else paste0("[", paste(parts, collapse = " "), "]")
11 }
12  
13 #' Negate the condition of if/while statements
14 #'
15 #' Wraps the condition expression of each matching statement in `!(...)`.
16 #' For example, `if (x > 0)` becomes `if (!(x > 0))`.
17 #'
18 #' @param statements Character vector of statement types to target.
19 #' Must be a subset of `c("if", "while")`. Defaults to both.
20 #' @return A [Mutator] object.
21 #' @export
22 #' @examples
23 #' negate_condition()
24 #' negate_condition(statements = "if")
25 negate_condition <- function(statements = c("if", "while")) {
26 checkmate::assert_subset(statements, c("if", "while"), empty.ok = FALSE)
27 Mutator$new(
28 from = "<condition>",
29 to = "!(<condition>)",
30 query = condition_query(statements),
31 match_fn = function(text) TRUE,
32 replacement_fn = function(text) paste0("!(", text, ")")
33 )
34 }
35  
36 #' Remove negation from the condition of if/while statements
37 #'
38 #' The inverse of [negate_condition()]. Strips the leading `!` from any
39 #' already-negated condition, so `if (!done)` becomes `if (done)` and
40 #' `while (!ready)` becomes `while (ready)`.
41 #'
42 #' Unlike [remove_negation()], this mutator is scoped exclusively to
43 #' conditions, leaving negations in other positions (assignments, return
44 #' values, etc.) untouched.
45 #'
46 #' @param statements Character vector of statement types to target.
47 #' Must be a subset of `c("if", "while")`. Defaults to both.
48 #' @return A [Mutator] object.
49 #' @export
50 #' @examples
51 #' remove_condition_negation()
52 #' remove_condition_negation(statements = "while")
53 remove_condition_negation <- function(statements = c("if", "while")) {
54 checkmate::assert_subset(statements, c("if", "while"), empty.ok = FALSE)
55 Mutator$new(
56 from = "!<condition>",
57 to = "<condition>",
58 query = condition_query(statements),
59 match_fn = function(text) startsWith(text, "!"),
60 replacement_fn = function(text) substring(text, 2)
61 )
62 }
R/mutator-na.R 2 killed score 100%
1 #' Mutate an NA or NULL literal
2 #'
3 #' Replaces `NA`, `NULL`, or a typed NA constant (`NA_real_`, `NA_integer_`,
4 #' `NA_complex_`, `NA_character_`) with another value.
5 #'
6 #' In tree-sitter-r, `NA` and all typed NA variants share the same `na` node
7 #' type, while `NULL` has its own `null` node type. `match_fn` distinguishes
8 #' between them by comparing the literal text.
9 #'
10 #' @param from The literal to replace. One of `"NA"`, `"NULL"`, `"NA_real_"`,
11 #' `"NA_integer_"`, `"NA_complex_"`, `"NA_character_"`.
12 #' @param to The replacement literal.
13 #' @return A [Mutator] object.
14 #' @export
15 #' @examples
16 #' na_literal("NULL", "NA")
17 #' na_literal("NA", "NULL")
18 #' na_literal("NA", "NA_real_")
19 #' na_literal("NA_real_", "NA")
20 na_literal <- function(from, to) {
21 allowed <- c("NA", "NULL", "NA_real_", "NA_integer_", "NA_complex_", "NA_character_")
22 checkmate::assert_choice(from, allowed)
23 checkmate::assert_string(to, min.chars = 1)
24 query <- if (from == "NULL") "(null) @target" else "(na) @target" 1 mutant
killed == → !=
- query <- if (from == "NULL") "(null) @target" else "(na) @target" + query <- if (from != "NULL") "(null) @target" else "(na) @target"
25 Mutator$new(
26 from = from,
27 to = to,
28 query = query,
29 match_fn = function(text) text == from 1 mutant
killed == → !=
- match_fn = function(text) text == from + match_fn = function(text) text != from
30 )
31 }
R/mutator-numeric.R 2 killed score 100%
1 #' Increment numeric literals
2 #'
3 #' Replaces every numeric literal `n` with `n + by`.
4 #' Handles both integer (e.g. `5L`) and floating-point (e.g. `3.14`) literals.
5 #'
6 #' @param by The amount to add. Defaults to `1`.
7 #' @return A [Mutator] object.
8 #' @export
9 #' @examples
10 #' numeric_increment()
11 #' numeric_increment(by = 2)
12 numeric_increment <- function(by = 1) {
13 checkmate::assert_number(by)
14 numeric_literal_mutator(
15 label = paste0("<n> + ", by),
16 transform = function(text) {
17 as.character(suppressWarnings(as.numeric(text)) + by) 1 mutant
killed + → -
- as.character(suppressWarnings(as.numeric(text)) + by) + as.character(suppressWarnings(as.numeric(text)) - by)
18 }
19 )
20 }
21  
22 #' Decrement numeric literals
23 #'
24 #' Replaces every numeric literal `n` with `n - by`.
25 #' Handles both integer (e.g. `5L`) and floating-point (e.g. `3.14`) literals.
26 #'
27 #' @param by The amount to subtract. Defaults to `1`.
28 #' @return A [Mutator] object.
29 #' @export
30 #' @examples
31 #' numeric_decrement()
32 #' numeric_decrement(by = 2)
33 numeric_decrement <- function(by = 1) {
34 checkmate::assert_number(by)
35 numeric_literal_mutator(
36 label = paste0("<n> - ", by),
37 transform = function(text) {
38 as.character(suppressWarnings(as.numeric(text)) - by) 1 mutant
killed - → +
- as.character(suppressWarnings(as.numeric(text)) - by) + as.character(suppressWarnings(as.numeric(text)) + by)
39 }
40 )
41 }
42  
43 numeric_literal_mutator <- function(label, transform) {
44 Mutator$new(
45 from = label,
46 to = label,
47 # Matches both `float` (e.g. 1.5) and `integer` (e.g. 5L) nodes.
48 # The predicate (#match?) is not used here; match_fn handles filtering.
49 query = "[(float) (integer)] @target",
50 match_fn = function(text) {
51 !is.na(suppressWarnings(as.numeric(text)))
52 },
53 replacement_fn = transform
54 )
55 }
R/mutator-operator.R 2 survived 12 killed score 85%
1 #' Mutate a binary operator
2 #'
3 #' Produces one mutant per occurrence of `from` in the source file, replacing
4 #' it with `to`. A surviving mutant means your tests cannot distinguish the
5 #' original operator from the replacement — pointing at the missing assertion
6 #' or input value.
7 #'
8 #' Use this when you need a specific swap not covered by the preset collections
9 #' ([arithmetic_operators()], [comparison_operators()], [logical_operators()]).
10 #'
11 #' @param from The operator to replace (e.g. `"+"`, `"=="`, `">"`).
12 #' @param to The replacement operator.
13 #' @return A [Mutator] object.
14 #' @seealso
15 #' [comparison_operators()], [arithmetic_operators()], [logical_operators()]
16 #' for ready-made preset lists.
17 #'
18 #' `vignette("mutators", package = "muttest")` for the full operator
19 #' reference with examples of what each preset catches.
20 #'
21 #' `vignette("interpreting-results", package = "muttest")` to learn how to
22 #' read surviving mutants and strengthen the tests they expose.
23 #' @export
24 #' @examples
25 #' operator("+", "-")
26 #' operator("==", "!=")
27 #' operator(">", ">=") # probe the strict vs. non-strict boundary
28 operator <- function(from, to) {
29 checkmate::assert_string(from, min.chars = 1)
30 checkmate::assert_string(to, min.chars = 1)
31 Mutator$new(
32 from = from,
33 to = to,
34 query = sprintf("(binary_operator
35 lhs: (_) @lhs
36 operator: _ @target
37 rhs: (_) @rhs
38 (#eq? @target \"%s\")
39 )", from)
40 )
41 }
42  
43 info_oneline <- function(m) {
44 paste(m$from, SYMBOLS$arrow, m$to)
45 }
46  
47 # 1-based, end-exclusive location of a treesitter node (points are 0-based).
48 node_location <- function(node) {
49 s <- treesitter::node_start_point(node)
50 e <- treesitter::node_end_point(node)
51 list(
52 start = list(line = s$row + 1L, column = s$column + 1L), 2 mutants
killed + → -
- start = list(line = s$row + 1L, column = s$column + 1L), + start = list(line = s$row - 1L, column = s$column + 1L),
survived + → -
- start = list(line = s$row + 1L, column = s$column + 1L), + start = list(line = s$row + 1L, column = s$column - 1L),
53 end = list(line = e$row + 1L, column = e$column + 1L) 2 mutants
killed + → -
- end = list(line = e$row + 1L, column = e$column + 1L) + end = list(line = e$row - 1L, column = e$column + 1L)
survived + → -
- end = list(line = e$row + 1L, column = e$column + 1L) + end = list(line = e$row + 1L, column = e$column - 1L)
54 )
55 }
56  
57 replace_with <- function(code, node, replacement_text) {
58 start_point <- treesitter::node_start_point(node)
59 original_text <- treesitter::node_text(node)
60 code[start_point$row + 1] <- paste0( 1 mutant
killed + → -
- code[start_point$row + 1] <- paste0( + code[start_point$row - 1] <- paste0(
61 substr(code[start_point$row + 1], 1, start_point$column), 1 mutant
killed + → -
- substr(code[start_point$row + 1], 1, start_point$column), + substr(code[start_point$row - 1], 1, start_point$column),
62 replacement_text,
63 substr(
64 code[start_point$row + 1], 1 mutant
killed + → -
- code[start_point$row + 1], + code[start_point$row - 1],
65 start_point$column + nchar(original_text) + 1, 2 mutants
killed + → -
- start_point$column + nchar(original_text) + 1, + start_point$column - nchar(original_text) + 1,
killed + → -
- start_point$column + nchar(original_text) + 1, + start_point$column + nchar(original_text) - 1,
66 nchar(code[start_point$row + 1]) 1 mutant
killed + → -
- nchar(code[start_point$row + 1]) + nchar(code[start_point$row - 1])
67 )
68 )
69 list(code = code, location = node_location(node), replacement = replacement_text)
70 }
71  
72 mutate_code <- function(code, mutator) {
73 language <- treesitter.r::language()
74 parser <- treesitter::parser(language)
75 treesitter_code <- paste(code, collapse = "\n")
76 tree <- treesitter::parser_parse(parser, treesitter_code)
77 root_node <- treesitter::tree_root_node(tree)
78  
79 query <- treesitter::query(language, mutator$query)
80  
81 mutations <- list()
82  
83 captures <- treesitter::query_captures(query, root_node)
84  
85 if (length(captures$node) == 0) { 1 mutant
killed == → !=
- if (length(captures$node) == 0) { + if (length(captures$node) != 0) {
86 return(NULL)
87 }
88  
89 for (i in seq_along(captures$node)) {
90 # By convention all queries name the node to mutate @target. Structural
91 # captures (e.g. @lhs, @rhs, @keyword) are present only for predicate
92 # filtering and must be skipped here to avoid spurious mutants.
93 if (captures$name[[i]] != "target") next 1 mutant
killed != → ==
- if (captures$name[[i]] != "target") next + if (captures$name[[i]] == "target") next
94 node <- captures$node[[i]]
95 node_text <- treesitter::node_text(node)
96  
97 matches_node <- if (!is.null(mutator$match_fn)) {
98 mutator$match_fn(node_text)
99 } else {
100 node_text == mutator$from 1 mutant
killed == → !=
- node_text == mutator$from + node_text != mutator$from
101 }
102  
103 if (!matches_node) next
104  
105 replacement <- if (!is.null(mutator$replacement_fn)) {
106 mutator$replacement_fn(node_text)
107 } else {
108 mutator$to
109 }
110  
111 mutations <- append(mutations, list(replace_with(code, node, replacement)))
112 }
113  
114 if (length(mutations) == 0) return(NULL) 1 mutant
killed == → !=
- if (length(mutations) == 0) return(NULL) + if (length(mutations) != 0) return(NULL)
115 mutations
116 }
R/mutator-return.R 1 killed score 100%
1 #' Replace the value in explicit return() calls
2 #'
3 #' Replaces the argument of every `return(expr)` with a fixed value (default
4 #' `"NULL"`). Tests that only check that a function returns *something* without
5 #' asserting the value will not kill these mutants.
6 #'
7 #' Only explicit `return()` calls are targeted. Implicit returns (the last
8 #' expression of a function body) are not affected.
9 #'
10 #' @param replacement Raw R source text to substitute as the return value.
11 #' Defaults to `"NULL"`. Examples: `"NA"` inserts the missing value `NA`;
12 #' `'"NULL"'` (inner quotes) inserts the string `"NULL"`; `'"NA"'` inserts
13 #' the string `"NA"` rather than the missing value.
14 #' @return A [Mutator] object.
15 #' @export
16 #' @examples
17 #' replace_return_value()
18 #' replace_return_value("NA")
19 replace_return_value <- function(replacement = "NULL") {
20 checkmate::assert_string(replacement, min.chars = 1)
21 Mutator$new(
22 from = "return(<value>)",
23 to = paste0("return(", replacement, ")"),
24 query = "(
25 call function: (identifier) @keyword arguments: (arguments (argument value: (_) @target))
26 (#eq? @keyword \"return\")
27 )",
28 match_fn = function(text) text != replacement, 1 mutant
killed != → ==
- match_fn = function(text) text != replacement, + match_fn = function(text) text == replacement,
29 replacement_fn = function(text) replacement
30 )
31 }
R/mutator-statement.R 1 survived 10 killed score 90%
1 delete_node <- function(code, node) {
2 start_row <- treesitter::node_start_point(node)$row + 1L 1 mutant
killed + → -
- start_row <- treesitter::node_start_point(node)$row + 1L + start_row <- treesitter::node_start_point(node)$row - 1L
3 end_row <- treesitter::node_end_point(node)$row + 1L 1 mutant
killed + → -
- end_row <- treesitter::node_end_point(node)$row + 1L + end_row <- treesitter::node_end_point(node)$row - 1L
4 before <- if (start_row > 1L) code[seq_len(start_row - 1L)] else character(0) 3 mutants
killed - → +
- before <- if (start_row > 1L) code[seq_len(start_row - 1L)] else character(0) + before <- if (start_row > 1L) code[seq_len(start_row + 1L)] else character(0)
killed > → <
- before <- if (start_row > 1L) code[seq_len(start_row - 1L)] else character(0) + before <- if (start_row < 1L) code[seq_len(start_row - 1L)] else character(0)
survived > → >=
- before <- if (start_row > 1L) code[seq_len(start_row - 1L)] else character(0) + before <- if (start_row >= 1L) code[seq_len(start_row - 1L)] else character(0)
5 after <- if (end_row < length(code)) code[(end_row + 1L):length(code)] else character(0) 3 mutants
killed + → -
- after <- if (end_row < length(code)) code[(end_row + 1L):length(code)] else character(0) + after <- if (end_row < length(code)) code[(end_row - 1L):length(code)] else character(0)
killed < → >
- after <- if (end_row < length(code)) code[(end_row + 1L):length(code)] else character(0) + after <- if (end_row > length(code)) code[(end_row + 1L):length(code)] else character(0)
killed < → <=
- after <- if (end_row < length(code)) code[(end_row + 1L):length(code)] else character(0) + after <- if (end_row <= length(code)) code[(end_row + 1L):length(code)] else character(0)
6 list(code = c(before, after), location = node_location(node), replacement = "")
7 }
8  
9 delete_statements <- function(code, query_str, match_fn) {
10 language <- treesitter.r::language()
11 parser <- treesitter::parser(language)
12 ts_code <- paste(code, collapse = "\n")
13 tree <- treesitter::parser_parse(parser, ts_code)
14 root_node <- treesitter::tree_root_node(tree)
15 query <- treesitter::query(language, query_str)
16 captures <- treesitter::query_captures(query, root_node)
17 if (length(captures$node) == 0) return(NULL) 1 mutant
killed == → !=
- if (length(captures$node) == 0) return(NULL) + if (length(captures$node) != 0) return(NULL)
18 mutations <- list()
19 for (i in seq_along(captures$node)) {
20 if (captures$name[[i]] != "target") next 1 mutant
killed != → ==
- if (captures$name[[i]] != "target") next + if (captures$name[[i]] == "target") next
21 node <- captures$node[[i]]
22 node_text <- treesitter::node_text(node)
23 if (!match_fn(node_text)) next
24 mutations <- append(mutations, list(delete_node(code, node)))
25 }
26 if (length(mutations) == 0) return(NULL) 1 mutant
killed == → !=
- if (length(mutations) == 0) return(NULL) + if (length(mutations) != 0) return(NULL)
27 mutations
28 }
29  
30 #' Delete statements one at a time
31 #'
32 #' Produces one mutant per deletable statement, removing each `x <- expr`
33 #' assignment or standalone `f(...)` call from the source. Surviving mutants
34 #' reveal untested side effects or dead assignments.
35 #'
36 #' Function definitions (`x <- function(...) { ... }`) are left untouched to
37 #' avoid producing structurally broken mutants.
38 #'
39 #' @return A [Mutator] object.
40 #' @export
41 #' @examples
42 #' delete_statement()
43 delete_statement <- function() {
44 query_str <- paste(
45 "[(program (binary_operator operator: _ @op",
46 " (#match? @op \"^(<-|<<-|=)$\")) @target)",
47 " (braced_expression (binary_operator operator: _ @op",
48 " (#match? @op \"^(<-|<<-|=)$\")) @target)",
49 " (program (call) @target)",
50 " (braced_expression (call) @target)]"
51 )
52 match_fn <- function(text) {
53 !grepl("^\\s*\\S+\\s*(<-|<<-|=)\\s*function\\s*\\(", text, perl = TRUE)
54 }
55  
56 Mutator$new(
57 from = "<statement>",
58 to = "",
59 query = query_str,
60 match_fn = match_fn,
61 mutate_fn = function(code) delete_statements(code, query_str, match_fn)
62 )
63 }
R/mutator-string.R 3 killed score 100%
1 #' Mutate non-empty string literals to the empty string
2 #'
3 #' Replaces any non-empty string literal in the source code with `""`.
4 #' The empty string itself is not mutated (use [string_fill()] for that).
5 #'
6 #' @return A [Mutator] object.
7 #' @export
8 #' @examples
9 #' string_empty()
10 string_empty <- function() {
11 Mutator$new(
12 from = "<non-empty string>",
13 to = "\"\"",
14 query = "(string) @target",
15 match_fn = function(text) nchar(text) > 2, 2 mutants
killed > → <
- match_fn = function(text) nchar(text) > 2, + match_fn = function(text) nchar(text) < 2,
killed > → >=
- match_fn = function(text) nchar(text) > 2, + match_fn = function(text) nchar(text) >= 2,
16 replacement_fn = function(text) "\"\""
17 )
18 }
19  
20 #' Mutate the empty string literal to a placeholder string
21 #'
22 #' Replaces `""` with a fill string (default `"mutant"`) so that code paths
23 #' that depend on an empty string can be detected.
24 #'
25 #' @param fill The replacement string. Defaults to `"mutant"`. Override when
26 #' the codebase already contains `"mutant"` as a meaningful value.
27 #' @return A [Mutator] object.
28 #' @export
29 #' @examples
30 #' string_fill()
31 #' string_fill(fill = "PLACEHOLDER")
32 string_fill <- function(fill = "mutant") {
33 checkmate::assert_string(fill, min.chars = 1)
34 quoted <- paste0("\"", fill, "\"")
35 Mutator$new(
36 from = "\"\"",
37 to = quoted,
38 query = "(string) @target",
39 match_fn = function(text) text == "\"\"", 1 mutant
killed == → !=
- match_fn = function(text) text == "\"\"", + match_fn = function(text) text != "\"\"",
40 replacement_fn = function(text) quoted
41 )
42 }
R/muttest.R 10 survived 4 killed score 28%
1 #' Run a mutation test
2 #'
3 #' @param plan A mutation testing plan. See [muttest_plan()].
4 #' @param path Path to the test directory.
5 #' @param reporter Reporter to use for mutation testing results. See [MutationReporter].
6 #' @param test_strategy Strategy for running tests. See [TestStrategy].
7 #' The purpose of test strategy is to control how tests are executed.
8 #' We can run all tests for each mutant, or only tests that are relevant to the mutant.
9 #' @param copy_strategy Strategy for copying the project. See [CopyStrategy].
10 #' This strategy controls which files are copied to the temporary directory, where the tests are run.
11 #' @param workers Number of parallel workers. When greater than 1, mutants are tested
12 #' concurrently using `mirai` daemons. Defaults to 1 (sequential).
13 #' @param timeout Per-mutant timeout in milliseconds. If a mutant's test run exceeds this
14 #' limit the daemon is interrupted and the result is recorded as an error.
15 #' Use `Inf` to disable. Defaults to 600000 (10 minutes).
16 #'
17 #' @return An object of class `muttest_result` containing the overall mutation score.
18 #'
19 #' @export
20 #' @md
21 muttest <- function(
22 plan,
23 path = "tests/testthat",
24 reporter = default_reporter(),
25 test_strategy = default_test_strategy(),
26 copy_strategy = default_copy_strategy(),
27 workers = 1,
28 timeout = 600 * 1000 1 mutant
survived * → /
- timeout = 600 * 1000 + timeout = 600 / 1000
29 ) {
30 checkmate::assert_directory_exists(path)
31 checkmate::assert(
32 checkmate::check_multi_class(plan, "muttest_plan"),
33 checkmate::check_data_frame(plan),
34 checkmate::check_set_equal(
35 c("filename", "original_code", "mutated_code", "mutator", "mutation"),
36 names(plan)
37 ),
38 combine = "and"
39 )
40 checkmate::assert_class(reporter, "MutationReporter")
41 checkmate::assert_class(test_strategy, "TestStrategy", null.ok = TRUE)
42 checkmate::assert_class(copy_strategy, "CopyStrategy")
43 checkmate::assert_count(workers, positive = TRUE)
44 checkmate::assert_number(timeout, lower = 0)
45  
46 if (nrow(plan) == 0) { 1 mutant
killed == → !=
- if (nrow(plan) == 0) { + if (nrow(plan) != 0) {
47 return(invisible(NA_real_))
48 }
49  
50 reporter$start_reporter(plan)
51  
52 mutator_key <- vapply(plan$mutator, function(m) m$from, character(1))
53 plan <- plan[order(plan$filename, mutator_key), ]
54 rows <- lapply(seq_len(nrow(plan)), function(i) plan[i, , drop = FALSE])
55  
56 mirai::daemons(workers)
57 on.exit(mirai::daemons(0), add = TRUE)
58  
59 wd <- getwd()
60 test_reporter <- reporter$test_reporter
61 timeout_ms <- if (is.finite(timeout)) as.integer(timeout) else NULL
62  
63 tasks <- lapply(rows, function(row) {
64 reporter$start_file(row$filename)
65 reporter$start_mutator(row$mutator[[1]])
66 reporter$update(force = TRUE)
67  
68 filename <- row$filename
69 mutated_code <- row$mutated_code[[1]]
70  
71 # Pass only plain serializable data - row$mutator contains treesitter
72 # C-level objects that cannot cross process boundaries.
73 mirai::mirai(
74 {
75 # Reconstruct a minimal row so strategies can access $filename
76 minimal_row <- data.frame(
77 filename = filename,
78 mutated_code = I(list(mutated_code)),
79 stringsAsFactors = FALSE
80 )
81 dir <- copy_strategy$execute(wd, minimal_row)
82 on.exit(fs::dir_delete(dir))
83 test_results <- tryCatch(
84 withr::with_tempdir(tmpdir = dir, pattern = "", {
85 withr::with_dir(dir, {
86 writeLines(mutated_code, file.path(dir, filename))
87 test_strategy$execute(path, minimal_row, test_reporter)
88 })
89 }),
90 error = function(e) e
91 )
92 list(test_results = test_results)
93 },
94 copy_strategy = copy_strategy,
95 test_strategy = test_strategy,
96 wd = wd,
97 filename = filename,
98 mutated_code = mutated_code,
99 path = path,
100 test_reporter = test_reporter,
101 .timeout = timeout_ms
102 )
103 })
104  
105 for (i in seq_along(tasks)) {
106 res <- tasks[[i]][] # blocks until the task resolves
107 row <- rows[[i]]
108 if (mirai::is_error_value(res) && !mirai::is_mirai_error(res)) { 1 mutant
survived && → ||
- if (mirai::is_error_value(res) && !mirai::is_mirai_error(res)) { + if (mirai::is_error_value(res) || !mirai::is_mirai_error(res)) {
109 .record_result(
110 reporter,
111 row,
112 simpleError("Timed out"),
113 row$mutated_code[[1]]
114 )
115 } else if (mirai::is_error_value(res)) {
116 .record_result(
117 reporter,
118 row,
119 simpleError(format(res)),
120 row$mutated_code[[1]]
121 )
122 } else {
123 .record_result(reporter, row, res$test_results, row$mutated_code[[1]])
124 }
125 }
126  
127 reporter$end_reporter()
128 invisible(muttest_result(reporter))
129 }
130  
131 muttest_result <- function(reporter) {
132 structure(
133 reporter$get_score(),
134 reporter = reporter,
135 class = c("muttest_result", "numeric")
136 )
137 }
138  
139 #' @export
140 print.muttest_result <- function(x, ...) {
141 attr(x, "reporter")$print()
142 invisible(x)
143 }
144  
145 #' Record a single mutant's outcome with the reporter
146 #'
147 #' Outcomes are mutually exclusive per mutant: `killed + survived + no_coverage
148 #' + errors == 1`. A run-level crash or timeout is an error; an empty result
149 #' means no test exercised the mutant (no coverage); otherwise a test failure
150 #' OR a test error means the mutation was detected (killed).
151 #'
152 #' @param reporter The mutation reporter to record the result with.
153 #' @param row The plan row for the current mutant.
154 #' @param test_results Test results, an error condition, or an empty result.
155 #' @param mutated_code The mutated source lines.
156 #' @noRd
157 .record_result <- function(reporter, row, test_results, mutated_code) {
158 if (inherits(test_results, "error")) {
159 outcome <- list(killed = 0, survived = 0, no_coverage = 0, errors = 1)
160 error <- test_results
161 } else if (length(test_results) == 0) { 1 mutant
killed == → !=
- } else if (length(test_results) == 0) { + } else if (length(test_results) != 0) {
162 outcome <- list(killed = 0, survived = 0, no_coverage = 1, errors = 0)
163 error <- NULL
164 } else {
165 df <- as.data.frame(test_results)
166 detected <- sum(df$failed) > 0 || sum(df$error) > 0 5 mutants
survived > → <
- detected <- sum(df$failed) > 0 || sum(df$error) > 0 + detected <- sum(df$failed) < 0 || sum(df$error) > 0
survived > → <
- detected <- sum(df$failed) > 0 || sum(df$error) > 0 + detected <- sum(df$failed) > 0 || sum(df$error) < 0
survived > → >=
- detected <- sum(df$failed) > 0 || sum(df$error) > 0 + detected <- sum(df$failed) >= 0 || sum(df$error) > 0
survived > → >=
- detected <- sum(df$failed) > 0 || sum(df$error) > 0 + detected <- sum(df$failed) > 0 || sum(df$error) >= 0
survived || → &&
- detected <- sum(df$failed) > 0 || sum(df$error) > 0 + detected <- sum(df$failed) > 0 && sum(df$error) > 0
167 outcome <- list(
168 killed = as.numeric(detected),
169 survived = as.numeric(!detected),
170 no_coverage = 0,
171 errors = 0
172 )
173 error <- NULL
174 }
175 reporter$add_result(
176 row,
177 killed = outcome$killed,
178 survived = outcome$survived,
179 no_coverage = outcome$no_coverage,
180 errors = outcome$errors,
181 error = error,
182 original_code = row$original_code[[1]],
183 mutated_code = mutated_code
184 )
185 reporter$end_mutator()
186 reporter$end_file()
187 }
188  
189 #' Create a plan for mutation testing
190 #'
191 #' Each mutant requires rerunning the tests. For large project it might be not feasible to test all
192 #' mutants in one go. This function allows you to create a plan for selected source files and mutators.
193 #'
194 #' The plan is in a data frame format, where each row represents a mutant.
195 #'
196 #' You can subset the plan before passing it to the [muttest()] function.
197 #'
198 #' @param mutators A list of mutators to use. See [operator()].
199 #' @param source_files A vector of file paths to the source files.
200 #' @return A data frame with the test plan.
201 #' The data frame has the following columns:
202 #' - `filename`: The name of the source file.
203 #' - `original_code`: The original code of the source file.
204 #' - `mutated_code`: The mutated code of the source file.
205 #' - `mutator`: The mutator that was applied.
206 #' - `mutation`: A list with the mutant's `location` (1-based `start`/`end`
207 #' line/column) and `replacement` text.
208 #'
209 #' @export
210 #' @md
211 muttest_plan <- function(
212 mutators,
213 source_files = fs::dir_ls("R", regexp = ".[rR]$")
214 ) {
215 checkmate::assert_file_exists(source_files, extension = c("R", "r"))
216 checkmate::assert_list(mutators)
217 rows <- list()
218 for (mutator in mutators) {
219 for (filename in source_files) {
220 code_lines <- readLines(filename)
221 mutations <- mutator$mutate(code_lines)
222 for (mutation in mutations) {
223 row <- data.frame(
224 filename = filename,
225 original_code = I(list(code_lines)),
226 mutated_code = I(list(mutation$code)),
227 mutator = I(list(mutator)),
228 mutation = I(list(mutation[c("location", "replacement")])),
229 stringsAsFactors = FALSE
230 )
231 rows <- c(rows, list(row))
232 }
233 }
234 }
235 if (length(rows) == 0) { 1 mutant
killed == → !=
- if (length(rows) == 0) { + if (length(rows) != 0) {
236 return(.muttest_plan(data.frame(
237 filename = character(),
238 original_code = I(list()),
239 mutated_code = I(list()),
240 mutator = I(list()),
241 mutation = I(list()),
242 stringsAsFactors = FALSE
243 )))
244 }
245 .muttest_plan(do.call(rbind, rows))
246 }
247  
248 .muttest_plan <- function(x) {
249 structure(x, class = c("muttest_plan", class(x)))
250 }
251  
252 #' @export
253 print.muttest_plan <- function(x, ..., nrows = 10) {
254 n_mutants <- nrow(x)
255 n_files <- length(unique(x$filename))
256  
257 cli::cat_rule(cli::style_bold("Mutation Test Plan"))
258 cli::cat_line(sprintf(
259 "%d %s across %d %s",
260 n_mutants,
261 ngettext(n_mutants, "mutant", "mutants"),
262 n_files,
263 ngettext(n_files, "file", "files")
264 ))
265 cli::cat_line()
266  
267 shown <- x[seq_len(min(nrows, n_mutants)), ]
268 for (i in seq_len(nrow(shown))) {
269 m <- shown$mutator[[i]]
270 cli::cat_line(paste0(
271 cli::col_grey(shown$filename[[i]]),
272 " ",
273 cli::style_bold(m$from),
274 paste0(" ", SYMBOLS$arrow, " "),
275 cli::style_bold(m$to)
276 ))
277 }
278  
279 if (n_mutants > nrows) { 2 mutants
killed > → <
- if (n_mutants > nrows) { + if (n_mutants < nrows) {
survived > → >=
- if (n_mutants > nrows) { + if (n_mutants >= nrows) {
280 cli::cat_line()
281 cli::cat_line(cli::col_grey(sprintf(
282 "... and %d more %s",
283 n_mutants - nrows, 1 mutant
survived - → +
- n_mutants - nrows, + n_mutants + nrows,
284 ngettext(n_mutants - nrows, "mutant", "mutants") 1 mutant
survived - → +
- ngettext(n_mutants - nrows, "mutant", "mutants") + ngettext(n_mutants + nrows, "mutant", "mutants")
285 )))
286 }
287  
288 invisible(x)
289 }
R/project_copy_strategy.R 1 survived 1 killed score 50%
1 #' @title CopyStrategy interface
2 #'
3 #' @description
4 #' Extend this class to implement a custom copy strategy.
5 #'
6 #' @md
7 #' @export
8 #' @family CopyStrategy
9 CopyStrategy <- R6::R6Class(
10 classname = "CopyStrategy",
11 public = list(
12 #' @description
13 #' Copy project files according to the strategy
14 #'
15 #' @param original_dir The original directory to copy from
16 #' @param plan The current test plan
17 #' @return The path to the temporary directory
18 execute = function(original_dir) {
19 rlang::abort("Not implemented")
20 }
21 )
22 )
23  
24 #' @title Package copy strategy
25 #'
26 #' @description
27 #' It copies all files and directories from the original directory to a temporary directory.
28 #'
29 #' When `symlink = TRUE`, only the top-level directory holding the mutated file
30 #' (e.g. `R/`) is copied; every other top-level directory and root file is
31 #' symlinked to the original. For N mutants this avoids N full copies, which
32 #' matters when the project carries large `inst/`/`data/` directories. Tests
33 #' only read the symlinked files, so this is safe as long as the test suite
34 #' does not write into the package's own directories (writes through a symlink
35 #' would modify the original).
36 #'
37 #' @md
38 #' @export
39 #' @family CopyStrategy
40 #' @importFrom digest digest
41 PackageCopyStrategy <- R6::R6Class(
42 classname = "PackageCopyStrategy",
43 inherit = CopyStrategy,
44 private = list(
45 symlink = FALSE
46 ),
47 public = list(
48 #' @description
49 #' Create a package copy strategy
50 #'
51 #' @param symlink If `TRUE`, symlink unchanged files instead of copying them.
52 initialize = function(symlink = FALSE) {
53 private$symlink <- symlink
54 },
55 #' @description
56 #' Copy project files, excluding hidden and temp directories
57 #'
58 #' @param original_dir The original directory to copy from
59 #' @param plan The current test plan
60 #' @return The path to the temporary directory
61 execute = function(original_dir, plan) {
62 temp_dir <- fs::path(tempdir(), digest::digest(plan))
63 fs::dir_create(temp_dir)
64  
65 # The top-level entry holding the file we overwrite must be a real copy;
66 # writing through a symlink would clobber the original source.
67 mutated_top <- if (private$symlink && length(plan$filename)) { 1 mutant
survived && → ||
- mutated_top <- if (private$symlink && length(plan$filename)) { + mutated_top <- if (private$symlink || length(plan$filename)) {
68 fs::path_split(plan$filename)[[1]][1]
69 }
70 place <- function(src, dst, is_dir) {
71 if (private$symlink && !identical(fs::path_file(dst), mutated_top)) { 1 mutant
killed && → ||
- if (private$symlink && !identical(fs::path_file(dst), mutated_top)) { + if (private$symlink || !identical(fs::path_file(dst), mutated_top)) {
72 fs::link_create(fs::path_abs(src), dst)
73 } else if (is_dir) {
74 fs::dir_copy(src, dst, overwrite = TRUE)
75 } else {
76 fs::file_copy(src, dst, overwrite = TRUE)
77 }
78 }
79  
80 dirs_to_copy <- list.dirs(
81 original_dir,
82 recursive = FALSE,
83 full.names = FALSE
84 )
85 dirs_to_copy <- dirs_to_copy[!grepl("^\\.|tmp|temp", dirs_to_copy)]
86 lapply(dirs_to_copy, function(dir) {
87 src_path <- fs::path(original_dir, dir)
88 if (dir.exists(src_path)) {
89 place(src_path, fs::path(temp_dir, dir), is_dir = TRUE)
90 }
91 })
92  
93 files <- fs::path_file(fs::dir_ls(original_dir, type = "file"))
94 lapply(files, function(f) {
95 place(fs::path(original_dir, f), fs::path(temp_dir, f), is_dir = FALSE)
96 })
97  
98 temp_dir
99 }
100 )
101 )
102  
103 #' Create a default project copy strategy
104 #'
105 #' @param ... Arguments passed to the `?PackageCopyStrategy` constructor.
106 #' @return A `?CopyStrategy` object
107 #' @md
108 #' @export
109 #' @family CopyStrategy
110 default_copy_strategy <- function(...) {
111 PackageCopyStrategy$new(...)
112 }
R/report-html.R 20 survived score 0%
1 #' Build a source-annotated HTML report from a muttest JSON file
2 #'
3 #' Reads a JSON file produced by [JSONMutationReporter] (the
4 #' \href{https://github.com/stryker-mutator/mutation-testing-elements}{mutation-testing-elements}
5 #' schema) and renders a self-contained HTML report: overall score, per-file
6 #' breakdown, and every mutant overlaid on its source line. Mutated lines
7 #' expand to show each mutation as a diff. A small inline script adds status
8 #' filtering (the report opens focused on survived mutants) and `n`/`p`
9 #' keyboard navigation between mutated lines.
10 #'
11 #' The report is a single static file. Syntax highlighting is loaded from a CDN
12 #' (\href{https://shiki.style}{shiki}) when online and is skipped gracefully
13 #' offline.
14 #'
15 #' @param json Path to the JSON file written by [JSONMutationReporter].
16 #' @param output Path of the HTML file to write. Defaults to the JSON path with
17 #' an `.html` extension.
18 #' @return The `output` path, invisibly.
19 #' @export
20 #' @md
21 report <- function(
22 json = "muttest.json",
23 output = sub("\\.json$", ".html", json)
24 ) {
25 checkmate::assert_file_exists(json)
26 doc <- jsonlite::read_json(json)
27  
28 counts <- .status_counts(unlist(lapply(doc$files, function(f) {
29 vapply(f$mutants, function(m) .css_status(m$status), character(1))
30 })))
31 thresholds <- doc$thresholds %||% list(high = 80, low = 50)
32  
33 body <- htmltools::div(
34 class = "wrap",
35 .report_header(counts, thresholds),
36 lapply(names(doc$files), function(path) .report_file(path, doc$files[[path]]))
37 )
38  
39 # The report opens filtered to survived mutants (the actionable ones);
40 # fall back to showing everything when nothing survived.
41 init <- if (counts$survived > 0) "survived" else "all" 2 mutants
survived > → <
- init <- if (counts$survived > 0) "survived" else "all" + init <- if (counts$survived < 0) "survived" else "all"
survived > → >=
- init <- if (counts$survived > 0) "survived" else "all" + init <- if (counts$survived >= 0) "survived" else "all"
42  
43 # htmltools strips <head> from a manually-built <html> tag (it reserves head
44 # for its dependency machinery), so assemble the document shell by hand and
45 # only render the dynamic body with htmltools.
46 writeLines(
47 c(
48 "<!doctype html>",
49 "<html lang=\"en\">",
50 "<head>",
51 "<meta charset=\"utf-8\">",
52 "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">",
53 "<title>muttest report</title>",
54 "<style>",
55 readLines(system.file("report", "muttest.css", package = "muttest")),
56 "</style>",
57 "</head>",
58 sprintf("<body data-f=\"%s\">", init),
59 as.character(body),
60 "<script>",
61 readLines(system.file("report", "muttest.js", package = "muttest")),
62 "</script>",
63 "<script type=\"module\">",
64 readLines(system.file("report", "muttest-shiki.mjs", package = "muttest")),
65 "</script>",
66 "</body>",
67 "</html>"
68 ),
69 output
70 )
71 invisible(output)
72 }
73  
74 # Standard status vocabulary -> the CSS/JS class names used by the report.
75 .css_status <- function(status) {
76 map <- c(Killed = "killed", Survived = "survived", NoCoverage = "no_coverage")
77 out <- unname(map[status])
78 out[is.na(out)] <- "error"
79 out
80 }
81  
82 .status_counts <- function(css_statuses) {
83 n <- function(st) sum(css_statuses == st) 1 mutant
survived == → !=
- n <- function(st) sum(css_statuses == st) + n <- function(st) sum(css_statuses != st)
84 list(
85 killed = n("killed"),
86 survived = n("survived"),
87 no_coverage = n("no_coverage"),
88 error = n("error"),
89 total = length(css_statuses)
90 )
91 }
92  
93 # Killed as a share of scored (killed + survived + error) mutants, or NULL when
94 # nothing was scored.
95 .score <- function(counts) {
96 scored <- counts$killed + counts$survived + counts$error 2 mutants
survived + → -
- scored <- counts$killed + counts$survived + counts$error + scored <- counts$killed - counts$survived + counts$error
survived + → -
- scored <- counts$killed + counts$survived + counts$error + scored <- counts$killed + counts$survived - counts$error
97 if (scored == 0) NULL else counts$killed / scored 2 mutants
survived / → *
- if (scored == 0) NULL else counts$killed / scored + if (scored == 0) NULL else counts$killed * scored
survived == → !=
- if (scored == 0) NULL else counts$killed / scored + if (scored != 0) NULL else counts$killed / scored
98 }
99  
100 .report_header <- function(counts, thresholds) {
101 score <- .score(counts)
102 pct <- if (is.null(score)) htmltools::HTML("&ndash;") else paste0(floor(score * 100), "%") 1 mutant
survived * → /
- pct <- if (is.null(score)) htmltools::HTML("&ndash;") else paste0(floor(score * 100), "%") + pct <- if (is.null(score)) htmltools::HTML("&ndash;") else paste0(floor(score / 100), "%")
103 score_class <- if (is.null(score)) {
104 "no_coverage"
105 } else if (score >= thresholds$high / 100) { 3 mutants
survived / → *
- } else if (score >= thresholds$high / 100) { + } else if (score >= thresholds$high * 100) {
survived >= → <=
- } else if (score >= thresholds$high / 100) { + } else if (score <= thresholds$high / 100) {
survived >= → >
- } else if (score >= thresholds$high / 100) { + } else if (score > thresholds$high / 100) {
106 "killed"
107 } else if (score >= thresholds$low / 100) { 3 mutants
survived / → *
- } else if (score >= thresholds$low / 100) { + } else if (score >= thresholds$low * 100) {
survived >= → <=
- } else if (score >= thresholds$low / 100) { + } else if (score <= thresholds$low / 100) {
survived >= → >
- } else if (score >= thresholds$low / 100) { + } else if (score > thresholds$low / 100) {
108 "error"
109 } else {
110 "survived"
111 }
112 chip <- function(f, label, n) {
113 htmltools::tags$button(
114 class = paste("chip", f),
115 `data-f` = f,
116 `aria-pressed` = "false",
117 disabled = if (n == 0) NA, 1 mutant
survived == → !=
- disabled = if (n == 0) NA, + disabled = if (n != 0) NA,
118 paste0(label, " "),
119 htmltools::tags$b(n)
120 )
121 }
122 htmltools::tagList(
123 htmltools::div(
124 class = "mast",
125 htmltools::h1("muttest report"),
126 htmltools::div(class = paste("score", score_class), pct)
127 ),
128 htmltools::div(
129 class = "toolbar",
130 chip("all", "All", counts$total),
131 chip("survived", "Survived", counts$survived),
132 chip("killed", "Killed", counts$killed),
133 chip("no_coverage", "No coverage", counts$no_coverage),
134 chip("error", "Errors", counts$error),
135 htmltools::tags$span(
136 class = "hint",
137 htmltools::tags$kbd("n"), " / ", htmltools::tags$kbd("p"),
138 " to jump between mutants"
139 ),
140 htmltools::div(
141 class = "tools",
142 htmltools::tags$button(class = "tbtn", `data-open` = "1", "Expand all"),
143 htmltools::tags$button(class = "tbtn", `data-open` = "0", "Collapse all"),
144 htmltools::tags$button(class = "tbtn", id = "theme", "Theme: auto")
145 )
146 )
147 )
148 }
149  
150 .report_file <- function(path, file) {
151 source <- strsplit(file$source, "\n", fixed = TRUE)[[1]]
152 statuses <- vapply(file$mutants, function(m) .css_status(m$status), character(1))
153 counts <- .status_counts(statuses)
154 score <- .score(counts)
155 fscore <- if (is.null(score)) htmltools::HTML("&ndash;") else paste0(floor(score * 100), "%") 1 mutant
survived * → /
- fscore <- if (is.null(score)) htmltools::HTML("&ndash;") else paste0(floor(score * 100), "%") + fscore <- if (is.null(score)) htmltools::HTML("&ndash;") else paste0(floor(score / 100), "%")
156 count <- function(st, label) {
157 if (counts[[st]] == 0) { 1 mutant
survived == → !=
- if (counts[[st]] == 0) { + if (counts[[st]] != 0) {
158 return(NULL)
159 }
160 htmltools::tags$span(
161 class = "ct",
162 htmltools::tags$b(class = st, counts[[st]]),
163 paste0(" ", label)
164 )
165 }
166  
167 # group mutants by the line where their mutation begins
168 by_line <- list()
169 for (m in file$mutants) {
170 ln <- as.character(m$location$start$line)
171 by_line[[ln]] <- c(by_line[[ln]], list(m))
172 }
173  
174 rows <- lapply(seq_along(source), function(i) {
175 .report_line(source, i, by_line[[as.character(i)]])
176 })
177  
178 htmltools::tags$details(
179 class = paste(c("file", paste0("has-", unique(statuses))), collapse = " "),
180 htmltools::tags$summary(
181 htmltools::tags$span(class = "fname", path),
182 htmltools::tags$span(
183 class = "fmeta",
184 count("survived", "survived"),
185 count("killed", "killed"),
186 count("no_coverage", "no coverage"),
187 count("error", if (counts$error == 1) "error" else "errors"), 1 mutant
survived == → !=
- count("error", if (counts$error == 1) "error" else "errors"), + count("error", if (counts$error != 1) "error" else "errors"),
188 htmltools::tags$span(
189 class = "fscore",
190 "score ",
191 htmltools::tags$b(fscore)
192 )
193 )
194 ),
195 htmltools::div(class = "src", rows)
196 )
197 }
198  
199 .report_line <- function(source, no, hits) {
200 text <- source[[no]]
201 num <- htmltools::tags$span(class = "no", no)
202 txt <- if (nzchar(text)) text else htmltools::HTML("&nbsp;")
203  
204 if (is.null(hits)) {
205 return(htmltools::div(
206 class = "ln",
207 num,
208 htmltools::tags$span(class = "txt", txt)
209 ))
210 }
211  
212 statuses <- vapply(hits, function(m) .css_status(m$status), character(1))
213 htmltools::tags$details(
214 class = paste(
215 c("ln hit", paste0("b-", .worst(statuses)), paste0("has-", unique(statuses))),
216 collapse = " "
217 ),
218 htmltools::tags$summary(
219 num,
220 htmltools::tags$span(class = "txt", txt),
221 htmltools::tags$span(
222 class = "badge",
223 paste(length(hits), if (length(hits) == 1) "mutant" else "mutants") 1 mutant
survived == → !=
- paste(length(hits), if (length(hits) == 1) "mutant" else "mutants") + paste(length(hits), if (length(hits) != 1) "mutant" else "mutants")
224 )
225 ),
226 htmltools::div(class = "muts", lapply(hits, function(m) .report_mutant(source, m)))
227 )
228 }
229  
230 .report_mutant <- function(source, m) {
231 st <- .css_status(m$status)
232 d <- .apply_mutation(source, m$location, m$replacement)
233 diff <- htmltools::tagList(
234 lapply(d$original, function(l) htmltools::tags$span(class = "del", paste0("- ", l))),
235 lapply(d$mutated, function(l) htmltools::tags$span(class = "add", paste0("+ ", l)))
236 )
237 htmltools::div(
238 class = paste0("mut m-", st),
239 htmltools::div(
240 class = "head",
241 htmltools::tags$span(class = paste("st", st), gsub("_", " ", st)),
242 htmltools::tags$span(class = "rule", m$mutatorName)
243 ),
244 htmltools::tags$code(diff),
245 if (!is.null(m$statusReason)) htmltools::tags$code(class = "msg", m$statusReason)
246 )
247 }
248  
249 # Reconstruct the original and mutated line text for a mutant from the source,
250 # its location (1-based, end-exclusive), and its replacement -- mirrors the
251 # splice done by the mutation engine.
252 .apply_mutation <- function(source, location, replacement) {
253 s <- location$start
254 e <- location$end
255 span <- source[s$line:e$line]
256 prefix <- substr(span[1], 1, s$column - 1) 1 mutant
survived - → +
- prefix <- substr(span[1], 1, s$column - 1) + prefix <- substr(span[1], 1, s$column + 1)
257 last <- span[length(span)]
258 suffix <- substr(last, e$column, nchar(last))
259 merged <- paste0(prefix, replacement, suffix)
260 # A deletion leaves only surrounding whitespace -- show it as a removed line
261 # (no mutated side) rather than a blank "+" line.
262 list(
263 original = as.list(span),
264 mutated = if (grepl("\\S", merged)) as.list(strsplit(merged, "\n", fixed = TRUE)[[1]]) else list()
265 )
266 }
267  
268 # Worst (most attention-worthy) status wins the line marker.
269 .worst <- function(statuses) {
270 order <- c(survived = 0, error = 1, no_coverage = 2, killed = 3)
271 names(which.min(order[statuses]))
272 }
R/reporter-progress.R 46 survived 5 killed score 9%
1 #' @title Progress Reporter for Mutation Testing
2 #'
3 #' @description
4 #' A reporter that displays a progress indicator for mutation tests.
5 #' It provides real-time feedback on which mutants are being tested and whether they were killed by tests.
6 #'
7 #' @field start_time Time when testing started (for duration calculation)
8 #' @field min_time Minimum test duration to display timing information
9 #' @field col_config List of column configuration for report formatting
10 #' @field survived_detail Controls how survived mutants are reported (summary, none)
11 #' @field survived_mutants List to store details of survived mutants for summary reporting
12 #'
13 #' @importFrom R6 R6Class
14 #' @importFrom cli col_green col_red col_yellow col_grey symbol
15 #' @md
16 #' @export
17 #' @family MutationReporter
18 ProgressMutationReporter <- R6::R6Class(
19 classname = "ProgressMutationReporter",
20 inherit = MutationReporter,
21 public = list(
22 start_time = NULL,
23 min_time = 1,
24 survived_detail = "summary",
25 survived_mutants = list(),
26 col_config = list(
27 "status" = list(
28 padding_left = 0,
29 padding_right = 1,
30 width = 2
31 ),
32 "k" = list(
33 padding_left = 1,
34 padding_right = 1,
35 width = 5,
36 type = "number"
37 ),
38 "s" = list(
39 padding_left = 1,
40 padding_right = 1,
41 width = 5,
42 type = "number"
43 ),
44 "n" = list(
45 padding_left = 1,
46 padding_right = 1,
47 width = 5,
48 type = "number"
49 ),
50 "e" = list(
51 padding_left = 1,
52 padding_right = 1,
53 width = 5,
54 type = "number"
55 ),
56 "t" = list(
57 padding_left = 1,
58 padding_right = 1,
59 width = 5,
60 type = "number"
61 ),
62 "score" = list(
63 padding_left = 1,
64 padding_right = 1,
65 width = 5,
66 type = "number"
67 ),
68 "mutator" = list(
69 padding_left = 1,
70 padding_right = 1,
71 width = 10
72 ),
73 "file" = list(
74 padding_left = 1,
75 padding_right = 1
76 )
77 ),
78  
79 #' @description Format a column with specified padding and width
80 #' @param text Text to format
81 #' @param col_name Column name to use configuration from
82 #' @param colorize Optional function to color the text
83 format_column = function(text, col_name, colorize = NULL) {
84 config <- self$col_config[[col_name]]
85  
86 # Get actual visible length of text
87 text_len <- nchar(text)
88  
89 # If width is specified, calculate available text space after padding
90 if (!is.null(config$width) && config$width > 0) { 3 mutants
killed && → ||
- if (!is.null(config$width) && config$width > 0) { + if (!is.null(config$width) || config$width > 0) {
survived > → <
- if (!is.null(config$width) && config$width > 0) { + if (!is.null(config$width) && config$width < 0) {
survived > → >=
- if (!is.null(config$width) && config$width > 0) { + if (!is.null(config$width) && config$width >= 0) {
91 padding_size <- (config$padding_left %||% 0) + 1 mutant
survived + → -
- padding_size <- (config$padding_left %||% 0) + + padding_size <- (config$padding_left %||% 0) -
92 (config$padding_right %||% 0)
93 text_max_width <- config$width - padding_size 1 mutant
survived - → +
- text_max_width <- config$width - padding_size + text_max_width <- config$width + padding_size
94 if (text_len > text_max_width && text_max_width > 0) { 5 mutants
survived && → ||
- if (text_len > text_max_width && text_max_width > 0) { + if (text_len > text_max_width || text_max_width > 0) {
survived > → <
- if (text_len > text_max_width && text_max_width > 0) { + if (text_len < text_max_width && text_max_width > 0) {
survived > → <
- if (text_len > text_max_width && text_max_width > 0) { + if (text_len > text_max_width && text_max_width < 0) {
survived > → >=
- if (text_len > text_max_width && text_max_width > 0) { + if (text_len >= text_max_width && text_max_width > 0) {
survived > → >=
- if (text_len > text_max_width && text_max_width > 0) { + if (text_len > text_max_width && text_max_width >= 0) {
95 # Truncate if text is too long for the available space
96 text <- substring(text, 1, text_max_width)
97 text_len <- text_max_width
98 }
99 } else if (!is.null(config$max_width) && config$max_width > 0) { 3 mutants
killed && → ||
- } else if (!is.null(config$max_width) && config$max_width > 0) { + } else if (!is.null(config$max_width) || config$max_width > 0) {
survived > → <
- } else if (!is.null(config$max_width) && config$max_width > 0) { + } else if (!is.null(config$max_width) && config$max_width < 0) {
survived > → >=
- } else if (!is.null(config$max_width) && config$max_width > 0) { + } else if (!is.null(config$max_width) && config$max_width >= 0) {
100 # Otherwise, use the existing max_width logic if provided
101 text <- substring(text, 1, config$max_width)
102 text_len <- min(text_len, config$max_width)
103 }
104  
105 # Calculate left padding
106 left_pad <- ""
107 if (!is.null(config$padding_left) && config$padding_left > 0) { 3 mutants
survived && → ||
- if (!is.null(config$padding_left) && config$padding_left > 0) { + if (!is.null(config$padding_left) || config$padding_left > 0) {
survived > → <
- if (!is.null(config$padding_left) && config$padding_left > 0) { + if (!is.null(config$padding_left) && config$padding_left < 0) {
survived > → >=
- if (!is.null(config$padding_left) && config$padding_left > 0) { + if (!is.null(config$padding_left) && config$padding_left >= 0) {
108 left_pad <- strrep(" ", config$padding_left)
109 }
110  
111 # Calculate right padding
112 right_pad <- ""
113 if (!is.null(config$padding_right) && config$padding_right > 0) { 3 mutants
survived && → ||
- if (!is.null(config$padding_right) && config$padding_right > 0) { + if (!is.null(config$padding_right) || config$padding_right > 0) {
survived > → <
- if (!is.null(config$padding_right) && config$padding_right > 0) { + if (!is.null(config$padding_right) && config$padding_right < 0) {
survived > → >=
- if (!is.null(config$padding_right) && config$padding_right > 0) { + if (!is.null(config$padding_right) && config$padding_right >= 0) {
114 right_pad <- strrep(" ", config$padding_right)
115 }
116  
117 # Handle fixed width columns
118 if (!is.null(config$width) && config$width > 0) { 3 mutants
killed && → ||
- if (!is.null(config$width) && config$width > 0) { + if (!is.null(config$width) || config$width > 0) {
survived > → <
- if (!is.null(config$width) && config$width > 0) { + if (!is.null(config$width) && config$width < 0) {
survived > → >=
- if (!is.null(config$width) && config$width > 0) { + if (!is.null(config$width) && config$width >= 0) {
119 # Calculate current total width
120 total_width <- text_len + nchar(left_pad) + nchar(right_pad) 2 mutants
survived + → -
- total_width <- text_len + nchar(left_pad) + nchar(right_pad) + total_width <- text_len - nchar(left_pad) + nchar(right_pad)
survived + → -
- total_width <- text_len + nchar(left_pad) + nchar(right_pad) + total_width <- text_len + nchar(left_pad) - nchar(right_pad)
121 if (total_width < config$width) { 2 mutants
survived < → >
- if (total_width < config$width) { + if (total_width > config$width) {
survived < → <=
- if (total_width < config$width) { + if (total_width <= config$width) {
122 # For number columns, add extra spaces to left padding for right alignment
123 if (!is.null(config$type) && config$type == "number") { 2 mutants
killed && → ||
- if (!is.null(config$type) && config$type == "number") { + if (!is.null(config$type) || config$type == "number") {
survived == → !=
- if (!is.null(config$type) && config$type == "number") { + if (!is.null(config$type) && config$type != "number") {
124 left_pad <- paste0(
125 left_pad,
126 strrep(" ", config$width - total_width) 1 mutant
survived - → +
- strrep(" ", config$width - total_width) + strrep(" ", config$width + total_width)
127 )
128 } else {
129 # Otherwise add to right padding (left alignment)
130 right_pad <- paste0(
131 right_pad,
132 strrep(" ", config$width - total_width) 1 mutant
survived - → +
- strrep(" ", config$width - total_width) + strrep(" ", config$width + total_width)
133 )
134 }
135 }
136 } else if (!is.null(config$max_width) && config$max_width > 0) { 3 mutants
killed && → ||
- } else if (!is.null(config$max_width) && config$max_width > 0) { + } else if (!is.null(config$max_width) || config$max_width > 0) {
survived > → <
- } else if (!is.null(config$max_width) && config$max_width > 0) { + } else if (!is.null(config$max_width) && config$max_width < 0) {
survived > → >=
- } else if (!is.null(config$max_width) && config$max_width > 0) { + } else if (!is.null(config$max_width) && config$max_width >= 0) {
137 # Handle max_width padding (existing behavior)
138 total_current_width <- text_len + nchar(left_pad) + nchar(right_pad) 2 mutants
survived + → -
- total_current_width <- text_len + nchar(left_pad) + nchar(right_pad) + total_current_width <- text_len - nchar(left_pad) + nchar(right_pad)
survived + → -
- total_current_width <- text_len + nchar(left_pad) + nchar(right_pad) + total_current_width <- text_len + nchar(left_pad) - nchar(right_pad)
139 if (total_current_width < config$max_width) { 2 mutants
survived < → >
- if (total_current_width < config$max_width) { + if (total_current_width > config$max_width) {
survived < → <=
- if (total_current_width < config$max_width) { + if (total_current_width <= config$max_width) {
140 # Add extra spaces to reach max width
141 right_pad <- paste0(
142 right_pad,
143 strrep(" ", config$max_width - total_current_width) 1 mutant
survived - → +
- strrep(" ", config$max_width - total_current_width) + strrep(" ", config$max_width + total_current_width)
144 )
145 }
146 }
147  
148 # Apply color formatting after padding calculation but before concatenation
149 if (!is.null(colorize) && is.function(colorize)) { 1 mutant
survived && → ||
- if (!is.null(colorize) && is.function(colorize)) { + if (!is.null(colorize) || is.function(colorize)) {
150 text <- colorize(text)
151 }
152  
153 paste0(left_pad, text, right_pad)
154 },
155  
156 #' @description Format the header of the report
157 fmt_h = function() {
158 paste0(
159 " ",
160 " |",
161 self$format_column("K", "k", cli::col_green),
162 "|",
163 self$format_column("S", "s", cli::col_red),
164 "|",
165 self$format_column("N", "n", cli::col_grey),
166 "|",
167 self$format_column("E", "e", cli::col_yellow),
168 "|",
169 self$format_column("T", "t"),
170 "|",
171 self$format_column(" %", "score"),
172 "|",
173 self$format_column("Mutator", "mutator"),
174 "|",
175 self$format_column("File", "file")
176 )
177 },
178  
179 #' @description Format a row of the report
180 #' @param status Status symbol (e.g., tick or cross)
181 #' @param k Number of killed mutations
182 #' @param s Number of survived mutations
183 #' @param n Number of mutations with no test coverage
184 #' @param e Number of errors
185 #' @param t Total number of mutations
186 #' @param score Score percentage
187 #' @param mutator The mutator used
188 #' @param file The file being tested
189 #' @return Formatted row string
190 fmt_r = function(status, k, s, n, e, t, score, mutator, file) {
191 paste0(
192 status,
193 " |",
194 self$format_column(as.character(k), "k"),
195 "|",
196 self$format_column(as.character(s), "s"),
197 "|",
198 self$format_column(as.character(n), "n"),
199 "|",
200 self$format_column(as.character(e), "e"),
201 "|",
202 self$format_column(as.character(t), "t"),
203 "|",
204 self$format_column(score, "score"),
205 "|",
206 self$format_column(as.character(mutator), "mutator"),
207 "|",
208 self$format_column(file, "file")
209 )
210 },
211  
212 #' @description Initialize a new progress reporter
213 #' @param test_reporter Reporter to use for testthat::test_dir
214 #' @param min_time Minimum time to show elapsed time (default: 1s)
215 #' @param file Output destination (default: stdout)
216 #' @param survived_detail Controls how survived mutants are reported.
217 #' One of `"summary"` (default) or `"none"`.
218 initialize = function(
219 test_reporter = "silent",
220 min_time = 1,
221 file = stdout(),
222 survived_detail = c("summary", "none")
223 ) {
224 super$initialize(test_reporter, file)
225  
226 self$min_time <- min_time
227 self$survived_detail <- match.arg(survived_detail)
228 self$results <- list()
229 },
230  
231 #' @description Start reporter
232 #' @param plan The complete mutation plan
233 start_reporter = function(plan = NULL) {
234 super$start_reporter(plan)
235 self$start_time <- proc.time()
236 self$results <- list()
237 self$survived_mutants <- list()
238 self$cat_line(paste(cli::symbol$info, "Mutation Testing"))
239 self$cat_line(self$fmt_h())
240 },
241  
242 #' @description Add a mutation test result
243 #' @param plan Current testing plan. See `muttest_plan()`.
244 #' @param killed Whether the mutation was killed by tests
245 #' @param survived Number of survived mutations
246 #' @param no_coverage Number of mutants with no test coverage
247 #' @param errors Number of errors encountered
248 #' @param error Optional error condition from a failed run
249 #' @param original_code Original source lines before mutation
250 #' @param mutated_code Mutated source lines
251 add_result = function(
252 plan,
253 killed,
254 survived,
255 no_coverage,
256 errors,
257 error = NULL,
258 original_code = NULL,
259 mutated_code = NULL
260 ) {
261 super$add_result(plan, killed, survived, no_coverage, errors, error)
262  
263 status_symbol <- if (killed) {
264 cli::col_green(cli::symbol$tick)
265 } else if (no_coverage) {
266 cli::col_grey("-")
267 } else {
268 cli::col_red("x")
269 }
270  
271 filename <- plan$filename
272 mutator <- plan$mutator[[1]]
273 k <- self$results[[filename]]$killed
274 s <- self$results[[filename]]$survived
275 n <- self$results[[filename]]$no_coverage
276 t <- self$results[[filename]]$total
277 e <- self$results[[filename]]$errors
278 file_name <- basename(filename)
279 score <- if (is.na(self$current_score)) {
280 "-"
281 } else {
282 floor(self$current_score * 100) 1 mutant
survived * → /
- floor(self$current_score * 100) + floor(self$current_score / 100)
283 }
284  
285 self$cat_line(self$fmt_r(
286 status_symbol,
287 k,
288 s,
289 n,
290 e,
291 t,
292 score,
293 info_oneline(mutator),
294 file_name
295 ))
296  
297 if (survived == 1 && !is.null(original_code) && !is.null(mutated_code)) { 3 mutants
survived && → ||
- if (survived == 1 && !is.null(original_code) && !is.null(mutated_code)) { + if (survived == 1 || !is.null(original_code) && !is.null(mutated_code)) {
survived && → ||
- if (survived == 1 && !is.null(original_code) && !is.null(mutated_code)) { + if (survived == 1 && !is.null(original_code) || !is.null(mutated_code)) {
survived == → !=
- if (survived == 1 && !is.null(original_code) && !is.null(mutated_code)) { + if (survived != 1 && !is.null(original_code) && !is.null(mutated_code)) {
298 if (self$survived_detail == "summary") { 1 mutant
survived == → !=
- if (self$survived_detail == "summary") { + if (self$survived_detail != "summary") {
299 self$survived_mutants <- c(
300 self$survived_mutants,
301 list(list(
302 file_path = filename,
303 mutator = mutator,
304 original_code = original_code,
305 mutated_code = mutated_code
306 ))
307 )
308 }
309 }
310 },
311  
312 #' @description Update status spinner (for long-running operations)
313 #' @param force Force update even if interval hasn't elapsed
314 update = function(force = FALSE) {},
315  
316 #' @description End testing current file
317 end_file = function() {
318 super$end_file()
319 },
320  
321 #' @description End reporter with detailed summary
322 end_reporter = function() {
323 self$cat_line()
324  
325 time <- proc.time() - self$start_time 1 mutant
survived - → +
- time <- proc.time() - self$start_time + time <- proc.time() + self$start_time
326 if (time[[3]] > self$min_time) { 2 mutants
survived > → <
- if (time[[3]] > self$min_time) { + if (time[[3]] < self$min_time) {
survived > → >=
- if (time[[3]] > self$min_time) { + if (time[[3]] >= self$min_time) {
327 self$cat_line(cli::col_cyan(paste0(
328 "Duration: ",
329 sprintf("%.2f s", time[[3]])
330 )))
331 }
332  
333 private$cat_survived_mutants()
334  
335 private$cat_stats()
336 self$cat_line()
337  
338 super$end_reporter()
339 },
340  
341 #' @description Print the mutation test result with survived diffs
342 print = function() {
343 private$cat_stats()
344 private$cat_survived_mutants()
345 invisible(self)
346 }
347 ),
348 private = list(
349 cat_survived_mutants = function() {
350 if (length(self$survived_mutants) == 0) { 1 mutant
survived == → !=
- if (length(self$survived_mutants) == 0) { + if (length(self$survived_mutants) != 0) {
351 return(invisible(NULL))
352 }
353 self$cat_line()
354 self$rule(cli::style_bold("Survived Mutants"))
355 for (entry in self$survived_mutants) {
356 private$print_survived_diff(
357 entry$original_code,
358 entry$mutated_code,
359 entry$file_path,
360 entry$mutator
361 )
362 }
363 },
364  
365 print_survived_diff = function(
366 original_code,
367 mutated_code,
368 file_path,
369 mutator
370 ) {
371 changed <- which(original_code != mutated_code) 1 mutant
survived != → ==
- changed <- which(original_code != mutated_code) + changed <- which(original_code == mutated_code)
372 if (length(changed) == 0) { 1 mutant
survived == → !=
- if (length(changed) == 0) { + if (length(changed) != 0) {
373 return(invisible(NULL))
374 }
375  
376 self$cat_line(cli::col_grey(paste0(
377 basename(file_path),
378 " ",
379 mutator$from,
380 " \u2192 ",
381 mutator$to
382 )))
383 for (i in changed) {
384 self$cat_line(cli::col_red(paste0(
385 " ",
386 i,
387 "- ",
388 trimws(original_code[[i]], "right")
389 )))
390 self$cat_line(cli::col_green(paste0(
391 " ",
392 i,
393 "+ ",
394 trimws(mutated_code[[i]], "right")
395 )))
396 }
397 },
398  
399 cat_stats = function() {
400 results <- do.call(rbind, lapply(self$results, as.data.frame))
401 k <- sum(results$killed)
402 s <- sum(results$survived)
403 n <- sum(results$no_coverage)
404 t <- sum(results$total)
405 e <- sum(results$errors)
406 score <- self$current_score
407 self$cat_line()
408 self$rule(cli::style_bold("Results"))
409 self$cat_line(
410 "[ ",
411 cli::col_green("KILLED "),
412 k,
413 " | ",
414 cli::col_red("SURVIVED "),
415 s,
416 " | ",
417 cli::col_grey("NO COVERAGE "),
418 n,
419 " | ",
420 cli::col_yellow("ERRORS "),
421 e,
422 " | ",
423 "TOTAL ",
424 t,
425 " | ",
426 cli::style_bold(cli::col_green(sprintf("SCORE %.1f%%", score * 100))), 1 mutant
survived * → /
- cli::style_bold(cli::col_green(sprintf("SCORE %.1f%%", score * 100))), + cli::style_bold(cli::col_green(sprintf("SCORE %.1f%%", score / 100))),
427 " ]"
428 )
429 }
430 )
431 )
R/reporter.R 7 survived 6 killed score 46%
1 #' @title Reporter for Mutation Testing
2 #'
3 #' @description
4 #' The job of a mutation reporter is to aggregate and display the results of mutation tests.
5 #' It tracks each mutation attempt, reporting on whether the tests killed the mutation or the mutation survived.
6 #'
7 #' @field test_reporter Reporter to use for the testthat::test_dir function
8 #' @field out Output destination for reporter messages
9 #' @field width Width of the console in characters
10 #' @field unicode Whether Unicode output is supported
11 #' @field crayon Whether colored output is supported
12 #' @field rstudio Whether running in RStudio
13 #' @field hyperlinks Whether terminal hyperlinks are supported
14 #' @field current_file Path of the file currently being mutated
15 #' @field current_mutator Mutator currently being applied
16 #' @field plan Complete mutation plan for the test run
17 #' @field results List of mutation test results, indexed by file path
18 #' @field current_score Current score of the mutation tests
19 #' @field error_messages List of error messages from failed mutant runs
20 #'
21 #' @md
22 #' @export
23 #' @importFrom rlang `%||%`
24 #' @family MutationReporter
25 MutationReporter <- R6::R6Class(
26 classname = "MutationReporter",
27 public = list(
28 # Define test reporter that will be used for running tests
29 test_reporter = NULL,
30  
31 # Output destination
32 out = NULL,
33  
34 # Display settings
35 width = 80,
36 unicode = TRUE,
37 crayon = TRUE,
38 rstudio = TRUE,
39 hyperlinks = TRUE,
40  
41 # Current state
42 current_file = NULL,
43 current_mutator = NULL,
44  
45 plan = NULL,
46  
47 # Track mutations by file
48 results = NULL,
49 current_score = NA_real_,
50 error_messages = list(),
51  
52 #' @description Initialize a new reporter
53 #' @param test_reporter Reporter to use for the testthat::test_dir function
54 #' @param file Output destination (default: stdout)
55 initialize = function(test_reporter = "silent", file = stdout()) {
56 self$test_reporter <- test_reporter
57 self$out <- file
58  
59 # Capture display settings
60 self$width <- cli::console_width()
61 self$unicode <- cli::is_utf8_output()
62 self$crayon <- cli::num_ansi_colors() > 1 2 mutants
survived > → <
- self$crayon <- cli::num_ansi_colors() > 1 + self$crayon <- cli::num_ansi_colors() < 1
survived > → >=
- self$crayon <- cli::num_ansi_colors() > 1 + self$crayon <- cli::num_ansi_colors() >= 1
63 self$rstudio <- Sys.getenv("RSTUDIO") == "1" 1 mutant
survived == → !=
- self$rstudio <- Sys.getenv("RSTUDIO") == "1" + self$rstudio <- Sys.getenv("RSTUDIO") != "1"
64 self$hyperlinks <- cli::ansi_hyperlink_types()[["run"]]
65 },
66  
67 #' @description Start reporter
68 #' @param plan The complete mutation plan
69 #' @param temp_dir Path to the temporary directory for testing
70 start_reporter = function(plan = NULL) {
71 self$plan <- plan
72 self$results <- list()
73 self$current_score <- NA_real_
74 self$error_messages <- list()
75 },
76  
77 #' @description Start testing a file
78 #' @param filename Path to the file being mutated
79 start_file = function(filename) {
80 self$current_file <- filename
81 self$results[[filename]] <- self$results[[filename]] %||%
82 list(
83 total = 0,
84 killed = 0,
85 survived = 0,
86 no_coverage = 0,
87 errors = 0
88 )
89 },
90  
91 #' @description Start testing with a specific mutator
92 #' @param mutator The mutator being applied
93 start_mutator = function(mutator) {
94 self$current_mutator <- mutator
95 },
96  
97 #' @description Add a mutation test result
98 #' @param plan Current testing plan. See `muttest_plan()`.
99 #' @param killed Whether the mutation was killed by tests
100 #' @param survived Number of survived mutations
101 #' @param no_coverage Number of mutants with no test coverage
102 #' @param errors Number of errors encountered
103 #' @param error Optional error condition from a failed run
104 #' @param original_code Original source lines before mutation
105 #' @param mutated_code Mutated source lines
106 add_result = function(
107 plan,
108 killed,
109 survived,
110 no_coverage,
111 errors,
112 error = NULL,
113 original_code = NULL,
114 mutated_code = NULL
115 ) {
116 filename <- plan$filename
117 self$results[[filename]]$total <- self$results[[filename]]$total + 1 1 mutant
survived + → -
- self$results[[filename]]$total <- self$results[[filename]]$total + 1 + self$results[[filename]]$total <- self$results[[filename]]$total - 1
118 self$results[[filename]]$killed <- self$results[[filename]]$killed + 1 mutant
killed + → -
- self$results[[filename]]$killed <- self$results[[filename]]$killed + + self$results[[filename]]$killed <- self$results[[filename]]$killed -
119 killed
120 self$results[[filename]]$survived <- self$results[[filename]]$survived + 1 mutant
killed + → -
- self$results[[filename]]$survived <- self$results[[filename]]$survived + + self$results[[filename]]$survived <- self$results[[filename]]$survived -
121 survived
122 self$results[[filename]]$no_coverage <- self$results[[
123 filename
124 ]]$no_coverage + 1 mutant
survived + → -
- ]]$no_coverage + + ]]$no_coverage -
125 no_coverage
126 self$results[[filename]]$errors <- self$results[[filename]]$errors + 1 mutant
killed + → -
- self$results[[filename]]$errors <- self$results[[filename]]$errors + + self$results[[filename]]$errors <- self$results[[filename]]$errors -
127 errors
128 if (!is.null(error)) {
129 self$error_messages <- c(
130 self$error_messages,
131 list(conditionMessage(error))
132 )
133 }
134 # No-coverage mutants are excluded from the score: an untested mutant says
135 # nothing about test quality. Denominator = killed + survived + errors.
136 killed_total <- sum(vapply(self$results, `[[`, numeric(1), "killed"))
137 scored_total <- killed_total + 1 mutant
killed + → -
- scored_total <- killed_total + + scored_total <- killed_total -
138 sum(vapply(self$results, `[[`, numeric(1), "survived")) + 1 mutant
killed + → -
- sum(vapply(self$results, `[[`, numeric(1), "survived")) + + sum(vapply(self$results, `[[`, numeric(1), "survived")) -
139 sum(vapply(self$results, `[[`, numeric(1), "errors"))
140 self$current_score <- if (scored_total > 0) { 2 mutants
killed > → <
- self$current_score <- if (scored_total > 0) { + self$current_score <- if (scored_total < 0) {
survived > → >=
- self$current_score <- if (scored_total > 0) { + self$current_score <- if (scored_total >= 0) {
141 killed_total / scored_total 1 mutant
survived / → *
- killed_total / scored_total + killed_total * scored_total
142 } else {
143 NA_real_
144 }
145 },
146  
147 #' @description Update status (no-op in base class)
148 #' @param force Ignored
149 update = function(force = FALSE) {},
150  
151 #' @description End testing with current mutator
152 end_mutator = function() {
153 self$current_mutator <- NULL
154 },
155  
156 #' @description End testing current file
157 end_file = function() {
158 self$current_file <- NULL
159 },
160  
161 #' @description End reporter and show summary
162 end_reporter = function() {},
163  
164 #' @description Get the current score
165 get_score = function() {
166 self$current_score
167 },
168  
169 #' @description Print a message to the output
170 #' @param ... Message to print
171 cat_line = function(...) {
172 cli::cat_line(..., file = self$out)
173 },
174  
175 #' @description Print a message to the output with a rule
176 #' @param ... Message to print
177 rule = function(...) {
178 cli::cat_rule(..., file = self$out)
179 }
180 )
181 )
182  
183 #' Create a default reporter
184 #'
185 #' @param ... Arguments passed to the `?ProgressMutationReporter` constructor.
186 #' @md
187 #' @export
188 #' @family MutationReporter
189 default_reporter <- function(...) {
190 ProgressMutationReporter$new(...)
191 }