Skip to content

Commit 9d673c4

Browse files
Matías Castillo AguilarMatías Castillo Aguilar
Matías Castillo Aguilar
authored and
Matías Castillo Aguilar
committed
-
1 parent 6837f55 commit 9d673c4

17 files changed

+423
-300
lines changed

‎NAMESPACE‎

Lines changed: 3 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

3+
S3method(as.data.frame,writR)
4+
S3method(print,writR)
35
export(aov_r)
46
export(autest)
57
export(cent_disp)
@@ -12,6 +14,7 @@ export(lablr)
1214
export(one_sample)
1315
export(pairs_two_sample)
1416
export(pairwise_test)
17+
export(sphericity_check)
1518
export(style.p)
1619
export(two_sample)
1720
importFrom(PMCMRplus,durbinAllPairsTest)

‎R/aov_r.R‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -38,10 +38,10 @@ aov_r <- function(data,
3838

3939
is.empty <- function(i) length(i) == 0
4040

41-
data <- droplevels(data[j = .SD, .SDcols = c(rowid, response, between, within)])
4241
is.null(response) && stop("'response' can't be null", call. = FALSE)
4342
is.empty(between) && is.empty(within) && stop("Need to specify one of between or within factors", call. = FALSE)
4443
is.null(rowid) && stop("'rowid' can't be null", call. = FALSE)
44+
data <- droplevels(data[j = .SD, .SDcols = c(rowid, response, between, within)])
4545

4646
model <- suppressMessages(
4747
suppressWarnings(
@@ -99,7 +99,7 @@ aov_r <- function(data,
9999
method = data.table::fcase(rn %chin% between, "Fisher's ANOVA",
100100
rn %chin% within, within_method,
101101
utils::combn(within, 1, grepl, T, rn), within_method),
102-
alternative = NA,
102+
alternative = NA_character_,
103103
estimate = efs[[2L]],
104104
conf.level = efs$CI,
105105
conf.low = efs$CI_low,

‎R/contingency.R‎

Lines changed: 9 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,7 @@ contingency <- function(data
4242
.f <- stats::fisher.test(tab)
4343
.es <- try(expr = effectsize::oddsratio(tab, ci = conf.level), silent = TRUE)
4444
if("try-error" %chin% class(.es)) {
45-
.es <- rep(NA, 4)
45+
.es <- rep(NA_real_, 4)
4646
.es <- `names<-`(.es, rep(NA, 4))
4747
.f$method <- paste(.f$method, "without OR")
4848
}
@@ -53,14 +53,14 @@ contingency <- function(data
5353
}
5454

5555
res <- list(
56-
y = if (is.null(y)) as.character(NA) else y,
56+
y = if (is.null(y)) NA_character_ else y,
5757
x = x,
58-
statistic = if (is.null(.f$statistic)) as.numeric(NA) else .f$statistic,
59-
df = if (is.null(.f$parameter)) as.numeric(NA) else .f$parameter,
60-
df.error = as.numeric(NA),
58+
statistic = if (is.null(.f$statistic)) NA_real_ else .f$statistic,
59+
df = if (is.null(.f$parameter)) NA_real_ else .f$parameter,
60+
df.error = NA_real_,
6161
p.value = .f$p.value,
6262
method = .f$method,
63-
alternative = as.character(NA),
63+
alternative = NA_character_,
6464
estimate = as.numeric(.es[[1L]]),
6565
conf.level = as.numeric(.es[[2L]]),
6666
conf.low = as.numeric(.es[[3L]]),
@@ -70,9 +70,11 @@ contingency <- function(data
7070
)
7171

7272
if(lbl) {
73-
res <- lablr(res, markdown = markdown)
73+
res <- lablr(res, markdown)
7474
}
7575

76+
class(res) <- c("writR", "list")
77+
7678
return(res)
7779
}
7880

‎R/k_sample.R‎

Lines changed: 50 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -121,7 +121,7 @@ k_sample <- function(data, x, y,
121121
} else {
122122
paste("Repeated measures ANOVA with", sphericity, "correction")
123123
},
124-
alternative = as.character(NA),
124+
alternative = NA_character_,
125125
estimate = es[[2L]],
126126
conf.level = es[["CI"]],
127127
conf.low = es[["CI_low"]],
@@ -130,7 +130,13 @@ k_sample <- function(data, x, y,
130130
n_obs = length(y_var) / length(x_lvl)
131131
)
132132

133-
if(lbl) return(lablr(test, markdown)) else return(test)
133+
if(lbl) {
134+
test <- lablr(test, markdown)
135+
}
136+
137+
class(test) <- c("writR", "list")
138+
139+
return(test)
134140
} else {
135141

136142
test <- stats::oneway.test(
@@ -148,7 +154,7 @@ k_sample <- function(data, x, y,
148154
df.error = test$parameter[["denom df"]],
149155
p.value = test$p.value,
150156
method = if (var.equal) "Fisher's ANOVA" else "Welch's ANOVA",
151-
alternative = as.character(NA),
157+
alternative = NA_character_,
152158
estimate = es[[1L]],
153159
conf.level = es[["CI"]],
154160
conf.low = es[["CI_low"]],
@@ -157,7 +163,13 @@ k_sample <- function(data, x, y,
157163
n_obs = length(y_var)
158164
)
159165

160-
if(lbl) return(lablr(test, markdown)) else return(test)
166+
if(lbl) {
167+
test <- lablr(test, markdown)
168+
}
169+
170+
class(test) <- c("writR", "list")
171+
172+
return(test)
161173
}
162174
}
163175
# Non-parametric statistics
@@ -183,10 +195,10 @@ k_sample <- function(data, x, y,
183195
"x" = x,
184196
statistic = test$statistic,
185197
df = as.double(test$parameter),
186-
df.error = as.double(NA),
198+
df.error = NA_real_,
187199
p.value = test$p.value,
188200
method = test$method,
189-
alternative = as.character(NA),
201+
alternative = NA_character_,
190202
estimate = es[[1L]],
191203
conf.level = es[["CI"]],
192204
conf.low = es[["CI_low"]],
@@ -195,7 +207,13 @@ k_sample <- function(data, x, y,
195207
n_obs = length(y_var) / length(x_lvl)
196208
)
197209

198-
if(lbl) return(lablr(test, markdown)) else return(test)
210+
if(lbl) {
211+
test <- lablr(test, markdown)
212+
}
213+
214+
class(test) <- c("writR", "list")
215+
216+
return(test)
199217
# Kruskal-Wallis rank-sum test for independent samples
200218
} else {
201219
test <- stats::kruskal.test(
@@ -214,10 +232,10 @@ k_sample <- function(data, x, y,
214232
"x" = x,
215233
statistic = test$statistic,
216234
df = as.double(test$parameter),
217-
df.error = as.double(NA),
235+
df.error = NA_real_,
218236
p.value = test$p.value,
219237
method = test$method,
220-
alternative = as.character(NA),
238+
alternative = NA_character_,
221239
estimate = es[[1L]],
222240
conf.level = es[["CI"]],
223241
conf.low = es[["CI_low"]],
@@ -226,7 +244,13 @@ k_sample <- function(data, x, y,
226244
n_obs = length(y_var)
227245
)
228246

229-
if(lbl) return(lablr(test, markdown)) else return(test)
247+
if(lbl) {
248+
test <- lablr(test, markdown)
249+
}
250+
251+
class(test) <- c("writR", "list")
252+
253+
return(test)
230254
}
231255
}
232256
# Robust statistics
@@ -258,7 +282,7 @@ k_sample <- function(data, x, y,
258282
df.error = as.double(test$df2),
259283
p.value = test$p.value,
260284
method = "one-way repeated measures ANOVA for trimmed means",
261-
alternative = as.character(NA),
285+
alternative = NA_character_,
262286
estimate = es[[1L]],
263287
conf.level = 0.95,
264288
conf.low = es[[2L]],
@@ -267,7 +291,13 @@ k_sample <- function(data, x, y,
267291
n_obs = length(y_var) / length(x_lvl)
268292
)
269293

270-
if(lbl) return(lablr(test, markdown)) else return(test)
294+
if(lbl) {
295+
test <- lablr(test, markdown)
296+
}
297+
298+
class(test) <- c("writR", "list")
299+
300+
return(test)
271301
# one-way ANOVA for trimmed means
272302
} else {
273303
test <- WRS2::t1way(
@@ -284,7 +314,7 @@ k_sample <- function(data, x, y,
284314
df.error = as.double(test$df2),
285315
p.value = test$p.value,
286316
method = "one-way ANOVA for trimmed means",
287-
alternative = as.character(NA),
317+
alternative = NA_character_,
288318
estimate = test$effsize,
289319
conf.level = 0.95,
290320
conf.low = test$effsize_ci[[1L]],
@@ -293,7 +323,13 @@ k_sample <- function(data, x, y,
293323
n_obs = length(y_var)
294324
)
295325

296-
if(lbl) return(lablr(test, markdown)) else return(test)
326+
if(lbl) {
327+
test <- lablr(test, markdown)
328+
}
329+
330+
class(test) <- c("writR", "list")
331+
332+
return(test)
297333
}
298334
}
299335
}

‎R/lablr.R‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -130,6 +130,9 @@ lablr <- function(t, markdown = FALSE) {
130130
ci = (.ci <- paste0(ci., format(round(t$conf.low, 2), nsmall = 2), ", ", format(round(t$conf.high, 2), nsmall = 2), "]")),
131131
full = paste(.p, .es, .ci, sep = ", ")
132132
)
133+
134+
class(res) <- c("writR", "list")
135+
133136
return(res)
134137
}
135138
if(method == "Fisher's Exact Test for Count Data without OR") {
@@ -140,6 +143,9 @@ lablr <- function(t, markdown = FALSE) {
140143
ci = as.character(NA),
141144
full = .p
142145
)
146+
147+
class(res) <- c("writR", "list")
148+
143149
return(res)
144150
}
145151

@@ -160,5 +166,7 @@ lablr <- function(t, markdown = FALSE) {
160166
full = paste(.stats, .p, .es, .ci, sep = ", ")
161167
)
162168

169+
class(res) <- c("writR", "list")
170+
163171
return(res)
164172
}

‎R/miscellaneous.R‎

Lines changed: 35 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -86,15 +86,14 @@ is_normal <- function(x, alpha = 0.05, test = NULL) {
8686
#' @param x Grouping factor.
8787
#' @param alpha Threshold for null hipotesis (of normality) rejection.
8888
#' @param center A function to compute the center of each group; mean gives the original Levene's test; the default, median, provides a more robust test.
89-
#' @importFrom nortest lillie.test
9089
#' @importFrom stats complete.cases anova lm median
9190
#' @export
9291

93-
is_var.equal <- function(y, x, alpha = 0.05, center = median) {
94-
valid <- complete.cases(y, x)
92+
is_var.equal <- function(y, x, alpha = 0.05, center = stats::median) {
93+
valid <- stats::complete.cases(y, x)
9594
meds <- tapply(y[valid], x[valid], center)
9695
resp <- abs(y - meds[x])
97-
anova(lm(resp ~ x))[["Pr(>F)"]][[1]] > alpha
96+
stats::anova(stats::lm(resp ~ x))[["Pr(>F)"]][[1]] > alpha
9897
}
9998

10099
#' @title Mauchly's Test of Sphericity
@@ -197,6 +196,7 @@ HF <- function(model, gg = NULL) {
197196
#' @description Internal function inside `k_sample`. Return the Spherecity correction suggested based on Mauchly test in one-way repeated measures designs
198197
#'
199198
#' @param model A repeated measures ANOVA model using Afex.
199+
#' @export
200200

201201
sphericity_check <- function(model) {
202202
.m <- model$Anova
@@ -206,3 +206,34 @@ sphericity_check <- function(model) {
206206
if(is_hf || is_hf_too) "HF" else "GG"
207207
}
208208
}
209+
210+
#' @title Print method for writR objects
211+
#' @name print.writR
212+
#' @param x A writR object from any of one_sample, two_sample, k_sample, autest or contingency.
213+
#' @param ... Currently ignored
214+
#' @importFrom data.table as.data.table
215+
#' @export
216+
217+
print.writR <- function(x, ...) {
218+
x <- data.table::as.data.table(
219+
x = x[!sapply(x, anyNA)]
220+
)
221+
print(x)
222+
}
223+
224+
#' @title as.data.frame method for writR objects
225+
#' @name as.data.frame.writR
226+
#' @param x A writR object from any of one_sample, two_sample, k_sample, autest or contingency.
227+
#' @param row.names Exported from other methods.
228+
#' @param optional Exported from other methods.
229+
#' @param ... Currently ignored
230+
#' @export
231+
232+
as.data.frame.writR <- function(x, row.names = NULL, optional = FALSE, ...) {
233+
as.data.frame(
234+
x = x[!sapply(x, anyNA)],
235+
row.names = row.names,
236+
optional = optional
237+
)
238+
}
239+

0 commit comments

Comments
 (0)