Refactor helper function issue #6702 (Refactored duplicated logic in setDT and [,:=])

.github/workflows/ci-cd.yml

@@ -0,0 +1,32 @@
+name: R Project CI/CD
+
+on:
+  push:
+    branches:
+      - main
+      - setup-github-actions
+  pull_request:
+    branches:
+      - main
+
+jobs:
+  build:
+    runs-on: ubuntu-latest
+
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v3
+
+      - name: Set up R
+        uses: r-lib/actions/setup-r@v2
+        with:
+          r-version: devel
+
+      - name: Install dependencies
+        run: |
+          install.packages("devtools")
+          devtools::install_deps(dependencies = TRUE)
+
+      - name: Run tests
+        run: |
+          R CMD check --as-cran

.github/workflows/performance-tests.yml

@@ -20,4 +20,13 @@ jobs:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
       repo_token: ${{ secrets.GITHUB_TOKEN }}
     steps:
-      - uses: Anirban166/[email protected]
+      - name: Checkout code
+        uses: actions/checkout@v4
+        with:
+          ref: refactor-helper-function-issue-6702
+      - run: |
+          echo "Current branch:"
+          git branch
+          echo "Listing all branches:"
+          git branch -a
+      - uses: Anirban166/[email protected]

.github/workflows/test-coverage.yaml

@@ -4,6 +4,9 @@ on:
   push:
     branches: [master]
   pull_request:
+    branches:
+      - master
+      - refactor-helper-function-issue-6702  # Ensure this branch exists
 
 name: test-coverage.yaml
 
@@ -21,7 +24,7 @@ jobs:
       - uses: r-lib/actions/setup-r@v2
         with:
           use-public-rspm: true
-          r-version: '4.3' # TODO(r-lib/covr#567): Go back to using r-devel
+          r-version: '4.3' # TODO: Go back to using r-devel
 
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
@@ -51,4 +54,4 @@ jobs:
         uses: actions/upload-artifact@v4
         with:
           name: coverage-test-failures
-          path: ${{ runner.temp }}/package
+          path: ${{ runner.temp }}/package

R/data.table.R

@@ -22,6 +22,26 @@ methods::setPackageName("data.table",.global)
 is.data.table = function(x) inherits(x, "data.table")
 is.ff = function(x) inherits(x, "ff")  # define this in data.table so that we don't have to require(ff), but if user is using ff we'd like it to work
 
+# Helper function to process assignment operations in lists or environments.
+# Used internally for efficient recursive assignments in data.table.
+
+process_assignment <- function(name, x, parent_env) {
+  k = eval(name[[2L]], parent_env, parent_env)
+  if (is.list(k)) {
+    origj = j = if (name[[1L]] == "$") as.character(name[[3L]]) else eval(name[[3L]], parent_env, parent_env)
+    if (is.character(j)) {
+      if (length(j) != 1L)
+        stopf("Cannot assign to an under-allocated recursively indexed list -- L[[i]][,:=] syntax is only valid when i is length 1, but its length is %d", length(j))
+      j = match(j, names(k))
+      if (is.na(j))
+        stopf("Item '%s' not found in names of input list", origj)
+    }
+    .Call(Csetlistelt, k, as.integer(j), x)
+  } else if (is.environment(k) && exists(as.character(name[[3L]]), k)) {
+    assign(as.character(name[[3L]]), x, k, inherits = FALSE)
+  }
+}
+
 #NCOL = function(x) {
 #    # copied from base, but additionally covers data.table via is.list()
 #    # because NCOL in base explicitly tests using is.data.frame()
@@ -1214,22 +1234,9 @@ replace_dot_alias = function(e) {
             setalloccol(x, n, verbose=verbose)   # always assigns to calling scope; i.e. this scope
             if (is.name(name)) {
               assign(as.character(name),x,parent.frame(),inherits=TRUE)
-            } else if (.is_simple_extraction(name)) { # TODO(#6702): use a helper here as the code is very similar to setDT().
-              k = eval(name[[2L]], parent.frame(), parent.frame())
-              if (is.list(k)) {
-                origj = j = if (name[[1L]] == "$") as.character(name[[3L]]) else eval(name[[3L]], parent.frame(), parent.frame())
-                if (is.character(j)) {
-                  if (length(j)!=1L) stopf("Cannot assign to an under-allocated recursively indexed list -- L[[i]][,:=] syntax is only valid when i is length 1, but its length is %d", length(j))
-                  j = match(j, names(k))
-                  if (is.na(j)) internal_error("item '%s' not found in names of list", origj) # nocov
-                }
-                .Call(Csetlistelt,k,as.integer(j), x)
-              } else if (is.environment(k) && exists(as.character(name[[3L]]), k)) {
-                assign(as.character(name[[3L]]), x, k, inherits=FALSE)
-              } else if (isS4(k)) {
-                .Call(CsetS4elt, k, as.character(name[[3L]]), x)
-              }
-            } # TO DO: else if env$<- or list$<-
+            } else if (name %iscall% c('$', '[[') && is.name(name[[2L]])) {
+            process_assignment(name, x, parent.frame())
+            }
           }
         }
       }
@@ -2962,25 +2969,13 @@ setDT = function(x, keep.rownames=FALSE, key=NULL, check.names=FALSE) {
   if (is.name(name)) {
     name = as.character(name)
     assign(name, x, parent.frame(), inherits=TRUE)
-  } else if (.is_simple_extraction(name)) {
-    # common case is call from 'lapply()'
-    k = eval(name[[2L]], parent.frame(), parent.frame())
-    if (is.list(k)) {
-      origj = j = if (name[[1L]] == "$") as.character(name[[3L]]) else eval(name[[3L]], parent.frame(), parent.frame())
-      if (length(j) == 1L) {
-        if (is.character(j)) {
-          j = match(j, names(k))
-          if (is.na(j))
-            stopf("Item '%s' not found in names of input list", origj)
-        }
-      }
-      .Call(Csetlistelt, k, as.integer(j), x)
-    } else if (is.environment(k) && exists(as.character(name[[3L]]), k)) {
-      assign(as.character(name[[3L]]), x, k, inherits=FALSE)
-    } else if (isS4(k)) {
+  } else if (name %iscall% c('$', '[[') && is.name(name[[2L]])) {
+   process_assignment(name, x, parent.frame())
+  }
+  else if (isS4(k)) {
       .Call(CsetS4elt, k, as.character(name[[3L]]), x)
     }
-  } else if (name %iscall% "get") { # #6725
+     else if (name %iscall% "get") { # #6725
     # edit 'get(nm, env)' call to be 'assign(nm, x, envir=env)'
     name = match.call(get, name)
     name[[1L]] = quote(assign)

R/fmelt.R

@@ -182,6 +182,12 @@ melt.data.table = function(data, id.vars, measure.vars, variable.name = "variabl
        value.name = "value", ..., na.rm = FALSE, variable.factor = TRUE, value.factor = FALSE,
        verbose = getOption("datatable.verbose")) {
   if (!is.data.table(data)) stopf("'data' must be a data.table")
+
+  # Validate id.vars
+  if (any(is.na(id.vars) | !nzchar(id.vars))) {
+    stopf("One or more values in 'id.vars' is invalid.")
+  }
+
   if (missing(id.vars)) id.vars=NULL
   if (missing(measure.vars)) measure.vars = NULL
   measure.sub = substitute(measure.vars)

inst/tests/tests.Rraw

@@ -3295,7 +3295,7 @@ test(1034, as.data.table(x<-as.character(sample(letters, 5))), data.table(V1=x))
   test(1035.291, melt(dt, measure.vars=NA_integer_, id.vars=NULL), error="One or more values in 'measure.vars'")
   test(1035.30, melt(dt, id.vars=NA_integer_), error="One or more values in 'id.vars'")
   test(1035.31, melt(dt, measure.vars=NA_character_), error="One or more values in 'measure.vars'")
-  test(1035.32, melt(dt, id.vars=NA_character_), error="One or more values in 'id.vars'")
+  test(1035.32, melt(dt, id.vars=NA_character_), error="One or more values in 'id.vars' is invalid.")
 
   if (test_R.utils) {
     # dup names in variable used to generate malformed factor error and/or segfault, #1754;  was test 1570