Differencing Functionality

DESCRIPTION

@@ -1,4 +1,4 @@
-Package: climwin
+Package: climwinBH
 Type: Package
 Title: Climate Window Analysis
 Version: 1.1.0

R/otherfunctions.R

@@ -28,7 +28,7 @@ basewin <- function(exclude, xvar, cdate, bdate, baseline, range,
                     type, stat = "mean", func = "lin", refday,
                     cmissing = FALSE, cinterval = "day", nrandom = 0, k = 0,
                     spatial, upper = NA, lower = NA, binary = FALSE, centre = list(NULL, "both"),
-                    cohort = NULL, fast){
+                    cohort = NULL, fast, cw_diff = FALSE){
 
   print("Initialising, please wait...")
 
@@ -127,7 +127,7 @@ basewin <- function(exclude, xvar, cdate, bdate, baseline, range,
   modlist   <- list()   # dataframes to store ouput
   baseline  <- update(baseline, .~.)
   nullmodel <- AICc(baseline)
-  modeldat  <- model.frame(baseline)
+  modeldat  <- model.frame(baseline)    
 
   if(attr(baseline, "class")[1] == "lme"){
 
@@ -158,8 +158,18 @@ basewin <- function(exclude, xvar, cdate, bdate, baseline, range,
     func <- "centre"
   }
 
+  # update in case of differencing 
+  if (cw_diff){
+    tmp = diff(modeldat$yvar)
+    modeldat = data.frame(yvar = tmp)
+    baseline  <- update(baseline, formula = yvar~., data = modeldat)
+    nullmodel <- AICc(baseline)
+  }
+
   ifelse(class(baseline)[length(class(baseline))]=="coxph", leng<-length(modeldat$yvar[,1]), leng<-length(modeldat$yvar))
-  if (leng != length(bdate)){
+  if ((leng != length(bdate)) && (!cw_diff)){
+      stop("NA values present in biological response. Please remove NA values")
+  } else if ((leng != (length(bdate)-1)) && (cw_diff)){
       stop("NA values present in biological response. Please remove NA values")
   }
 
@@ -461,8 +471,16 @@ basewin <- function(exclude, xvar, cdate, bdate, baseline, range,
             time             <- seq(1, n, 1)
             modeldat$climate <- apply(cmatrix[, windowclose:windowopen], 1, FUN = function(x) coef(lm(x ~ time))[2])
           } else { 
-            ifelse (n == 1, modeldat$climate <- cmatrix[, windowclose:windowopen], 
+            # Case: NOT differencing
+              if (!cw_diff){
+                ifelse (n == 1, modeldat$climate <- cmatrix[, windowclose:windowopen], 
                     modeldat$climate <- apply(cmatrix[, windowclose:windowopen], 1, FUN = stat))
+            # Case: Differencing
+              } else {
+                ifelse (n == 1, modeldat$climate <- diff(cmatrix[, windowclose:windowopen]), 
+                    modeldat$climate <- diff(apply(cmatrix[, windowclose:windowopen], 1, FUN = stat)))
+              }
+
           }
 
           if (min(modeldat$climate) <= 0 & func == "log" || min(modeldat$climate) <= 0 & func == "inv"){
@@ -758,9 +776,17 @@ basewin <- function(exclude, xvar, cdate, bdate, baseline, range,
     time      <- seq(1, n[1], 1)
     modeldat$climate <- apply(cmatrix[, windowclose:windowopen], 1, FUN = function(x) coef(lm(x ~ time))[2])
   } else {
-    ifelse (windowopen - windowclose == 0, 
+    # CASE: NOT differencing
+    if (!cw_diff){
+      ifelse (windowopen - windowclose == 0, 
             modeldat$climate <- cmatrix[, windowclose:windowopen], 
             modeldat$climate <- apply(cmatrix[, windowclose:windowopen], 1, FUN = stat))
+    # CASE: differencing
+    } else {
+      ifelse (windowopen - windowclose == 0, 
+            modeldat$climate <- diff(cmatrix[, windowclose:windowopen]), 
+            modeldat$climate <- diff(apply(cmatrix[, windowclose:windowopen], 1, FUN = stat)))
+    }
   }
 
   if (is.null(centre[[1]]) == FALSE){

R/randwin.R

@@ -156,7 +156,8 @@ randwin <- function(exclude = NA, repeats = 5, window = "sliding", xvar, cdate,
                     upper = NA, lower = NA, binary = FALSE, centre = list(NULL, "both"), k = 0,
                     weightfunc = "W", par = c(3, 0.2, 0), control = list(ndeps = c(0.01, 0.01, 0.01)), 
                     method = "L-BFGS-B", cutoff.day = NULL, cutoff.month = NULL,
-                    furthest = NULL, closest = NULL, thresh = NULL, cvk = NULL){
+                    furthest = NULL, closest = NULL, thresh = NULL, cvk = NULL, 
+                    cw_diff = FALSE){
 
   fast = FALSE
 
@@ -254,7 +255,7 @@ randwin <- function(exclude = NA, repeats = 5, window = "sliding", xvar, cdate,
                              upper = ifelse(binarylevel == "two" || binarylevel == "upper", allcombos$upper[combo], NA),
                              lower = ifelse(binarylevel == "two" || binarylevel == "lower", allcombos$lower[combo], NA),
                              binary = paste(allcombos$binary[combo]), centre = centre, k = k, spatial = spatial,
-                             cohort = cohort, fast = fast)
+                             cohort = cohort, fast = fast, cw_diff = cw_diff)
 
         outputrep$Repeat <- r
         WeightDist <- sum(as.numeric(cumsum(outputrep$ModWeight) <= 0.95))/nrow(outputrep)

R/slidingwin.R

@@ -188,7 +188,8 @@ slidingwin <- function(exclude = NA, xvar, cdate, bdate, baseline,
                        spatial = NULL, cohort = NULL, 
                        cutoff.day = NULL, cutoff.month = NULL, 
                        furthest = NULL, closest = NULL,
-                       thresh = NULL, cvk = NULL){
+                       thresh = NULL, cvk = NULL,
+                       cw_diff = FALSE){
 
   fast = FALSE
 
@@ -272,14 +273,15 @@ slidingwin <- function(exclude = NA, xvar, cdate, bdate, baseline,
   print(allcombos)
 
   combined <- list()
+
   for (combo in 1:nrow(allcombos)){
     runs <- basewin(exclude = exclude, xvar = xvar[[paste(allcombos[combo, 1])]], cdate = cdate, bdate = bdate, baseline = baseline,
                     range = range, type = paste(allcombos[combo, 2]), refday = refday, stat = paste(allcombos[combo, 3]), func = paste(allcombos[combo, 4]),
                     cmissing = cmissing, cinterval = cinterval, k = k, 
                     upper = ifelse(binarylevel == "two" || binarylevel == "upper", allcombos$upper[combo], NA),
                     lower = ifelse(binarylevel == "two" || binarylevel == "lower", allcombos$lower[combo], NA),
                     binary = paste(allcombos$binary[combo]), centre = centre, cohort = cohort,
-                    spatial = spatial, fast = fast)
+                    spatial = spatial, fast = fast, cw_diff = cw_diff)
 
     combined[[combo]]            <- runs
     allcombos$DeltaAICc[combo]   <- round(runs$Dataset$deltaAICc[1], digits = 2)