.test_stu_unequal <- function(n1,n2, sd1, sd2){
nu <- ( (1/n1 - ( ((sd2/sd1)**2) / n2) )**2 ) /
( 1/((n1**2) * (n1-1)) + ( ((sd2/sd1)**4) / ((n2**2) * (n2-1)) ) )
anom_cri90 <- sqrt( (sd1**2)/n1 + (sd2**2)/n2 ) * qt(p = 1-0.1, df = round(nu))
anom_cri95 <- sqrt( (sd1**2)/n1 + (sd2**2)/n2 ) * qt(p = 1-0.05, df = round(nu))
anom_cri99 <- sqrt( (sd1**2)/n1 + (sd2**2)/n2 ) * qt(p = 1-0.01, df = round(nu))
return(list(anom_cri90 = anom_cri90,
anom_cri95 = anom_cri95,
anom_cri99= anom_cri99))
}
composite <- function(data_array, id_time,
id_clim = 'All', test = TRUE, FUTURE = FALSE){
#' Test using:
#' Ruxton, G. D. (2006).
#' The unequal variance t-test is an underused alternative to Student's t-test and the Mann–Whitney U test.
#' Behavioral Ecology, 17(4), 688-690.
checks <- makeAssertCollection()
assert_array(data_array,mode = 'numeric',d = 3, add = checks)
assert_numeric(id_time,upper = dim(data_array)[3], lower = 1, add = checks)
assert_logical(test, add = checks)
assert_logical(FUTURE, add = checks)
reportAssertions(checks)
if(FUTURE){
if(is.character(id_clim)){
assert_character(id_clim,names = 'All', len = 1)
id_clim <- 1:dim(data_array)[3]
}else if(is.null(id_clim)){
clim <- future_apply(X = data_array[,,id_time],MARGIN = 1:2, FUN = mean, na.rm = TRUE)
test90 <- NULL
test95 <- NULL
test99 <- NULL
return(list(compo = clim, test90 = test90,
test95 = test95, test99 = test99))
}else{
assert_numeric(id_clim,upper = dim(data_array)[3], lower = 1)
}
clim <- future_apply(X = data_array[,,id_clim],MARGIN = 1:2, FUN = mean, na.rm = TRUE)
result <- future_apply(X = data_array[,,id_time],MARGIN = 1:2, FUN = mean, na.rm = TRUE)
result <- result - clim
if(test){
n_mat_clim <- future_apply(X = !is.na(data_array[,,id_clim]),MARGIN = 1:2, FUN = sum)
n_mat <- future_apply(X = !is.na(data_array[,,id_time]),MARGIN = 1:2, FUN = sum)
sd_mat <- future_apply(X = data_array[,,id_clim],MARGIN = 1:2, FUN = sd, na.rm = TRUE)
sd_clim <- future_apply(X = data_array[,,id_time],MARGIN = 1:2, FUN = sd, na.rm = TRUE)
asd <- .test_stu_unequal(n1 = n_mat_clim, sd1 = sd_clim, n2 = n_mat, sd2 = sd_mat)
test90 <- abs(result) > asd$anom_cri90
test95 <- abs(result) > asd$anom_cri95
test99 <- abs(result) > asd$anom_cri99
}else{
test90 <- NULL
test95 <- NULL
test99 <- NULL
}
return(list(compo = result, test90 = test90,
test95 = test95, test99 = test99))
}else{
if(is.character(id_clim)){
assert_character(id_clim,names = 'All', len = 1)
id_clim <- 1:dim(data_array)[3]
}else if(is.null(id_clim)){
clim <- apply(X = data_array[,,id_time],MARGIN = 1:2, FUN = mean, na.rm = TRUE)
test90 <- NULL
test95 <- NULL
test99 <- NULL
return(list(compo = clim, test90 = test90,
test95 = test95, test99 = test99))
}else{
assert_numeric(id_clim,upper = dim(data_array)[3], lower = 1)
}
clim <- apply(X = data_array[,,id_clim],MARGIN = 1:2, FUN = mean, na.rm = TRUE)
result <- apply(X = data_array[,,id_time],MARGIN = 1:2, FUN = mean, na.rm = TRUE)
result <- result - clim
if(test){
n_mat_clim <- apply(X = !is.na(data_array[,,id_clim]),MARGIN = 1:2, FUN = sum)
n_mat <- apply(X = !is.na(data_array[,,id_time]),MARGIN = 1:2, FUN = sum)
sd_mat <- apply(X = data_array[,,id_clim],MARGIN = 1:2, FUN = sd, na.rm = TRUE)
sd_clim <- apply(X = data_array[,,id_time],MARGIN = 1:2, FUN = sd, na.rm = TRUE)
asd <- .test_stu_unequal(n1 = n_mat_clim, sd1 = sd_clim, n2 = n_mat, sd2 = sd_mat)
test90 <- abs(result) > asd$anom_cri90
test95 <- abs(result) > asd$anom_cri95
test99 <- abs(result) > asd$anom_cri99
}else{
test90 <- NULL
test95 <- NULL
test99 <- NULL
}
return(list(compo = result, test90 = test90,
test95 = test95, test99 = test99))
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.