From a5ab03309def3d4e49db2219963c0cec8c9e61bb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Nussbaumer?= Date: Fri, 26 Apr 2024 14:39:13 +0200 Subject: [PATCH 1/8] Specify the package for function crop to avoid errors. --- R/internal.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/internal.R b/R/internal.R index 43ffeea..abd3485 100755 --- a/R/internal.R +++ b/R/internal.R @@ -507,7 +507,7 @@ repl_vals <- function(data, x, y){ #if(n.rlay > 1) r_list <- lapply(1:n.rlay, function(i) lapply(r_list, "[[", i)) else r_list <- list(r_list) #FRIDAY if(isTRUE(crop_raster)){ - r_list <- lapply(r_list, crop, y = extent(gg.ext[1], gg.ext[3], gg.ext[2], gg.ext[4]), snap = "out") + r_list <- lapply(r_list, terra::crop, y = extent(gg.ext[1], gg.ext[3], gg.ext[2], gg.ext[4]), snap = "out") } if(n > 1){ From c4ee7d50e21045099535826baf5c80665fab0e88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Nussbaumer?= Date: Fri, 26 Apr 2024 14:40:20 +0200 Subject: [PATCH 2/8] Fix missing assignment of `ext` in `.ext()` --- R/internal.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/internal.R b/R/internal.R index abd3485..713c5c7 100755 --- a/R/internal.R +++ b/R/internal.R @@ -214,6 +214,8 @@ repl_vals <- function(data, x, y){ ext <- st_bbox(st_transform(st_as_sfc(st_bbox(ext, crs = m.crs)), st_crs(4326))) if(!quiet(st_intersects(st_as_sfc(ext), st_as_sfc(gg.ext), sparse = F)[1,1])) out("Argument 'ext' does not overlap with the extent of 'm'.", type = 3) + + gg.ext <- ext margin_factor <- 1 # no margin since user extent set } From 8c4bc4a6fee56ef2eb2711693f945f2ddfd60a5a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Nussbaumer?= Date: Fri, 26 Apr 2024 14:42:34 +0200 Subject: [PATCH 3/8] Fix style with `styler:::style_active_pkg()` --- R/add_colourscale.R | 83 ++-- R/add_gg.R | 129 ++--- R/add_labels.R | 50 +- R/add_northarrow.R | 79 +-- R/add_progress.R | 47 +- R/add_scalebar.R | 131 ++--- R/add_text.R | 67 +-- R/add_timestamps.R | 43 +- R/align_move.R | 85 ++-- R/animate_frames.R | 152 +++--- R/data.R | 32 +- R/deprecated.R | 8 +- R/df2move.R | 72 ++- R/frames_graph.R | 202 ++++---- R/frames_spatial.R | 290 +++++------ R/get_frametimes.R | 18 +- R/internal.R | 669 ++++++++++++++------------ R/join_frames.R | 64 +-- R/methods.R | 114 ++--- R/pkgname.R | 10 +- R/reexports.R | 2 +- R/render_frame.R | 74 +-- R/settings.R | 66 +-- R/subset_move.R | 43 +- R/suggest_formats.R | 17 +- R/view_spatial.R | 95 ++-- tests/testthat/helper-vars.R | 24 +- tests/testthat/test-add_.R | 38 +- tests/testthat/test-align_move.R | 12 +- tests/testthat/test-animate_frames.R | 14 +- tests/testthat/test-deprecated.R | 4 +- tests/testthat/test-df2move.R | 68 ++- tests/testthat/test-frames_graph.R | 22 +- tests/testthat/test-frames_spatial.R | 44 +- tests/testthat/test-internal.R | 6 +- tests/testthat/test-join_frames.R | 4 +- tests/testthat/test-settings.R | 6 +- tests/testthat/test-subset_move.R | 6 +- tests/testthat/test-suggest_formats.R | 4 +- tests/testthat/test-view_spatial.R | 11 +- vignettes/example-7.Rmd | 2 +- 41 files changed, 1533 insertions(+), 1374 deletions(-) diff --git a/R/add_colourscale.R b/R/add_colourscale.R index b5233f6..29db8db 100644 --- a/R/add_colourscale.R +++ b/R/add_colourscale.R @@ -14,75 +14,80 @@ #' @author Jakob Schwalb-Willmann #' #' @importFrom ggplot2 scale_fill_gradientn scale_fill_manual expr -#' +#' #' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' # align movement #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames with frames_spatial: #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) #' frames[[100]] # take a look at one of the frames -#' +#' #' # default blue is boring, let's change the colour scale of all frames -#' frames <- add_colourscale(frames, type = "gradient", colours = c("orange", "white", "darkgreen"), -#' legend_title = "NDVI") +#' frames <- add_colourscale(frames, +#' type = "gradient", colours = c("orange", "white", "darkgreen"), +#' legend_title = "NDVI" +#' ) #' frames[[100]] -#' -#' +#' +#' #' # let's make up some classification data with 10 classes -#' r_list <- lapply(r_list, function(x){ -#' y <- raster::setValues(x, round(raster::getValues(x)*10)) +#' r_list <- lapply(r_list, function(x) { +#' y <- raster::setValues(x, round(raster::getValues(x) * 10)) #' return(y) #' }) #' # turn fade_raster to FALSE, since it makes no sense to temporally interpolate discrete classes -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "discrete", -#' fade_raster = FALSE) +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "discrete", +#' fade_raster = FALSE +#' ) #' frames[[100]] -#' +#' #' # now, let's assign a colour per class value to frames #' colFUN <- colorRampPalette(c("orange", "lightgreen", "darkgreen")) #' cols <- colFUN(10) #' frames <- add_colourscale(frames, type = "discrete", colours = cols, legend_title = "Classes") #' frames[[100]] #' } -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} #' @export -add_colourscale <- function(frames, type, colours, labels = waiver(), na.colour = "grey50", na.show = TRUE, legend_title = NULL, verbose = TRUE){ - +add_colourscale <- function(frames, type, colours, labels = waiver(), na.colour = "grey50", na.show = TRUE, legend_title = NULL, verbose = TRUE) { ## checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) - - if(!inherits(type, "character")) out("Argument 'type' must be of type 'character'.", type = 3) - if(!any(c("gradient", "discrete") %in% type)) out("Argument 'type' must either be 'gradient' or 'discrete'.", type = 3) - if(!inherits(colours, "character")) out("Argument 'colours' must be of type 'character'.", type = 3) - if(all(type == "discrete", !inherits(labels, "waiver"))){ - if(!inherits(labels, "character")) out("Argument 'labels' must be of type 'character'.", type = 3) - if(length(labels) != length(colours)) out("Arguments 'colours' and 'labels' must have equal lengths.", type = 3) + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) + + if (!inherits(type, "character")) out("Argument 'type' must be of type 'character'.", type = 3) + if (!any(c("gradient", "discrete") %in% type)) out("Argument 'type' must either be 'gradient' or 'discrete'.", type = 3) + if (!inherits(colours, "character")) out("Argument 'colours' must be of type 'character'.", type = 3) + if (all(type == "discrete", !inherits(labels, "waiver"))) { + if (!inherits(labels, "character")) out("Argument 'labels' must be of type 'character'.", type = 3) + if (length(labels) != length(colours)) out("Arguments 'colours' and 'labels' must have equal lengths.", type = 3) } - if(!inherits(na.colour, "character")) out("Argument 'na.colour' must be of type 'character'.", type = 3) - - if(type == "gradient"){ - if(!is.null(names(colours))) limits <- range(as.numeric(names(colours))) else limits <- NULL + if (!inherits(na.colour, "character")) out("Argument 'na.colour' must be of type 'character'.", type = 3) + + if (type == "gradient") { + if (!is.null(names(colours))) limits <- range(as.numeric(names(colours))) else limits <- NULL } - if(type == "discrete"){ - if(!is.null(names(colours))) limits <- names(colours) else limits <- NULL - if(!inherits(na.show, "logical")) out("Argument 'na.show' must be of type 'logical'.", type = 3) + if (type == "discrete") { + if (!is.null(names(colours))) limits <- names(colours) else limits <- NULL + if (!inherits(na.show, "logical")) out("Argument 'na.show' must be of type 'logical'.", type = 3) } - - if(type == "gradient") gg.scale <- expr(scale_fill_gradientn(name = legend_title, colours = colours, limits = limits, na.value = na.colour)) - if(type == "discrete") gg.scale <- expr(scale_fill_manual(name = legend_title, values = colours, labels = labels, limits = limits, na.translate = na.show, na.value = na.colour)) - + + if (type == "gradient") gg.scale <- expr(scale_fill_gradientn(name = legend_title, colours = colours, limits = limits, na.value = na.colour)) + if (type == "discrete") gg.scale <- expr(scale_fill_manual(name = legend_title, values = colours, labels = labels, limits = limits, na.translate = na.show, na.value = na.colour)) + add_gg(frames, gg.scale, colours = colours, legend_title = legend_title, limits = limits, na.colour = na.colour, na.show = na.show) } diff --git a/R/add_gg.R b/R/add_gg.R index 9e26f26..61bcd4d 100644 --- a/R/add_gg.R +++ b/R/add_gg.R @@ -15,114 +15,131 @@ #' } #' @param ... additional (non-iterated) objects that should be visible to \code{gg}. #' -#' @details +#' @details #' Agrument \code{gg} expects \code{ggplot2} functions handed over as expressions (see \code{\link{expr}}) to avoid their evaluation -#' before thex are called for the correct frame. Simply wrap your \code{ggplot2} function into \code{expr()} and supply it to -#' \code{gg}. To add multiple \code{ggplot2} functions to be applied on every frame, supply an expression containing a list of -#' \code{ggplot2} functions (e.g. \code{expr(list(geom_label(...), geom_text(...)))}). This expression would be added to all frames. +#' before thex are called for the correct frame. Simply wrap your \code{ggplot2} function into \code{expr()} and supply it to +#' \code{gg}. To add multiple \code{ggplot2} functions to be applied on every frame, supply an expression containing a list of +#' \code{ggplot2} functions (e.g. \code{expr(list(geom_label(...), geom_text(...)))}). This expression would be added to all frames. #' To add specific \code{ggplot2} functions per frame, supply a list of expressions of the same length as frames. Each expression may #' contain a list of \code{ggplot2} functions, if you want to add multiple functions per frame. -#' -#' If \code{data} is used, the \code{ggplot2} expressions supplied with \code{gg} can use the object by the name \code{data} for plotting. +#' +#' If \code{data} is used, the \code{ggplot2} expressions supplied with \code{gg} can use the object by the name \code{data} for plotting. #' If \code{data} is a list, it must be of the same length as \code{frames}. The list will be iterated, so that functions in \code{gg} #' will have access to the individual objects within the list by the name \code{data} per each frame. If the data you want to display #' is does not change with frames and may only be a character vector or similiar, you may not need \code{data}, as you can supply #' the needed values within the expression supplied through \code{gg}. -#' +#' #' If you supply \code{gg} as a list of expressions for each frame and \code{data} as a list of objects (e.g. data.frames) for each frame, -#' each frame will be manipulated with the corresponding \code{ggplot2} function and the corresponding data. +#' each frame will be manipulated with the corresponding \code{ggplot2} function and the corresponding data. #' #' @return A frames object of class \code{moveVis}. #' @author Jakob Schwalb-Willmann -#' +#' #' @examples #' library(moveVis) #' library(move) #' library(ggplot2) -#' +#' #' data("move_data", "basemap_data") #' # align movement #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' \dontrun{ #' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor") #' frames[[100]] # take a look at one of the frames -#' +#' #' # let's draw a polygon on frames: -#' data <- data.frame(x = c(8.917, 8.924, 8.924, 8.916, 8.917), -#' y = c(47.7678, 47.7675, 47.764, 47.7646, 47.7678)) -#' -#' frames = add_gg(frames, gg = expr(geom_path(aes(x = x, y = y), data = data, -#' colour = "red", linetype = "dashed")), data = data) -#' +#' data <- data.frame( +#' x = c(8.917, 8.924, 8.924, 8.916, 8.917), +#' y = c(47.7678, 47.7675, 47.764, 47.7646, 47.7678) +#' ) +#' +#' frames <- add_gg(frames, gg = expr(geom_path(aes(x = x, y = y), +#' data = data, +#' colour = "red", linetype = "dashed" +#' )), data = data) +#' #' # add some text -#' frames <- add_text(frames, "Static feature", x = 8.9205, y = 47.7633, -#' colour = "black", size = 3) +#' frames <- add_text(frames, "Static feature", +#' x = 8.9205, y = 47.7633, +#' colour = "black", size = 3 +#' ) #' frames[[100]] -#' +#' #' # add_gg can also be used iteratively to manipulate each frame differently. #' # Let's create unique polygons per frame: -#' +#' #' # create data.frame containing corner coordinates -#' data <- data.frame(x = c(8.96, 8.955, 8.959, 8.963, 8.968, 8.963, 8.96), -#' y = c(47.725, 47.728, 47.729, 47.728, 47.725, 47.723, 47.725)) +#' data <- data.frame( +#' x = c(8.96, 8.955, 8.959, 8.963, 8.968, 8.963, 8.96), +#' y = c(47.725, 47.728, 47.729, 47.728, 47.725, 47.723, 47.725) +#' ) #' # make a list from it by replicating it by the length of frames #' data <- rep(list(data), length.out = length(frames)) -#' +#' #' # now alter the coordinates to make them shift -#' data <- lapply(data, function(x){ -#' y <- rnorm(nrow(x)-1, mean = 0.00001, sd = 0.0001) +#' data <- lapply(data, function(x) { +#' y <- rnorm(nrow(x) - 1, mean = 0.00001, sd = 0.0001) #' x + c(y, y[1]) #' }) -#' +#' #' # draw each individual polygon to each frame -#' frames = add_gg(frames, gg = expr(geom_path(aes(x = x, y = y), data = data, -#' colour = "black")), data = data) -#' +#' frames <- add_gg(frames, gg = expr(geom_path(aes(x = x, y = y), +#' data = data, +#' colour = "black" +#' )), data = data) +#' #' # add a text label -#' frames <- add_text(frames, "Dynamic feature", x = 8.959, y = 47.7305, -#' colour = "black", size = 3) +#' frames <- add_text(frames, "Dynamic feature", +#' x = 8.959, y = 47.7305, +#' colour = "black", size = 3 +#' ) #' frames[[100]] -#' +#' #' # animate frames to see how the polygons "flip" #' animate_frames(frames, out_file = tempfile(fileext = ".mov")) -#' +#' #' # you can use add_gg on any list of ggplot2 objects, #' # also on frames made using frames_gr #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' -#' frames.gr <- frames_graph(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE, graph_type = "hist", val_by = 0.01) -#' frames.gr[[100]] +#' +#' frames.gr <- frames_graph(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE, graph_type = "hist", val_by = 0.01 +#' ) +#' frames.gr[[100]] #' # manipulate the labels, since they are very dense: #' # just replace the current scale -#' frames.gr <- add_gg(frames.gr, expr(scale_x_continuous(breaks=seq(0,1,0.1), -#' labels=seq(0,1,0.1), expand = c(0,0)))) +#' frames.gr <- add_gg(frames.gr, expr(scale_x_continuous( +#' breaks = seq(0, 1, 0.1), +#' labels = seq(0, 1, 0.1), expand = c(0, 0) +#' ))) #' frames.gr[[100]] #' } -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} #' @export -add_gg <- function(frames, gg, data = NULL, ..., verbose = T){ - +add_gg <- function(frames, gg, data = NULL, ..., verbose = T) { ## check data and replicate if necessary - if(inherits(data, "list")){ - if(length(data) != length(frames)) out("Argument 'data' is a list und thus must be of same length as 'frames'.", type = 3) - } else{ - if(!is.null(data)) data <- rep(list(data), length(frames)) + if (inherits(data, "list")) { + if (length(data) != length(frames)) out("Argument 'data' is a list und thus must be of same length as 'frames'.", type = 3) + } else { + if (!is.null(data)) data <- rep(list(data), length(frames)) } - + ## gg is not a list, make it one - if(inherits(gg, "list")){ - if(length(gg) != length(frames)) out("Argument 'gg' is a list und thus must be of same length as 'frames'.", type = 3) - } else{ - if(length(gg) != length(frames)) gg <- rep(list(gg), length(frames)) + if (inherits(gg, "list")) { + if (length(gg) != length(frames)) out("Argument 'gg' is a list und thus must be of same length as 'frames'.", type = 3) + } else { + if (length(gg) != length(frames)) gg <- rep(list(gg), length(frames)) } - if(!is.call(gg[[1]])) out("Argument 'gg' must be an expression or a list of expressions (see ?moveVis::add_gg and ?ggplot2::expr).", type = 3) - - if(is.null(frames$additions)) frames$additions <- list(list(expr = gg, data = data, arg = list(...))) else{ + if (!is.call(gg[[1]])) out("Argument 'gg' must be an expression or a list of expressions (see ?moveVis::add_gg and ?ggplot2::expr).", type = 3) + + if (is.null(frames$additions)) { + frames$additions <- list(list(expr = gg, data = data, arg = list(...))) + } else { frames$additions <- c(frames$additions, list(list(expr = gg, data = data, arg = list(...)))) } return(frames) diff --git a/R/add_labels.R b/R/add_labels.R index 0121358..3ad7a3f 100644 --- a/R/add_labels.R +++ b/R/add_labels.R @@ -17,48 +17,52 @@ #' #' @importFrom ggplot2 labs waiver theme element_text expr #' -#' @examples +#' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames using a custom NDVI base layer #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' #' # add labels to frames: -#' frames <- add_labels(frames, title = "Example animation using moveVis::add_labels()", -#' subtitle = "Adding a subtitle to frames created using frames_spatial()", -#' caption = "Projection: Geographical, WGS84. Sources: moveVis examples.", -#' x = "Longitude", y = "Latitude") +#' frames <- add_labels(frames, +#' title = "Example animation using moveVis::add_labels()", +#' subtitle = "Adding a subtitle to frames created using frames_spatial()", +#' caption = "Projection: Geographical, WGS84. Sources: moveVis examples.", +#' x = "Longitude", y = "Latitude" +#' ) #' # have a look at one frame #' frames[[100]] #' } -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} #' @export add_labels <- function(frames, title = waiver(), subtitle = waiver(), caption = waiver(), tag = waiver(), - x = waiver(), y = waiver(), verbose = TRUE){ - + x = waiver(), y = waiver(), verbose = TRUE) { ## checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) + waiver.args <- list(title = title, subtitle = subtitle, caption = caption, tag = tag, x = x, y = y) waiver.which <- sapply(waiver.args, function(x) inherits(x, "waiver")) - if(all(waiver.which)) out("At least one label argument has to be defined.", type = 3) - if(any(!sapply(waiver.args[!waiver.which], function(x) any(is.character(x), is.null(x))))) out("Label arguments must be of type character, NULL to remove a label or waiver() to keep an already set label.", type = 3) - + if (all(waiver.which)) out("At least one label argument has to be defined.", type = 3) + if (any(!sapply(waiver.args[!waiver.which], function(x) any(is.character(x), is.null(x))))) out("Label arguments must be of type character, NULL to remove a label or waiver() to keep an already set label.", type = 3) + add_gg(frames, gg = expr( - list(labs(title = title, subtitle = subtitle, caption = caption, tag = tag, x = x, y = y), - theme(plot.title = element_text(hjust = 0.5), plot.subtitle = element_text(hjust = 0.5), plot.caption = element_text(hjust = 0.5)) + list( + labs(title = title, subtitle = subtitle, caption = caption, tag = tag, x = x, y = y), + theme(plot.title = element_text(hjust = 0.5), plot.subtitle = element_text(hjust = 0.5), plot.caption = element_text(hjust = 0.5)) ) - ),title = title, subtitle = subtitle, caption = caption, tag = tag, x = x, y = y) + ), title = title, subtitle = subtitle, caption = caption, tag = tag, x = x, y = y) } diff --git a/R/add_northarrow.R b/R/add_northarrow.R index 862179f..827d7f8 100644 --- a/R/add_northarrow.R +++ b/R/add_northarrow.R @@ -18,68 +18,77 @@ #' #' @importFrom ggplot2 geom_line geom_text aes_string expr #' -#' @examples +#' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames using a custom NDVI base layer #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' #' # add a north arrow to frames: #' frames.a <- add_northarrow(frames) #' frames.a[[100]] -#' +#' #' # or in white at another position #' frames.b <- add_northarrow(frames, colour = "white", position = "bottomleft") #' frames.b[[100]] #' } -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} #' @export add_northarrow <- function(frames, height = 0.05, position = "bottomright", x = NULL, y = NULL, colour = "black", size = 1, - label_text = "N", label_margin = 0.4, label_size = 5, verbose = TRUE){ - + label_text = "N", label_margin = 0.4, label_size = 5, verbose = TRUE) { ## checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) - if(!is.character(position)) out("Argument 'position' needs to be of type 'character'.", type = 3) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) + if (!is.character(position)) out("Argument 'position' needs to be of type 'character'.", type = 3) + check.args <- list(x = x, y = y) - catch <- lapply(seq(1, length(check.args)), function(i) if(!any(is.numeric(check.args[[i]]), is.null(check.args[[i]]))) out(paste0("Argument '", names(check.args)[[i]], "' needs to be of type 'numeric'."), type = 3)) - + catch <- lapply(seq(1, length(check.args)), function(i) if (!any(is.numeric(check.args[[i]]), is.null(check.args[[i]]))) out(paste0("Argument '", names(check.args)[[i]], "' needs to be of type 'numeric'."), type = 3)) + ## calculate gg plot dimensions gg.xy <- ggplot_build(frames[[1]])$data[[1]] - gg.corner <- list(bottomleft = c(min(gg.xy$xmin), min(gg.xy$ymin)), upperleft = c(min(gg.xy$xmin), max(gg.xy$ymax)), - upperright = c(max(gg.xy$xmax), max(gg.xy$ymax)), bottomright = c(max(gg.xy$xmax), min(gg.xy$ymin))) - + gg.corner <- list( + bottomleft = c(min(gg.xy$xmin), min(gg.xy$ymin)), upperleft = c(min(gg.xy$xmin), max(gg.xy$ymax)), + upperright = c(max(gg.xy$xmax), max(gg.xy$ymax)), bottomright = c(max(gg.xy$xmax), min(gg.xy$ymin)) + ) + ## calculate arrow differnece gg.diff <- list(x = max(gg.xy$xmax) - min(gg.xy$xmin), y = max(gg.xy$ymax) - min(gg.xy$ymin)) - arrow.diff <- gg.diff$y*height - + arrow.diff <- gg.diff$y * height + ## calculate scale postiotn - gg.margin <- list(bottomleft = unlist(gg.diff)*0.1, - upperleft = c(x = gg.diff$x*0.1, y = gg.diff$y*-(0.1+height)), - upperright = c(x = gg.diff$x*-0.1, y = gg.diff$y*-(0.1+height)), - bottomright = c(x = gg.diff$x*-0.1, y = gg.diff$y*0.1)) + gg.margin <- list( + bottomleft = unlist(gg.diff) * 0.1, + upperleft = c(x = gg.diff$x * 0.1, y = gg.diff$y * -(0.1 + height)), + upperright = c(x = gg.diff$x * -0.1, y = gg.diff$y * -(0.1 + height)), + bottomright = c(x = gg.diff$x * -0.1, y = gg.diff$y * 0.1) + ) - arrow.data <- if(all(!is.null(x), !is.null(y))) c(x, y) else gg.corner[[position]] + gg.margin[[position]] - arrow.data <- rbind.data.frame(arrow.data, c(arrow.data[1], arrow.data[2]+arrow.diff)) + arrow.data <- if (all(!is.null(x), !is.null(y))) c(x, y) else gg.corner[[position]] + gg.margin[[position]] + arrow.data <- rbind.data.frame(arrow.data, c(arrow.data[1], arrow.data[2] + arrow.diff)) colnames(arrow.data) <- c("x", "y") - + ## text label - text.margin <- (max(arrow.data$y) - min(arrow.data$y))*label_margin - text.data <- data.frame(x = arrow.data$x[1], y = min(arrow.data$y)-text.margin, label = label_text) - - add_gg(frames, gg = expr(list(geom_line(aes_string(x = "x", y = "y"), data = arrow.data, arrow=grid::arrow(length = grid::unit(3.7, "mm")), size = size, colour = colour), - geom_text(aes_string(x = "x", y = "y", label = "label"), text.data, colour = colour, size = label_size))), - arrow.data = arrow.data, size = size, colour = colour, text.data = text.data, label_size = label_size) + text.margin <- (max(arrow.data$y) - min(arrow.data$y)) * label_margin + text.data <- data.frame(x = arrow.data$x[1], y = min(arrow.data$y) - text.margin, label = label_text) + + add_gg(frames, + gg = expr(list( + geom_line(aes_string(x = "x", y = "y"), data = arrow.data, arrow = grid::arrow(length = grid::unit(3.7, "mm")), size = size, colour = colour), + geom_text(aes_string(x = "x", y = "y", label = "label"), text.data, colour = colour, size = label_size) + )), + arrow.data = arrow.data, size = size, colour = colour, text.data = text.data, label_size = label_size + ) } diff --git a/R/add_progress.R b/R/add_progress.R index c20c482..b3d4c3e 100644 --- a/R/add_progress.R +++ b/R/add_progress.R @@ -11,48 +11,51 @@ #' #' @importFrom ggplot2 geom_line aes_string ggplot_build expr #' -#' @examples +#' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames using a custom NDVI base layer #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' #' # add a progress bar: #' frames.a <- add_progress(frames) #' frames.a[[100]] -#' +#' #' # or in red and larger #' frames.b <- add_progress(frames, colour = "red", size = 2.5) #' frames.b[[100]] #' } -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} #' @export -add_progress <- function(frames, colour = "grey", size = 1.8, verbose = TRUE){ - +add_progress <- function(frames, colour = "grey", size = 1.8, verbose = TRUE) { ## checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) - - if(!inherits(colour, "character")) out("Argument 'colour' needs to be of type 'character'.", type = 3) - if(!inherits(size, "numeric")) out("Argument 'size' needs to be of type 'numeric'.", type = 3) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) + + if (!inherits(colour, "character")) out("Argument 'colour' needs to be of type 'character'.", type = 3) + if (!inherits(size, "numeric")) out("Argument 'size' needs to be of type 'numeric'.", type = 3) + gg.xy <- ggplot_build(frames[[1]])$data[[1]] - - data <- lapply(seq(min(gg.xy$xmin), max(gg.xy$xmax), length.out = length(frames)), function(x, x.min = min(gg.xy$xmin), y = max(gg.xy$ymax)){ + + data <- lapply(seq(min(gg.xy$xmin), max(gg.xy$xmax), length.out = length(frames)), function(x, x.min = min(gg.xy$xmin), y = max(gg.xy$ymax)) { cbind.data.frame(x = c(x.min, x), y = c(y, y)) }) - - add_gg(frames, gg = expr(geom_line(aes_string(x = "x", y = "y"), data = data, colour = colour, size = size)), - data = data, colour = colour, size = size) + + add_gg(frames, + gg = expr(geom_line(aes_string(x = "x", y = "y"), data = data, colour = colour, size = size)), + data = data, colour = colour, size = size + ) } diff --git a/R/add_scalebar.R b/R/add_scalebar.R index 3b46f8a..331385a 100644 --- a/R/add_scalebar.R +++ b/R/add_scalebar.R @@ -18,29 +18,31 @@ #' @importFrom ggplot2 geom_polygon geom_text aes_string expr #' @importFrom sf st_distance st_sfc st_point st_crs #' -#' @examples +#' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames using a custom NDVI base layer #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' #' # add a scale bar to frames: #' frames.a <- add_scalebar(frames) #' frames.a[[100]] -#' +#' #' # or in white at another position #' frames.b <- add_scalebar(frames, colour = "white", position = "bottomright") #' frames.b[[100]] -#' +#' #' # or with another height #' frames.c <- add_scalebar(frames, colour = "white", position = "bottomright", height = 0.025) #' frames.c[[100]] @@ -48,29 +50,30 @@ #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} #' @export -add_scalebar <- function(frames, distance = NULL, height = 0.015, position = "bottomleft", x = NULL, y = NULL, colour = "black", label_margin = 1.2, units = "km", verbose = TRUE){ - +add_scalebar <- function(frames, distance = NULL, height = 0.015, position = "bottomleft", x = NULL, y = NULL, colour = "black", label_margin = 1.2, units = "km", verbose = TRUE) { ## checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) - if(!is.character(position)) out("Argument 'position' needs to be of type 'character'.", type = 3) - if(isFALSE(units == "km" | units == "miles")) out("Argument 'units' must either be 'km' or 'miles'.", type = 3) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) + if (!is.character(position)) out("Argument 'position' needs to be of type 'character'.", type = 3) + if (isFALSE(units == "km" | units == "miles")) out("Argument 'units' must either be 'km' or 'miles'.", type = 3) + check.args <- list(distance = distance, x = x, y = y) - catch <- lapply(seq(1, length(check.args)), function(i) if(!any(is.numeric(check.args[[i]]), is.null(check.args[[i]]))) out(paste0("Argument '", names(check.args)[[i]], "' needs to be of type 'numeric'."), type = 3)) - + catch <- lapply(seq(1, length(check.args)), function(i) if (!any(is.numeric(check.args[[i]]), is.null(check.args[[i]]))) out(paste0("Argument '", names(check.args)[[i]], "' needs to be of type 'numeric'."), type = 3)) + ## calculate gg plot dimensions gg.crs <- frames[[1]]$coordinates$crs gg.xy <- ggplot_build(frames[[1]])$data[[1]] - - .corner <- function(xy){ - list(bottomleft = c(min(xy$xmin), min(xy$ymin)), upperleft = c(min(xy$xmin), max(xy$ymax)), - upperright = c(max(xy$xmax), max(xy$ymax)), bottomright = c(max(xy$xmax), min(xy$ymin))) + + .corner <- function(xy) { + list( + bottomleft = c(min(xy$xmin), min(xy$ymin)), upperleft = c(min(xy$xmin), max(xy$ymax)), + upperright = c(max(xy$xmax), max(xy$ymax)), bottomright = c(max(xy$xmax), min(xy$ymin)) + ) } gg.corner <- .corner(gg.xy) - + # cross_dateline - if(is.null(gg.crs)){ + if (is.null(gg.crs)) { gg.crs <- st_crs(4326) gg.xy_cdl <- gg.xy gg.xy_cdl$xmin[gg.xy_cdl$xmin < -180] <- -180 @@ -82,51 +85,65 @@ add_scalebar <- function(frames, distance = NULL, height = 0.015, position = "bo } else { gg.corner_sf <- lapply(gg.corner, function(x) st_sfc(st_point(x), crs = gg.crs)) } - gg.dist <- list(x = as.numeric(suppressPackageStartupMessages(st_distance(gg.corner_sf$bottomleft, gg.corner_sf$bottomright, by_element = T)))/1000, - y = as.numeric(suppressPackageStartupMessages(st_distance(gg.corner_sf$bottomleft, gg.corner_sf$upperleft, by_element = T)))/1000) - + gg.dist <- list( + x = as.numeric(suppressPackageStartupMessages(st_distance(gg.corner_sf$bottomleft, gg.corner_sf$bottomright, by_element = T))) / 1000, + y = as.numeric(suppressPackageStartupMessages(st_distance(gg.corner_sf$bottomleft, gg.corner_sf$upperleft, by_element = T))) / 1000 + ) + ## calculate axis distances - if(units == "miles") gg.dist <- lapply(gg.dist, function(x) x/1.609344 ) + if (units == "miles") gg.dist <- lapply(gg.dist, function(x) x / 1.609344) gg.diff <- list(x = max(gg.xy$xmax) - min(gg.xy$xmin), y = max(gg.xy$ymax) - min(gg.xy$ymin)) - + ## calculate scale distance - if(!is.null(distance)){scale.dist <- distance}else{ + if (!is.null(distance)) { + scale.dist <- distance + } else { scale.dist <- digits <- 0 - while(scale.dist == 0){ - scale.dist <- round((gg.dist$x*0.2), digits = digits) - digits <- digits+1 + while (scale.dist == 0) { + scale.dist <- round((gg.dist$x * 0.2), digits = digits) + digits <- digits + 1 } } - + # round to even - if(scale.dist > 10) scale.dist <- round(scale.dist/2)*2 + if (scale.dist > 10) scale.dist <- round(scale.dist / 2) * 2 + + scale.diff <- gg.diff$x * ((scale.dist) / gg.dist$x) - scale.diff <- gg.diff$x*((scale.dist)/gg.dist$x) - ## calculate scale postiotn - gg.margin <- list(bottomleft = unlist(gg.diff)*0.1, - upperleft = c(x = gg.diff$x*0.1, y = gg.diff$y*-(0.1+height)), - upperright = c(x = (gg.diff$x*-0.1)-scale.diff, y = gg.diff$y*-(0.1+height)), - bottomright = c(x = (gg.diff$x*-0.1)-scale.diff, y = gg.diff$y*0.1)) + gg.margin <- list( + bottomleft = unlist(gg.diff) * 0.1, + upperleft = c(x = gg.diff$x * 0.1, y = gg.diff$y * -(0.1 + height)), + upperright = c(x = (gg.diff$x * -0.1) - scale.diff, y = gg.diff$y * -(0.1 + height)), + bottomright = c(x = (gg.diff$x * -0.1) - scale.diff, y = gg.diff$y * 0.1) + ) - scale.outer <- if(all(!is.null(x), !is.null(y))) c(x, y) else gg.corner[[position]] + gg.margin[[position]] - scale.outer <- rbind.data.frame(scale.outer, c(scale.outer[1], (scale.outer[2] + (gg.diff$y*height))), - c(scale.outer[1]+scale.diff, (scale.outer[2] + (gg.diff$y*height))), c(scale.outer[1]+scale.diff, scale.outer[2])) + scale.outer <- if (all(!is.null(x), !is.null(y))) c(x, y) else gg.corner[[position]] + gg.margin[[position]] + scale.outer <- rbind.data.frame( + scale.outer, c(scale.outer[1], (scale.outer[2] + (gg.diff$y * height))), + c(scale.outer[1] + scale.diff, (scale.outer[2] + (gg.diff$y * height))), c(scale.outer[1] + scale.diff, scale.outer[2]) + ) colnames(scale.outer) <- c("x", "y") - + ## calculate inner scale position scale.inner <- scale.outer - scale.inner[1:2,1] <- scale.inner[1:2,1] + (scale.diff/2) - + scale.inner[1:2, 1] <- scale.inner[1:2, 1] + (scale.diff / 2) + ## calculate annotation position - text.margin <- (max(scale.outer$y) - min(scale.outer$y))*label_margin - text.data <- cbind.data.frame(x = c(min(scale.outer$x), min(scale.inner$x), max(scale.outer$x)), - y = (min(scale.outer$y)-text.margin), - label = paste0(c(0, scale.dist/2, scale.dist), " ", units), - col = colour, stringsAsFactors = F) - - add_gg(frames, gg = expr(list(geom_polygon(aes_string(x = "x", y = "y"), data = scale.outer, fill = "white", colour = "black"), - geom_polygon(aes_string(x = "x", y = "y"), data = scale.inner, fill = "black", colour = "black"), - geom_text(aes_string(x = "x", y = "y", label = "label", color = "col"), data = text.data, size = 3, colour = text.data$col))), - scale.outer = scale.outer, scale.inner = scale.inner, text.data = text.data) + text.margin <- (max(scale.outer$y) - min(scale.outer$y)) * label_margin + text.data <- cbind.data.frame( + x = c(min(scale.outer$x), min(scale.inner$x), max(scale.outer$x)), + y = (min(scale.outer$y) - text.margin), + label = paste0(c(0, scale.dist / 2, scale.dist), " ", units), + col = colour, stringsAsFactors = F + ) + + add_gg(frames, + gg = expr(list( + geom_polygon(aes_string(x = "x", y = "y"), data = scale.outer, fill = "white", colour = "black"), + geom_polygon(aes_string(x = "x", y = "y"), data = scale.inner, fill = "black", colour = "black"), + geom_text(aes_string(x = "x", y = "y", label = "label", color = "col"), data = text.data, size = 3, colour = text.data$col) + )), + scale.outer = scale.outer, scale.inner = scale.inner, text.data = text.data + ) } diff --git a/R/add_text.R b/R/add_text.R index d158de7..0a39606 100644 --- a/R/add_text.R +++ b/R/add_text.R @@ -15,60 +15,65 @@ #' #' @importFrom ggplot2 annotate expr #' -#' @examples +#' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames using a custom NDVI base layer #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' #' # add text somewhere to all frames: -#' frames.a <- add_text(frames, "Water area", x = 8.959, y = 47.7305, -#' colour = "white", size = 3) +#' frames.a <- add_text(frames, "Water area", +#' x = 8.959, y = 47.7305, +#' colour = "white", size = 3 +#' ) #' frames.a[[100]] -#' +#' #' # or use the ggplot2 "label" type: -#' frames.b <- add_text(frames, "Water area", x = 8.959, y = 47.7305, -#' colour = "black", size = 3, type = "label") +#' frames.b <- add_text(frames, "Water area", +#' x = 8.959, y = 47.7305, +#' colour = "black", size = 3, type = "label" +#' ) #' frames.b[[100]] #' } -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} #' @export -add_text <- function(frames, labels, x, y, colour = "black", size = 3, type = "text", verbose = TRUE){ - +add_text <- function(frames, labels, x, y, colour = "black", size = 3, type = "text", verbose = TRUE) { ## checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) - - if(!is.character(labels)) out("Argument 'labels' must be of type 'character'.", type = 3) - if(!is.character(colour)) out("Argument 'colour' must be of type 'character'.", type = 3) - if(!is.numeric(x)) out("Argument 'x' must be of type 'numeric'.", type = 3) - if(!is.numeric(y)) out("Argument 'y' must be of type 'numeric'.", type = 3) - if(!is.numeric(size)) out("Argument 'size' must be of type 'numeric'.", type = 3) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) + + if (!is.character(labels)) out("Argument 'labels' must be of type 'character'.", type = 3) + if (!is.character(colour)) out("Argument 'colour' must be of type 'character'.", type = 3) + if (!is.numeric(x)) out("Argument 'x' must be of type 'numeric'.", type = 3) + if (!is.numeric(y)) out("Argument 'y' must be of type 'numeric'.", type = 3) + if (!is.numeric(size)) out("Argument 'size' must be of type 'numeric'.", type = 3) + ## check lengths check <- list("labels" = labels, "x" = x, "y" = y, "colour" = colour, "size" = size) - data <- sapply(1:length(check), function(i){ - if(length(check[[i]]) == 1) v <- rep(check[[i]], length(frames)) else v <- check[[i]] - if(length(v) != length(frames)) out(paste0("Length of argument ", names(check)[[i]], " must either be 1 or equal to the length of agrument 'frames'."), type = 3) + data <- sapply(1:length(check), function(i) { + if (length(check[[i]]) == 1) v <- rep(check[[i]], length(frames)) else v <- check[[i]] + if (length(v) != length(frames)) out(paste0("Length of argument ", names(check)[[i]], " must either be 1 or equal to the length of agrument 'frames'."), type = 3) return(v) }, simplify = F) - + data.classes <- sapply(data, class) data <- as.data.frame(do.call(cbind, data), stringsAsFactors = F) - for(i in 1:ncol(data)) class(data[,i]) <- data.classes[i] - + for (i in 1:ncol(data)) class(data[, i]) <- data.classes[i] + data <- split(data, seq(nrow(data))) - + add_gg(frames, gg = expr(annotate(type, x = data[[2]], y = data[[3]], label = data[[1]], colour = data[[4]], size = data[[5]])), data = data, type = type) } diff --git a/R/add_timestamps.R b/R/add_timestamps.R index 5a88790..7645449 100644 --- a/R/add_timestamps.R +++ b/R/add_timestamps.R @@ -7,53 +7,54 @@ #' @param x numeric, optional, position of timestamps on the x scale. By default, timestamps will be displayed in the top center. #' @param y numeric, optional, position of timestamps on the y scale. #' @param ... optional, arguments passed to \code{\link{add_text}}, such as \code{colour}, \code{size}, \code{type}. -#' +#' #' @return A frames object of class \code{moveVis}. #' @author Jakob Schwalb-Willmann #' #' @importFrom ggplot2 ggplot_build #' @importFrom move timestamps #' -#' @examples +#' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames using a custom NDVI base layer #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' #' # add timestamps as text #' frames.a <- add_timestamps(frames, type = "text") #' frames.a[[100]] -#' +#' #' # or use the ggplot2 "label" type: #' frames.b <- add_timestamps(frames, type = "label") #' frames.b[[100]] #' } -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} #' @export -add_timestamps <- function(frames, m = NULL, x = NULL, y = NULL, ..., verbose = TRUE){ - +add_timestamps <- function(frames, m = NULL, x = NULL, y = NULL, ..., verbose = TRUE) { ## checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) - if(!is.null(m)) out("Argument 'm' is deprecated and thus being ignored.", type = 2) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) + if (!is.null(m)) out("Argument 'm' is deprecated and thus being ignored.", type = 2) + ts <- as.character(get_frametimes(frames)) - - if(is.null(x)){ - x <- frames$aesthetics$gg.ext[1]+((frames$aesthetics$gg.ext[3]-frames$aesthetics$gg.ext[1])/2) - y <- frames$aesthetics$gg.ext[4]-((frames$aesthetics$gg.ext[4]-frames$aesthetics$gg.ext[2])*0.05) + + if (is.null(x)) { + x <- frames$aesthetics$gg.ext[1] + ((frames$aesthetics$gg.ext[3] - frames$aesthetics$gg.ext[1]) / 2) + y <- frames$aesthetics$gg.ext[4] - ((frames$aesthetics$gg.ext[4] - frames$aesthetics$gg.ext[2]) * 0.05) } - + add_text(frames, ts, x, y, ...) } diff --git a/R/align_move.R b/R/align_move.R index 158f171..95c5a0c 100644 --- a/R/align_move.R +++ b/R/align_move.R @@ -1,9 +1,9 @@ #' Align movement data #' -#' This function aligns movement data to a uniform time scale with a uniform temporal resolution throughout the complete movement sequence. +#' This function aligns movement data to a uniform time scale with a uniform temporal resolution throughout the complete movement sequence. #' This prepares the provided movement data to be interpretable by \code{\link{frames_spatial}}, which necessitates a uniform time scale and #' a consistent, unique temporal resolution for all moving individuals to turn recording times into frame times. -#' +#' #' @inheritParams frames_spatial #' @param m \code{move} or \code{moveStack}, which is allowed to contain irregular timestamps and diverging temporal resolutions to be aligned (see \code{\link{df2move}} to convert a \code{data.frame} to a \code{move} object). #' @param res either numeric, representing the temporal resolution, to which \code{m} should be aligned to (see argument \code{unit}), or character: @@ -20,97 +20,96 @@ #' @author Jakob Schwalb-Willmann #' #' @importFrom move timestamps timeLag interpolateTime moveStack move split namesIndiv -#' @importFrom lubridate second<- minute<- hour<- day<- +#' @importFrom lubridate second<- minute<- hour<- day<- #' #' @seealso \code{\link{df2move}} \code{\link{frames_spatial}} \code{\link{frames_graph}} -#' +#' #' @examples #' library(moveVis) #' library(move) #' data("move_data") -#' +#' #' # the tracks in move_data have irregular timestamps and sampling rates. #' # print unique timestamps and timeLag #' unique(timestamps(move_data)) #' unique(unlist(timeLag(move_data, units = "secs"))) -#' +#' #' # use align_move to correct move_data to a uniform time scale and lag using interpolation. #' # resolution of 4 minutes: #' m <- align_move(m = move_data, res = 4, unit = "mins") #' unique(unlist(timeLag(m, units = "mins"))) -#' +#' #' # resolution of 1 hour: #' m <- align_move(move_data, res = 1, unit = "hours") #' unique(unlist(timeLag(m, units = "hours"))) -#' +#' #' # resolution of 15 seconds: #' m <- align_move(move_data, res = 15, unit = "secs") #' unique(unlist(timeLag(m, units = "secs"))) -#' +#' #' @export -align_move <- function(m, res = "minimum", unit = NA, spaceMethod = "greatcircle", ..., verbose = TRUE){ - +align_move <- function(m, res = "minimum", unit = NA, spaceMethod = "greatcircle", ..., verbose = TRUE) { # deprecated arguments extras <- list(...) - if("digit" %in% names(extras)) out("Argument 'digit' is deprecated. See ?align_move for details.", type = 2) - + if ("digit" %in% names(extras)) out("Argument 'digit' is deprecated. See ?align_move for details.", type = 2) + ## check m and spaceMethod - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(m, c("Move", "MoveStack"))) out("Argument 'm' must be of class 'Move' or 'MoveStack'.", type = 3) - m.length <- if(inherits(m, "MoveStack")) sapply(split(m), length) else length(m) - if(any(m.length < 2)) out(paste0("Individual track(s) ", paste0(which(m.length < 2), collapse = ", "), " of 'm' consist(s) of less than 2 locations only. A minimum of 2 locations per indvidual track is required for alignment."), type = 3) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(m, c("Move", "MoveStack"))) out("Argument 'm' must be of class 'Move' or 'MoveStack'.", type = 3) + m.length <- if (inherits(m, "MoveStack")) sapply(split(m), length) else length(m) + if (any(m.length < 2)) out(paste0("Individual track(s) ", paste0(which(m.length < 2), collapse = ", "), " of 'm' consist(s) of less than 2 locations only. A minimum of 2 locations per indvidual track is required for alignment."), type = 3) + ## check resolution and define resolution - if(is.na(unit)) unit_ <- "secs" else unit_ <- unit - if(all(!c(inherits(res, "numeric"), inherits(res, "character")))) out("Argument 'res' must either be numeric or one of c('min', 'max', 'mean').", type = 3) - if(any(res == "min", res == "minimum")) res <- min(unique(unlist(timeLag(m, unit_)))) - if(any(res == "max", res == "maximum")) res <- max(unique(unlist(timeLag(m, unit_)))) - if(res == "mean") res <- round(mean(unique(unlist(timeLag(m, unit_))))) + if (is.na(unit)) unit_ <- "secs" else unit_ <- unit + if (all(!c(inherits(res, "numeric"), inherits(res, "character")))) out("Argument 'res' must either be numeric or one of c('min', 'max', 'mean').", type = 3) + if (any(res == "min", res == "minimum")) res <- min(unique(unlist(timeLag(m, unit_)))) + if (any(res == "max", res == "maximum")) res <- max(unique(unlist(timeLag(m, unit_)))) + if (res == "mean") res <- round(mean(unique(unlist(timeLag(m, unit_))))) res <- as.difftime(res, units = unit_) - + # recalc unit - if(is.na(unit)){ - if(all(res >= 60, res < 3600)) unit <- "mins" - if(all(res >= 3600, res < 86400)) unit <- "hours" - if(res >= 86400) unit <- "days" + if (is.na(unit)) { + if (all(res >= 60, res < 3600)) unit <- "mins" + if (all(res >= 3600, res < 86400)) unit <- "hours" + if (res >= 86400) unit <- "days" res <- `units<-`(res, unit) } - out(paste0("Temporal resolution of ", round(as.numeric(res), digits = 2), " [", units(res), "] is used to align trajectories.")) - + out(paste0("Temporal resolution of ", round(as.numeric(res), digits = 2), " [", units(res), "] is used to align trajectories.")) + # calculate time shoulders and full target timestamps ts <- timestamps(m) ts.shoulder <- list(min(ts), max(ts)) - if(unit != "secs"){ + if (unit != "secs") { set.fun <- list("mins" = `second<-`, "hours" = `minute<-`, "days" = `hour<-`) set.fun <- set.fun[1:match(unit, names(set.fun))] - ts.shoulder <- lapply(ts.shoulder, function(x){ - for(i in 1:length(set.fun)) x <- set.fun[[i]](x, value = 0) + ts.shoulder <- lapply(ts.shoulder, function(x) { + for (i in 1:length(set.fun)) x <- set.fun[[i]](x, value = 0) return(x) }) } ts.target <- seq.POSIXt(ts.shoulder[[1]], ts.shoulder[[2]], by = res) - + # calculate new timestamps per trajectory - m.indi <- if(inherits(m, "MoveStack")) split(m) else list(m) + m.indi <- if (inherits(m, "MoveStack")) split(m) else list(m) ts.m <- lapply(m.indi, timestamps) ts.t <- lapply(ts.m, function(x) ts.target[ts.target >= min(x) & ts.target <= max(x)]) - + # check whether resolution fits data i.finer <- which(sapply(ts.t, function(x) length(x) == 0)) - if(length(i.finer) > 0){ - if(length(i.finer) == length(m.indi)){ + if (length(i.finer) > 0) { + if (length(i.finer) == length(m.indi)) { out("The temporal coverage of all trajectories of 'm' is shorter than the specified resolution. You may want to choose a finer resolution.", type = 3) - } else{ + } else { out(paste0("The full temporal coverage of at least one trajectory is shorter than the specified resolution. You may want to choose a finer resolution.\nTrajectories that are excluded: '", paste0(namesIndiv(m)[i.finer], collapse = "', '"), "'"), type = 2) } m.indi <- m.indi[-i.finer] ts.t <- ts.t[-i.finer] } - + # interpolate m <- quiet(moveStack(mapply(x = m.indi, y = ts.t, function(x, y) interpolateTime(x, y, spaceMethod)))) - m[,c("x", "y")] <- m@coords - m[,"time"] <- timestamps(m) + m[, c("x", "y")] <- m@coords + m[, "time"] <- timestamps(m) return(m) -} \ No newline at end of file +} diff --git a/R/animate_frames.R b/R/animate_frames.R index af418a8..5228247 100644 --- a/R/animate_frames.R +++ b/R/animate_frames.R @@ -16,118 +16,126 @@ #' @details An appropriate render function is selected depending on the file extension in \code{out_file}: For \code{.gif} files, \code{gifski::save_gif} is used, for any other (video) format, \code{av::av_capture_graphics} is used. #' #' @return None or the default image/video viewer displaying the animation -#' +#' #' @importFrom av av_encode_video #' @importFrom gifski gifski #' @importFrom ggplot2 quo #' @importFrom lubridate dseconds #' @importFrom utils tail head -#' +#' #' @author Jakob Schwalb-Willmann -#' +#' #' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' # align movement #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames with frames_spatial: #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' #' # customize -#' frames <- add_colourscale(frames, type = "gradient", -#' colours = c("orange", "white", "darkgreen"), legend_title = "NDVI") +#' frames <- add_colourscale(frames, +#' type = "gradient", +#' colours = c("orange", "white", "darkgreen"), legend_title = "NDVI" +#' ) #' frames <- add_northarrow(frames, position = "bottomleft") #' frames <- add_scalebar(frames, colour = "white", position = "bottomright") -#' +#' #' frames <- add_progress(frames) #' frames <- add_timestamps(frames, m, type = "label") -#' +#' #' # check available formats #' suggest_formats() -#' +#' #' # animate frames as GIF #' animate_frames(frames, out_file = tempfile(fileext = ".gif")) -#' +#' #' # animate frames as mov #' animate_frames(frames, out_file = tempfile(fileext = ".gif")) #' } #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{join_frames}} -#' +#' #' @export -animate_frames <- function(frames, out_file, fps = 25, width = 700, height = 700, res = 100, end_pause = 0, display = TRUE, overwrite = FALSE, verbose = TRUE, ...){ - - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be a moveVis frames* object. See e.g. frames_spatial()).", type = 3) - - if(!is.character(out_file)) out("Argument 'out_file' must be of type 'character'.", type = 3) +animate_frames <- function(frames, out_file, fps = 25, width = 700, height = 700, res = 100, end_pause = 0, display = TRUE, overwrite = FALSE, verbose = TRUE, ...) { + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be a moveVis frames* object. See e.g. frames_spatial()).", type = 3) + + if (!is.character(out_file)) out("Argument 'out_file' must be of type 'character'.", type = 3) of_split <- strsplit(out_file, "/")[[1]] - if(length(of_split) > 1) if(isFALSE(dir.exists(paste0(utils::head(of_split, n = -1), collapse = "/")))) out("Target directory of 'out_file' does not exist.", type = 3) - if(all(file.exists(out_file), !isTRUE(overwrite))) out("Defined output file already exists and overwriting is disabled.", type = 3) + if (length(of_split) > 1) if (isFALSE(dir.exists(paste0(utils::head(of_split, n = -1), collapse = "/")))) out("Target directory of 'out_file' does not exist.", type = 3) + if (all(file.exists(out_file), !isTRUE(overwrite))) out("Defined output file already exists and overwriting is disabled.", type = 3) num.args <- c(fps = fps, width = width, height = height, res = res) - catch <- sapply(1:length(num.args), function(i) if(!is.numeric(num.args[[i]])) out(paste0("Argument '", names(num.args)[[i]], "' must be of type 'numeric'."), type = 3)) - - out_ext <- tolower(utils::tail(unlist(strsplit(out_file, "[.]")), n=1)) + catch <- sapply(1:length(num.args), function(i) if (!is.numeric(num.args[[i]])) out(paste0("Argument '", names(num.args)[[i]], "' must be of type 'numeric'."), type = 3)) + + out_ext <- tolower(utils::tail(unlist(strsplit(out_file, "[.]")), n = 1)) out("Rendering animation...") - if(end_pause > 0){ - n.add <- round(end_pause*fps) - + if (end_pause > 0) { + n.add <- round(end_pause * fps) + # add frames - if(length(frames$raster_data) > 1){ + if (length(frames$raster_data) > 1) { frames$raster_data <- c(frames$raster_data, rep(frames$raster_data[max(frames$move_data$frame)], n.add)) } - - frames$move_data <- rbind(frames$move_data, - do.call( - rbind, - lapply(1:n.add, function(x){ - nf <- frames$move_data[frames$move_data$frame == max(frames$move_data$frame),] - nf$frame <- nf$frame + 1 - return(nf) - }) - ) + + frames$move_data <- rbind( + frames$move_data, + do.call( + rbind, + lapply(1:n.add, function(x) { + nf <- frames$move_data[frames$move_data$frame == max(frames$move_data$frame), ] + nf$frame <- nf$frame + 1 + return(nf) + }) + ) ) - - #frames <- append(frames, rep(utils::tail(frames, n = 1), times = n.add)) - out(paste0("Number of frames: ", toString(length(frames)-n.add), " + ", toString(n.add), " to add \u2248 ", toString(dseconds(end_pause)), " of pause at the end")) + + # frames <- append(frames, rep(utils::tail(frames, n = 1), times = n.add)) + out(paste0("Number of frames: ", toString(length(frames) - n.add), " + ", toString(n.add), " to add \u2248 ", toString(dseconds(end_pause)), " of pause at the end")) } .stats(n.frames = length(frames), fps) - - #frames_expr <- expression(moveVis:::.lapply(frames, function(x) quiet(print(x)))) - + + # frames_expr <- expression(moveVis:::.lapply(frames, function(x) quiet(print(x)))) + # create PNGs frames_dir <- paste0(tempdir(), "/moveVis/frames/") dir.create(frames_dir, recursive = T) - - tryCatch({ - file <- file.path(frames_dir, "frame_%05d.png") - grDevices::png(file, width = width, height = height, res = res) - graphics::par(ask = FALSE) - .lapply(1:length(frames), function(i) quiet(print(frames[[i]])), moveVis.n_cores = 1) - grDevices::dev.off() - frames_files <- list.files(frames_dir, full.names = TRUE) - - # animate PNGs - if(out_ext == "gif"){ - if(length(frames) > 800) out("The number of frames exceeds 800 and the GIF format is used. This format may not be suitable for animations with a high number of frames, since it causes large file sizes. Consider using a video file format instead.", type = 2) - gifski(frames_files, gif_file = out_file, width = width, height = height, delay = (1/fps), progress = verbose) - #save_gif(.lapply(frames, function(x) quiet(print(x)), moveVis.n_cores = 1), gif_file = out_file, width = width, height = height, delay = (1/fps), progress = verbose, res = res, ...) - }else{ - av_encode_video(frames_files, output = out_file, framerate = fps, verbose = verbose, ...) - #av_capture_graphics(.lapply(frames, function(x) quiet(print(x)), moveVis.n_cores = 1), output = out_file, width = width, height = height, res = res, framerate = fps, verbose = verbose, ...) #, vfilter =' framerate=fps=10') - } - }, error = function(e){ - unlink(frames_dir, recursive = TRUE) - out(paste0("Error creating animation: ", as.character(e)), type = 3) - }, finally = unlink(frames_dir, recursive = TRUE)) - - if(isTRUE(display)) utils::browseURL(out_file) -} \ No newline at end of file + + tryCatch( + { + file <- file.path(frames_dir, "frame_%05d.png") + grDevices::png(file, width = width, height = height, res = res) + graphics::par(ask = FALSE) + .lapply(1:length(frames), function(i) quiet(print(frames[[i]])), moveVis.n_cores = 1) + grDevices::dev.off() + frames_files <- list.files(frames_dir, full.names = TRUE) + + # animate PNGs + if (out_ext == "gif") { + if (length(frames) > 800) out("The number of frames exceeds 800 and the GIF format is used. This format may not be suitable for animations with a high number of frames, since it causes large file sizes. Consider using a video file format instead.", type = 2) + gifski(frames_files, gif_file = out_file, width = width, height = height, delay = (1 / fps), progress = verbose) + # save_gif(.lapply(frames, function(x) quiet(print(x)), moveVis.n_cores = 1), gif_file = out_file, width = width, height = height, delay = (1/fps), progress = verbose, res = res, ...) + } else { + av_encode_video(frames_files, output = out_file, framerate = fps, verbose = verbose, ...) + # av_capture_graphics(.lapply(frames, function(x) quiet(print(x)), moveVis.n_cores = 1), output = out_file, width = width, height = height, res = res, framerate = fps, verbose = verbose, ...) #, vfilter =' framerate=fps=10') + } + }, + error = function(e) { + unlink(frames_dir, recursive = TRUE) + out(paste0("Error creating animation: ", as.character(e)), type = 3) + }, + finally = unlink(frames_dir, recursive = TRUE) + ) + + if (isTRUE(display)) utils::browseURL(out_file) +} diff --git a/R/data.R b/R/data.R index a2d88b1..5c0cbf4 100644 --- a/R/data.R +++ b/R/data.R @@ -1,40 +1,40 @@ #' Example simulated movement tracks #' #' This dataset contains a \code{Move} object, representing coordinates and acquisition times of three simulated movement tracks, covering a location nearby Lake of Constance, Germany. Individual names are made up for demonstration purposes. -#' +#' #' @details This object is used by some \code{moveVis} examples and unit tests. #' @note All data contained should only be used for testing \code{moveVis} and are not suitable to be used for analysis or interpretation. #' #' @format \code{Move} object, as used by the \code{move} package. #' @usage data(move_data) #' @docType data -#' +#' "move_data" #' White Stork LifeTrack tracks #' #' This dataset contains a \code{data.frame} object, representing coordinates and acquisition times of 15 White Storks, migrating from Lake of Constance, SW Germany, to Africa. -#' +#' #' @details These objects are used by some \code{moveVis} examples and have been included for demonstrational purposes. -#' +#' #' The dataset represents a subset of the LifeTrack White Stork dataset by Cheng et al. (2019) and Fiedler et al. (2019), available under the Creative Commons license "CC0 1.0 Universal Public Domain Dedication" on Movebank (doi:10.5441/001/1.ck04mn78/1). #' #' @references -#' Cheng Y, Fiedler W, Wikelski M, Flack A (2019) "Closer-to-home" strategy benefits juvenile survival in a long-distance migratory bird. Ecology and Evolution. doi:10.1002/ece3.5395 -#' -#' Fiedler W, Flack A, Schäfle W, Keeves B, Quetting M, Eid B, Schmid H, Wikelski M (2019) Data from: Study "LifeTrack White Stork SW Germany" (2013-2019). Movebank Data Repository. doi:10.5441/001/1.ck04mn78 +#' Cheng Y, Fiedler W, Wikelski M, Flack A (2019) "Closer-to-home" strategy benefits juvenile survival in a long-distance migratory bird. Ecology and Evolution. doi:10.1002/ece3.5395 +#' +#' Fiedler W, Flack A, Schäfle W, Keeves B, Quetting M, Eid B, Schmid H, Wikelski M (2019) Data from: Study "LifeTrack White Stork SW Germany" (2013-2019). Movebank Data Repository. doi:10.5441/001/1.ck04mn78 #' #' @format #' \itemize{ #' \item \code{df} is a \code{data.frame} object #' \item \code{m} is a \code{moveStack} object -#' } -#' -#' +#' } +#' +#' #' @usage data(whitestork_data) #' @docType data #' @name whitestork_data -#' +#' "df" #' @rdname whitestork_data @@ -42,20 +42,20 @@ "m" #' Example manipulated NDVI data -#' +#' #' This dataset contains two lists of equal lenghts: #' \itemize{ #' \item a list of ten single-layer \code{raster} objects, representing NDVI images covering the Lake of Constance area. #' \item a list of made-up times that simulate acquisition times with a temporal resolution, remote sensing scientiest would dream of... #' } -#' +#' #' @details This object is used by some \code{moveVis} examples and unit tests. #' @note All data contained should only be used for testing \code{moveVis} and are not suitable to be used for analysis or interpretation. #' -#' +#' #' @format List containing two lists of equal lengths: a list of \code{raster} objects and a list of \code{POSIXct} times. #' @source MODIS (MOD13Q1 NDVI) #' @usage data(basemap_data) #' @docType data -#' -"basemap_data" \ No newline at end of file +#' +"basemap_data" diff --git a/R/deprecated.R b/R/deprecated.R index a2509c1..7cd465f 100644 --- a/R/deprecated.R +++ b/R/deprecated.R @@ -1,13 +1,13 @@ #' Deprecated functions #' #' Several functions are deprecated due to a rewrite of moveVis with version 0.10. -#' +#' #' @param ... deprecated arguments. -#' +#' #' @details The new version of moveVis makes it much easier to animate movement data and multi-temporal imagery (see \code{?moveVis}). You gain more control about the preprocessing of your movement data as well as the visual customization of each animation frame through a more consequent link of \code{moveVis} to \code{gpplot2}. #' #' @note To install the old version of moveVis (0.9.9), see \url{https://github.com/16EAGLE/moveVis/releases/tag/v0.9.9}. -#' +#' #' @name deprecated #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{join_frames}} \code{\link{animate_frames}} #' @export @@ -32,4 +32,4 @@ get_formats <- function(...) out("get_formats() has been deprecated due to a rew #' @rdname deprecated #' @export -get_libraries <- function(...) out("get_libraries() has been deprecated due to a rewrite of moveVis with version 0.10. moveVis is now easier to use and customize. See ?moveVis and http://movevis.org for details on how to create animations with moveVis 0.10. See https://github.com/16EAGLE/moveVis/releases/tag/v0.9.9 for the old version of moveVis.", type = 2) \ No newline at end of file +get_libraries <- function(...) out("get_libraries() has been deprecated due to a rewrite of moveVis with version 0.10. moveVis is now easier to use and customize. See ?moveVis and http://movevis.org for details on how to create animations with moveVis 0.10. See https://github.com/16EAGLE/moveVis/releases/tag/v0.9.9 for the old version of moveVis.", type = 2) diff --git a/R/df2move.R b/R/df2move.R index cff7677..8f13839 100644 --- a/R/df2move.R +++ b/R/df2move.R @@ -12,64 +12,62 @@ #' @param ... additional arguments passed to \code{move}. #' #' @return A \code{move} or \code{moveStack} object. -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{subset_move}} -#' +#' #' @importFrom move move moveStack -#' +#' #' @examples #' library(moveVis) #' library(move) -#' +#' #' # load the example data and convert them into a data.frame #' data("move_data") #' move_df <- methods::as(move_data, "data.frame") -#' +#' #' # use df2move to convert the data.frame into a moveStack #' df2move(move_df, -#' proj = "+init=epsg:4326 +proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0", -#' x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId") +#' proj = "+init=epsg:4326 +proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0", +#' x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId" +#' ) #' @export -df2move <- function(df, proj, x, y, time, track_id = NULL, data = NULL, ...){ - +df2move <- function(df, proj, x, y, time, track_id = NULL, data = NULL, ...) { # checks - if(!inherits(df, "data.frame")) out("Argument 'df' must be of type 'data.frame'.", type = 3) + if (!inherits(df, "data.frame")) out("Argument 'df' must be of type 'data.frame'.", type = 3) df <- data.frame(df, check.names = F) df.names <- colnames(df) - + crs <- try(sf::st_crs(proj), silent = T) - if(inherits(crs, "try-error")) out("Argument 'proj' seems not to represent a valid projection.", type = 3) - - catch <- sapply(c(x, y, time), function(x) if(!isTRUE(x %in% df.names)) out(paste0("Column named '", x, "' cannot be found in 'df'."), type = 3)) - if(!is.null(data)) if(nrow(data) != nrow(df)) out("Number of rows in 'data' must be equal to number of rows in 'df'.", type = 3) - if(!inherits(df[,time], "POSIXct")) out("Time column must be of type POSIXct.", type = 3) - - if(!is.null(track_id)){ - + if (inherits(crs, "try-error")) out("Argument 'proj' seems not to represent a valid projection.", type = 3) + + catch <- sapply(c(x, y, time), function(x) if (!isTRUE(x %in% df.names)) out(paste0("Column named '", x, "' cannot be found in 'df'."), type = 3)) + if (!is.null(data)) if (nrow(data) != nrow(df)) out("Number of rows in 'data' must be equal to number of rows in 'df'.", type = 3) + if (!inherits(df[, time], "POSIXct")) out("Time column must be of type POSIXct.", type = 3) + + if (!is.null(track_id)) { # get ids per individual - if(!isTRUE(track_id %in% df.names)) out(paste0("Column named '", track_id, "' cannot be found in 'df'."), type = 3) + if (!isTRUE(track_id %in% df.names)) out(paste0("Column named '", track_id, "' cannot be found in 'df'."), type = 3) id.sub <- lapply(unique(df[, track_id]), function(x) which(df[, track_id] == x)) - df.split <- lapply(id.sub, function(x) df[x,]) - + df.split <- lapply(id.sub, function(x) df[x, ]) + # make moveStack for multiple individuals - m.split <- mapply(dfx = df.split, id = id.sub, function(dfx, id){ - dfx <- dfx[order(dfx[, time]),] - if(is.null(data)){ - move(x = dfx[,x], y = dfx[,y], time = dfx[,time], proj = crs$proj4string, animal = dfx[, track_id], ...) - } else{ - move(x = dfx[,x], y = dfx[,y], time = dfx[,time], proj = crs$proj4string, animal = dfx[, track_id], data = data[id,], ...) + m.split <- mapply(dfx = df.split, id = id.sub, function(dfx, id) { + dfx <- dfx[order(dfx[, time]), ] + if (is.null(data)) { + move(x = dfx[, x], y = dfx[, y], time = dfx[, time], proj = crs$proj4string, animal = dfx[, track_id], ...) + } else { + move(x = dfx[, x], y = dfx[, y], time = dfx[, time], proj = crs$proj4string, animal = dfx[, track_id], data = data[id, ], ...) } }) - if(length(m.split) == 1) m.split[[1]] else quiet(moveStack(m.split)) - } else{ - + if (length(m.split) == 1) m.split[[1]] else quiet(moveStack(m.split)) + } else { # make move for one individual - df <- df[order(df[, time]),] - if(is.null(data)){ - move(x = df[,x], y = df[,y], time = df[,time], proj = crs$proj4string, ...) - } else{ - move(x = df[,x], y = df[,y], time = df[,time], proj = crs$proj4string, data = data, ...) + df <- df[order(df[, time]), ] + if (is.null(data)) { + move(x = df[, x], y = df[, y], time = df[, time], proj = crs$proj4string, ...) + } else { + move(x = df[, x], y = df[, y], time = df[, time], proj = crs$proj4string, data = data, ...) } } -} \ No newline at end of file +} diff --git a/R/frames_graph.R b/R/frames_graph.R index d88c589..5bf7674 100644 --- a/R/frames_graph.R +++ b/R/frames_graph.R @@ -12,7 +12,7 @@ #' @param val_min numeric, minimum value of the value axis. If undefined, the minimum is collected automatically. #' @param val_max numeric, maximum value of the value axis. If undefined, the maximum is collected automatically. #' @param val_by numeric, increment of the value axis sequence. Default is 0.1. If \code{graph_type = "discrete"}, this value should be an integer of 1 or greater. -#' +#' #' @details To later on side-by-side join spatial frames created using \code{\link{frames_spatial}} with frames created with \code{\link{frames_graph}} for animation, #' equal inputs must have been used for both function calls for each of the arguments \code{m}, \code{r_list}, \code{r_times} and \code{fade_raster}. #' @@ -20,164 +20,174 @@ #' Colours could also be arranged to change through time or by behavioral segments, geographic locations, age, environmental or health parameters etc. If a column name \code{colour} in \code{m} is missing, colours will be selected automatically. Call \code{colours()} to see all available colours in R. #' #' @return An object of class \code{moveVis}. If \code{return_data} is \code{TRUE}, a \code{data.frame} is returned (see \code{return_data}). -#' +#' #' @author Jakob Schwalb-Willmann -#' +#' #' @importFrom raster compareCRS nlayers minValue maxValue extract -#' @importFrom sf st_crs +#' @importFrom sf st_crs #' @importFrom move n.indiv -#' +#' #' @examples #' library(moveVis) #' library(move) #' library(ggplot2) -#' +#' #' data("move_data", "basemap_data") #' # align movement #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' \dontrun{ #' # use the same inputs to create a non-spatial graph, e.g. a flow graph: -#' frames.gr <- frames_graph(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE, graph_type = "flow") +#' frames.gr <- frames_graph(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE, graph_type = "flow" +#' ) #' # take a look #' frames.gr[[100]] -#' +#' #' # make a histogram graph: -#' frames.gr <- frames_graph(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE, graph_type = "hist") +#' frames.gr <- frames_graph(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE, graph_type = "hist" +#' ) #' # change the value interval: -#' frames.gr <- frames_graph(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE, graph_type = "hist", val_by = 0.01) -#' +#' frames.gr <- frames_graph(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE, graph_type = "hist", val_by = 0.01 +#' ) +#' #' frames.gr[[100]] #' # manipulate the labels, since now they are very dense: #' # just replace the current scale -#' frames.gr <- add_gg(frames.gr, expr(scale_x_continuous(breaks=seq(0,1,0.1), -#' labels=seq(0,1,0.1), expand = c(0,0)))) +#' frames.gr <- add_gg(frames.gr, expr(scale_x_continuous( +#' breaks = seq(0, 1, 0.1), +#' labels = seq(0, 1, 0.1), expand = c(0, 0) +#' ))) #' frames.gr[[100]] -#' +#' #' # the same can be done for discrete data, histogram will then be shown as bin plots -#' +#' #' # to make your own graphs, use frames_graph to return data instead of frames -#' frames.gr <- frames_graph(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE, return_data = TRUE) -#' -#' # then simply animate the frames using animate_frames +#' frames.gr <- frames_graph(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE, return_data = TRUE +#' ) +#' +#' # then simply animate the frames using animate_frames #' # see all add_ functions on how to customize your frames created with frames_spatial #' # or frames_graph -#' +#' #' # see ?animate_frames on how to animate frames #' } #' @seealso \code{\link{frames_spatial}} \code{\link{join_frames}} \code{\link{animate_frames}} #' @export -frames_graph <- function(m, r_list, r_times, r_type = "gradient", fade_raster = FALSE, crop_raster = TRUE, return_data = FALSE, graph_type = "flow", path_size = 1, path_colours = NA, path_legend = TRUE, path_legend_title = "Names", - val_min = NULL, val_max = NULL, val_by = 0.1, verbose = T){ - +frames_graph <- function(m, r_list, r_times, r_type = "gradient", fade_raster = FALSE, crop_raster = TRUE, return_data = FALSE, graph_type = "flow", path_size = 1, path_colours = NA, path_legend = TRUE, path_legend_title = "Names", + val_min = NULL, val_max = NULL, val_by = 0.1, verbose = T) { ## check input arguments - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(all(!c(inherits(m, "MoveStack"), inherits(m, "Move")))) out("Argument 'm' must be of class 'Move' or 'MoveStack'.", type = 3) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (all(!c(inherits(m, "MoveStack"), inherits(m, "Move")))) out("Argument 'm' must be of class 'Move' or 'MoveStack'.", type = 3) + ## check m time conformities .time_conform(m) - - if(all(!is.list(r_list), inherits(r_list, "Raster"))) r_list <- list(r_list) - if(is.character(r_type)){ - if(!any(r_type == c("gradient", "discrete"))) out("Argument 'r_type' must be either 'gradient' or 'discrete'.", type = 3) - } else{ out("Argument 'r_type' must be of type 'character'.", type = 3)} - if(!inherits(r_list[[1]], "RasterLayer")) out("Argument 'r_list' must contain single-layer 'RasterLayer' objects. Multi-layer 'RasterStack' objects are not supported by this function.", type = 3) - if(any(!sapply(r_list, compareCRS, y = m))) out("Projections of 'm' and 'r_list' differ.", type = 3) - if(length(unique(sapply(r_list, nlayers))) > 1) out("Number of layers per raster object in list 'r' differ.", type = 3) - if(!inherits(r_times, "POSIXct")) out("Argument 'r_times' must be of type 'POSIXct' if 'r_list' is defined.", type = 3) - if(!is.logical(fade_raster)) out("Argument 'fade_raster' has to be either TRUE or FALSE.", type = 3) - - if(!is.numeric(path_size)) out("Argument 'path_size' must be of type 'numeric'.", type = 3) - if(is.character(path_colours)) if(length(path_colours) != n.indiv(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3) - if(!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3) - if(!is.character(path_legend_title)) out("Argument 'path_legend_title' must be of type 'character'.", type = 3) - if(!is.logical(return_data)) out("Argument 'return_data' must be of type 'logical'.", type = 3) - + + if (all(!is.list(r_list), inherits(r_list, "Raster"))) r_list <- list(r_list) + if (is.character(r_type)) { + if (!any(r_type == c("gradient", "discrete"))) out("Argument 'r_type' must be either 'gradient' or 'discrete'.", type = 3) + } else { + out("Argument 'r_type' must be of type 'character'.", type = 3) + } + if (!inherits(r_list[[1]], "RasterLayer")) out("Argument 'r_list' must contain single-layer 'RasterLayer' objects. Multi-layer 'RasterStack' objects are not supported by this function.", type = 3) + if (any(!sapply(r_list, compareCRS, y = m))) out("Projections of 'm' and 'r_list' differ.", type = 3) + if (length(unique(sapply(r_list, nlayers))) > 1) out("Number of layers per raster object in list 'r' differ.", type = 3) + if (!inherits(r_times, "POSIXct")) out("Argument 'r_times' must be of type 'POSIXct' if 'r_list' is defined.", type = 3) + if (!is.logical(fade_raster)) out("Argument 'fade_raster' has to be either TRUE or FALSE.", type = 3) + + if (!is.numeric(path_size)) out("Argument 'path_size' must be of type 'numeric'.", type = 3) + if (is.character(path_colours)) if (length(path_colours) != n.indiv(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3) + if (!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3) + if (!is.character(path_legend_title)) out("Argument 'path_legend_title' must be of type 'character'.", type = 3) + if (!is.logical(return_data)) out("Argument 'return_data' must be of type 'logical'.", type = 3) + ## check graph_type and hist arguments - if(!is.character(graph_type)){ + if (!is.character(graph_type)) { out("Argument 'graph_type' must be of type character.", type = 3) - } else{ - if(!any(graph_type == c("flow", "hist"))) out("Argument 'graph_type' must be either 'flow' or 'hist'.", type = 3) + } else { + if (!any(graph_type == c("flow", "hist"))) out("Argument 'graph_type' must be either 'flow' or 'hist'.", type = 3) } - if(graph_type == "hist"){ - if(!is.null(val_min)) if(!is.numeric(val_min)) out("Argument 'val_min' must be of type 'numeric', if defined.", type = 3) - if(!is.null(val_max)) if(!is.numeric(val_max)) out("Argument 'val_max' must be of type 'numeric', if defined.", type = 3) - if(!is.numeric(val_by)) out("Argument 'val_by' must be of type 'numeric'.", type = 3) + if (graph_type == "hist") { + if (!is.null(val_min)) if (!is.numeric(val_min)) out("Argument 'val_min' must be of type 'numeric', if defined.", type = 3) + if (!is.null(val_max)) if (!is.numeric(val_max)) out("Argument 'val_max' must be of type 'numeric', if defined.", type = 3) + if (!is.numeric(val_by)) out("Argument 'val_by' must be of type 'numeric'.", type = 3) } - + ## warnings - if(r_type == "discrete" & fade_raster == T) out("Argument 'fade_raster' is TRUE, while argument 'r_type' is set to 'discrete'. Interpolating discrete values will destroy discrete classes!", type = 2) - if(r_type == "discrete" & !val_by%%1==0) out("Argument 'val_by' is fractional, while argument 'r_type' is set to 'discrete'. You may want to set 'val_by' to 1 or another integer for discrete classes.", type = 2) - + if (r_type == "discrete" & fade_raster == T) out("Argument 'fade_raster' is TRUE, while argument 'r_type' is set to 'discrete'. Interpolating discrete values will destroy discrete classes!", type = 2) + if (r_type == "discrete" & !val_by %% 1 == 0) out("Argument 'val_by' is fractional, while argument 'r_type' is set to 'discrete'. You may want to set 'val_by' to 1 or another integer for discrete classes.", type = 2) + ## create data.frame from m with frame time and colour out("Processing movement data...") - m.df <- .m2df(m, path_colours = path_colours) + m.df <- .m2df(m, path_colours = path_colours) .stats(max(m.df$frame)) - + ## create raster list - r_list <- .rFrames(r_list = r_list, r_times = r_times, m.df = m.df, gg.ext = .ext(m.df, st_crs(m)), fade_raster = fade_raster, crop_raster = crop_raster) - if(length(r_list) == 1){ + r_list <- .rFrames(r_list = r_list, r_times = r_times, m.df = m.df, gg.ext = .ext(m.df, st_crs(m)), fade_raster = fade_raster, crop_raster = crop_raster) + if (length(r_list) == 1) { m.df$value <- sapply(1:nrow(m.df), function(i) raster::extract(r_list[[1]], m.df[i, c("x", "y")]), USE.NAMES = F) - } else{ - m.df$value <- sapply(1:nrow(m.df), function(i) raster::extract(r_list[[m.df[i,]$frame]], m.df[i, c("x", "y")]), USE.NAMES = F) + } else { + m.df$value <- sapply(1:nrow(m.df), function(i) raster::extract(r_list[[m.df[i, ]$frame]], m.df[i, c("x", "y")]), USE.NAMES = F) } - + ## create value sequence - if(is.null(val_min)) val_min <- floor(min(sapply(r_list, minValue), na.rm = T)) - if(is.null(val_max)) val_max <- ceiling(max(sapply(r_list, maxValue), na.rm = T)) + if (is.null(val_min)) val_min <- floor(min(sapply(r_list, minValue), na.rm = T)) + if (is.null(val_max)) val_max <- ceiling(max(sapply(r_list, maxValue), na.rm = T)) val_digits <- nchar(strsplit(as.character(val_by), "[.]")[[1]][2]) - if(is.na(val_digits)) val_digits <- 0 + if (is.na(val_digits)) val_digits <- 0 val_seq <- seq(val_min, val_max, by = val_by) - - if(isTRUE(return_data)){ + + if (isTRUE(return_data)) { return(m.df) - } else{ - + } else { ## create frames out("Creating frames...") # if(graph_type == "flow"){ # #frames <- .gg_flow(m.df, path_legend, path_legend_title, path_size, val_seq) # } hist_data <- NULL - if(graph_type == "hist"){ - - dummy <- do.call(rbind, lapply(unique(m.df$id), function(id){ - cbind.data.frame(count = 0, value = val_seq, id = id, name = unique(m.df[m.df$id == id,]$name), - colour = unique(m.df[m.df$id == id,]$colour)) + if (graph_type == "hist") { + dummy <- do.call(rbind, lapply(unique(m.df$id), function(id) { + cbind.data.frame( + count = 0, value = val_seq, id = id, name = unique(m.df[m.df$id == id, ]$name), + colour = unique(m.df[m.df$id == id, ]$colour) + ) })) - + ## Calculating time-cumulative value histogram per individual and timestep - #out("Calculating histogram...") - hist_data <- lapply(1:max(m.df$frame), function(i, d = dummy){ - x <- m.df[unlist(lapply(1:i, function(x) which(m.df$frame == x))),] - - x <- do.call(rbind, lapply(unique(x$id), function(id){ - y <- x[x$id == id,] + # out("Calculating histogram...") + hist_data <- lapply(1:max(m.df$frame), function(i, d = dummy) { + x <- m.df[unlist(lapply(1:i, function(x) which(m.df$frame == x))), ] + + x <- do.call(rbind, lapply(unique(x$id), function(id) { + y <- x[x$id == id, ] z <- table(round(y$value, digits = val_digits)) - - d.id <- d[d$id == id,] + + d.id <- d[d$id == id, ] d.id[match(names(z), as.character(d.id$value)), 1] <- z - - #d <- cbind(d, id = unique(y$id), name = unique(y$name), colour = unique(y$colour)) + + # d <- cbind(d, id = unique(y$id), name = unique(y$name), colour = unique(y$colour)) return(d.id) })) - }) - + ## fusing histograms for plot scaling # all.hist <- do.call(rbind, hist_data) - #frames <- .gg_hist(hist_data, all.hist, path_legend, path_legend_title, path_size, val_seq, r_type) + # frames <- .gg_hist(hist_data, all.hist, path_legend, path_legend_title, path_size, val_seq, r_type) } } - + # create frames object frames <- list( move_data = m.df, @@ -189,11 +199,11 @@ frames_graph <- function(m, r_list, r_times, r_type = "gradient", fade_raster = path_legend = path_legend, path_legend_title = path_legend_title, val_seq = val_seq, - r_type = r_type), + r_type = r_type + ), additions = NULL ) attr(frames, "class") <- c("moveVis", "frames_graph") - + return(frames) } - diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 50bd35c..7372058 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -32,8 +32,8 @@ #' @param map_type character, a map type, e.g. \code{"streets"}. Use \code{\link{get_maptypes}} for available map services and types. #' @param map_res numeric, resolution of base map in range from 0 to 1. #' @param map_token character, mapbox authentification token for mapbox basemaps. Register at \url{https://www.mapbox.com/} to get a mapbox token. Mapbox is free of charge after registration for up to 50.000 map requests per month. Ignored, if \code{map_service = "osm"}. -#' @param map_dir character, directory where downloaded basemap tiles can be stored. By default, a temporary directory is used. -#' If you use moveVis often for the same area it is recommended to set this argument to a directory persistent throughout sessions (e.g. in your user folder), +#' @param map_dir character, directory where downloaded basemap tiles can be stored. By default, a temporary directory is used. +#' If you use moveVis often for the same area it is recommended to set this argument to a directory persistent throughout sessions (e.g. in your user folder), #' so that baesmap tiles that had been already downloaded by moveVis do not have to be requested again. #' @param ... Additional arguments customizing the frame background: #' \itemize{ @@ -42,70 +42,78 @@ #' \item \code{macColorValue}, numeric, only relevant for RGB backgrounds (i.e. if \code{r_type = "RGB"} or if a default base map is used). Maximum colour value (e.g. 255). Defaults to maximum raster value. #' } #' @param verbose logical, if \code{TRUE}, messages and progress information are displayed on the console (default). -#' +#' #' @details If argument \code{path_colours} is not defined (set to \code{NA}), path colours can be defined by adding a character column named \code{colour} to \code{m}, containing a colour code or name per row (e.g. \code{"red"}. This way, for example, column \code{colour} for all rows belonging to individual A can be set to \code{"green"}, while column \code{colour} for all rows belonging to individual B can be set to \code{"red"}. #' Colours could also be arranged to change through time or by behavioral segments, geographic locations, age, environmental or health parameters etc. If a column name \code{colour} in \code{m} is missing, colours will be selected automatically. Call \code{colours()} to see all available colours in R. -#' +#' #' Basemap colour scales can be changed/added using \code{\link{add_colourscale}} or by using \code{ggplot2} commands (see \code{examples}). For continous scales, use \code{r_type = "gradient"}. For discrete scales, use \code{r_type = "discrete"}. -#' +#' #' If argument \code{equidistant} is set, the map extent is calculated (thus enlarged into one axis direction) to represent equal surface distances on the x and y axis. #' -#' @note -#' +#' @note +#' #' The use of the map services \code{"osm_thunderforest"} and \code{"mapbox"} require registration to obtain an API token/key which can be supplied to \code{map_token}. Register at \url{https://www.thunderforest.com/} and/or \url{https://www.mapbox.com/} to get a token. -#' +#' #' The projection of \code{m} is treated as target projection. Default basemaps accessed through a map service will be reprojected into the projection of \code{m}. Thus, depending on the projection of \code{m}, it may happen that map labels are distorted. To get undistorted map labels, reproject \code{m} to the web mercator projection (the default projection for basemaps): \code{spTransform(m, crs("+init=epsg:3857"))} #' #' @return A frames object of class \code{moveVis}. -#' +#' #' @author Jakob Schwalb-Willmann -#' +#' #' @importFrom raster compareCRS nlayers crs #' @importFrom sf st_crs st_bbox #' @importFrom move n.indiv moveStack #' @importFrom basemaps basemap_raster -#' -#' @examples +#' +#' @examples #' library(moveVis) #' library(move) #' library(ggplot2) -#' +#' #' data("move_data") #' # align movement #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' \dontrun{ #' # with osm watercolor base map #' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor") #' # take a look at one of the frames, e.g. the 100th #' frames[[100]] -#' +#' #' # make base map a bit transparent #' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor", alpha = 0.5) #' frames[[100]] # take a look -#' +#' #' # use a larger margin around extent -#' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor", alpha = 0.5, -#' margin_factor = 1.8) -#' +#' frames <- frames_spatial(m, +#' map_service = "osm", map_type = "watercolor", alpha = 0.5, +#' margin_factor = 1.8 +#' ) +#' #' # use a extent object as your AOI #' ext <- extent(m) -#' ext@xmin <- ext@xmin - (ext@xmin*0.003) -#' ext@xmax <- ext@xmax + (ext@xmax*0.003) -#' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor", alpha = 0.5, -#' ext = ext) -#' +#' ext@xmin <- ext@xmin - (ext@xmin * 0.003) +#' ext@xmax <- ext@xmax + (ext@xmax * 0.003) +#' frames <- frames_spatial(m, +#' map_service = "osm", map_type = "watercolor", alpha = 0.5, +#' ext = ext +#' ) +#' #' # alter path appearance (make it longer and bigger) -#' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor", alpha = 0.5, -#' path_size = 4, tail_length = 29) -#' +#' frames <- frames_spatial(m, +#' map_service = "osm", map_type = "watercolor", alpha = 0.5, +#' path_size = 4, tail_length = 29 +#' ) +#' #' # adjust path colours manually -#' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor", alpha = 0.5, -#' path_colours = c("black", "blue", "purple")) -#' +#' frames <- frames_spatial(m, +#' map_service = "osm", map_type = "watercolor", alpha = 0.5, +#' path_colours = c("black", "blue", "purple") +#' ) +#' #' # or do it directly within your moveStack, e.g. like: #' m.list <- split(m) # split m into list by individual -#' m.list <- mapply(x = m.list, y = c("orange", "purple", "darkgreen"), function(x, y){ +#' m.list <- mapply(x = m.list, y = c("orange", "purple", "darkgreen"), function(x, y) { #' x$colour <- y #' return(x) #' }) # add colour per individual @@ -113,41 +121,45 @@ #' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor", alpha = 0.5) #' # this way, you do not have to assign colours per individual track #' # instead, you could assign colours by segment, age, speed or other variables -#' +#' #' # get available map types #' get_maptypes() -#' +#' #' # use mapbox to get a satellite or other map types (register to on mapbox.com to get a token) #' # frames <- frames_spatial(m, map_service = "mapbox", #' # map_token = "your_token_from_your_mapbox_account", #' # map_type = "satellite") -#' +#' #' # if you make a lot of calls to frames_spatial during mutliple sessions, use a map directory #' # to save all base maps offline so that you do not have to query the servers each time #' # frames <- frames_spatial(m, map_service = "mapbox", #' # map_token = "your_token_from_your_mapbox_account", #' # map_type = "satellite", -#' # map_dir = "your/map_directory/") -#' +#' # map_dir = "your/map_directory/") +#' #' # use your own custom base maps #' data("basemap_data") #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' # using gradient data (e.g. NDVI) -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' #' # using discrete data (e.g. classifications) #' # let's make up some classification data with 10 classes -#' r_list <- lapply(r_list, function(x){ -#' y <- raster::setValues(x, round(raster::getValues(x)*10)) +#' r_list <- lapply(r_list, function(x) { +#' y <- raster::setValues(x, round(raster::getValues(x) * 10)) #' return(y) #' }) #' # turn fade_raster to FALSE, since it makes no sense to temporally interpolate discrete classes -#' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "discrete", -#' fade_raster = FALSE) -#' +#' frames <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "discrete", +#' fade_raster = FALSE +#' ) +#' #' # then simply animate the frames using animate_frames #' # see ?add_colourscale to learn how to change colours of custom base maps #' # see all add_ functions on how to customize your frames created with frames_spatial @@ -159,146 +171,152 @@ frames_spatial <- function(m, r_list = NULL, r_times = NULL, r_type = "gradient", fade_raster = FALSE, crop_raster = TRUE, map_service = "osm", map_type = "streets", map_res = 1, map_token = NULL, map_dir = NULL, margin_factor = 1.1, equidistant = NULL, ext = NULL, path_size = 3, path_end = "round", path_join = "round", path_mitre = 10, path_arrow = NULL, path_colours = NA, path_alpha = 1, path_fade = FALSE, - path_legend = TRUE, path_legend_title = "Names", tail_length = 19, tail_size = 1, tail_colour = "white", trace_show = FALSE, trace_size = tail_size, trace_colour = "white", cross_dateline = FALSE, ..., verbose = TRUE){ - + path_legend = TRUE, path_legend_title = "Names", tail_length = 19, tail_size = 1, tail_colour = "white", trace_show = FALSE, trace_size = tail_size, trace_colour = "white", cross_dateline = FALSE, ..., verbose = TRUE) { ## check input arguments - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(all(!c(inherits(m, "MoveStack"), inherits(m, "Move")))) out("Argument 'm' must be of class 'Move' or 'MoveStack'.", type = 3) - if(inherits(m, "Move")) m <- moveStack(m) - - if(!is.null(r_list)){ - if(all(!is.list(r_list), inherits(r_list, "Raster"))) r_list <- list(r_list) - if(any(!sapply(r_list, compareCRS, y = m))) out("Projections of 'm' and 'r_list' differ.", type = 3) - if(length(unique(sapply(r_list, nlayers))) > 1) out("Number of layers per raster object in list 'r' differ.", type = 3) - if(!inherits(r_times, "POSIXct")) out("Argument 'r_times' must be of type 'POSIXct' if 'r_list' is defined.", type = 3) - if(!isTRUE(r_type %in% c("gradient", "discrete", "RGB"))) out("Argument 'r_type' must eihter be 'gradient', 'discrete' or 'RGB'.", type = 3) - if(!is.logical(fade_raster)) out("Argument 'fade_raster' has to be either TRUE or FALSE.", type = 3) - if(!is.logical(crop_raster)) out("Argument 'crop_raster' has to be either TRUE or FALSE.", type = 3) - } else{ - if(isFALSE(tolower(map_service) %in% names(get_maptypes()))) out(paste0("Argument 'map_service' must be ", paste0(names(moveVis::get_maptypes()), collapse = ", "))) - if(isFALSE(tolower(map_type) %in% get_maptypes(map_service))) out("The defined map type is not supported for the selected service. Use get_maptypes() to get all available map types.", type = 3) - if(!is.numeric(map_res)) out("Argument 'map_res' must be 'numeric'.", type = 3) - if(any(map_res < 0, map_res > 1)) out("Argument 'map_res' must be a value between 0 and 1.", type = 3) - if(all(!inherits(map_token, "character"), map_service == "mapbox")) out("Argument 'map_token' must be defined to access a basemap, if 'r_list' is not defined and 'map_service' is 'mapbox'.", type = 3) - if(is.null(map_dir)){ + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (all(!c(inherits(m, "MoveStack"), inherits(m, "Move")))) out("Argument 'm' must be of class 'Move' or 'MoveStack'.", type = 3) + if (inherits(m, "Move")) m <- moveStack(m) + + if (!is.null(r_list)) { + if (all(!is.list(r_list), inherits(r_list, "Raster"))) r_list <- list(r_list) + if (any(!sapply(r_list, compareCRS, y = m))) out("Projections of 'm' and 'r_list' differ.", type = 3) + if (length(unique(sapply(r_list, nlayers))) > 1) out("Number of layers per raster object in list 'r' differ.", type = 3) + if (!inherits(r_times, "POSIXct")) out("Argument 'r_times' must be of type 'POSIXct' if 'r_list' is defined.", type = 3) + if (!isTRUE(r_type %in% c("gradient", "discrete", "RGB"))) out("Argument 'r_type' must eihter be 'gradient', 'discrete' or 'RGB'.", type = 3) + if (!is.logical(fade_raster)) out("Argument 'fade_raster' has to be either TRUE or FALSE.", type = 3) + if (!is.logical(crop_raster)) out("Argument 'crop_raster' has to be either TRUE or FALSE.", type = 3) + } else { + if (isFALSE(tolower(map_service) %in% names(get_maptypes()))) out(paste0("Argument 'map_service' must be ", paste0(names(moveVis::get_maptypes()), collapse = ", "))) + if (isFALSE(tolower(map_type) %in% get_maptypes(map_service))) out("The defined map type is not supported for the selected service. Use get_maptypes() to get all available map types.", type = 3) + if (!is.numeric(map_res)) out("Argument 'map_res' must be 'numeric'.", type = 3) + if (any(map_res < 0, map_res > 1)) out("Argument 'map_res' must be a value between 0 and 1.", type = 3) + if (all(!inherits(map_token, "character"), map_service == "mapbox")) out("Argument 'map_token' must be defined to access a basemap, if 'r_list' is not defined and 'map_service' is 'mapbox'.", type = 3) + if (is.null(map_dir)) { map_dir <- paste0(tempdir(), "/moveVis/basemap/") - if(!dir.exists(map_dir)) dir.create(map_dir, recursive = T) - } else{ - if(!dir.exists(map_dir)) out("The directory defined with 'map_dir' does not exist.", type = 3) + if (!dir.exists(map_dir)) dir.create(map_dir, recursive = T) + } else { + if (!dir.exists(map_dir)) out("The directory defined with 'map_dir' does not exist.", type = 3) } } num.args <- c(margin_factor = margin_factor, tail_length = tail_length, tail_size = tail_size, path_size = path_size, path_mitre = path_mitre, trace_size = trace_size) - catch <- sapply(1:length(num.args), function(i) if(!is.numeric(num.args[[i]])) out(paste0("Argument '", names(num.args)[[i]], "' must be of type 'numeric'."), type = 3)) + catch <- sapply(1:length(num.args), function(i) if (!is.numeric(num.args[[i]])) out(paste0("Argument '", names(num.args)[[i]], "' must be of type 'numeric'."), type = 3)) char.args <- c(path_end = path_end, path_join = path_join, path_legend_title = path_legend_title) - catch <- sapply(1:length(char.args), function(i) if(!is.character(char.args[[i]])) out(paste0("Argument '", names(char.args)[[i]], "' must be of type 'numeric'."), type = 3)) + catch <- sapply(1:length(char.args), function(i) if (!is.character(char.args[[i]])) out(paste0("Argument '", names(char.args)[[i]], "' must be of type 'numeric'."), type = 3)) extras <- list(...) - - #if(!is.null(ext)){ + + # if(!is.null(ext)){ # if(!inherits(ext, "Extent")) out("Argument 'ext' must be of type 'Extent' (see raster::extent), if defined.", type = 3) # if(isTRUE(ext < extent(m))) out("The frame extent defined using argument 'ext' is smaller than extent(m). Be aware that movements outside of 'ext' will be clipped.", type = 2) - #} - if(!is.null(path_arrow)) if(!inherits(path_arrow, "arrow")) out("Argument 'path_arrow' must be of type 'arrrow' (see grid::arrow), if defined.", type = 3) - if(is.character(path_colours)) if(length(path_colours) != n.indiv(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3) - if(!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3) - if(is.null(equidistant)) if(is.null(ext)) equidistant <- TRUE else equidistant <- FALSE - if(!is.logical(equidistant)) out("Argument 'equidistant' must be of type 'logical'.", type = 3) - - if(all(isTRUE(cross_dateline), !is.null(r_list))) out("Argument 'cross_dateline' only works with default base maps. Arguments 'r_list' and 'r_times' cannot be used, if cross_dateline = TRUE.\nTip: Reproject 'm' to another CRS that better suits the region if you want to use 'r_list' with tracks crossing the dateline.", type = 3) - + # } + if (!is.null(path_arrow)) if (!inherits(path_arrow, "arrow")) out("Argument 'path_arrow' must be of type 'arrrow' (see grid::arrow), if defined.", type = 3) + if (is.character(path_colours)) if (length(path_colours) != n.indiv(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3) + if (!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3) + if (is.null(equidistant)) if (is.null(ext)) equidistant <- TRUE else equidistant <- FALSE + if (!is.logical(equidistant)) out("Argument 'equidistant' must be of type 'logical'.", type = 3) + + if (all(isTRUE(cross_dateline), !is.null(r_list))) out("Argument 'cross_dateline' only works with default base maps. Arguments 'r_list' and 'r_times' cannot be used, if cross_dateline = TRUE.\nTip: Reproject 'm' to another CRS that better suits the region if you want to use 'r_list' with tracks crossing the dateline.", type = 3) + ## check m time conformities out("Checking temporal alignment...") .time_conform(m) - + ## preprocess movement data out("Processing movement data...") m.crs <- st_crs(m) - if(isTRUE(cross_dateline)){ + if (isTRUE(cross_dateline)) { equidistant <- FALSE - if(m.crs != st_crs(4326)) out("Since arugment 'cross_dateline' is TRUE, 'm' will be transformed to Geographic Coordinates (EPSG 4326, Lat/Lon WGS84)", type = 2) - m.crs <- st_crs(4326) + if (m.crs != st_crs(4326)) out("Since arugment 'cross_dateline' is TRUE, 'm' will be transformed to Geographic Coordinates (EPSG 4326, Lat/Lon WGS84)", type = 2) + m.crs <- st_crs(4326) } m.df <- .m2df(m, path_colours = path_colours, return_latlon = cross_dateline) # create data.frame from m with frame time and colour .stats(n.frames = max(m.df$frame)) - + gg.ext <- .ext(m.df, m.crs, ext, margin_factor, equidistant, cross_dateline) # calculate extent - - + + print(gg.ext) + ## shift coordinates crossing dateline - if(isTRUE(cross_dateline)){ + if (isTRUE(cross_dateline)) { rg <- c("pos" = diff(range(m.df$x[m.df$x >= 0])), "neg" = diff(range(m.df$x[m.df$x < 0]))) - if(which.max(rg) == 1){ - m.df$x[m.df$x < 0] <- 180+m.df$x[m.df$x < 0]+180 - } else{ - m.df$x[m.df$x >= 0] <- -180+m.df$x[m.df$x >= 0]-180 + if (which.max(rg) == 1) { + m.df$x[m.df$x < 0] <- 180 + m.df$x[m.df$x < 0] + 180 + } else { + m.df$x[m.df$x >= 0] <- -180 + m.df$x[m.df$x >= 0] - 180 } } - + ## calculate tiles and get map imagery - if(is.null(r_list)){ + if (is.null(r_list)) { out("Retrieving and compositing basemap imagery...") r_list <- list(suppressWarnings(basemap_raster( ext = gg.ext, map_service = map_service, map_type = map_type, map_res = map_res, map_token = map_token, map_dir = map_dir, verbose = verbose, custom_crs = as.character(m.crs$wkt), ... - #custom_crs = as.character(raster::crs(m)), ... + # custom_crs = as.character(raster::crs(m)), ... ))) - if(all(map_service == "mapbox", map_type == "terrain")) r_type = "gradient" else r_type <- "RGB" - } else{ + if (all(map_service == "mapbox", map_type == "terrain")) r_type <- "gradient" else r_type <- "RGB" + } else { map_service <- "custom" map_type <- "custom" } - + # calculate frames extents and coord labes - if(isTRUE(cross_dateline)){ + if (isTRUE(cross_dateline)) { gg.ext <- st_bbox(extent(r_list[[1]]), crs = m.crs) - + # use coord_equal for dateline crossingngs in EPSG:4326 only - m.df$coord <- list(ggplot2::coord_sf(xlim = c(gg.ext$xmin, gg.ext$xmax), ylim = c(gg.ext$ymin, gg.ext$ymax), - expand = F, clip = "on")) + m.df$coord <- list(ggplot2::coord_sf( + xlim = c(gg.ext$xmin, gg.ext$xmax), ylim = c(gg.ext$ymin, gg.ext$ymax), + expand = F, clip = "on" + )) m.df$scalex <- list(ggplot2::scale_x_continuous(labels = .x_labels)) m.df$scaley <- list(ggplot2::scale_y_continuous(labels = .y_labels)) - } else{ - + } else { # use coord_sf for all other cases - m.df$coord <- list(ggplot2::coord_sf(xlim = c(gg.ext$xmin, gg.ext$xmax), ylim = c(gg.ext$ymin, gg.ext$ymax), - expand = F, crs = st_crs(m), datum = st_crs(m), clip = "on")) + m.df$coord <- list(ggplot2::coord_sf( + xlim = c(gg.ext$xmin, gg.ext$xmax), ylim = c(gg.ext$ymin, gg.ext$ymax), + expand = F, crs = st_crs(m), datum = st_crs(m), clip = "on" + )) m.df$scaley <- m.df$scalex <- NULL } - + out("Assigning raster maps to frames...") r_list <- .rFrames(r_list, r_times, m.df, gg.ext, fade_raster, crop_raster = crop_raster) - + # create frames object frames <- list( move_data = m.df, raster_data = r_list, - aesthetics = c(list( - equidistant = equidistant, - path_size = path_size, - path_end = path_end, - path_join = path_join, - path_alpha = path_alpha, - path_mitre = path_mitre, - path_arrow = path_arrow, - path_legend = path_legend, - path_legend_title = path_legend_title, - tail_length = tail_length, - tail_size = tail_size, - tail_colour = tail_colour, - trace_show = trace_show, - trace_size = trace_size, - trace_colour = trace_colour, - path_fade = path_fade, - gg.ext = gg.ext, - map_service = map_service, - map_type = map_type, - r_type = r_type), - maxpixels = if(!is.null(extras$maxpixels)) extras$maxpixels else 500000, - alpha = if(!is.null(extras$alpha)) extras$alpha else 1, - maxColorValue = if(!is.null(extras$maxColorValue)) extras$maxColorValue else NA), + aesthetics = c( + list( + equidistant = equidistant, + path_size = path_size, + path_end = path_end, + path_join = path_join, + path_alpha = path_alpha, + path_mitre = path_mitre, + path_arrow = path_arrow, + path_legend = path_legend, + path_legend_title = path_legend_title, + tail_length = tail_length, + tail_size = tail_size, + tail_colour = tail_colour, + trace_show = trace_show, + trace_size = trace_size, + trace_colour = trace_colour, + path_fade = path_fade, + gg.ext = gg.ext, + map_service = map_service, + map_type = map_type, + r_type = r_type + ), + maxpixels = if (!is.null(extras$maxpixels)) extras$maxpixels else 500000, + alpha = if (!is.null(extras$alpha)) extras$alpha else 1, + maxColorValue = if (!is.null(extras$maxColorValue)) extras$maxColorValue else NA + ), additions = NULL ) attr(frames, "class") <- c("moveVis", "frames_spatial") - + return(frames) -} \ No newline at end of file +} diff --git a/R/get_frametimes.R b/R/get_frametimes.R index d396b6b..5f345aa 100644 --- a/R/get_frametimes.R +++ b/R/get_frametimes.R @@ -4,26 +4,26 @@ #' #' @inheritParams add_gg #' @return A POSIXct vector of timestamps representing the time associated with each frame. -#' -#' -#' @examples +#' +#' +#' @examples #' library(moveVis) #' library(move) -#' +#' #' data("move_data") #' # align movement #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' \dontrun{ #' frames <- frames_spatial(m, map_service = "osm", map_type = "watercolor") #' frames.ts <- get_frametimes(frames) #' print(frames.ts) #' } -#' +#' #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} #' @export -get_frametimes <- function(frames){ - if(!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) +get_frametimes <- function(frames) { + if (!inherits(frames, "moveVis")) out("Argument 'frames' needs to be of class 'moveVis'. See frames_spatial()).", type = 3) return(unique(frames$move_data$time)) -} \ No newline at end of file +} diff --git a/R/internal.R b/R/internal.R index 713c5c7..e017238 100755 --- a/R/internal.R +++ b/R/internal.R @@ -1,7 +1,7 @@ #' Suppress messages and warnings -#' @noRd -quiet <- function(expr){ - #return(expr) +#' @noRd +quiet <- function(expr) { + # return(expr) return(suppressWarnings(suppressMessages(expr))) } @@ -15,24 +15,35 @@ quiet <- function(expr){ #' @keywords internal #' @noRd -out <- function(input, type = 1, ll = NULL, msg = FALSE, sign = "", verbose = getOption("moveVis.verbose")){ - if(is.null(ll)) if(isTRUE(verbose)) ll <- 1 else ll <- 2 - if(type == 2 & ll <= 2){warning(paste0(sign,input), call. = FALSE, immediate. = TRUE)} - else{if(type == 3){stop(input, call. = FALSE)}else{if(ll == 1){ - if(msg == FALSE){ cat(paste0(sign,input),sep="\n") - } else{message(paste0(sign,input))}}}} +out <- function(input, type = 1, ll = NULL, msg = FALSE, sign = "", verbose = getOption("moveVis.verbose")) { + if (is.null(ll)) if (isTRUE(verbose)) ll <- 1 else ll <- 2 + if (type == 2 & ll <= 2) { + warning(paste0(sign, input), call. = FALSE, immediate. = TRUE) + } else { + if (type == 3) { + stop(input, call. = FALSE) + } else { + if (ll == 1) { + if (msg == FALSE) { + cat(paste0(sign, input), sep = "\n") + } else { + message(paste0(sign, input)) + } + } + } + } } #' Outputs animation stats #' #' @param n.frames numeric #' @param fps numeric -#' +#' #' @importFrom lubridate dseconds #' @keywords internal #' @noRd -.stats <- function(n.frames, fps = 25){ - out(paste0("Approximated animation duration: \u2248 ", as.character(dseconds(n.frames/fps)), " at ", toString(fps), " fps for ", toString(n.frames), " frames")) +.stats <- function(n.frames, fps = 25) { + out(paste0("Approximated animation duration: \u2248 ", as.character(dseconds(n.frames / fps)), " at ", toString(fps), " fps for ", toString(n.frames), " frames")) } #' Replace value @@ -43,8 +54,8 @@ out <- function(input, type = 1, ll = NULL, msg = FALSE, sign = "", verbose = ge #' #' @keywords internal #' @noRd -repl_vals <- function(data, x, y){ - for(i in 1:length(x)) data[data == x[i]] <- y[i] +repl_vals <- function(data, x, y) { + for (i in 1:length(x)) data[data == x[i]] <- y[i] data <- methods::as(data, class(y)) return(data) } @@ -57,10 +68,12 @@ repl_vals <- function(data, x, y){ #' #' @keywords internal #' @noRd -.na.approx <- function(v, rule = 2){ - if(length(which(!is.na(v))) < 2) return(v) else{ +.na.approx <- function(v, rule = 2) { + if (length(which(!is.na(v))) < 2) { + return(v) + } else { s <- 1:length(v) - stats::approx(x = s[!is.na(v)], y = v[!is.na(v)], rule = rule, xout = s)$y + stats::approx(x = s[!is.na(v)], y = v[!is.na(v)], rule = rule, xout = s)$y } } @@ -69,65 +82,64 @@ repl_vals <- function(data, x, y){ #' @importFrom sf st_transform #' @keywords internal #' @noRd -.st_transform <- function(...){ +.st_transform <- function(...) { return(quiet(sf::st_transform(...))) } #' verbose lapply #' #' @importFrom pbapply pblapply -#' @noRd -.lapply <- function(X, FUN, ..., moveVis.verbose = NULL, moveVis.n_cores = NULL, moveVis.export = NULL){ - if(is.null(moveVis.verbose)) moveVis.verbose <- getOption("moveVis.verbose") - if(is.null(moveVis.n_cores)) moveVis.n_cores <- getOption("moveVis.n_cores") - +#' @noRd +.lapply <- function(X, FUN, ..., moveVis.verbose = NULL, moveVis.n_cores = NULL, moveVis.export = NULL) { + if (is.null(moveVis.verbose)) moveVis.verbose <- getOption("moveVis.verbose") + if (is.null(moveVis.n_cores)) moveVis.n_cores <- getOption("moveVis.n_cores") + # with parallelization - if(moveVis.n_cores > 1){ + if (moveVis.n_cores > 1) { cl <- parallel::makeCluster(moveVis.n_cores) - if(!is.null(moveVis.export)) parallel::clusterExport(cl, moveVis.export) + if (!is.null(moveVis.export)) parallel::clusterExport(cl, moveVis.export) y <- try(parallel::parLapply(cl = cl, X, FUN, ...)) # ensures that cluster is stopped appropriately parallel::stopCluster(cl) - if(inherits(y, "try-error")) out(y, type = 3) else return(y) - - # without parallelization - }else if(isTRUE(moveVis.verbose)) pblapply(X, FUN, ...) else lapply(X, FUN, ...) + if (inherits(y, "try-error")) out(y, type = 3) else return(y) + + # without parallelization + } else if (isTRUE(moveVis.verbose)) pblapply(X, FUN, ...) else lapply(X, FUN, ...) } #' verbose apply #' #' @importFrom pbapply pbapply -#' @noRd -.apply <- function(X, MARGIN, FUN, ...){ - verbose = getOption("moveVis.verbose") - if(isTRUE(verbose)) pbapply(X, MARGIN, FUN, ...) else apply(X, MARGIN, FUN, ...) +#' @noRd +.apply <- function(X, MARGIN, FUN, ...) { + verbose <- getOption("moveVis.verbose") + if (isTRUE(verbose)) pbapply(X, MARGIN, FUN, ...) else apply(X, MARGIN, FUN, ...) } #' moveVis path standard colours #' @importFrom grDevices rainbow -#' @noRd -.standard_colours <- function(n){ +#' @noRd +.standard_colours <- function(n) { grDevices::rainbow(n) } #' returns sf data.frame from move object for internal use -#' @importFrom move n.indiv timestamps trackId +#' @importFrom move n.indiv timestamps trackId #' @importFrom sf st_transform st_as_sf st_crs st_coordinates -#' @noRd -.m2df <- function(m, path_colours = NA, tail_colour = NA, trace_colour = NA, return_latlon = FALSE){ - +#' @noRd +.m2df <- function(m, path_colours = NA, tail_colour = NA, trace_colour = NA, return_latlon = FALSE) { ## create data.frame from m with frame time and colour m.df <- cbind( - as.data.frame(m@coords), + as.data.frame(m@coords), id = repl_vals(as.character(trackId(m)), unique(as.character(trackId(m))), 1:n.indiv(m)), - time = timestamps(m), - time_chr = as.character(timestamps(m)), + time = timestamps(m), + time_chr = as.character(timestamps(m)), name = as.character(trackId(m)) ) - + # transform if requested - if(isTRUE(return_latlon)){ - m.df <- st_transform(st_as_sf(m.df, coords=1:2, crs = st_crs(m), remove = T), st_crs(4326)) + if (isTRUE(return_latlon)) { + m.df <- st_transform(st_as_sf(m.df, coords = 1:2, crs = st_crs(m), remove = T), st_crs(4326)) m.df <- cbind(st_coordinates(m.df), data.frame( id = m.df$id, time = m.df$time, @@ -136,135 +148,133 @@ repl_vals <- function(data, x, y){ )) } colnames(m.df)[1:2] <- c("x", "y") - + m.df$frame <- sapply(m.df$time, function(x) which(sort(unique(m.df$time)) == x)) - + ## handle colours, either provided as a field in m or argument or computed randomly m.info <- methods::as(m, "data.frame") - + # path colours - if(all(!is.character(path_colours), !all(is.na(m.info$colour)))){ + if (all(!is.character(path_colours), !all(is.na(m.info$colour)))) { m.df$colour <- as.character(m.info$colour) - } else{ - if(!is.character(path_colours)){ + } else { + if (!is.character(path_colours)) { path_colours <- .standard_colours(n.indiv(m)) } m.df$colour <- repl_vals(m.df$id, unique(m.df$id), path_colours[1:n.indiv(m)]) } - - - m.df <- m.df[order(m.df$frame),] + + + m.df <- m.df[order(m.df$frame), ] m.df$name <- factor(as.character(m.df$name), levels = unique(as.character(m.df$name))) return(m.df) } #' square it #' @importFrom sf st_bbox st_as_sfc st_crs st_sfc st_point st_distance -#' @noRd -.equidistant <- function(ext, margin_factor = 1){ - +#' @noRd +.equidistant <- function(ext, margin_factor = 1) { # lat lon extent ext.ll <- st_bbox(.st_transform(st_as_sfc(ext), st_crs(4326))) - + # calculate corner coordinates corn <- list(c(ext.ll[1], ext.ll[2]), c(ext.ll[1], ext.ll[4]), c(ext.ll[3], ext.ll[2]), c(ext.ll[3], ext.ll[4])) corn <- lapply(corn, function(x) st_sfc(st_point(x), crs = st_crs(4326))) - + # calculate difference and distance ax.dist <- as.numeric(c(suppressPackageStartupMessages(st_distance(corn[[1]], corn[[3]])), suppressPackageStartupMessages(st_distance(corn[[1]], corn[[2]])))) - ax.diff <- c(ext.ll[3]-ext.ll[1], ext.ll[4]-ext.ll[2]) - + ax.diff <- c(ext.ll[3] - ext.ll[1], ext.ll[4] - ext.ll[2]) + # add difference to match equal distances - if(ax.dist[1] < ax.dist[2]){ - x.devi <- (ax.diff[1]/ax.dist[1])*((ax.dist[2]-ax.dist[1])*margin_factor)/2 - y.devi <- ((ax.diff[2]/ax.dist[2])*(ax.dist[2]*margin_factor))-ax.diff[2] - } else{ - x.devi <- ((ax.diff[1]/ax.dist[1])*ax.dist[1])-ax.diff[1] - y.devi <- ((ax.diff[2]/ax.dist[2])*(ax.dist[1]-ax.dist[2])/2) + if (ax.dist[1] < ax.dist[2]) { + x.devi <- (ax.diff[1] / ax.dist[1]) * ((ax.dist[2] - ax.dist[1]) * margin_factor) / 2 + y.devi <- ((ax.diff[2] / ax.dist[2]) * (ax.dist[2] * margin_factor)) - ax.diff[2] + } else { + x.devi <- ((ax.diff[1] / ax.dist[1]) * ax.dist[1]) - ax.diff[1] + y.devi <- ((ax.diff[2] / ax.dist[2]) * (ax.dist[1] - ax.dist[2]) / 2) } - ext.ll.sq <- st_bbox(c(ext.ll[1]-x.devi, ext.ll[3]+x.devi, ext.ll[2]-y.devi, ext.ll[4]+y.devi), crs = st_crs(4326)) - + ext.ll.sq <- st_bbox(c(ext.ll[1] - x.devi, ext.ll[3] + x.devi, ext.ll[2] - y.devi, ext.ll[4] + y.devi), crs = st_crs(4326)) + ## add margin - if(margin_factor > 1){ - ax.diff <- c(ext.ll.sq[3]-ext.ll.sq[1], ext.ll.sq[4]-ext.ll.sq[2]) - x.devi <- ((ax.diff[1]*margin_factor)-ax.diff[1]) - y.devi <- ((ax.diff[2]*margin_factor)-ax.diff[2]) - ext.ll.sq <- st_bbox(c(ext.ll[1]-x.devi, ext.ll[3]+x.devi, ext.ll[2]-y.devi, ext.ll[4]+y.devi), crs = st_crs(4326)) - - if(ext.ll.sq["xmin"] < -180) ext.ll.sq["xmin"] <- -180 - if(ext.ll.sq["xmax"] > 180) ext.ll.sq["xmax"] <- 180 - if(ext.ll.sq["ymin"] < -90) ext.ll.sq["ymin"] <- -90 - if(ext.ll.sq["ymax"] > 90) ext.ll.sq["ymax"] <- 90 + if (margin_factor > 1) { + ax.diff <- c(ext.ll.sq[3] - ext.ll.sq[1], ext.ll.sq[4] - ext.ll.sq[2]) + x.devi <- ((ax.diff[1] * margin_factor) - ax.diff[1]) + y.devi <- ((ax.diff[2] * margin_factor) - ax.diff[2]) + ext.ll.sq <- st_bbox(c(ext.ll[1] - x.devi, ext.ll[3] + x.devi, ext.ll[2] - y.devi, ext.ll[4] + y.devi), crs = st_crs(4326)) + + if (ext.ll.sq["xmin"] < -180) ext.ll.sq["xmin"] <- -180 + if (ext.ll.sq["xmax"] > 180) ext.ll.sq["xmax"] <- 180 + if (ext.ll.sq["ymin"] < -90) ext.ll.sq["ymin"] <- -90 + if (ext.ll.sq["ymax"] > 90) ext.ll.sq["ymax"] <- 90 } return(st_bbox(.st_transform(st_as_sfc(ext.ll.sq, crs = st_crs(4326)), st_crs(ext)))) } #' generate extent, return as latlon #' @importFrom sf st_as_sf st_transform st_crs st_bbox st_as_sfc st_intersects st_coordinates -#' @noRd -.ext <- function(m.df, m.crs, ext = NULL, margin_factor = 1.1, equidistant = FALSE, cross_dateline = FALSE, return_latlon = FALSE){ +#' @noRd +.ext <- function(m.df, m.crs, ext = NULL, margin_factor = 1.1, equidistant = FALSE, cross_dateline = FALSE, return_latlon = FALSE) { # this works only with EPSG 4326 for cross_dateline stuff. - m.df <- st_as_sf(m.df, coords=c("x", "y"), crs = m.crs, remove = F) + m.df <- st_as_sf(m.df, coords = c("x", "y"), crs = m.crs, remove = F) m.df <- st_transform(m.df, st_crs(4326)) - + ## calcualte ext gg.ext <- st_bbox(m.df) - - if(!is.null(ext)){ + + if (!is.null(ext)) { ext <- st_bbox(st_transform(st_as_sfc(st_bbox(ext, crs = m.crs)), st_crs(4326))) - - if(!quiet(st_intersects(st_as_sfc(ext), st_as_sfc(gg.ext), sparse = F)[1,1])) out("Argument 'ext' does not overlap with the extent of 'm'.", type = 3) + + if (!quiet(st_intersects(st_as_sfc(ext), st_as_sfc(gg.ext), sparse = F)[1, 1])) out("Argument 'ext' does not overlap with the extent of 'm'.", type = 3) gg.ext <- ext margin_factor <- 1 # no margin since user extent set } - - xy.diff <- if(isTRUE(cross_dateline)){ + + xy.diff <- if (isTRUE(cross_dateline)) { xy <- st_coordinates(m.df) - c(abs(abs(max(xy[xy[,1] < 0, 1])) - min(xy[xy[,1] > 0,1])), gg.ext[4]-gg.ext[2])/2 - }else (gg.ext[3:4] - gg.ext[1:2])/2 - + c(abs(abs(max(xy[xy[, 1] < 0, 1])) - min(xy[xy[, 1] > 0, 1])), gg.ext[4] - gg.ext[2]) / 2 + } else { + (gg.ext[3:4] - gg.ext[1:2]) / 2 + } + # squared equidistant extent or not - if(isTRUE(cross_dateline)){ - + if (isTRUE(cross_dateline)) { # split extents for both dateline sides gg.ext <- list("west" = gg.ext, "east" = gg.ext) - + # cut extents and add margins to x components - gg.ext$west[[1]] <- -180 #xmin - gg.ext$west[[3]] <- max(xy[xy[,1] < 0,1]) + xy.diff[1]*(-1+margin_factor) #xmax - gg.ext$east[[1]] <- min(xy[xy[,1] > 0,1]) - xy.diff[1]*(-1+margin_factor) #xmin - gg.ext$east[[3]] <- 180 #xmax - + gg.ext$west[[1]] <- -180 # xmin + gg.ext$west[[3]] <- max(xy[xy[, 1] < 0, 1]) + xy.diff[1] * (-1 + margin_factor) # xmax + gg.ext$east[[1]] <- min(xy[xy[, 1] > 0, 1]) - xy.diff[1] * (-1 + margin_factor) # xmin + gg.ext$east[[3]] <- 180 # xmax + # add margins to y components - gg.ext$west[[2]] <- gg.ext$west[[2]] - xy.diff[2]*(-1+margin_factor) #ymin - gg.ext$west[[4]] <- gg.ext$west[[4]] + xy.diff[2]*(-1+margin_factor) #ymax - gg.ext$east[[2]] <- gg.ext$east[[2]] - xy.diff[2]*(-1+margin_factor) #ymin - gg.ext$east[[4]] <- gg.ext$east[[4]] + xy.diff[2]*(-1+margin_factor) #ymax - - } else{ - + gg.ext$west[[2]] <- gg.ext$west[[2]] - xy.diff[2] * (-1 + margin_factor) # ymin + gg.ext$west[[4]] <- gg.ext$west[[4]] + xy.diff[2] * (-1 + margin_factor) # ymax + gg.ext$east[[2]] <- gg.ext$east[[2]] - xy.diff[2] * (-1 + margin_factor) # ymin + gg.ext$east[[4]] <- gg.ext$east[[4]] + xy.diff[2] * (-1 + margin_factor) # ymax + } else { # equidistant currently not supported for cross_dateline - if(isTRUE(equidistant)){ + if (isTRUE(equidistant)) { gg.ext <- .equidistant(ext = gg.ext, margin_factor = margin_factor) - }else{ - gg.ext <- st_bbox(c(gg.ext[1:2] - (xy.diff*(-1+margin_factor)), gg.ext[3:4] + (xy.diff*(-1+margin_factor))), crs = st_crs(m.df)) + } else { + gg.ext <- st_bbox(c(gg.ext[1:2] - (xy.diff * (-1 + margin_factor)), gg.ext[3:4] + (xy.diff * (-1 + margin_factor))), crs = st_crs(m.df)) } - + # cut by longlat maximums - if(isTRUE(st_crs(m.df) == st_crs(4326))){ - if(gg.ext[1] < -180) gg.ext[1] <- -180 - if(gg.ext[3] > 180) gg.ext[3] <- 180 - if(gg.ext[2] < -90) gg.ext[2] <- -90 - if(gg.ext[4] > 90) gg.ext[4] <- 90 + if (isTRUE(st_crs(m.df) == st_crs(4326))) { + if (gg.ext[1] < -180) gg.ext[1] <- -180 + if (gg.ext[3] > 180) gg.ext[3] <- 180 + if (gg.ext[2] < -90) gg.ext[2] <- -90 + if (gg.ext[4] > 90) gg.ext[4] <- 90 } } - - if(isFALSE(return_latlon)){ + + if (isFALSE(return_latlon)) { transform_ext <- function(y) st_bbox(st_transform(st_as_sfc(y), m.crs)) - if(inherits(gg.ext, "list")){ + if (inherits(gg.ext, "list")) { gg.ext <- lapply(gg.ext, transform_ext) - } else{ + } else { gg.ext <- transform_ext(gg.ext) } } @@ -272,145 +282,140 @@ repl_vals <- function(data, x, y){ } #' calculate x labels from breaks -#' @noRd -.x_labels <- function(x){ +#' @noRd +.x_labels <- function(x) { x.num <- x - + # remove NAs which.na <- is.na(x.num) x.num[is.na(x.num)] <- 0 - + # shift dateline crossings - x.num[x.num < -180] <- x.num[x.num < -180]+360 - x.num[x.num > 180] <- x.num[x.num > 180]-360 - + x.num[x.num < -180] <- x.num[x.num < -180] + 360 + x.num[x.num > 180] <- x.num[x.num > 180] - 360 + x <- as.character(abs(x.num)) x <- paste0('"', x, '"', "*degree") x[which.na] <- "" - + # assign Northing/Southing x[x.num > 0] <- paste0(x[x.num > 0], "*E") x[x.num < 0] <- paste0(x[x.num < 0], "*W") - return(parse(text=x)) + return(parse(text = x)) } #' calculate y labels from breaks -#' @noRd -.y_labels <- function(x){ +#' @noRd +.y_labels <- function(x) { x.num <- x - + # remove NAs which.na <- is.na(x.num) x.num[is.na(x.num)] <- 0 - + x <- as.character(abs(x.num)) x <- paste0('"', x, '"', "*degree") x[which.na] <- "" - + # assign Northing/Southing x[x.num > 0] <- paste0(x[x.num > 0], "*N") x[x.num < 0] <- paste0(x[x.num < 0], "*S") - return(parse(text=x)) + return(parse(text = x)) } #' create paths data.frame for gg on the fly per frame #' @importFrom utils tail -#' @noRd -.df4gg <- function(m.df, i, tail_length = 0, path_size = 1, tail_size = 1, tail_colour = "white", trace_show = F, trace_size = tail_size, trace_colour = "grey", path_fade = F){ - +#' @noRd +.df4gg <- function(m.df, i, tail_length = 0, path_size = 1, tail_size = 1, tail_colour = "white", trace_show = F, trace_size = tail_size, trace_colour = "grey", path_fade = F) { # calc range - i.range <- seq(i-tail_length, i) + i.range <- seq(i - tail_length, i) i.range <- i.range[i.range > 0] - + # extract all rows of frame time range - paths <- m.df[!is.na(match(m.df$frame,i.range)),] - paths <- paths[order(paths$id),] - + paths <- m.df[!is.na(match(m.df$frame, i.range)), ] + paths <- paths[order(paths$id), ] + # compute colour ramp from id count - #paths.colours <- sapply(unique(paths$id), function(x) rev(unique(paths[paths$id == x,]$colour)), simplify = F) - paths.colours <- sapply(unique(paths$id), function(x) paths[paths$id == x,]$colour, simplify = F) + # paths.colours <- sapply(unique(paths$id), function(x) rev(unique(paths[paths$id == x,]$colour)), simplify = F) + paths.colours <- sapply(unique(paths$id), function(x) paths[paths$id == x, ]$colour, simplify = F) paths.count <- as.vector(table(paths$id)) - diff.max <- max(m.df$frame, na.rm = T)-max(i.range) - - paths$tail_colour <- unlist(mapply(paths.cols = paths.colours, paths.size = paths.count, function(paths.cols, paths.size){ - - if(all(isTRUE(path_fade), diff.max < tail_length, paths.size > diff.max)){ - n <- diff.max+1 - v <- rep(tail_colour, (paths.size-(n))) + diff.max <- max(m.df$frame, na.rm = T) - max(i.range) + + paths$tail_colour <- unlist(mapply(paths.cols = paths.colours, paths.size = paths.count, function(paths.cols, paths.size) { + if (all(isTRUE(path_fade), diff.max < tail_length, paths.size > diff.max)) { + n <- diff.max + 1 + v <- rep(tail_colour, (paths.size - (n))) paths.cols <- utils::tail(paths.cols, n = n) - } else{ + } else { n <- paths.size v <- NULL } - - paths.ramps <- lapply(unique(paths.cols), function(x){ + + paths.ramps <- lapply(unique(paths.cols), function(x) { f <- grDevices::colorRampPalette(c(x, tail_colour)) - rev(f(n+4)[1:n]) + rev(f(n + 4)[1:n]) }) - - c(v, mapply(i = 1:n, i.ramp = repl_vals(paths.cols, unique(paths.cols), 1:length(unique(paths.cols))), function(i, i.ramp){ + + c(v, mapply(i = 1:n, i.ramp = repl_vals(paths.cols, unique(paths.cols), 1:length(unique(paths.cols))), function(i, i.ramp) { paths.ramps[[i.ramp]][i] }, USE.NAMES = F)) - }, SIMPLIFY = F)) - + # compute tail size from id count - paths$tail_size <- unlist(lapply(paths.count, function(paths.size){ - - if(all(isTRUE(path_fade), diff.max < tail_length, paths.size > diff.max)){ - n <- diff.max+1 - v <- rep(tail_size, (paths.size-(n))) - } else{ + paths$tail_size <- unlist(lapply(paths.count, function(paths.size) { + if (all(isTRUE(path_fade), diff.max < tail_length, paths.size > diff.max)) { + n <- diff.max + 1 + v <- rep(tail_size, (paths.size - (n))) + } else { n <- paths.size v <- NULL } c(v, seq(tail_size, path_size, length.out = n)) })) - + paths$trace <- FALSE - if(all(isTRUE(trace_show))){ # & i > tail_size)){ # isn't rather path_length meant here? - - paths.trace <- m.df[!is.na(match(m.df$frame,1:(min(i.range)))),] + if (all(isTRUE(trace_show))) { # & i > tail_size)){ # isn't rather path_length meant here? + + paths.trace <- m.df[!is.na(match(m.df$frame, 1:(min(i.range)))), ] paths.trace$colour <- paths.trace$tail_colour <- trace_colour paths.trace$tail_size <- trace_size paths.trace$trace <- TRUE - + # join trace, reorder by frame and group by id paths <- rbind(paths, paths.trace) - paths <- paths[order(paths$frame),] - paths <- paths[order(paths$id),] + paths <- paths[order(paths$frame), ] + paths <- paths[order(paths$id), ] } return(paths) } #' detect time gaps -#' @noRd -.time_conform <- function(m){ - - m.indi <- if(inherits(m, "MoveStack")) move::split(m) else list(m) +#' @noRd +.time_conform <- function(m) { + m.indi <- if (inherits(m, "MoveStack")) move::split(m) else list(m) ts <- .lapply(m.indi, timestamps, moveVis.verbose = F) tl <- .lapply(m.indi, timeLag, unit = "secs", moveVis.verbose = F) - + ## check time lag uni.lag <- length(unique(unlist(tl))) <= 1 - if(!isTRUE(uni.lag)) out("The temporal resolution of 'm' is diverging. Use align_move() to align movement data to a uniform time scale with a consistent temporal resolution.", type = 3) - + if (!isTRUE(uni.lag)) out("The temporal resolution of 'm' is diverging. Use align_move() to align movement data to a uniform time scale with a consistent temporal resolution.", type = 3) + ## check temporal consistence per individual (consider to remove, if NA timestamps should be allowed) uni.intra <- mapply(x = tl, y = ts, function(x, y) length(c(min(y, na.rm = T), min(y, na.rm = T) + cumsum(x))) == length(y)) - if(!all(uni.intra)) out("For at least one movement track, variating time lags have been detected. Use align_move() to align movement data to a uniform time scale with a consistent temporal resolution.", type = 3) - + if (!all(uni.intra)) out("For at least one movement track, variating time lags have been detected. Use align_move() to align movement data to a uniform time scale with a consistent temporal resolution.", type = 3) + ## check overall consistence of timestamps ts.art <- seq.POSIXt(min(do.call(c, ts), na.rm = T), max(do.call(c, ts), na.rm = T), by = unique(unlist(tl))) uni.all <- all(sapply(unique(timestamps(m)), function(x, ta = ts.art) x %in% ta)) - if(!isTRUE(uni.all)) out("For at least one movement track, timestamps diverging from those of the other tracks have been detected. Use align_move() to align movement data to a uniform time scale with a consistent temporal resolution.", type = 3) - - ## snippet:: - # ts.origin <- as.POSIXct(0, origin = min(ts), tz = tz(ls)) + if (!isTRUE(uni.all)) out("For at least one movement track, timestamps diverging from those of the other tracks have been detected. Use align_move() to align movement data to a uniform time scale with a consistent temporal resolution.", type = 3) + + ## snippet:: + # ts.origin <- as.POSIXct(0, origin = min(ts), tz = tz(ls)) # set.fun <- list("secs" = function(x) `second<-`(x, 0), "mins" = function(x) `minute<-`(x, 0), # "hours" = function(x) `hour<-`(x, 0), "days" = function(x) `day<-`(x, 1)) # ts.origin <- lapply(names(set.fun), function(x, fun = set.fun, to = ts.origin) magrittr::freduce(to, fun[!(x == names(fun))])) - + ## former:: # ts.digits <- lapply(c("secs", "mins", "hours", "days"), function(x, ts = timestamps(m)){ # sort(unique(as.numeric(format(unique(ts), .convert_units(x))))) @@ -423,72 +428,74 @@ repl_vals <- function(data, x, y){ #' @importFrom raster clusterR overlay brick unstack stack #' @importFrom utils tail head #' @noRd -.int2frames <- function(r_list, pos, frames, n.rlay, cl){ - +.int2frames <- function(r_list, pos, frames, n.rlay, cl) { # get frames outside shoulders not to be interpolated r.frames <- rep(list(NULL), length(frames)) names(r.frames) <- frames - early <- as.numeric(names(r.frames)) < utils::head(pos, n=1) - if(any(early)) r.frames[early] <- utils::head(r_list, n=1) - - late <- as.numeric(names(r.frames)) > utils::tail(pos, n=1) - if(any(late)) r.frames[late] <- utils::tail(r_list, n=1) - + early <- as.numeric(names(r.frames)) < utils::head(pos, n = 1) + if (any(early)) r.frames[early] <- utils::head(r_list, n = 1) + + late <- as.numeric(names(r.frames)) > utils::tail(pos, n = 1) + if (any(late)) r.frames[late] <- utils::tail(r_list, n = 1) + exist <- match(as.numeric(names(r.frames)), pos) - if(any(!is.na(exist))){ + if (any(!is.na(exist))) { r.frames[!is.na(exist)] <- r_list[stats::na.omit(exist)] } - + # collect remaining frame ids i.frames <- as.numeric(names(r.frames)[sapply(r.frames, is.null)]) - + # between which elements - i.frames <- lapply(2:length(pos), function(i){ - y <- i.frames > pos[i-1] & i.frames < pos[i] - if(any(y)) return(i.frames[which(y)]) + i.frames <- lapply(2:length(pos), function(i) { + y <- i.frames > pos[i - 1] & i.frames < pos[i] + if (any(y)) { + return(i.frames[which(y)]) + } }) - i.rasters <- which(!sapply(i.frames, is.null))+1 - i.frames <- i.frames[i.rasters-1] - + i.rasters <- which(!sapply(i.frames, is.null)) + 1 + i.frames <- i.frames[i.rasters - 1] + # interpolation function v.fun <- function(v.x, v.y, ...) t(mapply(xx = v.x, yy = v.y, FUN = function(xx, yy, ...) .na.approx(c(xx, v.na, yy))[pos.frames], SIMPLIFY = T)) - #v.fun <- function(v.x, v.y, ...) t(mapply(xx = v.x, yy = v.y, FUN = function(xx, yy, ...) zoo::na.approx(c(xx, v.na, yy), rule = 2)[pos.frames], SIMPLIFY = T)) - #v.fun <- function(v.x, v.y) mapply(xx = v.x, yy = v.y, FUN = function(xx, yy, xx.pos = x.pos, yy.pos = y.pos, xy.frame = frame) zoo::na.approx(c(xx, rep(NA, (yy.pos-xx.pos)-1), yy))[(xy.frame-xx.pos)+1], SIMPLIFY = T) - #v.fun <- Vectorize(function(x, y, ...) zoo::na.approx(c(x, v.na, y), rule = 2)[pos.frame]) - + # v.fun <- function(v.x, v.y, ...) t(mapply(xx = v.x, yy = v.y, FUN = function(xx, yy, ...) zoo::na.approx(c(xx, v.na, yy), rule = 2)[pos.frames], SIMPLIFY = T)) + # v.fun <- function(v.x, v.y) mapply(xx = v.x, yy = v.y, FUN = function(xx, yy, xx.pos = x.pos, yy.pos = y.pos, xy.frame = frame) zoo::na.approx(c(xx, rep(NA, (yy.pos-xx.pos)-1), yy))[(xy.frame-xx.pos)+1], SIMPLIFY = T) + # v.fun <- Vectorize(function(x, y, ...) zoo::na.approx(c(x, v.na, y), rule = 2)[pos.frame]) + # iterate over shoulder ranges - for(i in i.rasters){ - + for (i in i.rasters) { # rasters - if(n.rlay > 1){ - x <- unstack(r_list[[i-1]]) + if (n.rlay > 1) { + x <- unstack(r_list[[i - 1]]) y <- unstack(r_list[[i]]) - } else{ - x <- r_list[i-1] # keep listed using [ instead of [[ to work with lapply + } else { + x <- r_list[i - 1] # keep listed using [ instead of [[ to work with lapply y <- r_list[i] } - + # positions - x.pos <- pos[i-1] + x.pos <- pos[i - 1] y.pos <- pos[i] - v.na <- rep(NA, (y.pos-x.pos)-1) - pos.frames <- (i.frames[[which(i.rasters == i)]]-x.pos)+1 - if(getOption("moveVis.n_cores") > 1) parallel::clusterExport(cl, c("v.na", "pos.frames"), envir = environment()) - + v.na <- rep(NA, (y.pos - x.pos) - 1) + pos.frames <- (i.frames[[which(i.rasters == i)]] - x.pos) + 1 + if (getOption("moveVis.n_cores") > 1) parallel::clusterExport(cl, c("v.na", "pos.frames"), envir = environment()) + # interpolate layer-wise - r <- lapply(1:length(x), function(i.layer){ - if(getOption("moveVis.n_cores") > 1){ + r <- lapply(1:length(x), function(i.layer) { + if (getOption("moveVis.n_cores") > 1) { clusterR(stack(x[[i.layer]], y[[i.layer]]), fun = overlay, args = list("fun" = v.fun), cl = cl) # export = c("pos.frames", "v.na")) - }else overlay(stack(x[[i.layer]], y[[i.layer]]), fun = v.fun) + } else { + overlay(stack(x[[i.layer]], y[[i.layer]]), fun = v.fun) + } }) - + # disassemble brick time- and layerwise - if(length(r) > 1){ - for(j in 1:length(i.frames[[which(i.rasters == i)]])){ + if (length(r) > 1) { + for (j in 1:length(i.frames[[which(i.rasters == i)]])) { r.frames[[match(i.frames[[which(i.rasters == i)]], frames)[j]]] <- brick(lapply(1:n.rlay, function(lay) r[[lay]][[j]])) } - } else{ - r.frames[match(i.frames[[which(i.rasters == i)]], frames)] <- if(inherits(r[[1]], "RasterLayer")) r else unstack(r[[1]]) + } else { + r.frames[match(i.frames[[which(i.rasters == i)]], frames)] <- if (inherits(r[[1]], "RasterLayer")) r else unstack(r[[1]]) } } return(r.frames) @@ -498,128 +505,146 @@ repl_vals <- function(data, x, y){ #' assign raster to frames #' @importFrom raster nlayers crop extent brick writeRaster dataType #' @noRd -.rFrames <- function(r_list, r_times, m.df, gg.ext, fade_raster = T, crop_raster = T, ...){ - - if(!is.list(r_list)){ +.rFrames <- function(r_list, r_times, m.df, gg.ext, fade_raster = T, crop_raster = T, ...) { + if (!is.list(r_list)) { r_list <- list(r_list) n <- 1 - } else n <- length(r_list) + } else { + n <- length(r_list) + } n.rlay <- nlayers(r_list[[1]]) - - #if(n.rlay > 1) r_list <- lapply(1:n.rlay, function(i) lapply(r_list, "[[", i)) else r_list <- list(r_list) #FRIDAY - - if(isTRUE(crop_raster)){ + + # if(n.rlay > 1) r_list <- lapply(1:n.rlay, function(i) lapply(r_list, "[[", i)) else r_list <- list(r_list) #FRIDAY + + if (isTRUE(crop_raster)) { r_list <- lapply(r_list, terra::crop, y = extent(gg.ext[1], gg.ext[3], gg.ext[2], gg.ext[4]), snap = "out") } - - if(n > 1){ - + + if (n > 1) { ## calcualte time differences to r_times - x <- lapply(1:max(m.df$frame), function(y) max(unique(m.df[m.df$frame == y,]$time))) + x <- lapply(1:max(m.df$frame), function(y) max(unique(m.df[m.df$frame == y, ]$time))) frame_times <- unlist(x) attributes(frame_times) <- attributes(x[[1]]) diff.df <- as.data.frame(sapply(r_times, function(x) abs(difftime(frame_times, x, units = "secs")))) - + ## assign r_list positions per frame times pos.df <- data.frame(frame = 1:nrow(diff.df), pos_r = apply(diff.df, MARGIN = 1, which.min)) - + ## interpolate/extrapolate - if(isTRUE(fade_raster)){ - pos.df <- pos.df[apply(diff.df[,unique(pos.df[,2])], MARGIN = 2, which.min),] - + if (isTRUE(fade_raster)) { + pos.df <- pos.df[apply(diff.df[, unique(pos.df[, 2])], MARGIN = 2, which.min), ] + # start cluster and interpolate over all frames or badge-wise - if(getOption("moveVis.n_cores") > 1) cl <- parallel::makeCluster(getOption("moveVis.n_cores")) - if(isFALSE(getOption("moveVis.frames_to_disk"))){ + if (getOption("moveVis.n_cores") > 1) cl <- parallel::makeCluster(getOption("moveVis.n_cores")) + if (isFALSE(getOption("moveVis.frames_to_disk"))) { r_list <- .int2frames(r_list, pos = pos.df$frame, frames = unique(m.df$frame), n.rlay = n.rlay, cl = cl) - } else{ - + } else { # create frames badge-wise? - badges <- unique(c(unlist(sapply(2:length(pos.df$frame), function(i){ - c(seq(if(i == 2) 1 else pos.df$frame[i-1], pos.df$frame[i], - by = if(is.null(getOption("moveVis.n_memory_frames"))) length(unique(m.df$frame)) else getOption("moveVis.n_memory_frames")), - pos.df$frame[i]) + badges <- unique(c(unlist(sapply(2:length(pos.df$frame), function(i) { + c( + seq(if (i == 2) 1 else pos.df$frame[i - 1], pos.df$frame[i], + by = if (is.null(getOption("moveVis.n_memory_frames"))) length(unique(m.df$frame)) else getOption("moveVis.n_memory_frames") + ), + pos.df$frame[i] + ) }, simplify = F)), max(m.df$frame))) - + # write to drive instead of memory - files <- unlist(sapply(2:length(badges), function(i){ - frames <- if(i == 2) (badges[i-1]):badges[i] else (badges[i-1]+1):badges[i] + files <- unlist(sapply(2:length(badges), function(i) { + frames <- if (i == 2) (badges[i - 1]):badges[i] else (badges[i - 1] + 1):badges[i] r <- .int2frames(r_list, pos = pos.df$frame, frames = frames, n.rlay = n.rlay, cl = cl) y <- paste0(getOption("moveVis.dir_frames"), "/moveVis_frame_", frames, ".tif") catch <- sapply(1:length(r), function(j) quiet(writeRaster(r[[j]], filename = y[[j]], datatype = dataType(r_list[[1]]), overwrite = T))) return(y) }, simplify = F, USE.NAMES = F)) - + # link to files r_list <- lapply(files, brick) } - if(getOption("moveVis.n_cores") > 1) parallel::stopCluster(cl) - }else{ + if (getOption("moveVis.n_cores") > 1) parallel::stopCluster(cl) + } else { r_list <- r_list[pos.df$pos_r] } - }else{r_list <- r_list} + } else { + r_list <- r_list + } return(r_list) } #' frame plotting function -#' @importFrom ggplot2 geom_path aes_string theme scale_colour_manual theme_bw guides guide_legend geom_point +#' @importFrom ggplot2 geom_path aes_string theme scale_colour_manual theme_bw guides guide_legend geom_point #' @noRd -gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, path_arrow, path_alpha, path_legend, path_legend_title, path_size, equidistant, tail_length){ - +gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, path_arrow, path_alpha, path_legend, path_legend_title, path_size, equidistant, tail_length) { ## scale plot to extent and set na.rm to TRUE to avoid warnings y$layers[[1]]$geom_params$na.rm <- T - - x_path <- x[!x$trace,] - x_trace <- x[x$trace,] - + + x_path <- x[!x$trace, ] + x_trace <- x[x$trace, ] + ## trace plot - if(nrow(x_trace) > 1){ - p <- y + geom_path(data = x_trace, aes_string(x = "x", y = "y", group = "id"), size = x_trace$tail_size, lineend = path_end, linejoin = path_join, - linemitre = path_mitre, arrow = path_arrow, colour = x_trace$tail_colour, alpha = path_alpha, na.rm = T) - } else p <- y - + if (nrow(x_trace) > 1) { + p <- y + geom_path( + data = x_trace, aes_string(x = "x", y = "y", group = "id"), size = x_trace$tail_size, lineend = path_end, linejoin = path_join, + linemitre = path_mitre, arrow = path_arrow, colour = x_trace$tail_colour, alpha = path_alpha, na.rm = T + ) + } else { + p <- y + } + ## base plot - if(tail_length == 0){ - p <- p + geom_point(data = x_path, aes_string(x = "x", y = "y", group = "id"), size = x_path$tail_size, - colour = x_path$tail_colour, alpha = path_alpha, na.rm = T) - }else{ - p <- p + geom_path(data = x_path, aes_string(x = "x", y = "y", group = "id"), size = x_path$tail_size, lineend = path_end, linejoin = path_join, - linemitre = path_mitre, arrow = path_arrow, colour = x_path$tail_colour, alpha = path_alpha, na.rm = T) + if (tail_length == 0) { + p <- p + geom_point( + data = x_path, aes_string(x = "x", y = "y", group = "id"), size = x_path$tail_size, + colour = x_path$tail_colour, alpha = path_alpha, na.rm = T + ) + } else { + p <- p + geom_path( + data = x_path, aes_string(x = "x", y = "y", group = "id"), size = x_path$tail_size, lineend = path_end, linejoin = path_join, + linemitre = path_mitre, arrow = path_arrow, colour = x_path$tail_colour, alpha = path_alpha, na.rm = T + ) } - p <- p+ theme_bw() + x$coord[[1]] + x$scalex[[1]] + x$scaley[[1]] - + p <- p + theme_bw() + x$coord[[1]] + x$scalex[[1]] + x$scaley[[1]] + ## add legend? - if(isTRUE(path_legend)){ - l.df <- cbind.data.frame(x = x[1,]$x, y = x[1,]$y, name = levels(m_names), - colour = as.character(m_colour[sapply(as.character(unique(m_names)), function(x) match(x, m_names)[1] )]), stringsAsFactors = F) + if (isTRUE(path_legend)) { + l.df <- cbind.data.frame( + x = x[1, ]$x, y = x[1, ]$y, name = levels(m_names), + colour = as.character(m_colour[sapply(as.character(unique(m_names)), function(x) match(x, m_names)[1])]), stringsAsFactors = F + ) l.df$name <- factor(l.df$name, levels = l.df$name) l.df <- rbind(l.df, l.df) - + p <- p + geom_path(data = l.df, aes_string(x = "x", y = "y", colour = "name", linetype = NA), size = path_size, na.rm = TRUE) + scale_colour_manual(values = as.character(l.df$colour), name = path_legend_title) + guides(color = guide_legend(order = 1)) - } - - if(isTRUE(equidistant)) p <- p + theme(aspect.ratio = 1) + } + + if (isTRUE(equidistant)) p <- p + theme(aspect.ratio = 1) return(p) } #' flow stats plot function #' @importFrom ggplot2 ggplot geom_path aes_string theme scale_fill_identity scale_y_continuous scale_x_continuous scale_colour_manual theme_bw coord_cartesian geom_bar -#' +#' #' @noRd -.gg_flow <- function(x, y, path_legend, path_legend_title, path_size, val_seq){ - +.gg_flow <- function(x, y, path_legend, path_legend_title, path_size, val_seq) { ## generate base plot - p <- ggplot(x, aes_string(x = "frame", y = "value")) + geom_path(aes_string(group = "id"), size = path_size, show.legend = F, colour = x$colour) + + p <- ggplot(x, aes_string(x = "frame", y = "value")) + + geom_path(aes_string(group = "id"), size = path_size, show.legend = F, colour = x$colour) + coord_cartesian(xlim = c(0, max(y$frame, na.rm = T)), ylim = c(min(val_seq, na.rm = T), max(val_seq, na.rm = T))) + - theme_bw() + theme(aspect.ratio = 1) + scale_y_continuous(expand = c(0,0), breaks = val_seq) + scale_x_continuous(expand = c(0,0)) - + theme_bw() + + theme(aspect.ratio = 1) + + scale_y_continuous(expand = c(0, 0), breaks = val_seq) + + scale_x_continuous(expand = c(0, 0)) + ## add legend - if(isTRUE(path_legend)){ - l.df <- cbind.data.frame(frame = x[1,]$frame, value = x[1,]$value, name = levels(y$name), - colour = as.character(y$colour[sapply(as.character(unique(y$name)), function(x) match(x, y$name)[1] )]), stringsAsFactors = F) + if (isTRUE(path_legend)) { + l.df <- cbind.data.frame( + frame = x[1, ]$frame, value = x[1, ]$value, name = levels(y$name), + colour = as.character(y$colour[sapply(as.character(unique(y$name)), function(x) match(x, y$name)[1])]), stringsAsFactors = F + ) l.df$name <- factor(l.df$name, levels = l.df$name) l.df <- rbind(l.df, l.df) p <- p + geom_path(data = l.df, aes_string(x = "frame", y = "value", colour = "name", linetype = NA), size = path_size, na.rm = TRUE) + scale_colour_manual(values = as.character(l.df$colour), name = path_legend_title) - } + } return(p) } @@ -628,19 +653,27 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, #' @importFrom ggplot2 ggplot geom_path aes_string theme scale_fill_identity scale_y_continuous scale_x_continuous scale_colour_manual theme_bw coord_cartesian geom_bar #' @noRd ## stats plot function -.gg_hist <- function(x, y, path_legend, path_legend_title, path_size, val_seq, r_type){ - +.gg_hist <- function(x, y, path_legend, path_legend_title, path_size, val_seq, r_type) { ## generate base plot - if(r_type == "gradient") p <- ggplot(x, aes_string(x = "value", y = "count")) + geom_path(aes_string(group = "name"), size = path_size, show.legend = F, colour = x$colour) - if(r_type == "discrete") p <- ggplot(x, aes_string(x = "value", y = "count", fill = "colour")) + geom_bar(stat = "identity", position = "dodge") + scale_fill_identity() - + if (r_type == "gradient") { + p <- ggplot(x, aes_string(x = "value", y = "count")) + + geom_path(aes_string(group = "name"), size = path_size, show.legend = F, colour = x$colour) + } + if (r_type == "discrete") { + p <- ggplot(x, aes_string(x = "value", y = "count", fill = "colour")) + + geom_bar(stat = "identity", position = "dodge") + + scale_fill_identity() + } + p <- p + coord_cartesian(xlim = c(min(val_seq, na.rm = T), max(val_seq, na.rm = T)), ylim = c(min(y$count, na.rm = T), max(y$count, na.rm = T))) + - theme_bw() + theme(aspect.ratio = 1) + scale_y_continuous(expand = c(0,0)) + scale_x_continuous(expand = c(0,0), breaks = val_seq) - + theme_bw() + theme(aspect.ratio = 1) + scale_y_continuous(expand = c(0, 0)) + scale_x_continuous(expand = c(0, 0), breaks = val_seq) + ## add legend - if(isTRUE(path_legend)){ - l.df <- cbind.data.frame(value = x[1,]$value, count = x[1,]$count, name = levels(y$name), - colour = as.character(y$colour[sapply(as.character(unique(y$name)), function(x) match(x, y$name)[1] )]), stringsAsFactors = F) + if (isTRUE(path_legend)) { + l.df <- cbind.data.frame( + value = x[1, ]$value, count = x[1, ]$count, name = levels(y$name), + colour = as.character(y$colour[sapply(as.character(unique(y$name)), function(x) match(x, y$name)[1])]), stringsAsFactors = F + ) l.df$name <- factor(l.df$name, levels = l.df$name) l.df <- rbind(l.df, l.df) p <- p + geom_path(data = l.df, aes_string(x = "value", y = "count", colour = "name", linetype = NA), size = path_size, na.rm = TRUE) + scale_colour_manual(values = as.character(l.df$colour), name = path_legend_title) @@ -650,7 +683,7 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, #' package attatching -#' @noRd +#' @noRd .onAttach <- function(...) { messages <- c( "Do you need help with moveVis? Have a look at the docs on our web page: http://movevis.org/", @@ -661,21 +694,21 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, "Read our accompanying open-access paper published in 'Methods in Ecology and Evolution': https://doi.org/10.1111/2041-210X.13374" ) packageStartupMessage(paste(strwrap(sample(messages, 1)), collapse = "\n")) - } +} #' package startup #' @importFrom pbapply pboptions -#' @noRd -.onLoad <- function(libname, pkgname){ +#' @noRd +.onLoad <- function(libname, pkgname) { catch <- try(lwgeom::lwgeom_extSoftVersion()) # lwgeom is needed for st_distance, but no import of sf. # Importing an lwgeom function here to avoid NOTE on missing imports - - pbapply::pboptions(type = "timer", char = "=", txt.width = getOption("width")-30) # can be changed to "none" - if(is.null(getOption("moveVis.verbose"))) options(moveVis.verbose = FALSE) - if(is.null(getOption("moveVis.n_cores"))) options(moveVis.n_cores = 1) - if(is.null(getOption("moveVis.frames_to_disk"))) options(moveVis.frames_to_disk = FALSE) - if(is.null(getOption("moveVis.dir_frames"))){ + + pbapply::pboptions(type = "timer", char = "=", txt.width = getOption("width") - 30) # can be changed to "none" + if (is.null(getOption("moveVis.verbose"))) options(moveVis.verbose = FALSE) + if (is.null(getOption("moveVis.n_cores"))) options(moveVis.n_cores = 1) + if (is.null(getOption("moveVis.frames_to_disk"))) options(moveVis.frames_to_disk = FALSE) + if (is.null(getOption("moveVis.dir_frames"))) { options(moveVis.dir_frames = paste0(tempdir(), "/moveVis")) - if(!dir.exists(getOption("moveVis.dir_frames"))) dir.create(getOption("moveVis.dir_frames")) + if (!dir.exists(getOption("moveVis.dir_frames"))) dir.create(getOption("moveVis.dir_frames")) } } diff --git a/R/join_frames.R b/R/join_frames.R index 0ccc609..517871b 100644 --- a/R/join_frames.R +++ b/R/join_frames.R @@ -1,73 +1,79 @@ #' Side-by-side join multiple frames -#' +#' #' This function side-by-side joins two or more \code{moveVis} frame objects of equal lengths into a single plot per frame using \code{\link{plot_grid}}. This is useful if you want to side-by-side combine spatial frames returned by \code{\link{frames_spatial}} with graph frames returned by \code{\link{frames_graph}}. -#' +#' #' @inheritParams frames_spatial #' @param frames_lists list, a list of two or more \code{moveVis} frame objects that you want to combine into onw. Must be of equal lengths. Frames are being passed to the \code{plotlist} argument of \code{\link{plot_grid}} and combined frame-by-frame. #' @param ... Further arguments, specifying the appearance of the joined \code{ggplot2} objects, passed to \code{\link{plot_grid}}. See \code{\link{plot_grid}} for further options. #' #' @return A frames object of class \code{moveVis}. -#' +#' #' @examples #' \dontrun{ #' library(moveVis) #' library(move) -#' +#' #' data("move_data", "basemap_data") #' # align movement #' m <- align_move(move_data, res = 4, unit = "mins") -#' +#' #' # create spatial frames and graph frames: #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' -#' frames.sp <- frames_spatial(m, r_list = r_list, r_times = r_times, r_type = "gradient", -#' fade_raster = TRUE) -#' frames.sp <- add_colourscale(frames.sp, type = "gradient", -#' colours = c("orange", "white", "darkgreen"), legend_title = "NDVI") +#' +#' frames.sp <- frames_spatial(m, +#' r_list = r_list, r_times = r_times, r_type = "gradient", +#' fade_raster = TRUE +#' ) +#' frames.sp <- add_colourscale(frames.sp, +#' type = "gradient", +#' colours = c("orange", "white", "darkgreen"), legend_title = "NDVI" +#' ) #' frames.flow <- frames_graph(m, r_list, r_times, path_legend = FALSE, graph_type = "flow") #' frames.hist <- frames_graph(m, r_list, r_times, path_legend = FALSE, graph_type = "hist") -#' +#' #' # check lengths (must be equal) #' sapply(list(frames.sp, frames.flow, frames.hist), length) -#' +#' #' # Let's join the graph frames vertically #' frames.join.gr <- join_frames(list(frames.flow, frames.hist), ncol = 1, nrow = 2) #' frames.join.gr[[100]] -#' +#' #' # Now, let's join the joined graph frames with the spatial frames horizontally #' # in 2:1 ration and align all axis #' frames.join <- join_frames(list(frames.sp, frames.join.gr), -#' ncol = 2, nrow = 1, rel_widths = c(2, 1), axis = "tb") +#' ncol = 2, nrow = 1, rel_widths = c(2, 1), axis = "tb" +#' ) #' frames.join[[100]] #' # in a standard graphics device, this looks a bit unproportional #' # however when setting the correct width, height and resolution of a graphic device, #' # it will come out well aligend. -#' +#' #' # Do so for example with animate_move() with width = 900, dheight = 500 and res = 90 -#' animate_frames(frames.join, out_file = tempfile(fileext = ".gif"), fps = 25, -#' width = 900, height = 500, res = 90, display = TRUE, overwrite = TRUE) +#' animate_frames(frames.join, +#' out_file = tempfile(fileext = ".gif"), fps = 25, +#' width = 900, height = 500, res = 90, display = TRUE, overwrite = TRUE +#' ) #' } #' @seealso \code{\link{frames_spatial}} \code{\link{frames_graph}} \code{\link{animate_frames}} -#' +#' #' @export -join_frames <- function(frames_lists, ..., verbose = T){ - - #frames_lists <- list(...) - +join_frames <- function(frames_lists, ..., verbose = T) { + # frames_lists <- list(...) + ## Check arguments - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(length(unique(sapply(frames_lists, length))) > 1) out("Frames lists provided through argument 'frames_lists' must be of equal lengths for joining their ggplot2 frames.", type = 3) - if(length(frames_lists) <= 1) out("There must be at least 2 frames lists for joining their ggplot2 frames.", type = 3) + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (length(unique(sapply(frames_lists, length))) > 1) out("Frames lists provided through argument 'frames_lists' must be of equal lengths for joining their ggplot2 frames.", type = 3) + if (length(frames_lists) <= 1) out("There must be at least 2 frames lists for joining their ggplot2 frames.", type = 3) - ## create joined frames + ## create joined frames frames <- list( frames_lists = frames_lists, cowplot_args = list(...) ) attr(frames, "class") <- c("moveVis", "frames_joined") - - + + return(frames) -} \ No newline at end of file +} diff --git a/R/methods.R b/R/methods.R index 1e60100..c957645 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1,37 +1,37 @@ #' Print moveVis frames -#' +#' #' Method for printing \code{moveVis} frames. Prints show basic information about the object, including number of frames, extent and more. -#' +#' #' @param x an object of class \code{moveVis}. #' @param ... further arguments passed to or from other methods. -#' -#' @return +#' +#' @return #' Invisible, used for its side effect. -#' +#' #' @rdname print #' @export print.moveVis <- function(x, ...) { - if(inherits(x, "frames_spatial")){ + if (inherits(x, "frames_spatial")) { cat(paste0("Spatial frames of class moveVis\n")) cat(paste0("number of frames: ", as.character(length(x)), "\n")) cat(paste0("temporal extent: ", paste0(x$move_data$time_chr[1], "' to '", x$move_data$time_chr[nrow(x$move_data)]), "\n")) cat(paste0("spatial extent: ", paste0(mapply(x = names(x$aesthetics$gg.ext), y = x$aesthetics$gg.ext, function(x, y) paste0(x, ": ", round(y, digits = 5)), USE.NAMES = F), collapse = "; "), "\n")) cat(paste0("raster type: ", x$aesthetics$r_type, "\n")) - cat(paste0("basemap: ", if(x$aesthetics$map_service != "custom") paste0("'", x$aesthetics$map_type, "' from '", x$aesthetics$map_service, "'") else "custom", "\n")) + cat(paste0("basemap: ", if (x$aesthetics$map_service != "custom") paste0("'", x$aesthetics$map_type, "' from '", x$aesthetics$map_service, "'") else "custom", "\n")) cat(paste0("names: '", paste0(unique(x$move_data$name), collapse = "', '"), "'\n")) - #cat(paste0("added function: ", length(x$additions), "\n")) + # cat(paste0("added function: ", length(x$additions), "\n")) } - - if(inherits(x, "frames_graph")){ + + if (inherits(x, "frames_graph")) { cat(paste0("Graph frames of class moveVis\n")) cat(paste0("number of frames: ", as.character(length(x)), "\n")) cat(paste0("temporal extent: ", paste0(x$move_data$time_chr[1], "' to '", x$move_data$time_chr[nrow(x$move_data)]), "\n")) cat(paste0("raster type: ", x$aesthetics$r_type, "\n")) cat(paste0("names: '", paste0(unique(x$move_data$name), collapse = "', '"), "'\n")) - #cat(paste0("added function: ", length(frames$additions), "\n")) + # cat(paste0("added function: ", length(frames$additions), "\n")) } - - if(inherits(x, "frames_joined")){ + + if (inherits(x, "frames_joined")) { cat(paste0("Joined frames of class moveVis\n")) cat(paste0("number of frames: ", as.character(length(x)), "\n")) cat(paste0("temporal extent: -")) @@ -41,36 +41,36 @@ print.moveVis <- function(x, ...) { } #' Length of moveVis frames -#' +#' #' Method to get length of \code{moveVis} frames, i.e. number of frames. -#' +#' #' @inheritParams print.moveVis -#' -#' @return +#' +#' @return #' Numeric -#' +#' #' @rdname length #' @export -length.moveVis <- function(x){ - if(inherits(x, "frames_joined")){ +length.moveVis <- function(x) { + if (inherits(x, "frames_joined")) { length(x$frames_lists[[1]]) - }else{ + } else { length(unique(x$move_data$frame)) } } #' Combining moveVis frames -#' +#' #' Method for combining multiple \code{moveVis} frames objects. -#' +#' #' @param ... two or more objects of class \code{moveVis}. -#' -#' @return +#' +#' @return #' A list of \code{moveVis} frames objects. -#' +#' #' @rdname c #' @export -c.moveVis <- function(...){ +c.moveVis <- function(...) { frames <- list(...) return(frames) } @@ -80,75 +80,75 @@ c.moveVis <- function(...){ #' @rdname head #' @importFrom utils tail #' @export -tail.moveVis <- function(x, n = 6L, ...){ +tail.moveVis <- function(x, n = 6L, ...) { x[utils::tail(1:length(x), n, ...)] } #' Return first or last frames of an moveVis frames object -#' +#' #' Method for returning \code{n} last or first frames of a \code{moveVis} frames objects. -#' +#' #' @inheritParams print.moveVis #' @param n an integer of length up to \code{length(x)}. -#' -#' @return +#' +#' @return #' A \code{moveVis} frames object. -#' +#' #' @rdname head #' @importFrom utils head #' @export -head.moveVis <- function(x, n = 6L, ...){ +head.moveVis <- function(x, n = 6L, ...) { x[utils::head(1:length(x), n, ...)] } #' Reverse moveVis frames -#' +#' #' Method for reversing the order of frames in a \code{moveVis} frames object. -#' +#' #' @inheritParams print.moveVis -#' -#' @return +#' +#' @return #' A \code{moveVis} frames object. -#' +#' #' @rdname rev #' @export -rev.moveVis <- function(x){ +rev.moveVis <- function(x) { x[rev(1:length(x))] } #' Extract moveVis frames -#' +#' #' Method for extracting individual frames or a sequence of frames from a \code{moveVis} frames object. -#' +#' #' @inheritParams print.moveVis #' @param i numeric, index number or sequence of index numbers of the frame(s) to be extracted. -#' -#' @return +#' +#' @return #' A \code{moveVis} frames object. -#' +#' #' @rdname Extract #' @export "[.moveVis" <- function(x, i, ...) { bounds <- sapply(i, function(j) any(j < 1, j > length(x))) - if(all(bounds)) stop(paste0("Subscript out of bounds. Length of frames is ", length(x), "."), call. = FALSE) - if(any(bounds)) warning(paste0("Subscript extends beyond bounds and is thus truncated. Length of frames is ", length(x), "."), call. = FALSE, immediate. = FALSE) + if (all(bounds)) stop(paste0("Subscript out of bounds. Length of frames is ", length(x), "."), call. = FALSE) + if (any(bounds)) warning(paste0("Subscript extends beyond bounds and is thus truncated. Length of frames is ", length(x), "."), call. = FALSE, immediate. = FALSE) i <- i[!bounds] - + # seubsetting - .sub <- function(x, i){ + .sub <- function(x, i) { sub <- apply(sapply(i, function(j) x$move_data$frame == j), MARGIN = 1, any) - - x$move_data <- x$move_data[sub,] - if(length(x$raster_data) > 1) x$raster_data <- x$raster_data[sub] + + x$move_data <- x$move_data[sub, ] + if (length(x$raster_data) > 1) x$raster_data <- x$raster_data[sub] return(x) } - - if(inherits(x, "frames_joined")){ + + if (inherits(x, "frames_joined")) { x$frames_lists <- lapply(x$frames_lists, function(x) x[i]) - }else{ + } else { x <- .sub(x, i) - } + } return(x) } @@ -157,4 +157,4 @@ rev.moveVis <- function(x){ #' @export "[[.moveVis" <- function(x, i, ...) { quiet(render_frame(x, i)) -} \ No newline at end of file +} diff --git a/R/pkgname.R b/R/pkgname.R index b1c32b4..ddbce0f 100755 --- a/R/pkgname.R +++ b/R/pkgname.R @@ -4,7 +4,7 @@ #' The \code{moveVis} package is closely connected to the \code{move} package and builds up on \code{ggplot2} grammar of graphics. #' #' @details The package includes the following functions, sorted by the order they would be applied to create an animation from movement data: -#' +#' #' \itemize{ #' \item \code{\link{df2move}} converts a \code{data.frame} into a \code{move} or \code{moveStack} object. This is useful if you do not usually work with the \code{move} classes and your tracks are present as \code{data.frames}. #' \item \code{\link{align_move}} aligns single and multi-individual movement data to a uniform time scale with a uniform temporal resolution needed for creating an animation from it. Use this function to prepare your movement data for animation depending on the temporal resolution that suits your data. @@ -26,11 +26,11 @@ #' \item \code{\link{suggest_formats}} returns a selection of suggested file formats that can be used with \code{out_file} of \code{\link{animate_frames}} on your system. #' \item \code{\link{animate_frames}} creates an animation from a list of frames computed with \code{\link{frames_spatial}} or \code{\link{frames_graph}}. #' \item \code{\link{view_spatial}} displays movement tracks on an interactive \code{mapview} or \code{leaflet} map. -#' \item \code{\link{use_multicore}} enables multi-core usage for computational expensive processing steps. +#' \item \code{\link{use_multicore}} enables multi-core usage for computational expensive processing steps. #' \item \code{\link{use_disk}} enables the usage of disk space for creating frames, which can prevent memory overload when creating frames for very large animations. #' } -#' +#' #' The majority of this functions can be used with the forward pipe operater \code{\%>\%}, which is re-exported by \code{moveVis}. -#' +#' #' @author Jakob Schwalb-Willmann. Maintainer: Jakob Schwalb-Willmann, moveVis@schwalb-willmann.de -"_PACKAGE" \ No newline at end of file +"_PACKAGE" diff --git a/R/reexports.R b/R/reexports.R index 068e229..a1fc06c 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -8,4 +8,4 @@ basemaps::get_maptypes #' @importFrom basemaps flush_cache #' @export -basemaps::flush_cache \ No newline at end of file +basemaps::flush_cache diff --git a/R/render_frame.R b/R/render_frame.R index adca49e..9a772e1 100644 --- a/R/render_frame.R +++ b/R/render_frame.R @@ -1,52 +1,50 @@ #' Render an individual frame -#' +#' #' This function renders an individual frame. It yields the same result as if an individual frame is extracted using default subsetting \code{[[]]}. -#' +#' #' @param frames frames as an object of class moveVis. #' @param x frames as an object of class moveVis. #' @param i numeric, index number of the frame to be rendered. #' @param ... additional arguments, currently not used. -#' +#' #' @export -#' +#' #' @importFrom cowplot plot_grid #' @importFrom basemaps gg_raster -#' +#' #' @examples -#' +#' #' library(moveVis) #' library(move) #' data("move_data") #' data("basemap_data") -#' +#' #' r_list <- basemap_data[[1]] #' r_times <- basemap_data[[2]] -#' +#' #' # align #' m <- align_move(m = move_data, res = 4, unit = "mins") -#' +#' #' # create frames #' frames <- frames_spatial(m, r_list = r_list, r_times = r_times, fade_raster = TRUE) -#' +#' #' # viewing frames calling this function: -#' render_frame(frames) # displays the last frame -#' render_frame(frames, i = 100) # displays frame 100 -#' +#' render_frame(frames) # displays the last frame +#' render_frame(frames, i = 100) # displays frame 100 +#' #' \dontrun{ #' # alternatively, you can simply use `[[` to do this: #' frames[[100]] # displays frame 100 -#' #' } -render_frame <- function(frames, i = length(frames)){ - +render_frame <- function(frames, i = length(frames)) { # checking subscript - if(length(i) > 1) out("Subscript must be of length 1.", type = 3) - if(i > length(frames)) out(paste0("Subscript out of bounds. Length of frames is ", length(frames), "."), type = 3) - + if (length(i) > 1) out("Subscript must be of length 1.", type = 3) + if (i > length(frames)) out(paste0("Subscript out of bounds. Length of frames is ", length(frames), "."), type = 3) + # make sure there always is a correct engine selected engine <- "ggplot2" # make this an argument at some point - if(engine == "ggplot2"){ - if(inherits(frames, "frames_spatial")){ + if (engine == "ggplot2") { + if (inherits(frames, "frames_spatial")) { gg <- gg.spatial( x = .df4gg( m.df = frames$move_data, @@ -58,14 +56,16 @@ render_frame <- function(frames, i = length(frames)){ trace_show = frames$aesthetics$trace_show, trace_size = frames$aesthetics$trace_size, trace_colour = frames$aesthetics$trace_colour, - path_fade = frames$aesthetics$path_fade), + path_fade = frames$aesthetics$path_fade + ), y = gg_raster( - r = frames$raster_data[[if(length(frames$raster_data) > 1) i else 1]], + r = frames$raster_data[[if (length(frames$raster_data) > 1) i else 1]], r_type = frames$aesthetics$r_type, maxpixels = frames$aesthetics$maxpixels, alpha = frames$aesthetics$alpha, maxColorValue = frames$aesthetics$maxColorValue, - add_coord = FALSE), + add_coord = FALSE + ), m_names = frames$move_data$name, m_colour = frames$move_data$colour, path_end = frames$aesthetics$path_end, @@ -80,10 +80,10 @@ render_frame <- function(frames, i = length(frames)){ tail_length = frames$aesthetics$tail_length ) } - if(inherits(frames, "frames_graph")){ - if(frames$graph_type == "flow"){ + if (inherits(frames, "frames_graph")) { + if (frames$graph_type == "flow") { gg <- .gg_flow( - x = frames$move_data[frames$move_data$frame <= i,], + x = frames$move_data[frames$move_data$frame <= i, ], y = frames$move_data, path_legend = frames$aesthetics$path_legend, path_legend_title = frames$aesthetics$path_legend_title, @@ -91,7 +91,7 @@ render_frame <- function(frames, i = length(frames)){ val_seq = frames$aesthetics$val_seq ) } - if(frames$graph_type == "hist"){ + if (frames$graph_type == "hist") { gg <- .gg_hist( x = frames$hist_data[[i]], y = do.call(rbind, frames$hist_data), @@ -103,19 +103,19 @@ render_frame <- function(frames, i = length(frames)){ ) } } - if(inherits(frames, "frames_joined")){ + if (inherits(frames, "frames_joined")) { gg <- do.call(cowplot::plot_grid, c( - plotlist = lapply(1:length(frames$frames_lists), function(ii) frames$frames_lists[[ii]][[i]]), - frames$cowplot_args) - ) + plotlist = lapply(1:length(frames$frames_lists), function(ii) frames$frames_lists[[ii]][[i]]), + frames$cowplot_args + )) } - + # any additions? - if(!is.null(frames$additions)){ - for(ix in 1:length(frames$additions)){ + if (!is.null(frames$additions)) { + for (ix in 1:length(frames$additions)) { .x <- frames$additions[[ix]] - if(length(.x[["arg"]]) > 0) for(j in 1:length(.x[["arg"]])) assign(names(.x[["arg"]])[[j]], .x[["arg"]][[j]]) - if(length(.x[["data"]]) > 0) assign("data", .x[["data"]][[i]]) + if (length(.x[["arg"]]) > 0) for (j in 1:length(.x[["arg"]])) assign(names(.x[["arg"]])[[j]], .x[["arg"]][[j]]) + if (length(.x[["data"]]) > 0) assign("data", .x[["data"]][[i]]) gg <- gg + eval(.x[["expr"]][[i]]) } } diff --git a/R/settings.R b/R/settings.R index f609115..5de6890 100644 --- a/R/settings.R +++ b/R/settings.R @@ -1,75 +1,75 @@ #' moveVis settings #' #' These functions control session-wide settings that can increase processing speeds. -#' +#' #' \code{use_multicore} enables multi-core usage of \code{moveVis} by setting the maximum number of cores to be used. This can strongly increase the speed of creating frames. -#' +#' #' \code{use_disk} enables the usage of disk space for creating frames. This can prevent memory overload when creating frames for very large animations. -#' +#' #' @inheritParams frames_spatial #' @param n_cores numeric, optional, number of cores to be used. If not defined, the number of cores will be detected automatically (\code{n-1} cores will be used with \code{n} being the number of cores available). #' @param frames_to_disk logical, whether to use disk space for creating frames or not. If \code{TRUE}, frames will be written to \code{dir_frames}, clearing memory. #' @param dir_frames character, directory where to save frame during frames creating. #' @param n_memory_frames numeric, maximum number of frames allowed to be hold in memory. This number defines after how many frames memory should be cleared by writing frames in memory to disk. -#' +#' #' @return None. These functions are used for their side effects. -#' +#' #' @details For most tasks, \code{moveVis} is able to use multiple cores to increase computational times through parallelization. By default, multi-core usage is disabled. This function saves the number of cores that \code{moveVis} should use to the global option \code{"moveVis.n_cores"} that can be printed using \code{getOption("moveVis.n_cores")}. -#' +#' #' How much memory is needed to create frames depends on the frame resolution (number of pixels) and the number of frames. Depending on how much memory is available it can make sense to allow disk usage and set a maximum number of frames to be hold in memory that won't fill up the available memory completely. -#' +#' #' \code{moveVis} uses the \code{parallel} package for parallelization. -#' -#' -#' @examples +#' +#' +#' @examples #' # enable multi-core usage automatically #' use_multicore() -#' +#' #' # define number of cores manually #' use_multicore(n_cores = 2) -#' +#' #' # allow disk use with default directory #' # and maxiumum of 50 frames in memory #' use_disk(frames_to_disk = TRUE, n_memory_frames = 50) -#' +#' #' @name settings #' @export -use_multicore <- function(n_cores = NULL, verbose = TRUE){ - +use_multicore <- function(n_cores = NULL, verbose = TRUE) { # checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + # cores cores <- parallel::detectCores() - if(is.null(n_cores)) n_cores <- cores-1 - if(n_cores < 1) n_cores <- 1 - if(n_cores > cores) n_cores <- cores - + if (is.null(n_cores)) n_cores <- cores - 1 + if (n_cores < 1) n_cores <- 1 + if (n_cores > cores) n_cores <- cores + # set options(moveVis.n_cores = n_cores) - + # inform out(paste0("Number of cores set to be used by moveVis: ", as.character(getOption("moveVis.n_cores")), " out of ", as.character(cores))) } #' @rdname settings #' @export -use_disk <- function(frames_to_disk = TRUE, dir_frames = paste0(tempdir(), "/moveVis"), n_memory_frames = NULL, verbose = TRUE){ - +use_disk <- function(frames_to_disk = TRUE, dir_frames = paste0(tempdir(), "/moveVis"), n_memory_frames = NULL, verbose = TRUE) { # checks - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(!dir.exists(dir_frames)) dir.create(dir_frames, recursive = T) - if(!is.null(n_memory_frames)) if(n_memory_frames < 3){ - out("Minimum number of frames in memory is 3.", type = 2) - n_memory_frames <- 3 + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (!dir.exists(dir_frames)) dir.create(dir_frames, recursive = T) + if (!is.null(n_memory_frames)) { + if (n_memory_frames < 3) { + out("Minimum number of frames in memory is 3.", type = 2) + n_memory_frames <- 3 + } } - + # options - if(isTRUE(frames_to_disk)){ + if (isTRUE(frames_to_disk)) { options(moveVis.frames_to_disk = TRUE, moveVis.dir_frames = dir_frames, moveVis.n_memory_frames = n_memory_frames) - out(paste0("Disk usage for creating frames enabled.\nDirectory: '", dir_frames, "'\nMaximum number of frames which will be hold in memory: ", if(is.null(n_memory_frames)) "auto." else as.character(n_memory_frames))) - } else{ + out(paste0("Disk usage for creating frames enabled.\nDirectory: '", dir_frames, "'\nMaximum number of frames which will be hold in memory: ", if (is.null(n_memory_frames)) "auto." else as.character(n_memory_frames))) + } else { options(moveVis.frames_to_disk = FALSE, moveVis.dir_frames = NULL, moveVis.n_memory_frames = NULL) out(paste0("Disk usage for creating frames disabled.\nAll frames will be hold in memory.")) } diff --git a/R/subset_move.R b/R/subset_move.R index ab15546..870f0ae 100644 --- a/R/subset_move.R +++ b/R/subset_move.R @@ -8,46 +8,47 @@ #' @param tz character, time zone that should be used if \code{from} and/or \code{to} are of type \code{character}. #' #' @return A \code{move} or \code{moveStack} object. -#' +#' #' @seealso \code{\link{df2move}} -#' +#' #' @importFrom move moveStack move -#' +#' #' @examples #' library(moveVis) #' library(move) -#' +#' #' # load the example data #' data("move_data") -#' +#' #' # check min and max of move_data timestamps #' min(timestamps(move_data)) #' max(timestamps(move_data)) -#' +#' #' # subset by character times #' m <- subset_move(move_data, from = "2018-05-15 07:00:00", to = "2018-05-15 18:00:00") -#' +#' #' # check min and max of result #' min(timestamps(m)) #' max(timestamps(m)) -#' +#' #' @export -subset_move <- function(m, from, to, tz = "UTC"){ - +subset_move <- function(m, from, to, tz = "UTC") { # checks - if(!inherits(from, "POSIXct")) from <- as.POSIXct(from, tz) - if(!inherits(to, "POSIXct")) to <- as.POSIXct(to, tz) - + if (!inherits(from, "POSIXct")) from <- as.POSIXct(from, tz) + if (!inherits(to, "POSIXct")) to <- as.POSIXct(to, tz) + # subset by time ts <- timestamps(m) - if(from < min(ts)) out("Argument 'from' cannot be smaller than the minimum timestamp of m.", type = 3) - if(to > max(ts)) out("Argument 'to' cannot be greater than the maximum timestamp of m.", type = 3) - + if (from < min(ts)) out("Argument 'from' cannot be smaller than the minimum timestamp of m.", type = 3) + if (to > max(ts)) out("Argument 'to' cannot be greater than the maximum timestamp of m.", type = 3) + ts.order <- order(ts) m.df <- methods::as(m, "data.frame") - m.df <- m.df[ts.order[ts[ts.order] >= from & ts[ts.order] <= to],] - - df2move(m.df, proj = crs(m), x = "coords.x1", y = "coords.x2", time = "timestamps", data = m.df, - track_id = if(!is.null(m.df$trackId)) "trackId" else NULL) -} \ No newline at end of file + m.df <- m.df[ts.order[ts[ts.order] >= from & ts[ts.order] <= to], ] + + df2move(m.df, + proj = crs(m), x = "coords.x1", y = "coords.x2", time = "timestamps", data = m.df, + track_id = if (!is.null(m.df$trackId)) "trackId" else NULL + ) +} diff --git a/R/suggest_formats.R b/R/suggest_formats.R index a996379..6b7dccb 100644 --- a/R/suggest_formats.R +++ b/R/suggest_formats.R @@ -3,27 +3,26 @@ #' This function returns a selection of suggested file formats that can be used with \code{out_file} of \code{\link{animate_frames}} on your system. #' #' @param suggested character, a vector of suggested file formats which are checked to be known by the available renderers on the running system. By default, these are \code{c("gif", "mov", "mp4", "flv", "avi", "mpeg", "3gp", "ogg")}. -#' +#' #' #' @return A subset of \code{suggested}, containing only those file formats which are known by the renderers on the running system. -#' +#' #' @seealso \code{\link{animate_frames}} -#' +#' #' @importFrom av av_muxers -#' +#' #' @examples #' # find out which formats are available #' suggest_formats() -#' +#' #' # check for a particular format not listed in "suggested" that you want to use, e.g. m4v #' suggest_formats("m4v") #' # if "m4v" is returned, you can use this format with animate_frames -#' +#' #' @export -suggest_formats <- function(suggested = c("gif", "mov", "mp4", "flv", "avi", "mpeg", "3gp", "ogg")){ - +suggest_formats <- function(suggested = c("gif", "mov", "mp4", "flv", "avi", "mpeg", "3gp", "ogg")) { mux <- as.character(stats::na.omit(av_muxers()$extensions)) mux <- unlist(sapply(mux, function(x) unlist(strsplit(x, ",")), simplify = F, USE.NAMES = F)) return(mux[as.numeric(stats::na.omit(match(suggested, mux)))]) -} \ No newline at end of file +} diff --git a/R/view_spatial.R b/R/view_spatial.R index 11a3370..6a43d3e 100644 --- a/R/view_spatial.R +++ b/R/view_spatial.R @@ -4,80 +4,87 @@ #' #' @inheritParams frames_spatial #' @param m \code{move} or \code{moveStack}. May contain a column named \code{colour} to control path colours (see \code{details}). -#' @param render_as character, either \code{'mapview'} to return a \code{mapview} map or \code{'leaflet'} to return a \code{leaflet} map. +#' @param render_as character, either \code{'mapview'} to return a \code{mapview} map or \code{'leaflet'} to return a \code{leaflet} map. #' @param time_labels logical, wether to display timestamps for each track fix when hovering it with the mouse cursor. #' @param stroke logical, whether to draw stroke around circles. -#' +#' #' @details If argument \code{path_colours} is not defined (set to \code{NA}), path colours can be defined by adding a character column named \code{colour} to \code{m}, containing a colour code or name per row (e.g. \code{"red"}. This way, for example, column \code{colour} for all rows belonging to individual A can be set to \code{"green"}, while column \code{colour} for all rows belonging to individual B can be set to \code{"red"}. #' Colours could also be arranged to change through time or by behavioral segments, geographic locations, age, environmental or health parameters etc. If a column name \code{colour} in \code{m} is missing, colours will be selected automatically. Call \code{colours()} to see all available colours in R. -#' +#' #' @return An interatcive \code{mapview} or \code{leaflet} map. -#' +#' #' @author Jakob Schwalb-Willmann -#' -#' -#' @examples +#' +#' +#' @examples #' \dontrun{ #' library(moveVis) #' library(move) -#' +#' #' data("move_data") -#' +#' #' # return a mapview map (mapview must be installed) #' view_spatial(move_data) -#' +#' #' # return a leaflet map (leaflet must be installed) #' view_spatial(move_data, render_as = "leaflet") -#' +#' #' # turn off time labels and legend #' view_spatial(move_data, time_labels = FALSE, path_legend = FALSE) -#' #' } #' @seealso \code{\link{frames_spatial}} #' @export -view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = TRUE, path_colours = NA, path_legend = TRUE, - path_legend_title = "Names", verbose = TRUE){ - +view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = TRUE, path_colours = NA, path_legend = TRUE, + path_legend_title = "Names", verbose = TRUE) { ## dependency check - if(is.character(render_as)){ - if(!isTRUE(render_as %in% c("mapview", "leaflet"))) out("Argument 'render_as' must be either 'mapview' or 'leaflet'.", type = 3) - } else{out("Argument 'render_as' must be of type 'character'.", type = 3)} + if (is.character(render_as)) { + if (!isTRUE(render_as %in% c("mapview", "leaflet"))) out("Argument 'render_as' must be either 'mapview' or 'leaflet'.", type = 3) + } else { + out("Argument 'render_as' must be of type 'character'.", type = 3) + } ## check input arguments - if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) - if(all(!c(inherits(m, "MoveStack"), inherits(m, "Move")))) out("Argument 'm' must be of class 'Move' or 'MoveStack'.", type = 3) - if(inherits(m, "Move")) m <- moveStack(m) - - if(is.character(path_colours)) if(length(path_colours) != n.indiv(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3) - if(!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3) - if(!is.logical(time_labels)) out("Argument 'time_labels' must be of type 'logical'.", type = 3) - if(!is.character(path_legend_title)) out("Argument 'path_legend_title' must be of type 'character'.", type = 3) - + if (inherits(verbose, "logical")) options(moveVis.verbose = verbose) + if (all(!c(inherits(m, "MoveStack"), inherits(m, "Move")))) out("Argument 'm' must be of class 'Move' or 'MoveStack'.", type = 3) + if (inherits(m, "Move")) m <- moveStack(m) + + if (is.character(path_colours)) if (length(path_colours) != n.indiv(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3) + if (!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3) + if (!is.logical(time_labels)) out("Argument 'time_labels' must be of type 'logical'.", type = 3) + if (!is.character(path_legend_title)) out("Argument 'path_legend_title' must be of type 'character'.", type = 3) + ## preprocess movement data m.df <- .m2df(m, path_colours = path_colours) # create data.frame from m with frame time and colour m.df$frame <- m.df$time <- NULL - + ## render as mapview object - if(render_as == "mapview"){ - if(length(grep("mapview", rownames(utils::installed.packages()))) == 0) out("'mapview' has to be installed to use this function. Use install.packages('mapview').", type = 3) - map <- mapview::mapview(m.df, map.types = "OpenStreetMap", xcol = "x", ycol = "y", zcol = "name", legend = path_legend, - crs = st_crs(m)$proj4string, grid = F, layer.name = path_legend_title, col.regions = unique(m.df$colour), - label = if(isTRUE(time_labels)) m.df$time_chr else NULL, stroke = stroke) + if (render_as == "mapview") { + if (length(grep("mapview", rownames(utils::installed.packages()))) == 0) out("'mapview' has to be installed to use this function. Use install.packages('mapview').", type = 3) + map <- mapview::mapview(m.df, + map.types = "OpenStreetMap", xcol = "x", ycol = "y", zcol = "name", legend = path_legend, + crs = st_crs(m)$proj4string, grid = F, layer.name = path_legend_title, col.regions = unique(m.df$colour), + label = if (isTRUE(time_labels)) m.df$time_chr else NULL, stroke = stroke + ) } - + ## render as leaflet object - if(render_as == "leaflet"){ - if(length(grep("leaflet", rownames(utils::installed.packages()))) == 0) out("'leaflet' has to be installed to use this function. Use install.packages('leaflet').", type = 3) - + if (render_as == "leaflet") { + if (length(grep("leaflet", rownames(utils::installed.packages()))) == 0) out("'leaflet' has to be installed to use this function. Use install.packages('leaflet').", type = 3) + m.split <- split(m.df, m.df$name) map <- leaflet::addTiles(map = leaflet::leaflet(m.df)) - for(i in 1:length(m.split)) map <- leaflet::addCircleMarkers(map = map, lng = m.split[[i]]$x, lat = m.split[[i]]$y, - radius = 5.5, color = "black", stroke = stroke, fillColor = m.split[[i]]$colour, fillOpacity = 0.6, weight = 2, opacity = 1, - label = if(isTRUE(time_labels)) m.split[[i]]$time_chr else NULL) - map <- leaflet::addScaleBar(map = leaflet::addLegend(map = map, colors = unique(m.df$colour), - labels = unique(m.df$name), opacity = 1, title = path_legend_title), position = "bottomleft") - + for (i in 1:length(m.split)) { + map <- leaflet::addCircleMarkers( + map = map, lng = m.split[[i]]$x, lat = m.split[[i]]$y, + radius = 5.5, color = "black", stroke = stroke, fillColor = m.split[[i]]$colour, fillOpacity = 0.6, weight = 2, opacity = 1, + label = if (isTRUE(time_labels)) m.split[[i]]$time_chr else NULL + ) + } + map <- leaflet::addScaleBar(map = leaflet::addLegend( + map = map, colors = unique(m.df$colour), + labels = unique(m.df$name), opacity = 1, title = path_legend_title + ), position = "bottomleft") } return(map) -} \ No newline at end of file +} diff --git a/tests/testthat/helper-vars.R b/tests/testthat/helper-vars.R index 2904397..a1c318a 100644 --- a/tests/testthat/helper-vars.R +++ b/tests/testthat/helper-vars.R @@ -1,9 +1,9 @@ ## env vars n_cores <- as.numeric(Sys.getenv("moveVis_n_cores")) -if(!is.na(n_cores)) if(n_cores > 1) use_multicore(n_cores) +if (!is.na(n_cores)) if (n_cores > 1) use_multicore(n_cores) -check_mapview <- any(grepl("mapview", installed.packages()[,1])) -check_leaflet <- any(grepl("leaflet", installed.packages()[,1])) +check_mapview <- any(grepl("mapview", installed.packages()[, 1])) +check_leaflet <- any(grepl("leaflet", installed.packages()[, 1])) ## which tests to run @@ -16,9 +16,9 @@ check_leaflet <- any(grepl("leaflet", installed.packages()[,1])) ## directories test_dir <- Sys.getenv("moveVis_test_dir") -if(test_dir != ""){ - if(!dir.exists(test_dir)) dir.create(test_dir) -}else{ +if (test_dir != "") { + if (!dir.exists(test_dir)) dir.create(test_dir) +} else { test_dir <- tempdir() } cat("Test directory: ", test_dir, "\n") @@ -32,12 +32,12 @@ m.aligned <- align_move(m, res = 4, unit = "mins", verbose = F) # shift across dateline l.df <- lapply(move::split(m.aligned), as.data.frame) -df <- do.call(rbind, mapply(x = names(l.df), y = l.df, function(x, y){ - y$id = x +df <- do.call(rbind, mapply(x = names(l.df), y = l.df, function(x, y) { + y$id <- x return(y) }, SIMPLIFY = F)) -df$x <- df$x+171.06 -df$x[df$x > 180] <- df$x[df$x > 180]-360 +df$x <- df$x + 171.06 +df$x[df$x > 180] <- df$x[df$x > 180] - 360 m.shifted <- df2move(df, proj = raster::crs("+init=epsg:4326"), x = "x", y = "y", time = "time", track_id = "id") @@ -48,8 +48,8 @@ m.shifted.repro <- df2move(df = df, proj = 3995, x = "X", y = "Y", time = "time" ## base map r_grad <- basemap_data[[1]] -r_disc <- lapply(r_grad, function(x){ - y <- raster::setValues(x, round(raster::getValues(x)*10)) +r_disc <- lapply(r_grad, function(x) { + y <- raster::setValues(x, round(raster::getValues(x) * 10)) return(y) }) r_times <- basemap_data[[2]] diff --git a/tests/testthat/test-add_.R b/tests/testthat/test-add_.R index 9241383..be57f01 100644 --- a/tests/testthat/test-add_.R +++ b/tests/testthat/test-add_.R @@ -3,41 +3,43 @@ context("add_ functions") frames <- frames_spatial(m.aligned, r_grad, r_times, r_type = "gradient", verbose = F) frames_nocrs <- frames_spatial(m = m.shifted, verbose = F, cross_dateline = T) -#if("add_" %in% which_tests){ +# if("add_" %in% which_tests){ test_that("add_colourscale", { # correct calls for type="gradient" expect_length(expect_is(add_colourscale(frames, type = "gradient", colours = c("orange", "white", "darkgreen"), legend_title = "NDVI"), "moveVis"), 188) # defualt expect_length(expect_is(add_colourscale(frames, type = "gradient", colours = c("0.1" = "orange", "0.2" = "white", "0.3" = "darkgreen"), legend_title = "NDVI"), "moveVis"), 188) # named colours - + # correct calls for type="discrete" expect_length(expect_is(add_colourscale(frames, type = "discrete", colours = c("orange", "white", "darkgreen"), legend_title = "NDVI"), "moveVis"), 188) expect_length(expect_is(add_colourscale(frames, type = "discrete", colours = c("0.1" = "orange", "0.2" = "white", "0.3" = "darkgreen"), legend_title = "NDVI"), "moveVis"), 188) # named colours - + # false calls for type="gradient" expect_error(add_colourscale(NA, type = "gradient", colours = c("orange", "white", "darkgreen"), legend_title = "NDVI")) # false frames expect_error(add_colourscale(list(frames[[1]], NA), type = "gradient", colours = c("orange", "white", "darkgreen"), legend_title = "NDVI")) # false frames expect_error(add_colourscale(frames, type = 25, colours = c("orange", "white", "darkgreen"), legend_title = "NDVI")) # false type expect_error(add_colourscale(frames, type = "RGB", colours = c("orange", "white", "darkgreen"), legend_title = "NDVI")) # false type - expect_error(add_colourscale(frames, type = "gradient", colours = c(2,3,4), legend_title = "NDVI")) # false coulous + expect_error(add_colourscale(frames, type = "gradient", colours = c(2, 3, 4), legend_title = "NDVI")) # false coulous expect_error(add_colourscale(frames, type = "gradient", colours = c("orange", "white", "darkgreen"), legend_title = "NDVI", na.colour = 1)) # false na.colour - + # false calls for type="discrete" - expect_error(add_colourscale(frames, type = "discrete", colours = c("orange", "white", "darkgreen"), labels = c(1,2,3), legend_title = "NDVI")) # false labels + expect_error(add_colourscale(frames, type = "discrete", colours = c("orange", "white", "darkgreen"), labels = c(1, 2, 3), legend_title = "NDVI")) # false labels expect_error(add_colourscale(frames, type = "discrete", colours = c("orange", "white", "darkgreen"), labels = c("1", "2"), legend_title = "NDVI")) # false labels expect_error(add_colourscale(frames, type = "discrete", colours = c("orange", "white", "darkgreen"), legend_title = "NDVI", na.show = "hi")) # false na.show }) test_that("add_gg", { # correct call - data <- data.frame(x = c(8.96, 8.955, 8.959, 8.963, 8.968, 8.963, 8.96), - y = c(47.725, 47.728, 47.729, 47.728, 47.725, 47.723, 47.725)) + data <- data.frame( + x = c(8.96, 8.955, 8.959, 8.963, 8.968, 8.963, 8.96), + y = c(47.725, 47.728, 47.729, 47.728, 47.725, 47.723, 47.725) + ) data <- rep(list(data), length.out = length(frames)) - data <- lapply(data, function(x){ - y <- rnorm(nrow(x)-1, mean = 0.00001, sd = 0.0001) + data <- lapply(data, function(x) { + y <- rnorm(nrow(x) - 1, mean = 0.00001, sd = 0.0001) x + c(y, y[1]) }) expect_length(expect_is(add_gg(frames, gg = ggplot2::expr(ggplot2::geom_path(ggplot2::aes(x = x, y = y), data = data, colour = "black")), data = data), "moveVis"), 188) - + # false calls expect_error(add_gg(frames, gg = ggplot2::expr(ggplot2::geom_path(ggplot2::aes(x = x, y = y), data = data, colour = "black")), data = data[-1])) expect_error(add_gg(frames, gg = list(ggplot2::expr(ggplot2::geom_path(ggplot2::aes(x = x, y = y), data = data, colour = "black"))), data = data)) @@ -47,7 +49,7 @@ test_that("add_gg", { test_that("add_labels", { # correct call expect_length(expect_is(add_labels(frames, x = "Longitude", y = "Latitude"), "moveVis"), 188) - + # false calls expect_error(add_labels("x", x = "Longitude", y = "Latitude")) expect_error(add_labels(list(frames[[1]], NA), x = "Longitude", y = "Latitude")) @@ -58,7 +60,7 @@ test_that("add_labels", { test_that("add_northarrow", { # correct call expect_length(expect_is(add_northarrow(frames, colour = "black"), "moveVis"), 188) - + # false calls expect_error(add_northarrow(NA, colour = "black")) expect_error(add_northarrow(list(frames[[1]], NA), colour = "black")) @@ -68,7 +70,7 @@ test_that("add_northarrow", { test_that("add_progress", { # correct call expect_length(expect_is(add_progress(frames), "moveVis"), 188) - + # false calls expect_error(add_progress(NA)) expect_error(add_progress(list(frames[[1]], NA))) @@ -82,7 +84,7 @@ test_that("add_scalebar", { expect_length(expect_is(add_scalebar(frames, distance = 1.5, units = "miles"), "moveVis"), 188) expect_length(expect_is(add_scalebar(frames), "moveVis"), 188) expect_length(expect_is(add_scalebar(frames_nocrs), "moveVis"), 188) - + # false call expect_error(add_scalebar(NA, distance = 1.5, colour = "black", 0.018)) # false frames expect_error(add_scalebar(list(frames[[1]], NA), distance = 1.5, colour = "black", 0.018)) # false frames @@ -93,7 +95,7 @@ test_that("add_scalebar", { test_that("add_text", { # correct call expect_length(expect_is(add_text(frames, "Some text", x = 8.96, y = 47.73, type = "text", colour = "black"), "moveVis"), 188) - + # false calls expect_error(add_text(NA, "Some text", x = 8.96, y = 47.73, type = "text", colour = "black")) # false frames expect_error(add_text(list(frames[[1]], NA), "Some text", x = 8.96, y = 47.73, type = "text", colour = "black")) # false frames @@ -108,10 +110,10 @@ test_that("add_text", { test_that("add_timestamps", { # correct call expect_length(expect_is(add_timestamps(frames, type = "label", colour = "black"), "moveVis"), 188) - + # false calls expect_error(add_timestamps(NA, type = "label", colour = "black")) # false frames expect_error(add_timestamps(list(frames[[1]], NA), type = "label", colour = "black")) # false frames expect_warning(add_timestamps(frames, m = m.aligned, type = "label", colour = "black")) # timestamps not matching }) -#} +# } diff --git a/tests/testthat/test-align_move.R b/tests/testthat/test-align_move.R index 7b74e20..b06c897 100644 --- a/tests/testthat/test-align_move.R +++ b/tests/testthat/test-align_move.R @@ -1,26 +1,26 @@ skip_on_cran() context("align_move") -#if("align_move" %in% which_tests){ +# if("align_move" %in% which_tests){ test_that("align_move (default)", { # correct calls x <- expect_is(align_move(m, verbose = F), "MoveStack") expect_length(unique(unlist(move::timeLag(x, units = "secs"))), 1) - + x <- expect_is(align_move(m, verbose = F, res = "max"), "MoveStack") expect_length(unique(unlist(move::timeLag(x, units = "secs"))), 1) - + x <- expect_is(align_move(m, res = "mean", verbose = F), "MoveStack") expect_length(unique(unlist(move::timeLag(x, units = "secs"))), 1) - + # false calls expect_error(align_move(NA, verbose = F)) # wrong class expect_error(align_move(m, res = FALSE, verbose = F)) expect_error(align_move(m, unit = "abc", verbose = F)) expect_error(align_move(move_data, res = 1, unit = "days", verbose = F)) - + # warnings expect_warning(align_move(m, digit = "max", verbose = F)) expect_warning(align_move(move_data, res = 13, unit = "hours", verbose = F)) }) -#} +# } diff --git a/tests/testthat/test-animate_frames.R b/tests/testthat/test-animate_frames.R index 38e0fb7..a5abfd8 100644 --- a/tests/testthat/test-animate_frames.R +++ b/tests/testthat/test-animate_frames.R @@ -6,19 +6,19 @@ test_that("animate_frames", { frames <- frames_spatial(m.aligned, r_grad, r_times, r_type = "gradient", verbose = F)[1:10] file.gif <- tempfile(tmpdir = test_dir, fileext = ".gif") expect_null(animate_frames(frames, out_file = file.gif, verbose = F, overwrite = T, display = F)) - + file.mov <- tempfile(tmpdir = test_dir, fileext = ".mov") expect_null(animate_frames(frames, out_file = file.mov, verbose = F, overwrite = T, display = F)) - + # end pause expect_null(animate_frames(frames, out_file = file.mov, verbose = F, overwrite = T, display = F, end_pause = 2)) - + # false calls expect_error(animate_frames(frames, out_file = file.mov, verbose = F, overwrite = F, display = F)) # overwrite error - + file.mov <- tempfile(tmpdir = test_dir, fileext = ".mov") expect_error(animate_frames(NA, out_file = file.mov, verbose = F, overwrite = T, display = F)) # wrong frames - expect_error(animate_frames(list(frames[[1]], NA), out_file = file.mov, verbose = F, overwrite = T, display = F)) #wrong frames + expect_error(animate_frames(list(frames[[1]], NA), out_file = file.mov, verbose = F, overwrite = T, display = F)) # wrong frames expect_error(animate_frames(frames, out_file = FALSE, verbose = F, overwrite = T, display = F)) # false out_file - expect_error(animate_frames(frames, out_file = paste0(paste0(c(tail(strsplit(file.mov, "/")[[1]], n=-1), "three", "more", "folders"), collapse = "/"), "xyz.mov"), verbose = F, overwrite = T, display = F)) # false out_file -}) \ No newline at end of file + expect_error(animate_frames(frames, out_file = paste0(paste0(c(tail(strsplit(file.mov, "/")[[1]], n = -1), "three", "more", "folders"), collapse = "/"), "xyz.mov"), verbose = F, overwrite = T, display = F)) # false out_file +}) diff --git a/tests/testthat/test-deprecated.R b/tests/testthat/test-deprecated.R index 7a90d9e..824f04a 100644 --- a/tests/testthat/test-deprecated.R +++ b/tests/testthat/test-deprecated.R @@ -1,7 +1,7 @@ skip_on_cran() context("deprecated") -#if("deprecated" %in% which_tests){ +# if("deprecated" %in% which_tests){ test_that("depreacated functions", { expect_warning(animate_move()) expect_warning(animate_stats()) @@ -9,4 +9,4 @@ test_that("depreacated functions", { expect_warning(get_formats()) expect_warning(get_libraries()) }) -#} \ No newline at end of file +# } diff --git a/tests/testthat/test-df2move.R b/tests/testthat/test-df2move.R index 18c7bbd..0177c48 100644 --- a/tests/testthat/test-df2move.R +++ b/tests/testthat/test-df2move.R @@ -1,37 +1,55 @@ skip_on_cran() context("df2move") -#if("df2move" %in% which_tests){ +# if("df2move" %in% which_tests){ test_that("df2move (stack)", { # correct calls move_df <- expect_is(methods::as(m.aligned, "data.frame"), "data.frame") - expect_is(df2move(move_df, proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId"), "MoveStack") # test without data - expect_is(df2move(move_df, proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId", data = move_df[,c("optional", "sensor")]), "MoveStack") # test with data - expect_is(df2move(move_df[move_df$trackId == "T246a",], proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId"), "Move") # test with track_id but only one individual - + expect_is(df2move(move_df, + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId" + ), "MoveStack") # test without data + expect_is(df2move(move_df, + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId", data = move_df[, c("optional", "sensor")] + ), "MoveStack") # test with data + expect_is(df2move(move_df[move_df$trackId == "T246a", ], + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId" + ), "Move") # test with track_id but only one individual + # false calls - expect_error(df2move(NA, proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId")) # df is NA - expect_error(df2move(move_df, proj = "abcdef", - x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId")) # false proj - expect_error(df2move(move_df, proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId", data = move_df[1:10,c("optional", "sensor")])) # data not long enough - expect_error(df2move(move_df, proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "coords.x2", track_id = "trackId")) # time not POSIXct - expect_error(df2move(move_df, proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "abc")) # track id not existing - - + expect_error(df2move(NA, + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId" + )) # df is NA + expect_error(df2move(move_df, + proj = "abcdef", + x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId" + )) # false proj + expect_error(df2move(move_df, + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "trackId", data = move_df[1:10, c("optional", "sensor")] + )) # data not long enough + expect_error(df2move(move_df, + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "coords.x2", track_id = "trackId" + )) # time not POSIXct + expect_error(df2move(move_df, + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "timestamps", track_id = "abc" + )) # track id not existing }) test_that("df2move (single)", { move_df <- expect_is(methods::as(m.aligned[[1]], "data.frame"), "data.frame") - expect_is(df2move(move_df, proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "timestamps"), "Move") - expect_is(df2move(move_df, proj = raster::crs("+init=epsg:4326"), - x = "coords.x1", y = "coords.x2", time = "timestamps", data = move_df[,c("optional", "sensor")]), "Move") + expect_is(df2move(move_df, + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "timestamps" + ), "Move") + expect_is(df2move(move_df, + proj = raster::crs("+init=epsg:4326"), + x = "coords.x1", y = "coords.x2", time = "timestamps", data = move_df[, c("optional", "sensor")] + ), "Move") }) -#} \ No newline at end of file +# } diff --git a/tests/testthat/test-frames_graph.R b/tests/testthat/test-frames_graph.R index b325268..7471095 100644 --- a/tests/testthat/test-frames_graph.R +++ b/tests/testthat/test-frames_graph.R @@ -1,30 +1,30 @@ skip_on_cran() context("frames_graph") -#if("frames_graph" %in% which_tests){ +# if("frames_graph" %in% which_tests){ test_that("frames_graph (gradient, flow)", { # correct calls frames <- expect_length(expect_is(frames_graph(m.aligned, r_grad, r_times, graph_type = "flow", verbose = F), "moveVis"), 188) # multi raster expect_is(frames[[1]], "ggplot") - + frames <- expect_length(expect_is(frames_graph(m.aligned, r_grad[[5]], r_times[[5]], graph_type = "flow", verbose = F), "moveVis"), 188) # single raster expect_is(frames[[1]], "ggplot") - + expect_is(frames_graph(m.aligned, r_grad, r_times, graph_type = "flow", return_data = T, verbose = F), "data.frame") # return data.frame - + # false calls expect_error(frames_graph(NA, r_grad, r_times, graph_type = "flow", verbose = F)) # no move expect_error(frames_graph(m.aligned, r_grad, r_times, r_type = NA, verbose = F)) # false r_type expect_error(frames_graph(m.aligned, r_grad, r_times, r_type = "abc", verbose = F)) # false r_type expect_error(frames_graph(m.aligned, list(NA), r_times, graph_type = "flow", verbose = F)) # false r_list - + x <- r_grad[[1]] raster::crs(x) <- raster::crs("+proj=utm +zone=32 +ellps=WGS84 +datum=WGS84 +units=m +no_defs") expect_error(frames_graph(m.aligned, list(x), r_times, graph_type = "flow", verbose = F)) # false proj - - x <- list(r_grad[[1]], raster::stack( r_grad[[2]], r_grad[[2]])) + + x <- list(r_grad[[1]], raster::stack(r_grad[[2]], r_grad[[2]])) expect_error(frames_graph(m.aligned, x, r_times, graph_type = "flow", verbose = F)) # differing numbers of layers - + expect_error(frames_graph(m.aligned, r_grad, as.character(r_times), graph_type = "flow", verbose = F)) # false r_times expect_error(frames_graph(m.aligned, r_grad, r_times, graph_type = "flow", fade_raster = 1, verbose = F)) # false fade_raster expect_error(frames_graph(m.aligned, r_grad, r_times, graph_type = "flow", path_size = "1", verbose = F)) @@ -39,7 +39,7 @@ test_that("frames_graph (gradient, hist)", { # correct calls frames <- expect_length(expect_is(frames_graph(m.aligned, r_grad, r_times, graph_type = "hist", verbose = F), "moveVis"), 188) expect_is(frames[[1]], "ggplot") - + # false calls expect_error(frames_graph(m.aligned, r_grad, r_times, graph_type = "hist", val_min = "1", verbose = F)) # false val_min expect_error(frames_graph(m.aligned, r_grad, r_times, graph_type = "hist", val_max = "1", verbose = F)) # false val_max @@ -50,7 +50,7 @@ test_that("frames_graph (gradient, hist)", { test_that("frames_graph (discrete, flow)", { frames <- expect_length(expect_is(frames_graph(m.aligned, r_disc, r_times, r_type = "discrete", graph_type = "flow", verbose = F, val_by = 1), "moveVis"), 188) expect_is(frames[[1]], "ggplot") - + # warning calls expect_warning(frames_graph(m.aligned, r_grad, r_times, r_type = "discrete", fade_raster = T, val_by = 1, verbose = F)) expect_warning(frames_graph(m.aligned, r_grad, r_times, r_type = "discrete", fade_raster = F, verbose = F)) @@ -60,4 +60,4 @@ test_that("frames_graph (discrete, hist)", { frames <- expect_length(expect_is(frames_graph(m.aligned, r_disc, r_times, r_type = "discrete", graph_type = "hist", verbose = F, val_by = 1), "moveVis"), 188) expect_is(frames[[1]], "ggplot") }) -#} \ No newline at end of file +# } diff --git a/tests/testthat/test-frames_spatial.R b/tests/testthat/test-frames_spatial.R index 197768d..5bbea37 100644 --- a/tests/testthat/test-frames_spatial.R +++ b/tests/testthat/test-frames_spatial.R @@ -8,7 +8,7 @@ test_that("frames_spatial (default maps)", { expect_is(frames, "frames_spatial") expect_is(frames[1:10], "moveVis") expect_is(frames[[10]], "ggplot") - + # false calls expect_error(frames_spatial(m.aligned, map_service = "abc", verbose = F)) # false map service expect_error(frames_spatial(m.aligned, map_service = "osm", map_type = "light", verbose = F)) # false map service @@ -32,23 +32,23 @@ test_that("frames_spatial (raster, gradient)", { expect_is(frames[[1]], "ggplot") # single raster frames <- expect_length(expect_is(frames_spatial(m.aligned, r_grad, r_times, r_type = "gradient", path_arrow = grid::arrow(), verbose = F), "moveVis"), 188) expect_is(frames[[1]], "ggplot") # path arrow - frames <- expect_length(expect_is(frames_spatial(m.aligned, r_grad, r_times, r_type = "gradient", trace_show = T, trace_size = 4, trace_colour = "black", verbose = F), "moveVis"), 188) + frames <- expect_length(expect_is(frames_spatial(m.aligned, r_grad, r_times, r_type = "gradient", trace_show = T, trace_size = 4, trace_colour = "black", verbose = F), "moveVis"), 188) expect_is(frames[[1]], "ggplot") # trace_ arguments frames <- expect_length(expect_is(frames_spatial(m.aligned, r_grad, r_times, r_type = "gradient", tail_length = 25, tail_size = 3, tail_colour = "black", verbose = F), "moveVis"), 188) expect_is(frames[[1]], "ggplot") # tail_ arguments - - + + # false calls expect_error(frames_spatial(m, r_grad, r_times, r_type = "gradient", verbose = F)) # diveriging temporal resolution (m not aligend) expect_error(frames_spatial(NA, r_grad, r_times, r_type = "gradient", verbose = F)) # false m - + x <- r_grad[[1]] raster::crs(x) <- raster::crs("+proj=utm +zone=32 +ellps=WGS84 +datum=WGS84 +units=m +no_defs") expect_error(frames_spatial(m.aligned, list(x), r_times, r_type = "gradient", verbose = F)) # false proj - - x <- list(r_grad[[1]], raster::stack( r_grad[[2]], r_grad[[2]])) + + x <- list(r_grad[[1]], raster::stack(r_grad[[2]], r_grad[[2]])) expect_error(frames_spatial(m.aligned, x, r_times, r_type = "gradient", verbose = F)) # differing numbers of layers - + expect_error(frames_spatial(m.aligned, r_grad, as.character(r_times), r_type = "gradient", verbose = F)) # false r_times expect_error(frames_spatial(m.aligned, r_grad, r_times, r_type = "abc", verbose = F)) # false r_type expect_error(frames_spatial(m.aligned, r_grad, r_times, r_type = "gradient", fade_raster = 1, verbose = F)) # false fade_raster @@ -61,14 +61,14 @@ test_that("frames_spatial (raster, gradient, fade)", { }) test_that("frames_spatial (raster, discrete)", { - frames <- expect_length(expect_is(frames_spatial(m.aligned, r_disc, r_times, r_type = "discrete", verbose = F), "moveVis"), 188) + frames <- expect_length(expect_is(frames_spatial(m.aligned, r_disc, r_times, r_type = "discrete", verbose = F), "moveVis"), 188) expect_is(frames[[1]], "ggplot") }) -#} +# } ## check special arguments, including ext and path_length test_that("frames_spatial (different extent/proj settings)", { - ext <- raster::extent(m)*1.1 + ext <- raster::extent(m) * 1.1 # custom extent frames <- expect_length(expect_is(frames_spatial(m.aligned, map_service = "osm", map_type = get_maptypes("osm")[1], map_res = 0.1, ext = ext, verbose = F), "moveVis"), 188) @@ -83,29 +83,27 @@ test_that("frames_spatial (different extent/proj settings)", { expect_is(frames[[1]], "ggplot") # other projections - frames <- lapply(c("+init=epsg:32632", "+init=epsg:3857"), function(p){ - + frames <- lapply(c("+init=epsg:32632", "+init=epsg:3857"), function(p) { # transform using sf m_tf <- sf::st_transform(sf::st_as_sf(m), sf::st_crs(p)) m_tf <- cbind.data.frame(sf::st_coordinates(m_tf), time = m_tf$time, id = move::trackId(m)) m <- quiet(df2move(m_tf, proj = p, x = "X", y = "Y", time = "time", track_id = "id")) # warnings are exected sometimes - + frames <- expect_length(expect_is(frames_spatial(m.aligned, map_service = "osm", map_type = get_maptypes("osm")[1], map_res = 0.1, equidistant = F, verbose = F), "moveVis"), 188) expect_is(frames[[1]], "ggplot") frames[[100]] }) - + # false calls expect_error(frames_spatial(m.aligned, map_res = 0.1, ext = "abc", verbose = F)) - #expect_warning(frames_spatial(m.aligned, map_res = 0.1, ext = raster::extent(m.aligned)*0.1, verbose = F)) - + # expect_warning(frames_spatial(m.aligned, map_res = 0.1, ext = raster::extent(m.aligned)*0.1, verbose = F)) }) test_that("frames_spatial (cross_dateline)", { - - frames <- expect_length(expect_is(frames_spatial(m = m.shifted, map_service = "carto", map_type = "light", - verbose = F, cross_dateline = T), "moveVis"), 188) - frames <- expect_warning(frames_spatial(m= m.shifted.repro, verbose = F, cross_dateline = T)) + frames <- expect_length(expect_is(frames_spatial( + m = m.shifted, map_service = "carto", map_type = "light", + verbose = F, cross_dateline = T + ), "moveVis"), 188) + frames <- expect_warning(frames_spatial(m = m.shifted.repro, verbose = F, cross_dateline = T)) frames <- expect_error(frames_spatial(m = m.shifted, r_list = r_grad, r_times = r_times, r_type = "gradient", verbose = F, cross_dateline = T)) - -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-internal.R b/tests/testthat/test-internal.R index 86466e3..4ae07ee 100644 --- a/tests/testthat/test-internal.R +++ b/tests/testthat/test-internal.R @@ -2,10 +2,10 @@ skip_on_cran() context("internal") test_that("internal (labels)", { - expect_length(expect_is(moveVis:::.x_labels(c(NA, -10,0,10,20,30)), "expression"), 5) - expect_length(expect_is(moveVis:::.y_labels(c(NA, -10,0,10,20,30)), "expression"), 5) + expect_length(expect_is(moveVis:::.x_labels(c(NA, -10, 0, 10, 20, 30)), "expression"), 5) + expect_length(expect_is(moveVis:::.y_labels(c(NA, -10, 0, 10, 20, 30)), "expression"), 5) }) test_that("internal (onLoad)", { expect_invisible(moveVis:::.onLoad()) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-join_frames.R b/tests/testthat/test-join_frames.R index 04d94ca..29d8ac5 100644 --- a/tests/testthat/test-join_frames.R +++ b/tests/testthat/test-join_frames.R @@ -6,8 +6,8 @@ test_that("join_frames", { f1 <- frames_spatial(m.aligned, r_grad, r_times, r_type = "gradient", verbose = F)[1:10] f2 <- frames_graph(m.aligned, r_grad, r_times, graph_type = "hist", verbose = F)[1:10] expect_length(expect_is(join_frames(frames_lists = list(f1, f2), verbose = F), "moveVis"), 10) - + # false calls expect_error(join_frames(frames_lists = list(f1[1:10], f2[1:5]), verbose = F)) # differing lengths expect_error(join_frames(frames_lists = list(f1[1:10]), verbose = F)) # nothing to join -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-settings.R b/tests/testthat/test-settings.R index 4d64829..43120b4 100644 --- a/tests/testthat/test-settings.R +++ b/tests/testthat/test-settings.R @@ -14,8 +14,10 @@ test_that("use_multicore", { test_that("use_disk", { expect_output(use_disk(frames_to_disk = TRUE, n_memory_frames = NULL)) - expect_is(frames_spatial(m = m.aligned[move::timestamps(m.aligned) > as.POSIXct("2018-05-15 07:00:00") & move::timestamps(m.aligned) < as.POSIXct("2018-05-15 10:00:00"),], - r_list = r_grad, r_times = r_times, r_type = "gradient", verbose = F, fade_raster = T), "moveVis") + expect_is(frames_spatial( + m = m.aligned[move::timestamps(m.aligned) > as.POSIXct("2018-05-15 07:00:00") & move::timestamps(m.aligned) < as.POSIXct("2018-05-15 10:00:00"), ], + r_list = r_grad, r_times = r_times, r_type = "gradient", verbose = F, fade_raster = T + ), "moveVis") expect_output(use_disk(frames_to_disk = TRUE, dir_frames = paste0(tempdir(), "/moveVis/xyz/abc"), n_memory_frames = NULL)) expect_output(expect_warning(use_disk(frames_to_disk = TRUE, n_memory_frames = 2))) use_disk(frames_to_disk = FALSE, verbose = F) diff --git a/tests/testthat/test-subset_move.R b/tests/testthat/test-subset_move.R index fb47c9c..2647763 100644 --- a/tests/testthat/test-subset_move.R +++ b/tests/testthat/test-subset_move.R @@ -1,14 +1,14 @@ skip_on_cran() context("subset_move") -#if("df2move" %in% which_tests){ +# if("df2move" %in% which_tests){ test_that("subset_move", { # correct calls m.subset <- expect_is(subset_move(m.aligned, from = min(move::timestamps(m.aligned)), to = "2018-05-15 18:00:00"), "MoveStack") expect_length(move::timestamps(m.subset), 424) - + # false calls expect_error(subset_move(m.aligned, from = "2018-05-15 07:00:00", to = "2018-05-15 18:00:00")) expect_error(subset_move(m.aligned, from = "2018-05-15 08:00:00", to = "2019-05-15 18:00:00")) }) -#} \ No newline at end of file +# } diff --git a/tests/testthat/test-suggest_formats.R b/tests/testthat/test-suggest_formats.R index 0fff3b7..e15965c 100644 --- a/tests/testthat/test-suggest_formats.R +++ b/tests/testthat/test-suggest_formats.R @@ -1,9 +1,9 @@ skip_on_cran() context("suggest_formats") -#if("suggest_formats" %in% which_tests){ +# if("suggest_formats" %in% which_tests){ test_that("suggest_formats", { expect_is(suggest_formats(), "character") expect_gt(length(suggest_formats()), 0) }) -#} \ No newline at end of file +# } diff --git a/tests/testthat/test-view_spatial.R b/tests/testthat/test-view_spatial.R index 7bc1bc5..72be4de 100644 --- a/tests/testthat/test-view_spatial.R +++ b/tests/testthat/test-view_spatial.R @@ -2,16 +2,15 @@ skip_on_cran() context("view_spatial") test_that("view_spatial", { - # correct calls - if(isTRUE(check_mapview)){ + if (isTRUE(check_mapview)) { expect_is(view_spatial(m), "mapview") expect_is(view_spatial(m, time_labels = FALSE, path_legend = FALSE), "mapview") expect_is(view_spatial(m[[1]], time_labels = FALSE, path_legend = FALSE), "mapview") } - - if(isTRUE(check_leaflet)) expect_is(view_spatial(m, render_as = "leaflet"), "leaflet") else expect_error(view_spatial(m)) - + + if (isTRUE(check_leaflet)) expect_is(view_spatial(m, render_as = "leaflet"), "leaflet") else expect_error(view_spatial(m)) + # false calls expect_error(view_spatial(m, render_as = "abc")) expect_error(view_spatial(m, render_as = NA)) @@ -20,4 +19,4 @@ test_that("view_spatial", { expect_error(view_spatial(m, path_legend = "1")) expect_error(view_spatial(m, time_labels = "1")) expect_error(view_spatial(m, path_legend_title = 1)) -}) \ No newline at end of file +}) diff --git a/vignettes/example-7.Rmd b/vignettes/example-7.Rmd index d0cd62b..f8794d0 100644 --- a/vignettes/example-7.Rmd +++ b/vignettes/example-7.Rmd @@ -27,4 +27,4 @@ When hovering a point with the cursor, the timestamps of that point is displayed

-
\ No newline at end of file +
From 3c5b86b75d1f103eba3f2edfd78fa9c0feba0d44 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Nussbaumer?= Date: Fri, 26 Apr 2024 15:00:02 +0200 Subject: [PATCH 4/8] remove debug flag --- R/frames_spatial.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 7372058..e7bb90d 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -233,8 +233,6 @@ frames_spatial <- function(m, r_list = NULL, r_times = NULL, r_type = "gradient" gg.ext <- .ext(m.df, m.crs, ext, margin_factor, equidistant, cross_dateline) # calculate extent - print(gg.ext) - ## shift coordinates crossing dateline if (isTRUE(cross_dateline)) { rg <- c("pos" = diff(range(m.df$x[m.df$x >= 0])), "neg" = diff(range(m.df$x[m.df$x < 0]))) From 9b93055dec6d088222922f91409b195eb245e5f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Nussbaumer?= Date: Fri, 26 Apr 2024 15:00:50 +0200 Subject: [PATCH 5/8] Update to new crs convention to fix test --- tests/testthat/test-frames_spatial.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-frames_spatial.R b/tests/testthat/test-frames_spatial.R index 5bbea37..ed7bddb 100644 --- a/tests/testthat/test-frames_spatial.R +++ b/tests/testthat/test-frames_spatial.R @@ -83,7 +83,7 @@ test_that("frames_spatial (different extent/proj settings)", { expect_is(frames[[1]], "ggplot") # other projections - frames <- lapply(c("+init=epsg:32632", "+init=epsg:3857"), function(p) { + frames <- lapply(c("EPSG:32632", "EPSG:3857"), function(p) { # transform using sf m_tf <- sf::st_transform(sf::st_as_sf(m), sf::st_crs(p)) m_tf <- cbind.data.frame(sf::st_coordinates(m_tf), time = m_tf$time, id = move::trackId(m)) From a092fbc42eeb0487a8776c54f11e8a6107b71e26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Nussbaumer?= Date: Fri, 26 Apr 2024 16:24:51 +0200 Subject: [PATCH 6/8] Fix compability with `terra` (probably need more check for this) --- R/frames_graph.R | 4 ++-- R/frames_spatial.R | 4 ++-- R/internal.R | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/frames_graph.R b/R/frames_graph.R index 5bf7674..336ab9d 100644 --- a/R/frames_graph.R +++ b/R/frames_graph.R @@ -101,8 +101,8 @@ frames_graph <- function(m, r_list, r_times, r_type = "gradient", fade_raster = out("Argument 'r_type' must be of type 'character'.", type = 3) } if (!inherits(r_list[[1]], "RasterLayer")) out("Argument 'r_list' must contain single-layer 'RasterLayer' objects. Multi-layer 'RasterStack' objects are not supported by this function.", type = 3) - if (any(!sapply(r_list, compareCRS, y = m))) out("Projections of 'm' and 'r_list' differ.", type = 3) - if (length(unique(sapply(r_list, nlayers))) > 1) out("Number of layers per raster object in list 'r' differ.", type = 3) + if (any(!sapply(r_list, terra::same.crs, y = m))) out("Projections of 'm' and 'r_list' differ.", type = 3) + if (length(unique(sapply(r_list, terra::nlyr))) > 1) out("Number of layers per raster object in list 'r' differ.", type = 3) if (!inherits(r_times, "POSIXct")) out("Argument 'r_times' must be of type 'POSIXct' if 'r_list' is defined.", type = 3) if (!is.logical(fade_raster)) out("Argument 'fade_raster' has to be either TRUE or FALSE.", type = 3) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index e7bb90d..877e272 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -179,8 +179,8 @@ frames_spatial <- function(m, r_list = NULL, r_times = NULL, r_type = "gradient" if (!is.null(r_list)) { if (all(!is.list(r_list), inherits(r_list, "Raster"))) r_list <- list(r_list) - if (any(!sapply(r_list, compareCRS, y = m))) out("Projections of 'm' and 'r_list' differ.", type = 3) - if (length(unique(sapply(r_list, nlayers))) > 1) out("Number of layers per raster object in list 'r' differ.", type = 3) + if (any(!sapply(r_list, terra::same.crs, y = m))) out("Projections of 'm' and 'r_list' differ.", type = 3) + if (length(unique(sapply(r_list, terra::nlyr))) > 1) out("Number of layers per raster object in list 'r' differ.", type = 3) if (!inherits(r_times, "POSIXct")) out("Argument 'r_times' must be of type 'POSIXct' if 'r_list' is defined.", type = 3) if (!isTRUE(r_type %in% c("gradient", "discrete", "RGB"))) out("Argument 'r_type' must eihter be 'gradient', 'discrete' or 'RGB'.", type = 3) if (!is.logical(fade_raster)) out("Argument 'fade_raster' has to be either TRUE or FALSE.", type = 3) diff --git a/R/internal.R b/R/internal.R index e017238..a1b5e3e 100755 --- a/R/internal.R +++ b/R/internal.R @@ -512,7 +512,7 @@ repl_vals <- function(data, x, y) { } else { n <- length(r_list) } - n.rlay <- nlayers(r_list[[1]]) + n.rlay <- terra::nlyr(r_list[[1]]) # if(n.rlay > 1) r_list <- lapply(1:n.rlay, function(i) lapply(r_list, "[[", i)) else r_list <- list(r_list) #FRIDAY From 7a119958b68febfff0619c699dbabcc45dc7f5c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Nussbaumer?= Date: Fri, 26 Apr 2024 16:25:20 +0200 Subject: [PATCH 7/8] Align `r_type` according to document to default to RGB if r_list provided with 3 layers --- R/frames_spatial.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 877e272..149e0be 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -256,6 +256,9 @@ frames_spatial <- function(m, r_list = NULL, r_times = NULL, r_type = "gradient" } else { map_service <- "custom" map_type <- "custom" + if (terra::nlyr(r_list[[1]]) == 3) { + r_type <- "RGB" + } } # calculate frames extents and coord labes From 4ccd157f9c632b9861f111250ee42c8a26a49b7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Nussbaumer?= Date: Fri, 26 Apr 2024 16:37:26 +0200 Subject: [PATCH 8/8] typo in doc --- R/animate_frames.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/animate_frames.R b/R/animate_frames.R index 5228247..6df10bc 100644 --- a/R/animate_frames.R +++ b/R/animate_frames.R @@ -4,7 +4,7 @@ #' #' @inheritParams add_gg #' @param out_file character, the output file path, e.g. "/dir/to/file.mov". The file extension must correspond to a file format known by the available renderers of the running system. Use \code{\link{suggest_formats}} to get a vector of suggested known file formats. -#' @param fps numeric, the number of frames to be displayed per second. Default is 2. +#' @param fps numeric, the number of frames to be displayed per second. Default is 25. #' @param width numeric, width of the output animation in pixels. #' @param height numeric, height of the output animation in pixels. #' @param res numeric, resolution of the output animation in ppi.