dev_func/osh_filter-new.R

In dof1985/OSHEX: Open Street Map History File Explorer

#' A class used to store filtering conditions for oshex objects
#' 
#' An \code{oshExpression} is an S4 class used in \code{\link{oshExList-class}} to store oshex filtering
#' conditions. For more details see \code{\link{oshExList-class}}.
#' 
#' @slot condition A named character vector with filtering codntions information.
#' @slot type A character vector specifying the condition type. See \code{\link{oshExList-class}} for more details.
#' 

oshExpression <- setClass("oshExpression",
         slots = c("condition" = "character",
                   "type" = "character"))

#' @template oshExList
setClass("oshExList",
           slots = c("conditions" = "list"))

#' @template oshExList
oshExListTemp <- setClass("oshExListTemp",
                          contains = "oshExList")

#' @template oshExList
oshExListTag <- setClass("oshExListTag",
                          contains = "oshExList")

#' @template oshExList
oshExListAttrs <- setClass("oshExListAttrs",
                          contains = "oshExList")


# No Documentation
checkExprs <- function(object, exprs){
  unlist(lapply(object, function(z) {
    if(!is.null(z)) {
      if(class(exprs) != "list") exprs <- list(exprs)
      boolean <- unlist(lapply(exprs, function(x) {
        
        if (x@type %in% c("txt")) {
          col <- grep(x@condition["k"], names(z))
          if(length(col) > 0) {
            if(length(x@condition) > 1) {
              return(length(grep(x@condition["v"], z[col])) > 0)
            } else {
              return(TRUE)
            }
          }
          return(FALSE)
          
        } else if (x@type %in% "number") {
          col <- grep(x@condition["k"], names(z))
          if(length(col) > 0) {
            if(length(x@condition) > 1) {
              return(eval(parse(text = sprintf("%s%s", z[col], x@condition["v"]))))
            } else {
              return(TRUE)
            }
          } else {
            return(FALSE)
          }
        } # else if ..temp...geog 
      }))
      all(boolean)
    } else {
      FALSE
    }
  }))}

#' Binary operators used for building key-value pairs for oshExList
#' 
#' These binary operators are used to query and filter oshex objects. They allow for grep-like textual
#' queries (e.g. using %eq% or %inc%), and for numerical equality or inequality queries (e.g. using
#' %l%, %leq%, etc.). See 'Details' below for a description of each operator.
#' 
#' @section Details:
#' ...

`%eq%`   <- function(k, v) {
  args <- as.list(match.call())[-1]
  args <- lapply(args, function(x) {
    if(class(x) %in% "name") return(deparse(x))
    return(x)
  })
  
  if(!args$b %in% ".") args$v <- sprintf("^%s$", args$v)
  
  args <- unlist(args)
  return(args)
} # for equality

`%inc%`  <- function(k, v) {
  args <- as.list(match.call())[-1]
  args <- lapply(args, function(x) {
    if(class(x) %in% "name") return(deparse(x))
    return(x)
  })
  
  args <- unlist(args)
  return(args)
} # for inclusion

`%l%`    <- function(k, v) {
  args <- as.list(match.call())[-1]
  args <- lapply(args, function(x) {
    if(class(x) %in% "name") return(deparse(x))
    return(x)
  })
  
  args$v <- sprintf("<%s", args$v)
  
  args <- unlist(args)
  return(args)
}

`%m%`    <- function(a, b) {
  args <- as.list(match.call())[-1]
  args <- lapply(args, function(x) {
    if(class(x) %in% "name") return(deparse(x))
    return(x)
  })
  
  args$v <- sprintf(">%s", args$v)
  
  args <- unlist(args)
  return(args)
}
`%meq%`   <- function(a, b) {
  args <- as.list(match.call())[-1]
  args <- lapply(args, function(x) {
    if(class(x) %in% "name") return(deparse(x))
    return(x)
  })
  
  args$v <- sprintf(">=%s", args$v)
  
  args <- unlist(args)
  return(args)
}

`%leq%`   <- function(a, b) {
  args <- as.list(match.call())[-1]
  args <- lapply(args, function(x) {
    if(class(x) %in% "name") return(deparse(x))
    return(x)
  })
  
  args$v <- sprintf("<=%s", args$v)
  
  args <- unlist(args)
  return(args)
}

# types: tag.n, tag.t
#' Build an \code{oshExListTag} condition
#' 
#' The function is used to create an \code{\link{oshExListTag}} condition that can be used by the \code{\link{osh_filter}} function. 
#' 
#' @param ... One or more key-value pairs binary operators. See 'Details' below for a description of each operator.
#' 
#' @section Details:
#' The \code{tag} function can be used to create one or multiple conditions bundeled together within an \code{\link{oshExList-class}} object.
#' \code{tag} can be also used to filter data based on numeric relations (i.e. inequalities)
#' Use concatenate to create a filter for a key-value pair (see examples). 
#'
#' @examples
#' \dontrun{
#'   # Filter highway of type primary only
#'   cond <- tag(c(k %eq% highway, v %eq% primary))
#'   
#'   # Filter only buildings with house number equal or higher than 30
#'   cond <- tag(k %eq% building, c(k %eq% addr:housenumber, v %meq% 30))
#'   } 

tag <- function(...) {
  conds <- list(...)
  oexpl <- oshExListTag()
  oexpl@conditions <- lapply(conds, function(x) {
    tag.type <- "txt"
    if(length(grep(">|<|<=|>=", x)) > 0) tag.type <- "number" 
    oexp <- oshExpression()
    oexp@condition <- x
    oexp@type <- tag.type
    return(oexp)
  })
  return(oexpl)
}

#types: attrs
#' Build an \code{oshExListAttrs} condition
#' 
#' The function is used to create an \code{\link{oshExListAttrs}} condition that can be used by the \code{\link{osh_filter}} function. 
#' 
#' @param ... One or more key-value pairs binary operators. See 'Details' below for a description of each operator.
#' 
#' @section Details:
#' The \code{attrs} function can be used to create one or multiple conditions bundeled together within an \code{\link{oshExList-class}} object.
#' Currently \code{attrs} can't filter by numeric relations.
#' Use concatenate to create a filter for a key-value pair (see examples). 
#'
#' @examples
#' \dontrun{
#'   # Filter edits by osm user name 
#'   cond <- attrs(c(k %eq% user, v %eq% wew84))
#'   }
  

attrs <- function(...) {
  conds <- list(...)
  oexpl <- oshExListAttrs()
  oexpl@conditions <- lapply(conds, function(x) {
    tag.type <- "txt"
    oexp <- oshExpression()
    oexp@condition <- x
    oexp@type <- tag.type
    return(oexp)
  })
  return(oexpl)
}

#types: temp
temp <- function(from = NA, to = NA, format = "%d-%m-%Y") {
  oexpl <- oshExListTemp()
  oexpl@conditions <- mapply(function(x, f) {
    if(!is.na(x)) {
      tag.type <- "time"
      oexp <- oshExpression()
      oexp@condition <- c("operator" = f, "date" = sprintf("as.Date('%s', '%s')", x, format))
      oexp@type <- tag.type
      return(oexp)
    }}, c(from, to), c(">=", "<="))
  
  names(oexpl@conditions) <- c("from", "to")
  return(oexpl)
}

#types:  geobox
geobox <- function() {
  oshexp <- oshExpression()
}


# checkExprs as generic

setGeneric("checkExprs", function(object, exprs) {
  standardGeneric("checkExprs")
})



setClassUnion("listORmissing", c("list", "NULL", "missing", "oshExListAttrs", "oshExListTag", "oshExListTemp"))

## OSH filter

#' Apply filters to an \code{oshex-class}
#' 
#' Filter an \code{oshex-class} based on temporal, tags and attributes expression Lists.
#' 
#' @param object An \code{oshex} object as given by \code{\link[OSHEX]{as_oshex}}.
#' @param conditions One condition given as an \code{\link{oshExList-class}} object, or
#' a list with several conditions. 
#' 
#' @examples 
#' \dontrun{
#' highway <- osh_filter(object = osh, conditions = tag(c(k %eq% highway, v %eq% primary))
#' }

setGeneric("osh_filter", function(object,
                                  conditions = NULL){
  standardGeneric("osh_filter")
})




###
setMethod("osh_filter",
          signature(object = "oshex", conditions = "listORmissing"), # should get a list of conditions
          function(object, conditions = NULL) {
            if(class(conditions) != "list") conditions <- list(conditions)
            slts <- slotNames(object)[!slotNames(object) %in% "bounds"]
            for (cond. in conditions) {
              # arrange by order (geog, temp, attrs, tag)
              for (slt in slts) {
                slot(object, slt) <- osh_filter(slot(object, slt), conditions = cond.)
              }
            }
            return(object)
          })

#"oshExListTag" 

setMethod("osh_filter",  
          signature(object = "oshElement", conditions = "oshExListTag"),
          function(object, conditions = NULL) {

            # check if tags  exist
            if(is.null(object@tags)) {
              object@tags <- lapply(object@data, function(x) {
                nodeTags <- do.call("rbind", xmlApply(x, function(x) {
                  if(xmlName(x) %in% "tag")  iconv(xmlAttrs(x) ,"UTF-8", "UTF-8")
                }))
                
                if(!is.null(nodeTags)) {
                  nodeTags <- t(nodeTags)
                  colnames(nodeTags) <- nodeTags[1, ]
                  nodeTags <- nodeTags[2, ]
                }
                return(nodeTags)
              })
            }
           
            
            indsVector <- rep(FALSE, length(object@data))
            threshold  <- 0
            
            for(condition in conditions@conditions) {
              indsVector <- indsVector + checkExprs(object@tags, condition)#conditions@conditions)
              threshold <- threshold + 1
            }
            
            
            indsVector <- indsVector == threshold
            
            object@data <- object@data[indsVector]
            object@tags <- object@tags[indsVector]
            object@attrs <- object@attrs[indsVector]
            
            
            
            return(object)
          })

#"oshExListAttrs"

setMethod("osh_filter", # should also differentiate between text and numeric; may be also added to the class
          signature(object = "oshElement", conditions = "oshExListAttrs"),
          function(object, conditions = NULL) {
            
            # check if tags  exist
            if(is.null(object@attrs)) {
              object@attrs <- lapply(object@data, function(x) {
                iconv(xmlAttrs(x), "UTF-8", "UTF-8")
              })
            }
            
            indsVector <- rep(FALSE, length(object@data))
            threshold  <- 0
            
            for(condition in conditions@conditions) {
              indsVector <- indsVector + checkExprs(object@attrs, condition)#conditions@conditions)
              threshold <- threshold + 1
            }
            
            
            indsVector <- indsVector == threshold
            
            object@data <- object@data[indsVector]
            object@tags <- object@tags[indsVector]
            object@attrs <- object@attrs[indsVector]
            
            return(object)
          })

#"oshExListTemp"

setMethod("osh_filter",
          signature(object = "oshElement", conditions = "oshExListTemp"),
          function(object, conditions = NULL) {
            
            # check if tags  exist
            if(is.null(object@attrs)) {
              object@attrs <- lapply(object@data, function(x) {
                iconv(xmlAttrs(x), "UTF-8", "UTF-8")
              })
            }
            
            indsVector <- rep(FALSE, length(object@data))
            threshold  <- 0
            dates <-  unlist(lapply(object@attrs, function(x) {as.Date(x["timestamp"], format = "%Y-%m-%d")}))
            
            for(condition in conditions@conditions) {
              if(!is.null(condition)) {
                
                indsVector <- indsVector + do.call(condition@condition["operator"], list(dates, as.numeric(eval(parse(text = condition@condition["date"])))))
                threshold <- threshold + 1
                
              }
              
            }
            
            
            indsVector <- indsVector == threshold
            
            object@data <- object@data[indsVector]
            object@tags <- object@tags[indsVector]
            object@attrs <- object@attrs[indsVector]
            
            return(object)
          })