0.3.0 fix: #28, #49, #50, #51, #52, #55 and more

atmoschem · Feb 5, 2018 · aa0ccfe · aa0ccfe
1 parent ccb8f3a
commit aa0ccfe
Show file tree

Hide file tree

Showing 95 changed files with 657 additions and 463 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -16,7 +16,7 @@ URL: https://github.com/atmoschem/vein
 BugReports: https://github.com/atmoschem/vein/issues/
 LazyData: no
 Depends: R (>= 2.10)
-Imports: sf, sp, data.table, graphics, stats, units
+Imports: sf, sp, data.table, graphics, stats, units, methods
 Suggests: knitr, rmarkdown
 RoxygenNote: 6.0.1
 NeedsCompilation: no

diff --git a/NAMESPACE b/NAMESPACE
@@ -67,23 +67,25 @@ export(running_losses)
 export(speciate)
 export(temp_fact)
 export(vkm)
-import(sf)
 import(sp)
+importFrom(data.table,.SD)
 importFrom(data.table,data.table)
-importFrom(raster,raster)
-importFrom(raster,rasterToPolygons)
+importFrom(grDevices,terrain.colors)
+importFrom(methods,as)
+importFrom(sf,st_as_sf)
 importFrom(sf,st_cast)
 importFrom(sf,st_dimension)
 importFrom(sf,st_intersection)
 importFrom(sf,st_length)
+importFrom(sf,st_set_geometry)
 importFrom(sf,st_sf)
 importFrom(sf,st_transform)
 importFrom(sp,CRS)
 importFrom(sp,GridTopology)
 importFrom(sp,SpatialGridDataFrame)
 importFrom(sp,bbox)
 importFrom(sp,coordinates)
-importFrom(sp,over)
 importFrom(sp,proj4string)
 importFrom(sp,spTransform)
 importFrom(units,as_units)
+importFrom(utils,head)
diff --git a/NEWS.md b/NEWS.md
@@ -4,8 +4,13 @@
 - Fix #51: deparse text
 - Fix #52: separate objects in rm with ','
 - Add class GriddedEmissionsArray
-- emis_grid adds argument array which can returns spatial object or 
-GriddedEmissionsArray
+- Fix #28, data.table imported in emis_grd. Now very fast!
+- Fix #55.
+- Minor fix on demo(VEIN).
+- emis and emis_cold adjust length of ef by length of columns of first
+element of the list of data-frames.
+- Revised all examples.
+
 
 ## vein v0.2.4 (Release date: 2018-01-31)
 - new data set names profiles data(profiles)

diff --git a/R/Emissions.R b/R/Emissions.R
@@ -34,8 +34,8 @@
 #' #vehicles newer than pre-euro
 #' co1 <- fe2015[fe2015$Pollutant=="CO", ] #24 obs!!!
 #' cod <- c(co1$PC_G[1:24]*c(cod1,cod2),co1$PC_G[25:nrow(co1)])
-#' lef <- ef_ldv_scaled(co1, cod, v = "PC", t = "ALL", cc = "ALL",
-#'                      f = "G",p = "CO", eu=co1$Euro_LDV)
+#' lef <- ef_ldv_scaled(co1, cod, v = "PC",  cc = "<=1400",
+#'                      f = "G", p = "CO", eu=co1$Euro_LDV)
 #' lef <- c(lef,lef[length(lef)],lef[length(lef)],lef[length(lef)],
 #'          lef[length(lef)],lef[length(lef)])
 #' E_CO <- emis(veh = pc1,lkm = net$lkm, ef = lef, speed = speed, agemax = 41,

diff --git a/R/EmissionsArray.R b/R/EmissionsArray.R
@@ -32,10 +32,8 @@
 #' #vehicles newer than pre-euro
 #' co1 <- fe2015[fe2015$Pollutant=="CO", ] #24 obs!!!
 #' cod <- c(co1$PC_G[1:24]*c(cod1,cod2),co1$PC_G[25:nrow(co1)])
-#' lef <- ef_ldv_scaled(co1, cod, v = "PC", t = "ALL", cc = "ALL",
+#' lef <- ef_ldv_scaled(co1, cod, v = "PC", cc = "<=1400",
 #'                      f = "G",p = "CO", eu=co1$Euro_LDV)
-#' lef <- c(lef,lef[length(lef)],lef[length(lef)],lef[length(lef)],
-#'          lef[length(lef)],lef[length(lef)])
 #' E_CO <- emis(veh = pc1,lkm = net$lkm, ef = lef, speed = speed, agemax = 41,
 #'              profile = pc_profile, hour = 24, day = 7, array = T)
 #' class(E_CO)

diff --git a/R/EmissionsList.R b/R/EmissionsList.R
@@ -30,7 +30,7 @@
 #' #vehicles newer than pre-euro
 #' co1 <- fe2015[fe2015$Pollutant=="CO", ] #24 obs!!!
 #' cod <- c(co1$PC_G[1:24]*c(cod1,cod2),co1$PC_G[25:nrow(co1)])
-#' lef <- ef_ldv_scaled(co1, cod, v = "PC", t = "ALL", cc = "ALL",
+#' lef <- ef_ldv_scaled(co1, cod, v = "PC", cc = "<=1400",
 #'                      f = "G",p = "CO", eu=co1$Euro_LDV)
 #' lef <- c(lef,lef[length(lef)],lef[length(lef)],lef[length(lef)],
 #'          lef[length(lef)],lef[length(lef)])

diff --git a/R/GriddedEmissionsArray.R b/R/GriddedEmissionsArray.R
@@ -15,7 +15,9 @@
 #' @rdname GriddedEmissionsArray
 #' @aliases GriddedEmissionsArray print.GriddedEmissionsArray
 #' summary.GriddedEmissionsArray plot.GriddedEmissionsArray
-#' @import sf
+#' @importFrom sf st_set_geometry
+#' @importFrom grDevices terrain.colors
+#' @importFrom utils head
 #' @examples \dontrun{
 #' data(net)
 #' data(pc_profile)
@@ -36,10 +38,8 @@
 #' #vehicles newer than pre-euro
 #' co1 <- fe2015[fe2015$Pollutant=="CO", ] #24 obs!!!
 #' cod <- c(co1$PC_G[1:24]*c(cod1,cod2),co1$PC_G[25:nrow(co1)])
-#' lef <- ef_ldv_scaled(co1, cod, v = "PC", t = "ALL", cc = "ALL",
+#' lef <- ef_ldv_scaled(co1, cod, v = "PC", t = "4S", cc = "<=1400",
 #'                      f = "G",p = "CO", eu=co1$Euro_LDV)
-#' lef <- c(lef,lef[length(lef)],lef[length(lef)],lef[length(lef)],
-#'          lef[length(lef)],lef[length(lef)])
 #' E_CO <- emis(veh = pc1,lkm = net$lkm, ef = lef, speed = speed, agemax = 41,
 #'              profile = pc_profile, hour = 24, day = 7, array = T)
 #' class(E_CO)
@@ -51,29 +51,32 @@
 #' names(net)
 #' E_CO_g <- emis_grid(spobj = net, g = g, sr= 31983)
 #' head(E_CO_g) #class sf
-#' gr <- GriddedEmissionsArray(E_CO_g, rows = 23, cols = 19, times = 168)
-#' E_CO_g$V138 <- as.numeric(E_CO_g$V138)
+#' library(mapview)
+#' mapview(E_CO_g, zcol= "V1", legend = T)
+#' gr <- GriddedEmissionsArray(E_CO_g, rows = 19, cols = 23, times = 168)
+#' plot(gr)
 #' }
 #' @export
-GriddedEmissionsArray <- function(x, ..., rows, cols, times = ncol(x)) {
-  if (class(x) == "SpatialPolygonsDataFrame") {
-    df <- x@data
-  } else if (class(x) == "sf") {
+GriddedEmissionsArray <- function(x, ..., cols, rows, times = ncol(x)) {
+  x$id <- NULL
+  if(inherits(x, "Spatial")){
+  df <- sf::st_as_sf(x)
+  df <- sf::st_set_geometry(x, NULL)
+  } else if(inherits(x, "sf")){
     df <- sf::st_set_geometry(x, NULL)
-  } else if(is.data.frame(x) | is.matrix(x)){
-      df <- x
   }
   for (i in 1:ncol(df)) {
     df[, i] <- as.numeric(df[, i])
   }
-  df$id <- NULL
-  e <- array(unlist(df), c(rows, cols, zlev, times))
+  e <- simplify2array(lapply(1:ncol(df), function(i){
+    m <- matrix(df[, i], nrow = rows, ncol = cols, byrow = T)
+    m <- m[nrow(m):1, ]
+    }))
   class(e) <- c("GriddedEmissionsArray",class(e))
   cat("This GriddedEmissionsArray has:\n",
-      dim(e)[1], "lat points\n",
-      dim(e)[2], "lon points\n",
-      dim(e)[3], "Vertical levels\n",
-      dim(e)[4], "hours\n")
+      rows, "lat points\n",
+      cols, "lon points\n",
+      times,  "hours\n")
   return(e)
 }
 
@@ -86,9 +89,8 @@ if (is.array(e)) {
     cat("This GriddedEmissionsArray has:\n",
         dim(e)[1], "lat points\n",
         dim(e)[2], "lon points\n",
-        dim(e)[3], "Vertical levels\n",
-        dim(e)[4], "hours\n\n")
-  print(head(e))
+        dim(e)[3], "hours\n\n")
+  print(utils::head(e))
   }
 }
 
@@ -97,17 +99,14 @@ if (is.array(e)) {
 #' @export
 summary.GriddedEmissionsArray <- function(object, ...) {
   e <- object
-  summary(e[ , , 0 , ])
+  summary(e[ , ,  ])
   }
 
 #' @rdname GriddedEmissionsArray
 #' @method plot GriddedEmissionsArray
 #' @export
-plot.GriddedEmissionsArray <- function(x, ...) {
+plot.GriddedEmissionsArray <- function(x, ..., times = 1) {
   e <- x
-  graphics::par(mfrow=c(3, 3), tcl = -0.5)
-  for (i in 1:9){
-    graphics::image(e[ , , 0 , i], col = terrain.colors(12))
-  }
+  graphics::image(e[ , , times], col = grDevices::terrain.colors(12))
   graphics::par(mfrow = c(1, 1))
 }
diff --git a/R/adt.R b/R/adt.R
@@ -63,6 +63,9 @@ adt <- function(pc, lcv, hgv, bus, mc,
      return(df*units::as_units("d-1"))
    } else{
      df <- df_pc + df_lcv + df_hgv + df_bus + df_mc
+     for (i  in 1:ncol(df) ) {
+       df[, i] <- as.numeric(df[, i])
+     }
      return(Vehicles(df))
      }
    }
diff --git a/R/age_moto.R b/R/age_moto.R
@@ -15,8 +15,8 @@
 #' @export
 #' @examples \dontrun{
 #' # Do not run
-#' m <- rnorm(100, 300, 10)
-#' MOTO_E25_500 <- age_moto(x = m,name = "M_E25_500")
+#' mc <- rnorm(100, 300, 10)
+#' MOTO_E25_500 <- age_moto(x = mc, name = "M_E25_500")
 #' plot(MOTO_E25_500)
 #' }
 age_moto <- function (x, name, a = 0.2, b = 17, agemin = 1, agemax = 50, k = 1,

diff --git a/R/ef_nitro.R b/R/ef_nitro.R
@@ -27,7 +27,9 @@
 #' show.equation = F)
 #' efe50 <- ef_nitro(v = "PC", t = "Hot", cc = "Urban", f = "G",
 #' eu = "III", p = "NH3", S = 50,
-#' show.equation = F)
+#' show.equation = T)
+#' efe10(10)
+#' efe50(10)
 #' }
 ef_nitro <- function(v, t, cc, f, eu, p, S, k = 1, show.equation = TRUE){
   ef <- sysdata[[8]]

diff --git a/R/emis.R b/R/emis.R
@@ -75,15 +75,15 @@ emis <- function (veh, lkm, ef, speed = 34,
   }
   # veh is "Vehicles" data-frame
   if (!inherits(x = veh, what = "list")) {
-      veh <- as.data.frame(veh)
-      for (i  in 1:ncol(veh) ) {
-        veh[,i] <- as.numeric(veh[,i])
-      }
-      if(ncol(veh) != length(ef)){
-        message("Number of columns of 'veh' is different than length of 'ef'")
-        cat("\nadjusting length of ef to the number of colums of 'veh'\n")
-        if(ncol(veh) > length(ef)){
-          for(i in (ncol(veh) - length(ef)):ncol(veh) ){
+    veh <- as.data.frame(veh)
+    for (i  in 1:ncol(veh) ) {
+      veh[,i] <- as.numeric(veh[,i])
+    }
+    if(ncol(veh) != length(ef)){
+      message("Number of columns of 'veh' is different than length of 'ef'")
+      message("adjusting length of ef to the number of colums of 'veh'\n")
+      if(ncol(veh) > length(ef)){
+        for(i in (length(ef) + 1):ncol(veh) ){
             ef[[i]] <- ef[[length(ef)]]
           }
           if (ncol(veh) < length(ef)){
@@ -97,13 +97,14 @@ emis <- function (veh, lkm, ef, speed = 34,
       }
 
       if(array == F){
-      lista <- lapply(1:day,function(j){
-        lapply(1:hour,function(i){
-          lapply(1:agemax, function(k){
+        lista <- lapply(1:day,function(j){
+          lapply(1:hour,function(i){
+            lapply(1:agemax, function(k){
             veh[, k]*profile[i,j]*lkm*ef[[k]](speed[, i])
             }) }) })
         return(EmissionsList(lista))
       } else {
+
       d <-  simplify2array(
         lapply(1:day,function(j){
           simplify2array(
@@ -118,10 +119,21 @@ emis <- function (veh, lkm, ef, speed = 34,
       }
   # veh is a list of "Vehicles" data-frames
   } else {
-    if (ncol(veh[[1]]) != length(ef)){
-      stop("Number of columns in 'veh' must be the same as length of ef")
-    } else if(length(veh) != ncol(speed)) {
-      stop("Length of 'veh' must be the same as number of columns of speed")
+    if(ncol(veh[[1]]) != length(ef)){
+      message("Number of columns of 'veh' is different than length of 'ef'")
+      message("adjusting length of ef to the number of colums of 'veh'\n")
+      if(ncol(veh[[1]]) > length(ef)){
+        for(i in (length(ef) + 1):ncol(veh[[1]]) ){
+          ef[[i]] <- ef[[length(ef)]]
+        }
+        if (ncol(veh[[1]]) < length(ef)){
+          ff <- list()
+          for(i in 1:ncol(veh[[1]])){
+            ff[[i]] <- ef[[i]]
+          }
+          ef <- ff
+        }
+      }
     }
     for (j in 1:length(veh)) {
         for (i  in 1:ncol(veh[[j]]) ) {

diff --git a/R/emis_cold.R b/R/emis_cold.R
@@ -55,9 +55,12 @@
 #' lef <- c(lef,lef[length(lef)],lef[length(lef)],lef[length(lef)],
 #'          lef[length(lef)],lef[length(lef)])
 #' # Mohtly average temperature 18 Celcius degrees
-#' lefc <- ef_ldv_cold_list(df = co1, ta = 18, cc = "<=1400", f = "G",
+#' lefec <- ef_ldv_cold_list(df = co1, ta = 18, cc = "<=1400", f = "G",
 #'                           eu = co1$Euro_LDV, p = "CO" )
-#' length(lefc) != ncol(pc1)
+#' lefec <- c(lefec,lefec[length(lefec)], lefec[length(lefec)],
+#'            lefec[length(lefec)], lefec[length(lefec)],
+#'            lefec[length(lefec)])
+#' length(lefec) == ncol(pc1)
 #' #emis change length of 'ef' to match ncol of 'veh'
 #' class(lefec)
 #' PC_CO_COLD <- emis_cold(veh = pc1, lkm = net$lkm, ef = lef, efcold = lefec,
@@ -90,16 +93,18 @@ emis_cold <- function (veh, lkm, ef, efcold, beta, speed = 34,
     speed[, i] <- as.numeric(speed[, i])
   }
   if (!inherits(x = veh, what = "list")) {
-          veh <- as.data.frame(veh)
-        lkm <- as.numeric(lkm)
-        for(i in 1:ncol(veh)){
-          veh[,i] <- as.numeric(veh[,i])
-        }
-        if(ncol(veh) != length(ef)){
-          message("Number of columns of 'veh' is different than length of 'ef'")
-          cat("\nadjusting length of ef to the number of colums of 'veh'\n")
-          if(ncol(veh) > length(ef)){
-            for(i in (ncol(veh) - length(ef)):ncol(veh) ){
+    veh <- as.data.frame(veh)
+    lkm <- as.numeric(lkm)
+    for(i in 1:ncol(veh)){
+      veh[,i] <- as.numeric(veh[,i])
+    }
+    if(ncol(veh) != length(ef)){
+      message("Number of columns of 'veh' is different than length of 'ef'")
+      message("adjusting length of ef to the number of colums of 'veh'\n")
+      if(ncol(veh) > length(ef)){
+        for(i in (length(ef) + 1):ncol(veh) ){
+
+            # for(i in (ncol(veh) - length(ef)):ncol(veh) ){
               ef[[i]] <- ef[[length(ef)]]
             }
             if (ncol(veh) < length(ef)){
@@ -142,10 +147,21 @@ emis_cold <- function (veh, lkm, ef, efcold, beta, speed = 34,
         return(EmissionsArray(d))
       }
   } else {
-    if (ncol(veh[[1]]) != length(ef)){
-      stop("Number of columns in 'veh' must be the same as length of ef")
-    } else if(length(veh) != ncol(speed)) {
-      stop("Length of 'veh' must be the same as number of columns of speed")
+    if(ncol(veh[[1]]) != length(ef)){
+      message("Number of columns of 'veh' is different than length of 'ef'")
+      message("adjusting length of ef to the number of colums of 'veh'\n")
+      if(ncol(veh[[1]]) > length(ef)){
+        for(i in (length(ef) + 1):ncol(veh[[1]]) ){
+          ef[[i]] <- ef[[length(ef)]]
+        }
+        if (ncol(veh[[1]]) < length(ef)){
+          ff <- list()
+          for(i in 1:ncol(veh[[1]])){
+            ff[[i]] <- ef[[i]]
+          }
+          ef <- ff
+        }
+      }
     }
     for (j in 1:length(veh)) {
           for (i  in 1:ncol(veh[[j]]) ) {