CODEWITHSUNDEEP
vb6
Sumayyah Patel
Sumayyah Patel

Reputation: 21

Using sparse matrices in VB

I'm working on a least squares program in Visual Basic that requires me to process 44000 points to find an overdetermined solution. I am using a linear algebra matrix that accepts 2D arrays as double matrices.It allows me to invert, transpose and carry out basic matrix calculations. the problem is that the program keeps crashing when i input more that 3000 points. I think it has to do with the fact that i have zero's in my A (design) matrix. I know that using a sparse matrix will help me out by removing the columns and rows that contain zero's, but i have no idea as to how i should implement this within my program. can anybody help me figure out how to use sparse matrices with the current Linear algebra library i am using or what code i can you to allow my program to process 44000 points without crashing? I'm on a time limit and help would be much appreciated. Thanks S.P

Upvotes: 2

Views: 591

Answers (2)

wqw
wqw

Reputation: 11991

Here is a quick&dirty sparse matrix class implemented with arrays. Const CHUNK_SIZE controls the "sparseness" of the martix. Array reallocations are happening on power of 2 boundaries. Only positive indexes are supported.

Option Explicit
DefObj A-Z

Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dst As Any, src As Any, ByVal nBytes As Long)

Private Const CHUNK_SIZE                As Long = 100

Private Type UcsColChunk
    ColValue()                      As Double
End Type

Private Type UcsRowValue
    ColChunk()                      As UcsColChunk
End Type

Private Type UcsRowChunk
    RowValue()                      As UcsRowValue
End Type

Private m_uRowChunks() As UcsRowChunk

Property Get Cell(ByVal lRow As Long, ByVal lCol As Long) As Double
    On Error Resume Next
    Cell = m_uRowChunks(lRow \ CHUNK_SIZE).RowValue(lRow Mod CHUNK_SIZE).ColChunk(lCol \ CHUNK_SIZE).ColValue(lCol Mod CHUNK_SIZE)
End Property

Property Let Cell(ByVal lRow As Long, ByVal lCol As Long, ByVal dblValue As Double)
    If pvPeek(ArrPtr(m_uRowChunks)) = 0 Then
        ReDim m_uRowChunks(0 To pvCalcSize(lRow \ CHUNK_SIZE)) As UcsRowChunk
    ElseIf UBound(m_uRowChunks) < lRow \ CHUNK_SIZE Then
        ReDim Preserve m_uRowChunks(0 To pvCalcSize(lRow \ CHUNK_SIZE)) As UcsRowChunk
    End If
    With m_uRowChunks(lRow \ CHUNK_SIZE)
        If pvPeek(ArrPtr(.RowValue)) = 0 Then
            ReDim .RowValue(0 To CHUNK_SIZE - 1) As UcsRowValue
        End If
        With .RowValue(lRow Mod CHUNK_SIZE)
            If pvPeek(ArrPtr(.ColChunk)) = 0 Then
                ReDim .ColChunk(0 To pvCalcSize(lCol \ CHUNK_SIZE)) As UcsColChunk
            ElseIf UBound(.ColChunk) < lCol \ CHUNK_SIZE Then
                ReDim Preserve .ColChunk(0 To pvCalcSize(lCol \ CHUNK_SIZE)) As UcsColChunk
            End If
            With .ColChunk(lCol \ CHUNK_SIZE)
                If pvPeek(ArrPtr(.ColValue)) = 0 Then
                    ReDim .ColValue(0 To CHUNK_SIZE - 1) As Double
                End If
                .ColValue(lCol Mod CHUNK_SIZE) = dblValue
            End With
        End With
    End With
End Property

Private Function pvCalcSize(ByVal lSize As Long) As Long
    pvCalcSize = 2 ^ (Int(Log(lSize + 1) / Log(2)) + 1) - 1
End Function

Private Function pvPeek(ByVal lPtr As Long) As Long
    Call CopyMemory(pvPeek, ByVal lPtr, 4)
End Function

Upvotes: 1

Shane Wealti
Shane Wealti

Reputation: 2342

Try something like this in your own sparse matrix class (from here: Sparse Matrix Class Demo).

Private m_RowCollection As New Collection

'Returns the cell value for the given row and column
Public Property Get Cell(nRow As Integer, nCol As Integer)
    Dim ColCollection As Collection
    Dim value As Variant

    On Error Resume Next
    Set ColCollection = m_RowCollection(CStr(nRow))
    'Return empty value if row doesn't exist
    If Err Then Exit Property
    value = ColCollection(CStr(nCol))
    'Return empty value is column doesn't exist
    If Err Then Exit Property
    'Else return cell value
    Cell = value
End Property

'Sets the cell value for the given row and column
Public Property Let Cell(nRow As Integer, nCol As Integer, value As Variant)
    Dim ColCollection As Collection

    On Error Resume Next
    Set ColCollection = m_RowCollection(CStr(nRow))
    'Add row if it doesn't exist
    If Err Then
        Set ColCollection = New Collection
        m_RowCollection.Add ColCollection, CStr(nRow)
    End If
    'Remove cell if it already exists (errors ignored)
    ColCollection.Remove CStr(nCol)
    'Add new value
    ColCollection.Add value, CStr(nCol)
End Property

Upvotes: 1

Related Questions