bugfix for melt when measure.vars is a named list of length=1 (#5112)

tdhock · web-flow · commit 457fe7b4213a · 2021-08-26T10:38:22.000-06:00
diff --git a/NEWS.md b/NEWS.md
@@ -56,7 +56,7 @@
 
 8. `melt()` now supports `NA` entries when specifying a list of `measure.vars`, which translate into runs of missing values in the output. Useful for melting wide data with some missing columns, [#4027](https://github.com/Rdatatable/data.table/issues/4027). Thanks to @vspinu for reporting, and @tdhock for implementing.
 
-9. `melt()` now supports multiple output variable columns via the `variable_table` attribute of `measure.vars`, [#3396](https://github.com/Rdatatable/data.table/issues/3396) [#2575](https://github.com/Rdatatable/data.table/issues/2575) [#2551](https://github.com/Rdatatable/data.table/issues/2551), [#4998](https://github.com/Rdatatable/data.table/issues/4998). It should be a `data.table` with one row that describes each element of the `measure.vars` vector(s). These data/columns are copied to the output instead of the usual variable column. This is backwards compatible since the previous behavior (one output variable column) is used when there is no `variable_table`. New functions `measure()` and `measurev()` which use either a separator or a regex to create a `measure.vars` list/vector with `variable_table` attribute; useful for melting data that has several distinct pieces of information encoded in each column name. See new `?measure` and new section in reshape vignette. Thanks to Matthias Gomolka, Ananda Mahto, Hugh Parsonage, Mark Fairbanks for reporting, and to @tdhock for implementing.
+9. `melt()` now supports multiple output variable columns via the `variable_table` attribute of `measure.vars`, [#3396](https://github.com/Rdatatable/data.table/issues/3396) [#2575](https://github.com/Rdatatable/data.table/issues/2575) [#2551](https://github.com/Rdatatable/data.table/issues/2551), [#4998](https://github.com/Rdatatable/data.table/issues/4998). It should be a `data.table` with one row that describes each element of the `measure.vars` vector(s). These data/columns are copied to the output instead of the usual variable column. This is backwards compatible since the previous behavior (one output variable column) is used when there is no `variable_table`. New functions `measure()` and `measurev()` which use either a separator or a regex to create a `measure.vars` list/vector with `variable_table` attribute; useful for melting data that has several distinct pieces of information encoded in each column name. See new `?measure` and new section in reshape vignette. Thanks to Matthias Gomolka, Ananda Mahto, Hugh Parsonage, Mark Fairbanks for reporting, and to Toby Dylon Hocking for implementing. Thanks to @keatingw for testing before release, requesting `measure()` accept single groups too [#5065](https://github.com/Rdatatable/data.table/issues/5065), and Toby for implementing.
 
 10. A new interface for _programming on data.table_ has been added, closing [#2655](https://github.com/Rdatatable/data.table/issues/2655) and many other linked issues. It is built using base R's `substitute`-like interface via a new `env` argument to `[.data.table`. For details see the new vignette *programming on data.table*, and the new `?substitute2` manual page. Thanks to numerous users for filing requests, and Jan Gorecki for implementing.
 
diff --git a/R/fmelt.R b/R/fmelt.R
@@ -60,7 +60,7 @@ measure = function(..., sep="_", pattern, cols, multiple.keyword="value.name") {
       stopf("each ... argument to measure must be a function with at least one argument, problem: %s", names(fun.list)[[fun.i]])
     }
     fun.list[[fun.i]] = fun
-  }  
+  }
   measurev.args = c(
     list(fun.list),
     L[formal.i.vec],
@@ -185,7 +185,7 @@ measurev = function(fun.list, sep="_", pattern, cols, multiple.keyword="value.na
   } else {# single output column.
     structure(measure.vec, variable_table=group.dt)
   }
-}  
+}
 
 melt.data.table = function(data, id.vars, measure.vars, variable.name = "variable",
        value.name = "value", ..., na.rm = FALSE, variable.factor = TRUE, value.factor = FALSE,
@@ -200,11 +200,11 @@ melt.data.table = function(data, id.vars, measure.vars, variable.name = "variabl
       measure.vars = eval.result
     }
   }
-  if (is.list(measure.vars) && length(measure.vars) > 1L) {
+  if (is.list(measure.vars)) {
     meas.nm = names(measure.vars)
     if (is.null(meas.nm)) {
       # user-provided or default stub
-      if (length(value.name) == 1L) {
+      if (length(value.name) == 1L && length(measure.vars) > 1L) {
         value.name = paste0(value.name, seq_along(measure.vars))
       }
     } else {
diff --git a/inst/tests/tests.Rraw b/inst/tests/tests.Rraw
@@ -17643,7 +17643,8 @@ DTid = data.table(DT.wide, id=1)
 exid = data.table(id=1, expected)
 test(2182.3, melt(DTid, measure.vars=list(a=c(NA,1), b=2:3), id.vars="id"), exid)
 test(2182.4, melt(DTid, measure.vars=list(a=c(NA,"a2"), b=c("b1","b2")), id.vars="id"), exid)
-test(2182.5, melt(DT.wide, measure.vars=list(a=c(NA,1), b=2:3), na.rm=TRUE)[, .(a, b)], data.table(a=2, b=2))#not testing variable because it is not computed correctly, #4455
+test(2182.5, melt(DT.wide, measure.vars=list(a=c(NA,1), b=2:3), na.rm=TRUE), data.table(variable=factor(2), a=2, b=2))
+test(2182.6, melt(DT.wide, measure.vars=list(b=c("b1","b2"))), data.table(a2=2, variable=factor(c("b1","b2")), b=c(1,2))) # measure.vars named list length=1, #5065
 
 ### First block testing measurev
 # new variable_table attribute for measure.vars, PR#4731 for multiple issues

Original file line number	Diff line number	Diff line change
`@@ -60,7 +60,7 @@ measure = function(..., sep="_", pattern, cols, multiple.keyword="value.name") {`
`60`	`60`	`stopf("each ... argument to measure must be a function with at least one argument, problem: %s", names(fun.list)[[fun.i]])`
`61`	`61`	`}`
`62`	`62`	`fun.list[[fun.i]] = fun`
`63`		`- }`
	`63`	`+ }`
`64`	`64`	`measurev.args = c(`
`65`	`65`	`list(fun.list),`
`66`	`66`	`L[formal.i.vec],`
`@@ -185,7 +185,7 @@ measurev = function(fun.list, sep="_", pattern, cols, multiple.keyword="value.na`
`185`	`185`	`} else {# single output column.`
`186`	`186`	`structure(measure.vec, variable_table=group.dt)`
`187`	`187`	`}`
`188`		`-}`
	`188`	`+}`
`189`	`189`
`190`	`190`	`melt.data.table = function(data, id.vars, measure.vars, variable.name = "variable",`
`191`	`191`	`value.name = "value", ..., na.rm = FALSE, variable.factor = TRUE, value.factor = FALSE,`
`@@ -200,11 +200,11 @@ melt.data.table = function(data, id.vars, measure.vars, variable.name = "variabl`
`200`	`200`	`measure.vars = eval.result`
`201`	`201`	`}`
`202`	`202`	`}`
`203`		`- if (is.list(measure.vars) && length(measure.vars) > 1L) {`
	`203`	`+ if (is.list(measure.vars)) {`
`204`	`204`	`meas.nm = names(measure.vars)`
`205`	`205`	`if (is.null(meas.nm)) {`
`206`	`206`	`# user-provided or default stub`
`207`		`- if (length(value.name) == 1L) {`
	`207`	`+ if (length(value.name) == 1L && length(measure.vars) > 1L) {`
`208`	`208`	`value.name = paste0(value.name, seq_along(measure.vars))`
`209`	`209`	`}`
`210`	`210`	`} else {`