###########################################################################################################################################
# script name: ESM_1.R (v1.0)
# Author: M. Vorkauf, evamaria.vorkauf@unibas.ch / maria.vorkauf@gmail.com
# Date: 29.04.2020
# Content: R script including a function to derive snow onset (SO) and melt (SM) from snow depth (HS) measurements at IMIS stations
#          additionally returns mean snow depth (between SO and SM)
# R version 3.6.0
# package versions (tidyverse v1.3.0 , caTools v1.18.0, DescTools v0.99.32)
###########################################################################################################################################

###########################################################################################################################################
# requires an input data frame (data) with the following column names: 
# STAT [character]  station name (short), e.g. BED2 
# DATE [date]       date of the snow depth measurement
# HS   [numeric]    corresponding snow depth measurement 
###########################################################################################################################################

###########################################################################################################################################
# Application expample: to derive snow onset, melt, mean snow depth for the station WFJ2 in 2003 run:
# snowcoverIMIS(s = "WFJ2", y = 2003, IMISdata = dataframe_input)
###########################################################################################################################################

###########################################################################################################################################
# has been developed and tested only for the following IMIS stations (may not be suitable for all IMIS stations):
# BED2, BED3, GOM2, GOM3, GUE1, URS2, LUK2, LUM2, MEI2, OBW2, OBW3, PUZ2, TUJ2, TUJ3, VAL2, WFJ2
# some of the thresholds used were chosen because we found good fits for SO and SM; those have not been tested for a larger set of stations
# it is possible that other stations require different thresholds, so all results should be checked visually before further use
###########################################################################################################################################


# required libraries
require(tidyverse)
require(caTools) # runmean
require(DescTools) # Mode

# helper functions:
rle_na = function (x) { 
  # base part of the function as already in R: rle()
  if (!is.vector(x) && !is.list(x)) 
    stop("'x' must be an atomic vector") 
  n = length(x) 
  if (n == 0L) 
    return(structure(list(lengths = integer(), values = x), class = "rle")) 
  
  # addition: handle multiple NA values (temporarily replace NA with different value, calculate the runtime elements, then back-replace the NA values)
  if (any(is.na(x))){
    repeatedNA = TRUE
    xtype = typeof(x)
    if (xtype=="logical"){x1 = as.numeric(x); replacementforNA = -999} # numeric of TRUE and FALSE gives 1 and 0
    if (xtype%in%c("numeric","double","integer")){x1 = x; replacementforNA = min(x[!is.na(x) & !is.infinite(x)] - 999)}
    x1[is.na(x1)] = replacementforNA
    
    y1 = x1[-1L] != x1[-n] 
    i1 = c(which(y1), n) 
    
    x1[which(x1==replacementforNA)] = NA 
    if(xtype=="logical"){ x1 = as.logical(x) }
    
    return(structure(list(lengths = diff(c(0L, i1)), values = x1[i1]), class = "rle") )
  } else {
    y = x[-1L] != x[-n] 
    i = c(which(y), n) 
    return(structure(list(lengths = diff(c(0L, i)), values = x[i]), class = "rle") ) }
}
smoothers = function(x = HS) {
  testm = runmean(x, k= 5)        # running window mean with 5 days
  testsd = runsd(x, k= 5)         # running standard deviaton with 5 day
  testsdm = runsd(testm, k=5)     # running standard deviaton of running mean with 5 days
  testm.round = round(testm)      # rounded running mean (to full number)
  return(as_tibble(data.frame(testm=testm, testsd=testsd, testsdm=testsdm, testm.round=testm.round)))
}
find_start_end = function(a = rleobject, where = i) {
  start = (sum(a$lengths[1:(where-1)])+1); 
  end = (sum(a$lengths[1:where]));
  return(c(start, end))
}

# Function to retrieve SO and SM
snowcoverIMIS <- function(s, y, IMISdata = data) {
  
  # e.g.: for the year 2010 select all data between 2009-07-15 and 2010-08-31 in order to be sure to include a long enough period before and after SO and SM
  D = IMISdata %>% filter(STAT==s & DATE > as.Date(paste( (y-1),"-07-15",sep="")) & DATE <= as.Date(paste( (y),"-08-31",sep=""))  )
  
  if (dim(D)[1] < 60) {start = NA; end = NA; end.value = NA} else {
    
    # if data starts with big jump, ignore this jump
    if (is.na(D[which(!is.na(D$HS))[1]+1,]$HS ) ||
        D[which(!is.na(D$HS))[1],]$HS - D[which(!is.na(D$HS))[1]+1,]$HS > 20) {D[which(!is.na(D$HS))[1],]$HS = D[which(!is.na(D$HS))[1]+1,]$HS}
    
    # precaution: every date between -07-15 and -08-31must be included, if necessary with NAs
    tutti_datum = expand.grid(DATE = seq( as.Date(paste( (y-1),"-07-15",sep="")) ,  as.Date(paste( (y),"-08-31",sep="")) , by = "days") )
    D = as_tibble(merge(tutti_datum, D, by="DATE", all = TRUE))
    D = D[order(D$DATE),] # precaution again
    D$HSA = NA # add an empty column for adapted HS (HSA)
    
    # based on experience: absolutely no variation in data very suspicious >> delete
    # but if this happens close to zero (<10cm) sometimes the data series hased been "cleaned" already, so don't delete the data in this case
    D$diff = c(0, diff(D$HS)); RD = rle_na(D$diff); 
    suspicious= which(RD$values==0 & RD$lengths>= 10)
    for (i in suspicious){
      start = (sum(RD$lengths[1:(i-1)])+1); end = (sum(RD$lengths[1:i]));
      if (unique(D$HS[start:end])>10) {D$HS[start:end]=NA}
    }
    
    # only interested in SO and SM, interpolate the HS data; if we interpolate over SO and SM we will delete these later
    RS = rle_na(D$HS)
    for (i in which(is.na(RS$values))) {
      if (RS$lengths[i] <= 50 &&
          i != 1 && RS$lengths &&
          !is.na(abs(RS$values[i-1] - RS$values[i+1]) > 0) &&(abs(RS$values[i-1] - RS$values[i+1]) > 0) &&
          # !is.na(RS$values[i+1]) && !is.na(RS$values[i+2]) &&
          ((RS$values[i+1] > 15 && RS$values[i-1] > 15) || (RS$values[i+1] < 15 && RS$values[i-1] < 15) ) ) {
        start = (sum(RS$lengths[1:(i-1)])+1); end = (sum(RS$lengths[1:i]));
        D$HS[start:end] = approx(x = c(D$HS[start-1], D$HS[end+1]), n = length(D$HS[start:end]))$y }
      if (RS$lengths[i] <= 8 && i != 1 && !is.na(RS$values[i+1])  ) {
        start = (sum(RS$lengths[1:(i-1)])+1); end = (sum(RS$lengths[1:i]));
        D$HS[start:end] = approx(x = c(D$HS[start-1], D$HS[end+1]), n = length(D$HS[start:end]))$y }
    }
    
    # Often the whole growing season included even though not necessary. Start from the back and see whether daily changes are not higher than 8cm in a 5 day window
    i = length(D$HS); i = max(which(!is.na(D$HS))); diffs = c(0, diff(D$HS)); l = 5; DL = diffs[i:(i-5)]
    while (i > 200 && !any(is.na(DL)) &&
           (all(abs(DL) < 8) && !all(sign(DL)==(-1)) && (D$HS[i-5]-D$HS[i])<30) 
    ) { i = i - 1; DL = diffs[i:(i-5)]}
    if (i + 10 < length(D$HS)) { D$HS[(i+10):length(D$HS)] = NA }
    
    # Set up mostly in summer before 2000. Sometimes no long dataseries before the snow cover. If there is only missing data in the first 48 days, fill them with the mean of the first five days that are not missing
    if (y == 2000 & all(is.na(D$HS[1:48])) ) {
      D$HS[1:which(!is.na(D$HS))[1]-1] = mean(D$HS[which(!is.na(D$HS))[1] : which(!is.na(D$HS))[1]+5])
    }
    
    # Index included in dataframe, to make work a little easier
    D$I = c(1:dim(D)[1])
    
    # find the running window mean and sd (window of 5 days)
    sm = smoothers(D$HS)
    SDL = ifelse(abs(sm$testsd) < 0.8, 1, 0)
    
    # Maintenance leads to subsequent plateaus before SO: ignore the first one of these
    testsd.rle = rle_na(SDL[1:120]); is = which(testsd.rle$value==1 & testsd.rle$length > 20 ); 
    if (length(is)>1){i = is[length(is)-1]} else {i = 1}
    if (abs(i) != Inf && i != 1
    ) {
      start = (sum(testsd.rle$lengths[1:(i-1)])+1); end = (sum(testsd.rle$lengths[1:i]));
      D$HS[1:end] = NA
    }
    
    # We have adapted the HS, so derive running window mean and sd again
    sm = smoothers(D$HS)
    SDL = ifelse(abs(sm$testsdm) < 0.8, 1, 0)
    # the summer values are (almost) never at 0 >>> find the most frequently occurring value between Aug - Dec
    start.value = Mode( sm$testm[D$I <= 168 & D$I > 50 & !is.na(sm$testm) & SDL == 1])[1]
    
    
    # after melt: sometimes (almost always) the summer "snow depth" does not go back to the level of the previous year, but to a new one >> find most frequent value there
    end.value = max(Mode(sm$testm[!is.na(sm$testm) & SDL == 1 & D$I > 296 & D$I > 50]) )
    if (is.na(start.value) & !is.na(end.value)) { start.value = end.value}
    if ( abs(end.value)==Inf || !(( end.value > start.value) &&   (length(which(!is.na(D$HS) & abs(sm$testm - end.value) < 1)) >= 5))  ) {    # >= 14!!
      end.value = start.value}
    
    # adapted snow depth: substract the start / end value so that summer values are close to 0
    D$HSA = D$HS
    D$HSA[1:200] = D$HS[1:200] - start.value; 
    D$HSA[200:dim(D)[1]] = D$HS[200:dim(D)[1]] - end.value
    
    # finally, find PLATEUS
    sm = smoothers((D$HSA))
    SDL = ifelse(abs(sm$testsdm) < 0.8, 1, 0)
    W  = ifelse(D$HSA >= 2 | SDL == 0 , 1, 0) # >> these are the potentil plauteaus
    
    # short gaps between plateaus should be ignored to derive larger plateaus
    gaps = rle_na(W)
    for (i in which(gaps$values==0 & gaps$lengths <= 3)) {
      start = (sum(gaps$lengths[1:(i-1)])+1) 
      end = (sum(gaps$lengths[1:i]))
      if ( !(any(D$HSA[start:end] <= 0)) ) {W[start:end] = 1}
    }
    
    # determine the time period where there is enough snow and higher variability >> time with snow cover (with start and end)
    # because of running mean: theoretically +2.5 days for appoximate start/end >> to be sure take +1 and +3 days
    RS = rle_na(W)
    SD = which(RS$values==1 & RS$lengths== max(RS$lengths[which( !is.na(RS$values) & RS$values==1)]))
    start = (sum(RS$lengths[1:(SD-1)])+1) + 1
    end = (sum(RS$lengths[1:SD]))   - 3
    
    # if start/end fall to day with no measurements and there is none before and after either >> timepoint of start&end cannot be determined
    if (all(is.na(D$HSA[c(start-1,start,start+1)]))) {start = NA}
    if (all(is.na(D$HSA[c(end-1,end,end+1)]))) {end = NA}
    
    # start/end only approximate >>> if values are still decreasing with time >>> go to next minimum
    while(!is.na(D$HSA[start]) && !is.na(D$HSA[start+1]) &&
          ((D$HSA[start + 1] - D$HSA[start] <= 1 || D$HSA[start + 1] == D$HSA[start]) ||
           any(na.omit(D$HS[start:(start+10)] - D$HS[start]) < 0) || length(which(na.omit(D$HS[start:(start+10)] - D$HS[start])==0))>3)) {start = start + 1}
    while(!is.na(D$HSA[end]) && !is.na(D$HSA[end+1]) &&
          (D$HSA[end + 1] < D$HSA[end])  ) {end = end + 1}
  }
  
  # make a plot
  if (!is.na(D$HS[end]) && (D$HS[end] - end.value) > 20) {end = NA}
  if (!is.na(end) && is.na(D$HS[end])) {end = NA}
  if (!is.na(start)&& is.na(D$HS[start])) {start = NA}
  if (dim(D[format(D$DATE,"%m")=="10" & !is.na(D$HS),])[1] < 10) {start = NA}
  if ((start!= 1 && end!= 1) && (!is.na(start)&&!is.na(end))) { 
    if (length(which(is.na(D$HS[start:end]))) <= 10) {
      mean.h = mean(D$HS[start:end] - start.value)  
    } else {
      mean.h = NA
    }} else {
      mean.h = NA}
  
  if (!is.na(start) && start==1){start = NA}; if (!is.na(end) && end==1){end = NA}
  
  onset = ifelse(is.na(start), NA, as.character(D$DATE[start]) )
  melt =  ifelse(is.na(end), NA, as.character(D$DATE[end]) )
  
  # return the values
  return(data.frame(STAT=s, YEAR=y, ON = onset , ME = melt, mean.h = mean.h) )
  
}

# Example
snowcoverIMIS(s = "TUJ3", y = 2002, IMISdata = data)
# ggplot(data %>% filter(STAT==s & (format(DATE,"%Y")==y | (format(DATE,"%Y")==y-1 ))) ) +
#   geom_hline(yintercept = 0, linetype="dotted") +
#   geom_line(aes(x=DATE, y=HS)) +
#   geom_vline(xintercept = as.Date(snowcoverIMIS(s = s, y=y)$ON), color="blue") +
#   geom_vline(xintercept = as.Date(snowcoverIMIS(s = s, y=y)$ME), color="red") +
#   geom_segment(x = as.Date(snowcoverIMIS(s = s, y=y)$ON), xend = as.Date(snowcoverIMIS(s = s, y=y)$ME),
#                y = snowcoverIMIS(s = s, y=y)$mean.h, yend = snowcoverIMIS(s = s, y=y)$mean.h, linetype="dashed") +
#   scale_x_date("Date") + scale_y_continuous("Snow depth HS (cm)") +
#   theme_classic()