R/canvec.R

In paleolimbot/rcanvec: Access and Plot CanVec and CanVec+ Data for Rapid Basemap Creation in Canada

 #functions involving canvec

#' Get Cache Directory
#' 
#' Get the default cache directory, which is the folder rcanvec.cache
#' in the current working directory. Modify this behaviour by passing
#' a \code{cachedir} argument to \code{canvec.download()}, \code{canvec.load()}, or
#' \code{canvec.qplot()}.
#' 
#' @return A character string of the cache directory path
#' 
#' @export
canvec.cachedir <- function() {
  dirname <- file.path(getwd(), "rcanvec.cache")
  created<-suppressWarnings(dir.create(dirname))
  dirname
}


# Load canvec_layers into package namespace
#canvec_layers <- NULL #hack because data(canvec_layers) will load to variable
utils::data(canvec_layers, envir=environment())

# Functions to get file names --------

canvec.layers <- function(...) {
  layerids <- list(...)
  if(length(layerids)==0) stop("No arguments passed to canvec.layers()")
  
  filt <- match(layerids, canvec_layers$id)
  if(any(is.na(filt))) {
    stop("Could not find layer(s): ", paste(layerids[is.na(filt)], collapse=", "))
  }
  paste0(canvec_layers$filename[filt],
        canvec_layers$geometry_ext[filt])
} 

canvec.filename <- function(ntsid, ext=NULL) {
  if(length(ntsid)>=3) {
    #canvec
    out <- paste("canvec", paste(tolower(ntsid), collapse=""), "shp", sep="_")
  } else if(length(ntsid)==2) {
    #canvec+
    out <- paste("canvec", paste(toupper(ntsid), collapse=""), "shp", sep="_")
  } else {
    stop("Invalid nts passed to canvec.filename")
  }
  
  if(is.null(ext)) {
    out
  } else {
    paste0(out, ext)
  }
}

#' Get CanVec or CanVec+ data URL
#' 
#' Get CanVec or CanVec+ data URL based on the NTS Reference (as generated by
#' \code{nts()}) provided. The URL generated may or may not exist depending whether
#' or not the sheet or area is available. CanVec data is available by mapsheet
#' (e.g. 021H01; 1:50k), CanVec+ data is available by map area (e.g. 021H; 1:250k).
#' If a the \code{ntsid} provided is a 1:50k reference, a CanVec URL will be generated.
#' Otherwise, a CanVec+ url is generated.
#' 
#' @param ntsid A single NTS Reference as generated by nts().
#' @param server The server to download from (default: \url{http://ftp.geogratis.gc.ca/pub/nrcan_rncan/vector/})
#' @return A URL where the given data can be found.
#' 
#' @export
canvec.url <- function(ntsid, server="http://ftp.geogratis.gc.ca/pub/nrcan_rncan/vector/") {
  if(length(ntsid)>=3) {
    #assume canvec, available in 50k sheets
    paste(server, "canvec/archive/canvec_archive_20130515/50k_shp", ntsid[1], tolower(ntsid[2]), canvec.filename(ntsid, ext=".zip"), sep="/")
  } else if(length(ntsid)==2) {
    #assume canvec+, only available in 250k sheets
    paste(server, "canvec/archive/canvec+_archive_20151029/shp", ntsid[1], canvec.filename(ntsid, ext=".zip"), sep="/")
  } else {
    stop("Invalid nts id passed to canvec.url: ", ntsid)
  }
}

#' Download and Extract CanVec or CanVec+ Data
#' 
#' Downloads CanVec or CanVec+ data (as applicable) to \code{cachedir} and extracts the archive.
#' 
#' @param ... A list of NTS References as generated by \code{nts()}
#' @param forcedownload A boolean describing if the file should be re-downloaded,
#'        even if already present.
#' @param forceextract Force the exctraction of the archive even if the folder is already
#'        present.
#' @param extract Pass \code{extract=FALSE} to download the archive without extracting.
#' @param cachedir Pass a specific cache directory in which to download and extract the file.
#'                  Default value is that returned by \code{canvec.cachedir()}
#' @examples 
#' \donttest{
#' canvec.download(nts('21h1'))
#' }
#' 
#' @export
canvec.download <- function(..., forcedownload=FALSE, forceextract=FALSE, extract=TRUE, cachedir=NULL) {
  if(is.null(cachedir)) {
    cachedir <- canvec.cachedir()
  }
  
  ntsids <- list(...)
  if(length(ntsids)==0) stop("No arguments passed to canvec.download()")
  
  if(length(ntsids)==1 && class(ntsids[[1]])=="list") {
    ntsids <- ntsids[[1]]
  }
  
  for(ntsid in ntsids) {
    #get folder path
    folderpath <- paste(cachedir, canvec.filename(ntsid), sep="/")
    zippath <- paste(cachedir, canvec.filename(ntsid, ext=".zip"), sep="/")
    skipextract <- FALSE
    if((!file.exists(zippath) || forcedownload) && !file.exists(folderpath)) { #don't know how to test if it is a directory
      #download
      uri <- canvec.url(ntsid)
      cat("Downloading sheet", paste(ntsid,collapse=""), "from", uri, "\n")
      tryCatch(utils::download.file(uri, zippath),
               error=function(err) {
                 skipextract<<-TRUE
                 unlink(zippath)
                 cat("Could not download sheet ", paste(ntsid, collapse=""), " (sheet may not exist)")
               })
    } else {
      cat("Skipping download of", paste(ntsid,collapse=""), "\n")
    }
    if((!file.exists(folderpath) || forceextract || forcedownload) && !skipextract && extract) {
      cat("Extracting to", folderpath, "\n")
      utils::unzip(zipfile=zippath, exdir=folderpath, overwrite=TRUE)
    } else {
      cat("Skipping extraction", "\n")
    }
  }
  cat("Done\n")
}


#' Get File Prefix of a CanVec Layer
#' 
#' Find directory and file prefix for a layer id (as 
#' listed in \code{canvec_layers$id}) in the directory specified. 
#' If the layer is not available, a warning will be issued.
#' 
#' @param directory A directory where CanVec shapefiles are located.
#' @param layerid A single layer id as listed in \code{canvec_layers$id}
#' @return The file prefix of the layer, or \code{NA} if the layer does not exist
#' 
#' @export
#' 
#' 
canvec.findlayer <- function(directory, layerid) {
  wd <- directory
  layername <- canvec.layers(layerid)
  
  #try canvec+
  shapefile <- file.path(wd, paste0(layername, ".shp"))
  if(file.exists(shapefile)) {
    return(layername)
  } else {
    #try canvec
    files <- list.files(wd, pattern=paste0("*", paste0(toupper(layername), ".shp")))
    if(length(files)==1) {
      layername <- substr(files[1], 1, nchar(files[1])-4)
      return(layername)
    } else {
      warning("Layer ", layerid, " does not exist in directory ", directory)
      return(NA)
    }
  }
}

#' Load CanVec Data
#' 
#' Load layerid for NTS reference(s) that were previously downloaded to cachedir.
#' 
#' @param ntsid One or more NTS References as generated by \code{nts()}
#' @param layerid A single layer id as listed in \code{canvec_layers$id}
#' @param cachedir Pass a specific cache directory in which files have been extracted.
#'                  Default value is that returned by \code{canvec.cachedir()}
#' @return A sp::Spatial* object loaded from the given shapefile or a \code{list}
#'         of Spatial* objects if more than one directory is specified.
#'         
#' @examples buildings <- canvec.load(nts("21h1"), "building")
#'
#' @export
canvec.load <- function(ntsid, layerid, cachedir=NULL) {
  if(is.null(cachedir)) {
    cachedir <- canvec.cachedir()
  }
  if(class(ntsid)=="list") {
    out <- list()
    for(singleid in ntsid) {
      directory = file.path(cachedir, canvec.filename(singleid))
      out[[length(out)+1]] <- canvec.loadfromdir(directory, layerid)
    }
    out
  } else {
    #check if file exists before reading
    directory = file.path(cachedir, canvec.filename(ntsid))
    canvec.loadfromdir(directory, layerid)
  }
}

#' Load CanVec Data From Directory
#' 
#' Load layerid from a directory or directories that contain(s) CanVec data.
#' 
#' @param directory A directory or directories that contain(s) CanVec or CanVec+ data.
#' @param layerid A single layer id as listed in \code{canvec_layers$id}
#' @return A sp::Spatial* object loaded from the given shapefile or a \code{list}
#'         of Spatial* objects if more than one directory is specified.
#' @seealso canvec.load
#' 
#' @export
canvec.loadfromdir <- function(directory, layerid) {
  if(length(directory) > 1) {
    out <- list()
    for(directory_single in directory) {
      out[[length(out)+1]] <- canvec.load(directory_single, layerid)
    }
    out
  } else {
    layername <- canvec.findlayer(directory, layerid)
    if(is.na(layername)) return(NULL) #shapefile not found in canvec
    rgdal::readOGR(dsn=directory, layer=layername)
  }
}

#' Export CanVec Data
#' 
#' Export \code{layers} for one or more NTS reference(s) \code{ntsid} to path \code{tofolder}, 
#' automatically renaming layers based on their layerid. Pass \code{crs} to re-project data,
#' or pass \code{driver} to convert file format.
#' 
#' @param ntsid One or more NTS References as generated by \code{nts()}
#' @param tofolder A directory to which files should be copied.
#' @param layers One or more layer ids as listed in \code{canvec_layers$id}. Defaults to
#'                  all layers.
#' @param crs A CRS (as generated by \code{sp::CRS()}) in which to project the data.
#' @param driver A \code{rgdal} driver with which to save data. \code{ESRI Shapefile},
#' \code{KML}, \code{CSV}, and \code{GML} have been tested; others returned by
#' \code{rgdal::ogrDrivers()} may also work.
#' @param cachedir Pass a specific cache directory in which files have been extracted.
#'                  Default value is that returned by \code{canvec.cachedir()}
#' @param combine \code{TRUE} if output should be one file per layer, \code{FALSE} otherwise
#' @param overwrite \code{TRUE} if files should overwrite files already in output directory.
#' @param ... Arguments passed on to \code{sp::writeOGR()}
#' @examples 
#' \donttest{
#' canvec.download(nts("21h01"))
#' canvec.export(nts("21h01"), "exporteddata", layers=c("road", "river"))
#' canvec.export(nts("21h01"), "exporteddataUTM", layers=c("road", "river"), 
#'                  crs=sp::CRS("+init=epsg:26920"))
#' canvec.export(nts("21h01"), "exporteddata", layers=c("road", "river"), 
#'                driver="KML")
#' canvec.export(nts("21h01"), "exporteddataALL")
#' }
#' 
#' @export
#' @importFrom sp rbind.SpatialPointsDataFrame
#' @importFrom sp rbind.SpatialPolygonsDataFrame
#' @importFrom sp rbind.SpatialLinesDataFrame
canvec.export <- function(ntsid, tofolder, layers=NULL, crs=NULL, cachedir=NULL, driver=NULL,
                          combine=TRUE, overwrite=TRUE, ...) {
  # CMD trick
  rbind.SpatialLinesDataFrame; rbind.SpatialPointsDataFrame; rbind.SpatialPolygonsDataFrame
  dir.create(tofolder)
  
  if(class(ntsid) != "list") {
    ntsid <- list(ntsid)
  }
  if(is.null(cachedir)) {
    cachedir <- canvec.cachedir()
  }
  if(is.null(layers)) {
    layers <- canvec_layers$id
  }
  
  if(combine && length(ntsid) > 1) {
    
    for(layer in layers) {
      spdf <- do.call(.spatial_rbind, lapply(ntsid, function(n, ...) {
        tryCatch(return(canvec.load(n, ...)), error=function(err) {
          return(NULL)
        })
      }, layer))
      
      if(is.null(spdf)) {
        next
      }
      
      if(is.null(driver)) {
        driver <- "ESRI Shapefile"
      }
      
      if(driver == "ESRI Shapefile") {
        dsn <- tofolder
      } else {
        if(driver == "KML") {
          ext <- ".kml"
        } else if(driver == "CSV") {
          ext <- ".csv"
        } else if(driver == "GML") {
          ext <- ".gml"
        } else {
          ext <- driver
        }
        
        dsn <- paste0(file.path(tofolder, layer), ext)
      }
      message("Writing dsn: ", dsn, "; layer: ", layer)
      if(is.null(crs)) {
        rgdal::writeOGR(spdf, dsn=dsn, layer=layer, driver=driver, overwrite=overwrite, ...)
      } else {
        rgdal::writeOGR(sp::spTransform(spdf, crs), 
                        dsn=dsn, layer=layer, driver=driver, overwrite=overwrite, ...)
      }
    }
    
  } else {
    layerinfo <- list()
    filesto <- rep(NA, length(layers)*length(ntsid))
    filemeta <- list()
    for(i in 1:length(ntsid)) {
      directory = file.path(cachedir, canvec.filename(ntsid[[i]]))
      for(j in 1:length(layers)) {
        ind <- (i-1)*length(layers)+j
        layerinfo[[ind]] <- c(directory, canvec.findlayer(directory, layers[j]))
        filemeta[[ind]] <- c(ntsstring(ntsid[[i]]), layers[j])
        filesto[ind] <- paste(layers[j], paste(ntsid[[i]], collapse=""), sep="_")
      }
    }
    
    extensions <- c(".cpg", ".dbf", ".prj", ".shp", ".shx")
    for(i in 1:length(layerinfo)) {
      filefrom <- file.path(layerinfo[[i]][1], layerinfo[[i]][2])
      if(is.null(crs) && is.null(driver)) {
        #copy files
        for(ext in extensions) {
          filename <- paste0(filefrom, ext)
          if(file.exists(filename)) {
            fileto <- paste0(file.path(tofolder, filesto[i]),ext)
            message("Copying ", filename, " to ", fileto, "\n")
            file.copy(filename, fileto, overwrite=TRUE)
          } else {
            message("*File ", filename, " not found. not copied\n")
          }
        }
      } else {
        #load file, convert crs, then save
        if(file.exists(paste0(filefrom, ".shp"))) {
          
          if(is.null(driver)) {
            driver <- "ESRI Shapefile"
          }
          
          if(driver == "ESRI Shapefile") {
            dsn <- tofolder
          } else {
            if(driver == "KML") {
              ext <- ".kml"
            } else if(driver == "CSV") {
              ext <- ".csv"
            } else if(driver == "GML") {
              ext <- ".gml"
            } else {
              ext <- driver
            }
            
            dsn <- paste0(file.path(tofolder, filesto[i]), ext)
          }
          
          layer <- filesto[i]
          
          spobj <- rgdal::readOGR(dsn=layerinfo[[i]][1], layer=layerinfo[[i]][2])
          message("Writing dsn: ", dsn, "; layer: ", layer)
          if(is.null(crs)) {
            rgdal::writeOGR(spobj, dsn=dsn, layer=layer, driver=driver, overwrite=overwrite, ...)
          } else {
            rgdal::writeOGR(sp::spTransform(spobj, crs), 
                            dsn=dsn, layer=layer, driver=driver, overwrite=overwrite, ...)
          }
        } else {
          message("File ", filefrom, " not found, skipping.")
        }
      }
      
    }
  }
}

#' Remove CanVec Data Files
#' 
#' Deletes files downloaded by \code{canvec.download()}. Use \code{all=TRUE}
#' to remove the cache directory entirely.
#' 
#' @param ntsid One or more NTS References as generated by \code{nts()}
#' @param cachedir The same \code{cachedir} that was passed to \code{canvec.download()}
#' @param all Use \code{all=TRUE} to recursively delete the cache directory.
#' @param keeparchives Pass \code{TRUE} to keep .zip files downloaded by \code{canvec.download()}
#' @param keepfolders Pass \code{TRUE} to keep folders extracted by \code{canvec.download()}
#' 
#' @export
#' @examples
#' \donttest{
#' canvec.download(nts('21h1'))
#' canvec.cleanup(nts('21h1'))
#' #or
#' canvec.cleanup(all=TRUE)
#' }

canvec.cleanup <- function(ntsid=NULL, cachedir=NULL, all=FALSE, 
                           keeparchives=FALSE, keepfolders=FALSE) {
  if(is.null(cachedir)) {
    cachedir <- canvec.cachedir()
  }
  
  if(is.null(ntsid) && !all) {
    stop("ntsid=NULL and all=FALSE: nothing to clean")
  } else if(!is.null(ntsid) && all) {
    stop("Ambiguous call: ntsid and all=TRUE both specified")
  } else if (all) {
    zipfiles <- list.files(cachedir, "canvec_.*.zip", full.names = TRUE)
    folders <- list.files(cachedir, "canvec_.*_shp$", full.names = TRUE)
    if(!keeparchives) {
      for(zipfile in zipfiles) {
        cat("Removing", zipfile, "\n")
        if(unlink(zipfile)==1) warning("File ", zipfile, " not deleted")
      }
    } else {
      cat("Skipping cleanup of .zip files\n")
    }
    
    if(!keepfolders) {
      for(folder in folders) {
        cat("Removing", folder, " recursively\n")
        if(unlink(folder, recursive=TRUE)==1) warning("Directory ", folder, " not deleted")
      }
    } else {
      cat("Skipping cleanup of extracted folders\n")
    }
  } else {
    if(class(ntsid) != "list") {
      ntsid <- list(ntsid)
    }
    
    for(singleid in ntsid) {
      folder <- file.path(cachedir, canvec.filename(singleid))
      zipfile <- file.path(cachedir, canvec.filename(singleid, ext=".zip"))
      if(!keeparchives) {
        if(file.exists(zipfile)) {
          cat("Removing", zipfile, "\n")
          if(unlink(zipfile)==1) warning("File ", zipfile, " not deleted")
        } else {
          cat("File", zipfile, "not found\n")
        }
      }
      
      if(!keepfolders) {
        if(file.exists(folder)) {
          cat("Removing", folder, " recursively\n")
          if(unlink(folder, recursive=TRUE)==1) warning("Directory ", folder, " not deleted")
        } else {
          cat("Directory", folder, "not found\n")
        }
      }
    }
    
  }
  
  
}


#' Plot CanVec Spatial Data
#' 
#' @param loaded A Spatial* object or list of Spatial* objects such as those
#' generated by \code{canvec.load()}
#' @param options A \code{list} object with the graphical options to be applied
#' to the layers specified
#' @param crs A CRS (as generated by \code{sp::CRS()}) in which to project the data.
#' @param add TRUE if layer or layers should be added to the current plot, FALSE
#' if all layers should be plotted on a fresh plot (not reccomended) or NULL for
#' default behaviour, which will create a new plot for the first layer and add
#' each subsequent layer
#' 
#' @export
#' 
canvec.plot <- function(loaded, options=NULL, crs=NULL, add=NULL) {
  if(class(loaded)!="list") {
    loaded <- list(loaded)
  }
  if(is.null(options)) {
    options <- list()
  }
  added=FALSE
  for(layer in loaded) {
    if(is.null(crs)) {
      options$x <- layer
    } else {
      options$x <- sp::spTransform(layer, crs)
    }
    
    if(is.null(add) && !added) {
      options$add <- TRUE
    }
    options$add <- add
    
    do.call(sp::plot, options)
    added=TRUE
  }
}

.makecol <- function(r, g, b, alpha=1) {
  grDevices::rgb(r, g, b, alpha*255, maxColorValue=255)
}

#' Get Default Options For Plotting Layers
#' 
#' @param layerid The layer id as defined in \code{canvec_layers$id}
#' @return a \code{list} object that can be passed to \code{canvec.plot()}
#' 
#' @export
#' 
canvec.defaultoptions <- function(layerid) {
  
  if(layerid=="waterbody") {
    return(list(col=.makecol(220, 234, 247), border=.makecol(220, 234, 247)))
  } else if(layerid=="building") {
    return(list(pch=15, cex=0.2, col="black"))
  } else if(layerid=="contour") {
    return(list(col=.makecol(165, 43, 42), lwd=0.2))
  } else if(layerid=="river") {
    return(list(col="lightblue", lwd=1))
  } else if(layerid=="road") {
    return(list(col="black", lwd=0.5))
  } else if(layerid=="forest") {
    return(list(col=.makecol(208, 234, 221), border=.makecol(208, 234, 221)))
  } else if(layerid=="building_poly") {
    return(list(col="black", border="black"))
  } else {
    return(list())
  }
}

.spatial_rbind <- function(...) {
  arglist <- list(...)
  lastid <- -1
  
  for(i in 1:length(arglist)) {
    rows <- length(arglist[[i]])
    if(rows > 0) {
      row.names(arglist[[i]]) <- as.character((lastid+1):(lastid+rows))
    }
    lastid <- lastid + rows
  }

  do.call(rbind, arglist[!sapply(arglist,is.null)])
}