R/fixTools.R

In erikor/airtraffic: Work with air navigation data

#' fetchFixes
#'
#' Get all LIDs, fixes, and waypoints for the US from FAA
#'
#' @param verbose provide updates on progress
#'
#' Note that this takes about a minute as we fetch in batches
#' of 1000 and we pause half a second between the requests to
#' be kind and avoid undue attention.
#'
#' This data is already availble as data(fixes), so you usually
#' don't need to call this. But it is here to provide updates as
#' needed.
#'
#' @return dataframe containing identifier, lon, and lat
#' @importFrom foreach foreach %do%
#' @importFrom jsonlite fromJSON
#' @importFrom RCurl getForm
#' @export
fetchFixes <- function(verbose = TRUE) {
  i <- NULL # keep R CMD CHECK happy
  res <- foreach(i = 1:68, .combine=rbind) %do% {
    if(verbose)
      print(paste0("Iteration ", i, " of 68"))
    # play nice with the server
    Sys.sleep(0.5)
    res <- fromJSON(getForm("https://nfdc.faa.gov/nfdcApps/controllers/PublicDataController/getLidData",
                           dataType="LIDFIXESWAYPOINTS",
                           start=(i-1)*1000,
                           length=1000,
                           sortcolumn="state",
                           sortdir="asc",
                           searchval=""))
    cbind(res$data$fix_identifier, res$data$description)
  }
  res <- fixFixes(res)
  res$lon <- as.numeric(as.character(res$lat))
  res$lon <- as.numeric(as.character(res$lon))
  res <- res[order(res$id), ]
  rownames(res) <- res$ID
  res[,2:3]
}

#' fixFixes
#'
#' Convert from FAA format (Preamble 34-36-21.2900N 087-16-24.7500W) to
#' pair of decimal values.
#'
#' @param dat dataframe with rows in format c(fix_id, coordinates)
#'
#' @return dataframe containing identifier, lon, and lat
#' @export
fixFixes <- function(dat) {
  coord <- dat[,2]
  lon <- gsub(".* (\\d+-\\d+-\\d+\\.\\d+(W|E))", "\\1", coord)
  lat <- gsub(".*(\\d{2,2}-\\d+-\\d+\\.\\d+(N|S)).*", "\\1", coord)
  lat <- coord2dec(lat)
  lon <- coord2dec(lon)
  data.frame(ID=dat[,1], lat=lat, lon=lon)
}

#' fixesNear
#'
#' Find all LIDs/fixes/waypoints near a point
#'
#' @param lat latitude of point
#' @param lon longitdue of point
#' @param d distance in nautical miles
#'
#' @return dataframe, or, optionally, JSON containing the fixes.
#' @export
fixesNear <- function(lat, lon, d, JSON=FALSE) {
  if(!exists("fixes"))
    data(fixes)
  dists <- apply(fixes, 1, function(x) {
    distNm(lat, lon, as.numeric(x['lat']), as.numeric(x['lon']))
  })
  ix <- which(dists < d)
  if(JSON) {
    dat <- fixes[ix,]
    ids <- dat$ID
    dat <- apply(dat, 1, function(x) { L <- list(); L[[x[1]]]<-x[2:3]; L})
    dat <- lapply(dat, function(x) { x[[1]] })
    dat <- lapply(dat, function(x) { as.numeric(x)})
    names(dat) <- ids
    js <- jsonlite::toJSON(dat, pretty = TRUE, auto_unbox = FALSE, digits=15)
    return(js)
  } else{
    return(fixes[ix,])
  }
}

#' fetchRunways
#'
#' Get coordinates for ends of all runways and assign invisible
#' fix id to them.
#'
#' This data is already availble as data(fixes), so you usually
#' don't need to call this. But it is here to provide updates as
#' needed.
#'
#' @return dataframe containing lon, and lat. Rownames are id.
#' @export
fetchRunways <- function() {
  ap <- read.csv("https://opendata.arcgis.com/datasets/544332e4258b463da760aefe0e6ffb79_0.csv")
  icao <- paste0("K", ap$Loc_Id)

  # note that database has coordinates for the starts of the
  # runways...we want the ends for navigation
  base_id <- paste0("_", paste0(icao, "_", ap$Recip_End_Id))
  ix <- which(!duplicated(base_id))
  ap <- ap[ix,]
  base_id <- base_id[ix]
  icao <- icao[ix]

  base_lat <- coord2dec(ap$Base_End_Lat)
  base_lon <- coord2dec(ap$Base_End_Lon)

  recip_id <- paste0("_", paste0(icao, "_", ap$Base_End_Id))
  recip_lat <- coord2dec(ap$Recip_End_Lat)
  recip_lon <- coord2dec(ap$Recip_End_Lon)
  bases <- data.frame(ID=base_id, lat=base_lat, lon=base_lon)
  recip <- data.frame(ID=recip_id, lat=recip_lat, lon=recip_lon)
  fixes <- rbind(bases, recip)
  rownames(fixes) <- fixes$ID
  fixes <- fixes[order(rownames(fixes)), c(2,3)]
  fixes
}