R/events.R

In mundl/smires: Science and Management of Intermittent Rivers and Ephemeral Streams

find_spells <- function(x, threshold = 0.001, rule = "cut", na.rm = TRUE,
                        warn = TRUE, complete = "none",
                        spell.vars = vars(duration), ...)
{
  x %>%
    .append_flow_state(threshold = threshold) %>%
    summarize_spell(rule = rule, na.rm = na.rm, warn = warn,
                    complete = complete, spell.vars = spell.vars, ...)
}

summarize_spell <- function(x,
                            rule = c("cut", "duplicate", "onset", "termination"),
                            na.rm = TRUE, warn = TRUE, complete = "none",
                            spell.vars = spell.vars)
{
  rule <- match.arg(rule)

  x %>%
    .add_spellvars(warn = warn, duplicate = rule != "cut",
                   spell.vars = spell.vars) %>%
    .assign_spell(rule = rule) %>%
    .complete_spell(complete = complete) %>%
    arrange(spell) # sort by spell
}



.assign_spell <- function(x,
                          rule = c("cut", "duplicate", "onset", "termination"))
{
  rule <- match.arg(rule)
  attr_smires(x) <- list("rule" = rule)

  # todo: rules for "majority" and "center"
  # todo: cut = cut_group = cut_minor, cut_major

  # spells are already cut or duplicated
  if(rule %in% c("cut", "duplicate")) {
    y <- x
  }

  if(rule == "onset") {
    y <- arrange(ungroup(x), spell, group) %>%
      distinct(spell, state, .keep_all = TRUE)
  }

  if(rule == "termination") {
    y <- arrange(ungroup(x), desc(spell), desc(group)) %>%
      distinct(spell, state, .keep_all = TRUE) %>%
      arrange(spell)
  }

  return(y)
}

.complete_spell <- function(x, complete = c("none", "major", "minor", "group"),
                            fill = NA)
{
  if (!is.na(fill)) message("Argument 'fill' is currently not used. ")
  complete <- match.arg(complete)

  # retain zero length events
  fill <- list(onset = NA, termination = NA, duration = 0,
               group = NA, major = NA, minor = NA#, var = fill
               )


  x <- ungroup(x)
  # it is only safe to complete years that do not have NA values
  y <- switch(complete,
              major = complete(x, state, nesting(major), fill = fill),
              minor = complete(x, state, nesting(minor), fill = fill),
              group = complete(x, state, nesting(group), fill = fill),
              x)

  return(y)
}


.append_flow_state <- function(x, threshold = 0.001)
{
  if(is.null(threshold))
  {
    x$spell <- seq.int(from = 1, to = nrow(x))
  } else {
    att <- attr_smires(x)

    # todo, better use cut?
    # cut(, breaks = c(0, threshold, Inf), labels = c("no-flow", "flow"))
    x$state <- ifelse(x$discharge <= threshold, "no-flow", "flow")
    x$state <- factor(x$state, levels = c("no-flow", "flow"))
    x <- mutate(x, spell = .spell(x$state))

    att[["threshold"]] <- threshold
    attr_smires(x) <- att
  }


  return(x)
}




# .detect_increase(balder) %>%
#   .add_spellvars()

.detect_increase <- function(x)
{
  att <- attr_smires(x)

  d <- diff(x$discharge)
  # as we are only interested in counting the state changes and not in
  # the duration of a state, we can assign zeros to either increase or decrease
  state <- cut(d, breaks = c(-Inf, 0, Inf), labels = c("decrease", "increase"))

  x <- data_frame(time = head(x$time, n = -1),
                  state = state,
                  spell = .spell(state))

  attr_smires(x) <- att

  return(x)
}

.add_spellvars <- function(x, warn = TRUE, duplicate = FALSE,
                           spell.vars = spell.vars)
{
  grouped <- "group" %in% colnames(x)

  y <- if(grouped && !duplicate) {
    group_by(x, spell, state, group)
  } else {
    group_by(x, spell, state)
  }

  att <- attr_smires(x)

  # always store cutted spells in attributes,  needed for plotting
  if(grouped) {
    cut <- group_by(x, spell, state, group)
  } else{
    cut <- group_by(x, spell, state)
  }
  cut <- cut %>%
    summarize(onset = min(time), termination = max(time) + att$dt,
              duration = termination - onset)


  res <- y %>%
    summarize(onset = min(time),
              termination = max(time) + att$dt,
              duration = termination - onset, !!!spell.vars)

  if(duplicate) {
    # duplicate the summary statistics for every group
    g <- summarise(y, group = list(unique(group))) %>%
      select(-state) %>%
      unnest()

    res <- res %>%
      left_join(g, by = "spell")
  }


  if(grouped) {
    # merge with minor an major intervals, if data was grouped
    res <- right_join(res, att[["group_interval"]], by = "group")
    cut <- right_join(cut, att[["group_interval"]], by = "group")
  }

  # quick and dirty way to drop smires attributes, no need to store them twice
  att[["spell_cut"]] <- cut[, seq_along(cut)]

  #if(grouped | duplicate)
  attr_smires(res) <- att


  return(res)
}


.spell <- function(x, new.group.na = TRUE, as.factor = TRUE)
{
  # copied from lfstat group()
  # operates just on the grouping variable

  x <- as.numeric(as.factor(x))

  if(!new.group.na) {
    s <- seq_along(x)
    finite <- !is.na(x)
    x <- approx(s[finite], x[finite], xout = s, f = 0,
                method = "constant", rule = c(1, 2))$y
  } else {
    # treat NAs as a group of its own
    # there isn't yet a level zero, therefore NAs can become zeros
    x[is.na(x)] <- 0
  }

  inc <- diff(x)
  if (new.group.na) inc[is.na(inc)] <- Inf

  grp <- c(0, cumsum(inc != 0))

  if(grp[1] == 0) grp <- grp + 1

  if(as.factor) {
    return(factor(grp, ordered = TRUE))
  } else {
    return(grp)
  }
}