diff --git a/R/border_correction_sf.R b/R/border_correction_sf.R index be558682..6145d234 100644 --- a/R/border_correction_sf.R +++ b/R/border_correction_sf.R @@ -3,72 +3,62 @@ #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -#' @title Simple NKDE border correction -#' -#' @description A function to calculate the Diggle correction factor with the -#' simple NKDE. -#' @param graph The graph (igraph) used to calculate distances between nodes -#' @param events A feature collection of points representing the events -#' @param edges A feature collection of lines representing the edges of the graph -#' @param bws A vector of the bandwidths for each event -#' @keywords internal -#' @importFrom igraph ends -#' @return A numeric vector with the correction factor values -corrfactor_simple <- function(graph,events,edges,bws){ - tree_edges <- build_quadtree(edges) - buffers <- st_buffer(events, dist = bws) - #iterons sur chacun des evenements - dfs <- lapply(1:nrow(events),function(i){ - e <- events[i,] - y <- e$vertex_id - bw <- bws[[i]] - ## step1 selecting the edges inside of the radius - #buff <- gBuffer(e,width=bw) - buff <- buffers[,i] - ok_edges <- spatial_request(buff,tree_edges,edges) - ## Step3 for each edge, find its two vertices - vertices <- ends(graph,ok_edges$edge_id,names = FALSE) - ## step4 calculate the the distance between the start node and each edge - ## vertex - un_vertices <- unique(c(vertices[,1],vertices[,2])) - dist1 <- as.numeric(distances(graph,y,to=un_vertices,mode="out")) - - dist_table <- data.frame("vertex"=un_vertices, - "distance" = dist1) - ## step5 aggregate all the data - df_edges <- data.frame("edge_id" = ok_edges$edge_id, - "weight" = ok_edges$weight, - "node1" = vertices[,1], - "node2" = vertices[,2] - ) - A <- data.table(df_edges) - B <- data.table(dist_table) - df_edges$d1 <- A[B, on = c("node1" = "vertex"), - names(B) := mget(paste0("i.", names(B)))]$distance - df_edges$d2 <- A[B, on = c("node2" = "vertex"), - names(B) := mget(paste0("i.", names(B)))]$distance - - df_edges <- subset(df_edges,df_edges$d10)) - }) - return(dfs) -} +# this function is not usefull anymore. We keep it only for debuging purpose +# corrfactor_simple <- function(graph,events,edges,bws){ +# tree_edges <- build_quadtree(edges) +# buffers <- st_buffer(events, dist = bws) +# #iterons sur chacun des evenements +# dfs <- lapply(1:nrow(events),function(i){ +# e <- events[i,] +# y <- e$vertex_id +# bw <- bws[[i]] +# ## step1 selecting the edges inside of the radius +# #buff <- gBuffer(e,width=bw) +# buff <- buffers[,i] +# ok_edges <- spatial_request(buff,tree_edges,edges) +# ## Step3 for each edge, find its two vertices +# vertices <- ends(graph,ok_edges$edge_id,names = FALSE) +# ## step4 calculate the the distance between the start node and each edge +# ## vertex +# un_vertices <- unique(c(vertices[,1],vertices[,2])) +# dist1 <- as.numeric(distances(graph,y,to=un_vertices,mode="out")) +# +# dist_table <- data.frame("vertex"=un_vertices, +# "distance" = dist1) +# ## step5 aggregate all the data +# df_edges <- data.frame("edge_id" = ok_edges$edge_id, +# "weight" = ok_edges$weight, +# "node1" = vertices[,1], +# "node2" = vertices[,2] +# ) +# A <- data.table(df_edges) +# B <- data.table(dist_table) +# df_edges$d1 <- A[B, on = c("node1" = "vertex"), +# names(B) := mget(paste0("i.", names(B)))]$distance +# df_edges$d2 <- A[B, on = c("node2" = "vertex"), +# names(B) := mget(paste0("i.", names(B)))]$distance +# +# df_edges <- subset(df_edges,df_edges$d10)) +# }) +# return(dfs) +# } diff --git a/tests/testthat/test_bw_selection_sf.R b/tests/testthat/test_bw_selection_sf.R index 12950a91..fcf4620e 100644 --- a/tests/testthat/test_bw_selection_sf.R +++ b/tests/testthat/test_bw_selection_sf.R @@ -476,6 +476,63 @@ test_that("Testing the bw selection function with Van Lieshout's Criterion and c +test_that("Testing the bw selection function with Van Lieshout's Criterion and simple kernel and adaptive", { + + ## creating the simple situation + # start with de definition of some lines + wkt_lines <- c( + "LINESTRING (0 5, 0 0)", + "LINESTRING (-5 0, 0 0)", + "LINESTRING (0 -5, 0 0)", + "LINESTRING (5 0, 0 0)") + + linesdf <- data.frame(wkt = wkt_lines, + id = paste("l",1:length(wkt_lines),sep="")) + + all_lines <- st_as_sf(linesdf, wkt = "wkt") + + # definition of three events + event <- data.frame(x=c(0,3,0), + y=c(3,0,-3), + id = c(1,2,3)) + event <- st_as_sf(event, coords = c("x","y")) + + + # we can admit a bw of 10 here + # the network distance between two points is 6 + # so the density at one event is + s1 <- (quartic_kernel(6,10) + quartic_kernel(6,10) + quartic_kernel(0,10)) *(1/10) + + hf0 <- c(s1, s1, s1) + + h0 <- 10 + gamma_val <- exp(sum(log(1/sqrt(hf0)))/3) + abws <- h0 * (1/sqrt(hf0)) * (1/gamma_val) + + #so the score value is + Wl <- sum(as.numeric(st_length(all_lines))) + score <- ((1/s1+1/s1+1/s1) - Wl)**2 + + + #let us calculate the value with our function + obs_value <- bw_cvl_calc(bws = seq(8,10,1), + trim_bws = seq(8,10,1) * 2, + lines = all_lines, + events = event, + w = c(1,1,1), + check = F, + kernel_name = "quartic", + adaptive = TRUE, + method = "simple", + digits = 1, + agg = NULL, + verbose = F, + tol = 0.00001 + ) + expect_equal(obs_value[3,2], score) +}) + + #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #### Comparing multicore and single core #### #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -588,7 +645,7 @@ test_that("Testing that bw selection with Van Lieshout's Criterion gives the sam max_depth = 8, digits=2, tol=0.1, agg=5, sparse=TRUE, grid_shape=c(2,2), - sub_sample = 1, verbose=FALSE, check=TRUE) + sub_sample = 1, verbose=TRUE, check=TRUE) ## single core cv score cv_scores <- bw_cvl_calc(seq(200,400,100),