最新消息:雨落星辰是一个专注网站SEO优化、网站SEO诊断、搜索引擎研究、网络营销推广、网站策划运营及站长类的自媒体原创博客

r - Raster calculations parallelisation on hpc using a shiny app - Stack Overflow

programmeradmin2浏览0评论

I am currently developing a shinyapp for rastercalculations similarly like:

I am developing it to run on a high performance cluster because I want to parallize the calculation of vegetation indices. On my PC it's working totaly fine. Here is the code snippet which is causing the error:


p <- wrap(values$raster_rgb)
        
        # Set up parallel backend
        plan(multisession, workers = input$numCores)  # Use multiple cores
        
        # Parallel processing of raster indices
        raster_indices_rgb <- future_lapply(input$rgbIndices, function(idx) {
          idx_eq <- indices_equations$eq[indices_equations$index == idx]
          
          # Create function dynamically
          eval(parse(text = paste0(idx, " <- function(Red, Green, Blue, Alpha) { return(", idx_eq, ") }")))
          
          # Process raster tiles
          x <- unwrap(p)
          raster_idx <- lapp(x, get(idx), usenames = TRUE)
          names(raster_idx) <- idx
          
          return(setNames(list(raster_idx), idx))
        })
        
        # Combine results into a named list
        raster_indices_rgb <- unlist(raster_indices_rgb, recursive = FALSE)
        
        
  
        
        if(length(raster_indices_rgb) > 0) {
          raster_indices_rgb <- rast(raster_indices_rgb)
          raster_no_soil_indices_rgb <- terra::mask(raster_indices_rgb, values$mask)
          values$indices_rgb_per_plot_without_soil <- exact_extract(raster_no_soil_indices_rgb, values$shape_file, fun = 'mean')
          
          
          #If only one vector is slected colnames does not work therefore this ifstatement:
          if (length(raster_indices_rgb) == 1){
            values$indices_rgb_per_plot_without_soil <- as.data.frame(values$indices_rgb_per_plot_without_soil)
            colnames(values$indices_rgb_per_plot_without_soil) <- input$rgbIndices
          }
          
          colnames(values$indices_rgb_per_plot_without_soil) <- paste(colnames(values$indices_rgb_per_plot_without_soil), "without_soil", sep = "_")
          values$indices_rgb_per_plot_with_soil <- exact_extract(raster_indices_rgb, values$shape_file, fun = 'mean')
          #If only one vector is slected colnames does not work therefore this ifstatement:
          if (length(raster_indices_rgb) == 1){
            values$indices_rgb_per_plot_with_soil <- as.data.frame(values$indices_rgb_per_plot_with_soil)
            colnames(values$indices_rgb_per_plot_with_soil) <- input$rgbIndices
          }
          
          colnames(values$indices_rgb_per_plot_with_soil) <- paste(colnames(values$indices_rgb_per_plot_with_soil), "with_soil", sep = "_")
        }
      }
      
      plan(sequential)

It is causing the following error:

    Warning: Error in : external pointer is not valid
      95: <Anonymous>
      94: stop
      93: x@pntr$deepcopy
      92: .local
      91: deepcopy
      89: .local
      88: rast
      83: observe
      82: <observer:observeEvent(input$runAnalysis)>
       3: runApp
       2: print.shiny.appobj
       1: <Anonymous>

I thought that I solved the issue with the wrap und unwrap part. But now when I am running it at the hpc its not working... I allocated 1 node with 40 cores and a total --mem of 96gb ... Any suggestions?

I already tried to use plan(multisession) and plan(multicore) did not change the error...

Because it was asked for a reproducible example:

rm(list=ls())
# Required libraries

if (!require("pacman")) install.packages("pacman")
pacman::p_load(
  shiny,
  terra,
  sf,
  exactextractr,
  shinydashboard,
  DT,
  dplyr,
  shinyFiles,
  tidyverse,
  raster,
  tictoc,
  parallel,
  doParallel,
  future,
  foreach,
  future.apply
)

#vegetation indices
indices_equations <- data.frame(
  index = c("BI", "BIM", "SCI", 
            "GLI", "HI", "NGRDI", 
            "SI", "VARI", "HUE", "BGI", 
            "PSRI", "NDVI"),
  eq = c("sqrt((Red^2+Green^2+Blue^2)/3)", 
         "sqrt((Red*2+Green*2+Blue*2)/3)", 
         "(Red-Green)/(Red+Green)", 
         "(2*Green-Red-Blue)/(2*Green+Red+Blue)", 
         "(2*Red-Green-Blue)/(Green-Blue)", 
         "(Green-Red)/(Green+Red)", 
         "(Red-Blue)/(Red+Blue)", 
         "(Green-Red)/(Green+Red-Blue)", 
         "atan(2*(Blue-Green-Red)/30.5*(Green-Red))", 
         "Blue/Green", 
         "(Red-Green)/RE", 
         "(NIR-Red)/(NIR+Red)"),
  type = c("RGB", "RGB", "RGB", 
           "RGB", "RGB", "RGB", 
           "RGB", "RGB", "RGB", "RGB", 
           "Multispectral", "Multispectral")
)

# Create a sample 4-band RGBA raster
create_sample_raster <- function(size = 100) {
  red <- matrix(runif(size^2, 0, 1), nrow = size)
  green <- matrix(runif(size^2, 0, 1), nrow = size)
  blue <- matrix(runif(size^2, 0, 1), nrow = size)
  alpha <- matrix(rep(255, size^2), nrow = size)
  
  r <- rast(red)
  g <- rast(green)
  b <- rast(blue)
  a <- rast(alpha)
  
  rgba <- c(r, g, b, a)
  names(rgba) <- c("Red", "Green", "Blue", "Alpha")
  
  return(rgba)
}

set.seed(145)
raster_rgb <- create_sample_raster()
names(raster_rgb) <- c("Red", "Green", "Blue", "Alpha")



input <- list()
input$rgbIndices <- c("BI", "BIM", "GLI")
input$numCores <- availableCores() / 2

p <- wrap(raster_rgb)
future::plan(future::multicore, workers = input$numCores)

raster_indices_rgb <- future.apply::future_lapply(input$rgbIndices, function(idx) {
  idx_eq <- indices_equations$eq[indices_equations$index == idx]
  
  # Create function dynamically and set its environment
  idx_function <- eval(parse(text = paste0("function(Red, Green, Blue, Alpha) { return(", idx_eq, ") }")))
 
  x <- terra::unwrap(p)
  raster_idx <- terra::lapp(x, fun = idx_function, usenames = TRUE)
  names(raster_idx) <- idx
  
  return(setNames(list(raster_idx), idx))
})

raster_indices_rgb <- do.call(c, raster_indices_rgb)

future::plan(future::sequential)
plot(raster_indices_rgb$BIM)

As I said, my code works fine on my laptop. But when I go to the high performance cluster, I get the following error:

    Error in .Call(list(name = "CppField__get", address = <pointer: (nil)>,  : 
  NULL value passed as symbol address
发布评论

评论列表(0)

  1. 暂无评论