如何用更高效的方式替换R语言中的多层嵌套for循环？

Absolutely, you can replace those nested for loops with more efficient vectorized operations or functions like lapply/purrr::map to drastically speed up your large dataframe processing. Let's walk through how to refactor your code while preserving all your original logic.

Why Your Current Loops Are Slow #

Your nested loops (names → place → class) create unnecessary overhead that slows down processing, especially with large datasets:

• Each filter() call inside loops generates temporary dataframes, which is inefficient and repetitive.
• R loops have higher per-iteration overhead compared to vectorized operations or grouped dplyr workflows.
• You're repeating the same data queries (like pulling Cu.No..Of.Emp or Sh.fact) multiple times instead of precomputing them once.

Step-by-Step Refactoring #

First, we'll preprocess your data to eliminate repeated lookups and streamline access to key values:

library(dplyr)
library(purrr)
library(tidyr)

# Precompute a lookup table for employee counts and shift factors
cu_emp_lookup <- databackend3 %>%
  select(Names, Cu.No.Of.Emp, Sh.fact) %>%
  mutate(
    n_cu = ifelse(is.na(Cu.No.Of.Emp) | Cu.No.Of.Emp == 0, 0, Cu.No.Of.Emp),
    n_cu_norm_fact = ifelse(is.na(Cu.No.Of.Emp) | Cu.No.Of.Emp == 0, 1, Cu.No.Of.Emp)
  )

# Combine core datasets to avoid repeated filtering across loops
combined_data <- databackend2 %>%
  left_join(
    databackend3 %>% select(Places, Names, Cu.Stage, One.Target.Stage, Two.Target.Stage),
    by = c("Places", "Names")
  )

Next, we'll replace the outer names loop with purrr::map (a cleaner alternative to lapply). We'll create a function that processes a single name, then apply it to all unique names:

process_single_name <- function(name) {
  # Pull precomputed values for the current name
  name_meta <- cu_emp_lookup %>% filter(Names == name) %>% slice(1)
  n_cu <- name_meta$n_cu
  n_cu_norm_fact <- name_meta$n_cu_norm_fact
  sh_fact_names <- name_meta$Sh.fact
  
  # Calculate sum of Final.Work for current stage (no place loop needed)
  sum_of_cu_work_names <- combined_data %>%
    filter(Names == name, d_stage == Cu.Stage) %>%
    pull(Final.Work) %>%
    sum(na.rm = TRUE)
  sum_of_cu_work_names <- ifelse(n_cu == 0, 1, sum_of_cu_work_names)
  
  # Process all places in one grouped operation
  place_data <- combined_data %>%
    filter(Names == name) %>%
    group_by(Places) %>%
    mutate(
      # Extract target stage data for each place
      target_one = list(filter(cur_data(), d_stage == One.Target.Stage)),
      target_two = list(filter(cur_data(), d_stage == Two.Target.Stage)),
      cu_work = list(filter(cur_data(), d_stage == Cu.Stage) %>% select(Class, Final.Work))
    ) %>%
    ungroup() %>%
    # Expand target data into rows
    unnest(target_one, names_sep = "_one") %>%
    unnest(target_two, names_sep = "_two") %>%
    left_join(., cu_work %>% rename(Cu.Work = Final.Work), by = "Class") %>%
    # Compute initial normalized work values
    mutate(
      work_norm_one = Final.Work_one / sum_of_cu_work_names,
      work_norm_two = Final.Work_two / sum_of_cu_work_names
    )
  
  # Apply class-level adjustments (vectorized, no loop!)
  adjusted_data <- place_data %>%
    filter(!is.na(Parent_one)) %>%
    left_join(cu_emp_lookup, by = c("Parent_one" = "Names")) %>%
    rename(
      n_source_names = Cu.No.Of.Emp,
      sh_fact_source = Sh.fact
    ) %>%
    mutate(
      n_source_names = ifelse(n_source_names == 0, 1, n_source_names),
      # Calculate sum of work for parent names
      sum_cu_work_parent = map_dbl(Parent_one, ~{
        combined_data %>%
          filter(Names == ., d_stage == Cu.Stage) %>%
          pull(Final.Work) %>%
          sum(na.rm = TRUE)
      }),
      # Update normalized work values
      work_norm_one = (n_source_names / sh_fact_source) * (Final.Work_one / sum_cu_work_parent) / (n_cu_norm_fact / sh_fact_names),
      work_norm_two = (n_source_names / sh_fact_source) * (Final.Work_two / sum_cu_work_parent) / (n_cu_norm_fact / sh_fact_names)
    )
  
  # Combine adjusted and unadjusted rows for target one
  df_names_one <- bind_rows(
    place_data %>% filter(is.na(Parent_one)),
    adjusted_data %>% select(all_of(names(place_data)), work_norm_one)
  ) %>%
    select(Class_one, Places, Names, Final.Work_one, Cu.Work, work_norm_one) %>%
    rename(Class = Class_one, Final.Work = Final.Work_one)
  
  # Combine adjusted and unadjusted rows for target two
  df_names_two <- bind_rows(
    place_data %>% filter(is.na(Parent_two)),
    adjusted_data %>% select(all_of(names(place_data)), work_norm_two)
  ) %>%
    select(Class_two, Places, Names, Final.Work_two, Cu.Work, work_norm_two) %>%
    rename(Class = Class_two, Final.Work = Final.Work_two)
  
  # Write output files
  write.csv2(df_names_one, file = paste0("debugging\\one\\", name, ".csv"), row.names = FALSE)
  write.csv2(df_names_two, file = paste0("debugging\\bl\\", name, ".csv"), row.names = FALSE)
  
  # Calculate summary values for n_emp_df
  sum_work_one <- df_names_one %>% pull(work_norm_one) %>% sum(na.rm = TRUE)
  sum_work_two <- df_names_two %>% pull(work_norm_two) %>% sum(na.rm = TRUE)
  
  tibble(
    names = name,
    n_cu = n_cu,
    n_target_one = ifelse(n_cu > 0, sum_work_one * n_cu, sum_work_one),
    n_target_two = ifelse(n_cu > 0, sum_work_two * n_cu, sum_work_two)
  )
}

# Apply function to all unique names
all_names <- unique(combined_data$Names)
n_emp_updates <- map_dfr(all_names, process_single_name)

# Update your original n_emp_df
n_emp_df <- n_emp_df %>%
  left_join(n_emp_updates, by = "names") %>%
  mutate(
    n_cu = coalesce(n_cu.y, n_cu.x),
    n_target_one = coalesce(n_target_one.y, n_target_one.x),
    n_target_two = coalesce(n_target_two.y, n_target_two.x)
  ) %>%
  select(-ends_with(".x"), -ends_with(".y"))

Key Optimizations Explained #

• Precomputed Lookups: The cu_emp_lookup table stores values we need repeatedly, eliminating redundant filter() calls.
• Grouped Operations: Instead of looping over places, we use group_by to process all places in one go, leveraging dplyr's optimized C++ backend.
• Vectorized Class Adjustments: We replace the inner class loop with a left_join and mutate, which handles all class-level calculations in a single pass.
• purrr::map: The outer loop is replaced with map_dfr, which efficiently processes each name and binds results into a dataframe without manual row binding.

Additional Speed Tips #

• For extremely large datasets, switch to data.table — it's optimized for fast joins and grouped operations.
• Use vroom::vroom_write instead of write.csv2 for faster file output.
• Profile your code with profvis to identify any remaining bottlenecks.

内容的提问来源于stack exchange，提问作者math_ist