R/compo.R

In santiagoh719/ClimFunctions: Functions For Climate Data

.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))
  }

}