Skip to content

Commit c7ece8f

Browse files
DivyanshuVortexDivyanshuVortex
committed
feat(stats/mannwhitneyu): add Mann–Whitney U test package fix-2
1 parent e6b0c4f commit c7ece8f

File tree

2 files changed

+141
-103
lines changed
  • lib/node_modules/@stdlib/stats/mannwhitneyu/test/fixtures/r
  • tools/lint/r

2 files changed

+141
-103
lines changed

‎lib/node_modules/@stdlib/stats/mannwhitneyu/test/fixtures/r/runner.R‎

Lines changed: 135 additions & 100 deletions
Original file line numberDiff line numberDiff line change
@@ -16,114 +16,149 @@
1616
# See the License for the specific language governing permissions and
1717
# limitations under the License.
1818

19-
# Set the precision to 16 digits:
20-
options( digits = 16L );
19+
# Ensure jsonlite is available (works on R 3.5.3):
20+
if (!requireNamespace("jsonlite", quietly = TRUE)) {
21+
install.packages("jsonlite", repos = "https://cloud.r-project.org", quiet = TRUE)
22+
if (!requireNamespace("jsonlite", quietly = TRUE)) {
23+
message("jsonlite unavailable; cannot generate fixtures.")
24+
quit(status = 0)
25+
}
26+
}
27+
28+
# Set numeric precision:
29+
options(digits = 16L)
2130

22-
#' Generate test fixtures.
23-
#'
24-
#' @examples
25-
#' main();
2631
main <- function() {
27-
#' Get the script filepath.
28-
#'
29-
#' @return The absolute path of this script
30-
#'
31-
#' @examples
32-
#' filepath <- get_script_path();
32+
3333
get_script_path <- function() {
34-
args <- commandArgs( trailingOnly = FALSE );
35-
needle <- '--file=';
36-
match <- grep( needle, args );
37-
if ( length( match ) > 0L ) {
38-
# Rscript:
39-
filepath <- sub( needle, '', args[match] );
40-
} else {
41-
ls_vars <- ls( sys.frames()[[1L]] )
42-
if ( 'fileName' %in% ls_vars ) {
43-
# Source'd via RStudio:
44-
filepath <- sys.frames()[[1L]]$fileName; # nolint
45-
} else {
46-
# Source'd via R console:
47-
filepath <- sys.frames()[[1L]]$ofile;
48-
}
49-
}
50-
return( normalizePath( filepath ) );
34+
args <- commandArgs(trailingOnly = FALSE)
35+
needle <- "--file="
36+
match <- grep(needle, args)
37+
if (length(match) > 0L) {
38+
filepath <- sub(needle, "", args[match])
39+
} else {
40+
ls_vars <- ls(sys.frames()[[1L]])
41+
if ("fileName" %in% ls_vars) {
42+
filepath <- sys.frames()[[1L]]$fileName # nolint
43+
} else {
44+
filepath <- sys.frames()[[1L]]$ofile
5145
}
52-
53-
#' Convert a data structure to JSON.
54-
#'
55-
#' @param x A data structure to convert
56-
#' @return JSON blob
57-
#'
58-
#' @examples
59-
#' x <- seq( -6.5, 25, 0.5 );
60-
#' json <- to_json( x );
61-
to_json <- function( x ) {
62-
return( jsonlite::toJSON( x, digits = 16L, auto_unbox = TRUE ) );
6346
}
64-
65-
#' Generate an output absolute filepath based on the script directory.
66-
#'
67-
#' @param name An output filename
68-
#' @return An absolute filepath
69-
#'
70-
#' @examples
71-
#' filepath <- get_filepath( 'data.json' );
72-
get_filepath <- function( name ) {
73-
return( paste( source_dir, '/', name, sep = '' ) );
47+
normalizePath(filepath)
7448
}
7549

76-
# Get the directory of this script:
77-
source_dir <- dirname( get_script_path() );
78-
79-
# Generate test fixture data:
80-
# Note: We set exact=FALSE to force normal approximation matching JS implementation.
81-
high_p_res <- wilcox.test( c( 10.0, 11.0, 12.0, 13.0, 14.0 ), c( 1.0, 2.0, 3.0, 4.0, 5.0 ), alternative = 'two.sided', correct = FALSE, exact = FALSE );
82-
u_high <- min( high_p_res$statistic, ( 5.0 * 5.0 ) - high_p_res$statistic );
83-
high_p <- list( x = c( 10.0, 11.0, 12.0, 13.0, 14.0 ), y = c( 1.0, 2.0, 3.0, 4.0, 5.0 ), U = u_high, pValue = high_p_res$p.value, alternative = 'two-sided', alpha = 0.05,
84-
rejected = high_p_res$p.value <= 0.05 );
85-
86-
medium_p_res <- wilcox.test( c( 5.0, 6.0, 7.0, 8.0 ), c( 4.0, 5.0, 6.0, 7.0 ), alternative = 'two.sided', correct = FALSE, exact = FALSE );
87-
u_med <- min( medium_p_res$statistic, ( 4.0 * 4.0 ) - medium_p_res$statistic );
88-
medium_p <- list( x = c( 5.0, 6.0, 7.0, 8.0 ), y = c( 4.0, 5.0, 6.0, 7.0 ), U = u_med, pValue = medium_p_res$p.value, alternative = 'two-sided', alpha = 0.05,
89-
rejected = medium_p_res$p.value <= 0.05 );
90-
91-
low_p_res <- wilcox.test( c( 5.0, 6.0, 7.0, 8.0 ), c( 6.0, 7.0, 8.0, 9.0 ), alternative = 'two.sided', correct = FALSE, exact = FALSE );
92-
u_low <- min( low_p_res$statistic, ( 4.0 * 4.0 ) - low_p_res$statistic );
93-
low_p <- list( x = c( 5.0, 6.0, 7.0, 8.0 ), y = c( 6.0, 7.0, 8.0, 9.0 ), U = u_low, pValue = low_p_res$p.value, alternative = 'two-sided', alpha = 0.05,
94-
rejected = low_p_res$p.value <= 0.05 );
95-
96-
less <- wilcox.test( c( 5.0, 6.0, 7.0, 8.0 ), c( 6.0, 7.0, 8.0, 9.0 ), alternative = 'less', correct = FALSE, exact = FALSE );
97-
less <- list( x = c( 5.0, 6.0, 7.0, 8.0 ), y = c( 6.0, 7.0, 8.0, 9.0 ), U = less$statistic, pValue = less$p.value, alternative = 'less', alpha = 0.05,
98-
rejected = less$p.value <= 0.05 );
99-
100-
greater <- wilcox.test( c( 5.0, 6.0, 7.0, 8.0 ), c( 4.0, 5.0, 6.0, 7.0 ), alternative = 'greater', correct = FALSE, exact = FALSE );
101-
greater <- list( x = c( 5.0, 6.0, 7.0, 8.0 ), y = c( 4.0, 5.0, 6.0, 7.0 ), U = greater$statistic, pValue = greater$p.value, alternative = 'greater', alpha = 0.05,
102-
rejected = greater$p.value <= 0.05 );
103-
104-
# Convert fixture data to JSON:
105-
high_p <- to_json( high_p );
106-
medium_p <- to_json( medium_p );
107-
low_p <- to_json( low_p );
108-
less <- to_json( less );
109-
greater <- to_json( greater );
110-
111-
112-
# Write the data to file...
113-
filepath <- get_filepath( 'high_p.json' );
114-
write( high_p, filepath );
115-
116-
filepath <- get_filepath( 'medium_p.json' );
117-
write( medium_p, filepath );
118-
119-
filepath <- get_filepath( 'low_p.json' );
120-
write( low_p, filepath );
50+
to_json <- function(x) {
51+
jsonlite::toJSON(x, digits = 16L, auto_unbox = TRUE)
52+
}
12153

122-
filepath <- get_filepath( 'less.json' );
123-
write( less, filepath );
54+
get_filepath <- function(name) {
55+
paste(source_dir, "/", name, sep = "")
56+
}
12457

125-
filepath <- get_filepath( 'greater.json' );
126-
write( greater, filepath );
58+
source_dir <- dirname(get_script_path())
59+
60+
# Generate test fixture data using base R wilcox.test:
61+
high_p_res <- wilcox.test(
62+
c(10, 11, 12, 13, 14),
63+
c(1, 2, 3, 4, 5),
64+
alternative = "two.sided",
65+
correct = FALSE,
66+
exact = FALSE
67+
)
68+
u_high <- min(high_p_res$statistic, (5 * 5) - high_p_res$statistic)
69+
high_p <- list(
70+
x = c(10, 11, 12, 13, 14),
71+
y = c(1, 2, 3, 4, 5),
72+
U = u_high,
73+
pValue = high_p_res$p.value,
74+
alternative = "two-sided",
75+
alpha = 0.05,
76+
rejected = high_p_res$p.value <= 0.05
77+
)
78+
79+
medium_p_res <- wilcox.test(
80+
c(5, 6, 7, 8),
81+
c(4, 5, 6, 7),
82+
alternative = "two.sided",
83+
correct = FALSE,
84+
exact = FALSE
85+
)
86+
u_med <- min(medium_p_res$statistic, (4 * 4) - medium_p_res$statistic)
87+
medium_p <- list(
88+
x = c(5, 6, 7, 8),
89+
y = c(4, 5, 6, 7),
90+
U = u_med,
91+
pValue = medium_p_res$p.value,
92+
alternative = "two-sided",
93+
alpha = 0.05,
94+
rejected = medium_p_res$p.value <= 0.05
95+
)
96+
97+
low_p_res <- wilcox.test(
98+
c(5, 6, 7, 8),
99+
c(6, 7, 8, 9),
100+
alternative = "two.sided",
101+
correct = FALSE,
102+
exact = FALSE
103+
)
104+
u_low <- min(low_p_res$statistic, (4 * 4) - low_p_res$statistic)
105+
low_p <- list(
106+
x = c(5, 6, 7, 8),
107+
y = c(6, 7, 8, 9),
108+
U = u_low,
109+
pValue = low_p_res$p.value,
110+
alternative = "two-sided",
111+
alpha = 0.05,
112+
rejected = low_p_res$p.value <= 0.05
113+
)
114+
115+
less <- wilcox.test(
116+
c(5, 6, 7, 8),
117+
c(6, 7, 8, 9),
118+
alternative = "less",
119+
correct = FALSE,
120+
exact = FALSE
121+
)
122+
less <- list(
123+
x = c(5, 6, 7, 8),
124+
y = c(6, 7, 8, 9),
125+
U = less$statistic,
126+
pValue = less$p.value,
127+
alternative = "less",
128+
alpha = 0.05,
129+
rejected = less$p.value <= 0.05
130+
)
131+
132+
greater <- wilcox.test(
133+
c(5, 6, 7, 8),
134+
c(4, 5, 6, 7),
135+
alternative = "greater",
136+
correct = FALSE,
137+
exact = FALSE
138+
)
139+
greater <- list(
140+
x = c(5, 6, 7, 8),
141+
y = c(4, 5, 6, 7),
142+
U = greater$statistic,
143+
pValue = greater$p.value,
144+
alternative = "greater",
145+
alpha = 0.05,
146+
rejected = greater$p.value <= 0.05
147+
)
148+
149+
# Convert to JSON
150+
high_p <- to_json(high_p)
151+
medium_p <- to_json(medium_p)
152+
low_p <- to_json(low_p)
153+
less <- to_json(less)
154+
greater <- to_json(greater)
155+
156+
# Write fixtures
157+
write(high_p, get_filepath("high_p.json"))
158+
write(medium_p, get_filepath("medium_p.json"))
159+
write(low_p, get_filepath("low_p.json"))
160+
write(less, get_filepath("less.json"))
161+
write(greater, get_filepath("greater.json"))
127162
}
128163

129-
main();
164+
main()

‎tools/lint/r/linter.R‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,7 @@
2525
# [1]: https://github.com/jimhester/lintr
2626

2727
# Ensure that the `lintr` package is installed...
28-
if ( !requireNamespace( 'lintr', quietly = TRUE ) ) {
28+
if ( !require( 'lintr', quietly = TRUE, character.only = TRUE ) ) {
2929
install.packages( 'lintr', repos = 'http://lib.stat.cmu.edu/R/CRAN/', quiet = TRUE );
3030
}
3131

@@ -39,7 +39,7 @@ if ( n == 0L ) {
3939
}
4040

4141
# Specify which linters to use...
42-
linters <- lintr::linters_with_defaults( defaults = lintr::default_linters,
42+
linters <- lintr::linters_with_defaults( defaults = default_linters,
4343
# Check that no absolute paths are used:
4444
absolute_path_linter = lintr::absolute_path_linter(),
4545

@@ -52,6 +52,9 @@ linters <- lintr::linters_with_defaults( defaults = lintr::default_linters,
5252
# Allow commented code outside roxygen blocks:
5353
commented_code_linter = NULL, # lintr::commented_code_linter,
5454

55+
# Require the `[[` operator is used when extracting a single element from an object, not `[` (subsetting) or `$` (interactive use):
56+
extraction_operator_linter = lintr::extraction_operator_linter(),
57+
5558
# Require that integers are explicitly typed using the form `1L` instead of `1`:
5659
implicit_integer_linter = lintr::implicit_integer_linter(),
5760

@@ -108,7 +111,7 @@ linters <- lintr::linters_with_defaults( defaults = lintr::default_linters,
108111
T_and_F_symbol_linter = lintr::T_and_F_symbol_linter(),
109112

110113
# Report the use of undesirable functions (e.g., `attach` or `sapply`) and suggest an alternative:
111-
undesirable_function_linter = lintr::undesirable_function_linter( fun = within( lintr::default_undesirable_functions, rm( options ) ) ),
114+
undesirable_function_linter = lintr::undesirable_function_linter( fun = within( default_undesirable_functions, rm( options ) ) ),
112115

113116
# Report the use of undesirable operators (e.g., `:::` or `<<-`) and suggest an alternative:
114117
undesirable_operator_linter = lintr::undesirable_operator_linter(),

0 commit comments

Comments
 (0)