Skip to content

Instantly share code, notes, and snippets.

@brucemcpherson
Created August 15, 2012 09:13
Show Gist options
  • Save brucemcpherson/3357942 to your computer and use it in GitHub Desktop.
Save brucemcpherson/3357942 to your computer and use it in GitHub Desktop.
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)
' http://www.statmethods.net/management/reshape.html
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
ws.Cells.ClearContents
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':'" & ActiveSheet.name & "'," & _
"'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
@brucemcpherson
Copy link
Author

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment