Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
Basic Implementation of r-melt for Excel/VBA
Option Explicit
Public Function reshapeMelt(options As String) As cDataSet
' this is a very basic start at vba implementation of Hadley Wickhams melt(R)
Dim jArgs As cJobject, ds As cDataSet, cj As cJobject, _
R As Range, ws As Worksheet, dr As cDataRow, dsOut As cDataSet, _
dc As cCell, dsre As cDataSet
' sort out the options
Set jArgs = optionsExtend(options, rOptionDefaults)
' check for argument programming syntax error
Debug.Assert Not jArgs Is Nothing
With jArgs
If .toString("inputsheet") = .toString("outputsheet") Then
MsgBox ("Reading and writing to the same sheet - not allowed")
Exit Function
End If
End With
' read input sheet
Set ds = New cDataSet
If ds.populateData _
(wholeSheet(jArgs.toString("inputsheet")), , , , , , True) Is Nothing Then
Exit Function
End If
' check we have everything we need
With jArgs
For Each cj In .child("id").children
If Not ds.headingRow.validate(.cValue("complain"), cj.toString) Then
Exit Function
End If
Next cj
' check if output sheet exists?
Set ws = sheetExists(.toString("outputSheet"), .cValue("complain"))
If ws Is Nothing Then
Exit Function
End If
' good to go
Set R = ws.Cells(1, 1)
If .cValue("clearContents") Then
End If
' make headings
For Each cj In .child("id").children
R.value = cj.value
Set R = R.Offset(, 1)
Next cj
R.value = .toString("variableColumn")
R.Offset(, 1).value = .toString("valueColumn")
' lets get that in a dataset for abstracted column access
Set dsOut = New cDataSet
dsOut.populateData ws.Cells.Resize(1, R.column + 1)
' now data
Set R = dsOut.headingRow.Where.Offset(1).Resize(1, 1)
For Each dr In ds.rows
For Each dc In dr.columns
' need to generate a new row for each non ID cell
If .child("id").valueIndex _
(ds.headings(dc.column).toString) = 0 Then
' the id fields
For Each cj In .child("id").children
R.Offset(, dsOut.headingRow.exists(cj.toString).column - 1).value = dr.value(cj.toString)
Next cj
' this variable value
R.Offset(, _
dsOut.headingRow.exists(.toString("valueColumn")).column - 1).value _
= dc.value
' and its name
R.Offset(, _
dsOut.headingRow.exists(.toString("variableColumn")).column - 1).value _
= ds.headings(dc.column).value
Set R = R.Offset(1)
End If
Next dc
Next dr
End With
' send back what we just did
Set dsre = New cDataSet
Set reshapeMelt = dsre.populateData(dsOut.headingRow.Where.Resize(R.row - 1))
End Function
Public Function rOptionDefaults() As String
' this sets up the defaults for all R related stuff
rOptionDefaults = _
"{'complain':true, 'inputSheet':'" & & "'," & _
"'variableColumn' : 'variable', 'valueColumn' : 'value', 'id':['id'] ," & _
"'outputSheet': 'rOutputData' , 'clearContents':true}"
End Function
Option Explicit
Public Sub testMelt()
reshapeMelt "{'outputSheet':'meltOut','id':['id','time']}"
End Sub

This comment has been minimized.

Copy link
Owner Author

brucemcpherson commented Aug 15, 2012

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.