I'm stumped... I'm trying to get the hang of splitting up calculations in tasks to speed up the program. That seems to work fine for small pieces of code, but I'm failing miserably when it gets a little more difficult.
Situation:
I have a program that calculates about 1,000 factors in a 5-step process for each factor. I want to split the calculation of those factors up into tasks.
The code that does the trick (but without using Tasks):
Public Overridable Function GetFactor(Gender As Short, Age As Short) As Double Implements IFactor.GetFactor
'Set up the Markov Chain associated with a factor
Me.Markov = New MarkovChain(Gender, Age)
'Set up the payment schedule
Me.Payments = New PaymentsAnnuity(Age, Me.MaxAge)
'Determine the benefits
Me.Benefits = New Benefit(Age, Me.MaxAge)
'Calculate the cash flows
Call Me.CalcCashFlow()
'Calculate the factor and return it
Return Me.CalcFactor()
End Function
That code works fine for one factor. I then have a calculation engine that iterates through all factors and ages
Public Sub RunCalculations(ByVal MinAge As Short, ByVal MaxAge As Short)
'Cycle through all available factors
For iParam As Integer = 0 To Me.Factors.Length - 1
'Fetch the new factor specific parameter set
Dim Param As FactorParameters = Me.Factors(iParam)
'Get a new factor generator of the proper kind. Note that all generators are stored in their corresponding
'FactorParameters "FactorType" value upon creation of the Calculation Engine to allow for easy selection
Dim Generator As IFactor = Me.Generators(Param.FactorType).GetInstance(Me.Assumptions, Param)
'Calculate the factors for both males and females and store them in the Output matrices
For iAge As Short = MinAge To MaxAge
Me.OutputResultsMale(iAge - MinAge, iParam + 1) = Generator.GetFactor(0, iAge)
Me.OutputResultsFemale(iAge - MinAge, iParam + 1) = Generator.GetFactor(1, iAge)
Next iAge
Next iParam
End Sub
The above code runs fine and I get all the factors I asked for, but it takes ages. I therefore tried to generate tasks, one for each factor and have it run on multiple cores. I changed the code in the Sub RunCalculations (most notably the iAge For-loop):
Public Sub RunCalculations(ByVal MinAge As Short, ByVal MaxAge As Short)
'Set up Task matrices to populate the output matrices
Dim aTasksMale(MaxAge - MinAge, Me.Factors.Length) As Task(Of Double)
Dim aTasksFemale(MaxAge - MinAge, Me.Factors.Length) As Task(Of Double)
'Cycle through all available factors
For iParam As Integer = 0 To Me.Factors.Length - 1
'Fetch the new factor specific parameter set
Dim Param As FactorParameters = Me.Factors(iParam)
'Get a new factor generator of the proper kind. Note that all generators are stored in their corresponding
'FactorParameters "FactorType" value upon creation of the Calculation Engine to allow for easy selection
Dim Generator As IFactor = Me.Generators(Param.FactorType).GetInstance(Me.Assumptions, Param)
'Calculate the factors for both males and females and store them in the Task matrices
For iAge As Short = MinAge To MaxAge
'Set up a local variable and set it to the iteration value
'Note: not doing this results in the following Warning: "Using the iteration variable in a lambda expression may have unexpected results.
'Instead, create a local variable within the loop and assign it the value of the iteration variable."
Dim iLoopAge As Short = iAge
'Run the tasks of generating the factors for both males and females
aTasksMale(iLoopAge - MinAge, iParam + 1) = Task.Run(Function() Generator.GetFactor(0, iLoopAge))
aTasksFemale(iLoopAge - MinAge, iParam + 1) = Task.Run(Function() Generator.GetFactor(1, iLoopAge))
Next iAge
Next iParam
'Wait for all tasks to complete
Task.WaitAll()
'Populate the output matrices
For iAge = MinAge To MaxAge
For iFactor = 1 To Me.Factors.Length
'Copy the factors to the output matrices
Me.OutputResultsMale(iAge - MinAge, iFactor) = aTasksMale(iAge - MinAge, iFactor).Result
Me.OutputResultsFemale(iAge - MinAge, iFactor) = aTasksFemale(iAge - MinAge, iFactor).Result
Next iFactor
Next iAge
End Sub
I was hoping (and perhaps even expecting) that would do the trick and speed up the process, but instead I get a weird error I can't seem to fix, especially in the CalcCashFlow and CalcFactor routines. The CalcFactor routine is pretty short and simple:
Friend Overridable Function CalcFactor() As Double
'Set up a double representing the factor
Dim dFactor As Double
'Cycle through all cash flows
For iPeriod As Short = 0 To Me.CashFlow.Length - 1
'Determine the present value of the cash flow and add it to the factor value
dFactor += Me.CashFlow(iPeriod) * Me.Assumptions.Yield.GetPV(iPeriod)
Next iPeriod
'Return the factor
Return dFactor
End Function
I get an IndexOutOfBounds error for the iPeriod loop variable in the CalcFactor routine. When I get the OutOfBounds error I noticed that the iPeriod variable would be (e.g.) 118 whereas the cash flow array holds only 113 values (the values for both the iPeriod variable and the length of the Factor array differ between runs / errors). I don't understand why, because the loop explicitly says iPeriod should only loop until the end of the cash flow array.
When running the 'regular' (slow) program, iPeriod would never get above 113 in that example. But adding it to a Task somehow screws that all up. It looks like the iPeriod loop variable gets mixed up with other tasks or something, so I also tried adding a new local looping variable and setting it to the iPeriod variable, but to no avail.
What am I doing wrong here?
If you need more explanation / code, just let me know.
Fixed with the help of commenters: I used one class instance (Generator) for two simultaneous tasks, which .Net apparently did not appreciate. Changed part of the RunCalculations code to reflect that and added a separate function that always instantiates a new Generator for each calculation:
'Set up Task lists to populate the output matrices
Dim TaskListMale As New List(Of Task(Of Double))
Dim TaskListFemale As New List(Of Task(Of Double))
Dim NextTask As Task(Of Double)
'Cycle through all available factors
For iParam As Short = 0 To Me.Factors.Length - 1
'Fetch the next factor specific parameter set
Dim Param As FactorParameters = Me.Factors(iParam)
'Set up the tasks
For iAge As Short = MinAge To MaxAge
'Set up a local variable and set it to the iteration value
'Note: not doing this results in the following Warning: "Using the iteration variable in a lambda expression may have unexpected results.
'Instead, create a local variable within the loop and assign it the value of the iteration variable."
Dim iLoopAge As Short = iAge
'Calculate the factors for both males and females and add them to the Task lists
NextTask = Task.Run(Function() GenerateFactorAsync(Param, Gender.Male, iLoopAge))
TaskListMale.Add(NextTask)
NextTask = Task.Run(Function() GenerateFactorAsync(Param, Gender.Female, iLoopAge))
TaskListFemale.Add(NextTask)
Next iAge
Next iParam
'Wait for all tasks to complete
Task.WaitAll(TaskListMale.ToArray)
Task.WaitAll(TaskListFemale.ToArray)
'Populate the output matrices from the task lists. For easier reference, a counter variable is used
Dim iTask As Short = 0
For iFactor = 0 To Me.Factors.Length - 1
For iAge = MinAge To MaxAge
'Copy the factors to the output matrices
Me.OutputResultsMale(iAge - MinAge, iFactor + 1) = TaskListMale(iTask).Result
Me.OutputResultsFemale(iAge - MinAge, iFactor + 1) = TaskListFemale(iTask).Result
iTask += 1
Next iAge
Next iFactor
End Sub
Private Function GenerateFactorAsync(ByVal Param As FactorParameters, ByVal Gender As Gender, ByVal Age As Short) As Double
'Get a new factor generator of the proper kind. Note that all generators are stored in their corresponding
'FactorParameters "FactorType" value upon creation of the Calculation Engine to allow for easy selection
Dim Generator As IFactor = Me.Generators(Param.FactorType).GetInstance(Me.Assumptions, Param)
'Calculate the corresponding factor for the gender and age given and return it
Return Generator.GetFactor(Gender.Type, Age)
End Function
It now works as intended
Related
So I have a really huge excel spreadsheet with about 100 thousands rows. Each row represents a client. Each column stores that client's name, debt, probability of default and so on. There are about 12 columns.
In my code, I loop through the rows and store the data for each client as a class object, then add that object to a collection:
Function getClients(dataWorkbook As Workbook)
Dim resultColl As Collection
Set resultColl = New Collection
...
With dataWorkbook.Worksheets(globals("DATA_SHEET"))
For i = firstRow To lastRow
Set clientCopy = New Client
clientCopy.setClientName = .Cells(i, column_names).value
clientCopy.setContractNumber = .Cells(i, column_contract_numbers).value
...
resultColl.Add clientCopy
Next
End With
Set getClients = resultColl
End Function
Then for each client in the collection I calculate the random numbers and store them in a collection for that client (the collection of size N, depending the number a user wants, usually 1000 - 5000).
Then I go through those random numbers of each client and store an outcome in an outcomes collection, depending on the random number's value (if the number is greater than the client's number P, then I store 0, else 1).
Then I calculate a financial result for each client, meaning, I check for each outcome in the outcomes collection and store appropriate values in losses and profits collections, depending if the outcome is 1 or 0.
These methods inside the Client class:
Public Sub generateRandoms()
Set randomNumbers = New Collection
Dim i As Long
For i = 1 To simulationCount
randomNumbers.Add Rnd()
'Debug.Print "random: " & randomNumbers(i)
Next
End Sub
Public Sub calculateOutcomes()
Set outcomes = New Collection
Dim i As Long
If totalPd <> -1 Then
For i = 1 To simulationCount
If randomNumbers(i) < totalPd Then
outcomes.Add 1
Else
outcomes.Add 0
End If
Next
Else
For i = 1 To simulationCount
outcomes.Add Null
Next
End If
End Sub
Public Sub calculateFinancialResult()
Set losses = New Collection
Set profits = New Collection
Dim i As Long
For i = 1 To outcomes.Count
If outcomes(i) = 1 Then
losses.Add totalLoss
profits.Add 0
ElseIf outcomes(i) = 0 Then
losses.Add 0
profits.Add totalProfit
Else
losses.Add Null
profits.Add Null
End If
Next
End Sub
The code in the main module goes like this:
Dim clientsColl As Collection
Set clientsColl = getClients(dataWorkbook)
Dim clientCopy As Client
For Each clientCopy In clientsColl
clientCopy.setSimulationCount = globals("SIMULATION_COUNT")
clientCopy.generateRandoms 'up to this line it's fast
'clientCopy.calculateOutcomes 'this line is slow, so i have to shut excel down
'clientCopy.calculateFinancialResult
clientCopy.clearSums
Next
MsgBox ("Done for")
While the data collection from the data workbook is rather slow, it takes a reasonable enough amount of time. At the same time, the calculations itself are extraordinary slow. I tried to figure out which function or sub takes the most time. So far it looks like calculateOutcomes is pretty slow, while generateRandoms is quite fast and takes less than a minute.
I don't understand why is that so - both of them loop through each client and store data in a collection N times. At the same time the first is fast, while the second is slow. If I don't terminate the excel eventually I encounter an Out of memory error. Why?
Is there anything I can do about this code's performance? Any suggestions are appreciated. What are the general practices in situations like this?
I have a system where I have a list of data from a truck scale reading the weight of a truck on a scale. This data ranges from -30,000lbs or so due to the scale being tared but truckless, to 40,000lbs with a full and tared truck on it. My task is to determine the total weight that has left our facility via truck. The problem is some days only a few trucks leave our facility and others a dozen leave, all with slightly different weights.
The graph of these weights looks like a saw tooth pattern. It is a largely negative value (due to tare), quickly reaches approximately zero as a truck pulls onto the scale, and slowly builds to a final weight. After the final weight is reached the weight quickly goes back to the largely negative value as the truck pulls away.
My idea on how to approach this is look for where the data is less than zero and return the max weight of the sensor between zeros. If the max weight is above some noise filter value (say, 5000lbs) then add the max weight to some counter. In theory, not bad, in practice, a bit out of my league.
Here's my code so far, as I know I need to show my effort so far. I recommend ignoring it as it's mostly just a failed start after a few days of restarting work.
Public Function TruckLoad(rngData As Range)
Dim intCount As Integer
intCount = 0
For Each cell In rngData
intCount = intCount + 1
Next cell
Dim n As Integer
n = 1
Dim x As Integer
x = 1
Dim arr() As Double
For i = 1 To intCount
If rngData(i, 1) < 0 Then
arr(n) = x
n = n + 1
x = x + 1
Else
x = x + 1
End If
Next
TruckLoad = arr(1)
End Function
If anyone could give me advice on how to proceed it would be extremely valuable. I'm not a computer programmer outside of the very basics.
Edit: Sorry, I should have said this initially. I can't post the entirety of the raw sample data but I can post a photo of a graph. There is a degree to which I can't post publicly (not that you can do anything particularly nefarious with the data, it's a corporate rule).
www.imgur.com/a/LGQY9
My understanding of the data is in line with Robin's comment. There are a couple of ways to solve this problem. I've written a function loops through data range looking for the 'next zero' in the data set, and calculates the max value between the current row and the row that the 'next zero' is in. If the max value is above the value of your noise filter, the value will be added to the running total.
Option Explicit
Private Const NOISE_FILTER As Double = 5000
Public Function TruckLoad(rngData As Range) As Double
Dim r As Integer
Dim runningTruckLoad As Double
Dim maxLoadReading As Double
Dim nextZeroRow As Integer
For r = 1 To rngData.Rows.Count
nextZeroRow = FindNextZeroRow(r, rngData)
maxLoadReading = Application.WorksheetFunction.Max(Range(rngData.Cells(r, 1), rngData.Cells(nextZeroRow, 1)))
If maxLoadReading > NOISE_FILTER Then
runningTruckLoad = runningTruckLoad + maxLoadReading
End If
r = nextZeroRow 'skip the loop counter ahead to our new 0 row
Next r
TruckLoad = runningTruckLoad
End Function
Private Function FindNextZeroRow(startRow As Integer, searchRange As Range) As Integer
Dim nextZeroRow As Range
Set nextZeroRow = searchRange.Find(0, searchRange.Rows(startRow))
If nextZeroRow.Row < startRow Then 'we've hit the end of the data range
FindNextZeroRow = startRow
ElseIf nextZeroRow.Value <> 0 Then 'we've found a data point with a zero in it, not interested in this row
FindNextZeroRow = FindNextZeroRow(nextZeroRow.Row, searchRange)
Else
FindNextZeroRow = nextZeroRow.Row 'we've found our next zero data point
End If
End Function
I have a Part class with the fields list in the code below. I have a DataGridView control, which I am filtering with the Advanced DGV (ADGV) DLL from NUGET. I must include the ADGV in my winform. I currently have a DataGridView, a search box on the form, and a button to run the following function. I need to go through all of the visible rows, collect a unique list of part numbers with their most recent revisions, and then color the rows in DataGridView which are out of date by checking the part number and rev on each row against the mostuptodate list. For 45,000 entries displayed in DataGridView, this take ~17 secs. For ~50 entries, it take ~1.2 seconds. This is extremely inefficient, but I can't see a way to cut the time down.
Sub highlightOutdatedParts()
'Purpose: use the results in the datagridview control, find the most recent revision of each part, and
' highlight all outdated parts relative to their respective most recent revisions
'SORT BY PART NUMBER AND THEN BY REV
If resultsGrid.ColumnCount = 0 Or resultsGrid.RowCount = 0 Then Exit Sub
Dim stopwatch As New Stopwatch
stopwatch.Start()
resultsGrid.Sort(resultsGrid.Columns("PartNumber"), ListSortDirection.Ascending)
Dim iBag As New ConcurrentBag(Of Part)
Dim sortedList As Generic.List(Of Part)
For Each row As DataGridViewRow In resultsGrid.Rows
If row.Visible = True Then
Dim iPart As New Part()
Try
iPart.Row = row.Cells(0).Value
iPart.Workbook = CStr(row.Cells(1).Value)
iPart.Worksheet = CStr(row.Cells(2).Value)
iPart.Product = CStr(row.Cells(3).Value)
iPart.PartNumber = CStr(row.Cells(4).Value)
iPart.ItemNo = CStr(row.Cells(5).Value)
iPart.Rev = CStr(row.Cells(6).Value)
iPart.Description = CStr(row.Cells(7).Value)
iPart.Units = CStr(row.Cells(8).Value)
iPart.Type = CStr(row.Cells(9).Value)
iPart.PurchCtgy = CStr(row.Cells(10).Value)
iPart.Qty = CDbl(row.Cells(11).Value)
iPart.TtlPerProd = CDbl(row.Cells(12).Value)
iPart.Hierarchy = CStr(row.Cells(13).Value)
iBag.Add(iPart)
Catch ice As InvalidCastException
Catch nre As NullReferenceException
End Try
End If
Next
sortedList = (From c In iBag Order By c.PartNumber, c.Rev).ToList() ' sort and convert to list
Dim mostUTDRevList As New Generic.List(Of Part) ' list of most up to date parts, by Rev letter
For sl As Integer = sortedList.Count - 1 To 0 Step -1 'start at end of list and work to beginning
Dim query = From entry In mostUTDRevList ' check if part number already exists in most up to date list
Where entry.PartNumber = sortedList(sl).PartNumber
Select entry
If query.Count = 0 Then ' if this part does not already exist in the list, add.
mostUTDRevList.Add(sortedList(sl))
End If
Next
'HIGHLIGHT DATAGRIDVIEW ROWS WHERE PART NUMBERS ARE OUT OF DATE
For Each row As DataGridViewRow In resultsGrid.Rows
' if that part with that Rev does not exist in the list, it must be out of date
Try
Dim rowPN As String = CStr(row.Cells(4).Value).ToUpper ' get part number
Dim rowR As String = CStr(row.Cells(6).Value).ToUpper ' get Rev
Dim query = From entry In mostUTDRevList ' check if that part number with that Rev is in the list.
Where entry.PartNumber.ToUpper.Equals(rowPN) AndAlso
entry.Rev.ToUpper.Equals(rowR)
Select entry
If query.Count = 0 Then ' if the part is out of date highlight its' row
row.DefaultCellStyle.BackColor = Color.Chocolate
End If
Catch ex As NullReferenceException
Catch ice As InvalidCastException
End Try
Next
resultsGrid.Select()
stopwatch.Stop()
If Not BackgroundWorker1.IsBusy() Then timertextbox.Text = stopwatch.Elapsed.TotalSeconds.ToString & " secs"
MessageBox.Show("Highlighting completed successfully.")
End Sub
It is almost always faster to work with the data than the control. The control is simply the means to present a view of the data (in a grid) to the users. Working with the data from there requires too much converting to be effieicent. Then, use the DGV events to highlight the rows
Its hard to tell all the details of what you are doing, but it looks like you are comparing the data to itself (as opposed to some concrete table where the lastest revision codes are defined). Nor is it clear why the datasources are collections, ConcurrentBags etc. The key would be to use collections optimized for the job.
To demonstrate, I have a table with 75,000 rows; the product codes are randomly selected from a pool of 25,000 and a revision code is a random integer (1-9). After the DGV datasource is built (a DataTable) a LookUp is created from the ProductCode-Revision pair. This is done once and once only:
' form level declaration
Private PRCodes As ILookup(Of String, Int32)
' go thru table
' group by the product code
' create an anon Name-Value object for each,
' storing the code and highest rev number
' convert result to a LookUp
PRCodes = dtSample.AsEnumerable.
GroupBy(Function(g) g.Item("ProductCode"),
Function(key, values) New With {.Name = key.ToString(), .Value = values.
Max(Of Int32)(Function(j) j.Field(Of Int32)("RevCode"))
}).
ToLookup(Of String, Int32)(Function(k) k.Name, Function(v) v.Value)
Elapsed time via stopwatch: 81 milliseconds to create the collection of 23731 items. The code uses an anonymous type to store a Max Revision code for each product code. A concrete class could also be used. If you're worried about mixed casing, use .ToLowerInvariant() when creating the LookUp (not ToUpper -- see What's Wrong With Turkey?) and again later when looking up the max rev.
Then rather than looping thru the DGV rows use the RowPrePaint event:
If e.RowIndex = -1 Then Return
If dgv1.Rows(e.RowIndex).IsNewRow Then Return
' .ToLowerInvariant() if the casing can vary row to row
Dim pc = dgv1.Rows(e.RowIndex).Cells("ProductCode").Value.ToString()
Dim rv = Convert.ToInt32(dgv1.Rows(e.RowIndex).Cells("RevCode").Value)
Dim item = PRCodes(pc)(0)
If item > rv Then
dgv1.Rows(e.RowIndex).DefaultCellStyle.BackColor = Color.MistyRose
End If
Notes
It takes some time to create the DataSource, but 75,000 rows is a lot to throw at a user
The time to create the LookUp is minimal - barely measurable
There is no noticeable wait in displaying them because a) the LookUp is made for this sort of thing, b) rows are done as needed when they are displayed. Row # 19,999 may never be processed if the user never scrolls that far.
This is all geared to just color a row. If you needed to save the Current/NotCurrent state for each row, add a Boolean column to the DataTable and loop on that. The column can be invisible if to hide it from the user.
The random data results in 47,000 out of date RevCodes. Processing 75k rows in the DataTable to set the flag takes 591 milliseconds. You would want to do this before you set the DataTable as the DataSource to prevent changes to the data resulting in various events in the control.
In general, the time to harvest the max RevCode flag and even tag the out of date rows is a trivial increment to creating the datasource.
The Result:
The data view is sorted by ProductCode so that the coloring of lower RevCodes is apparent.
We surely cant grok all the details and constraints of the system from a small snippet - even the data types and original datasource are a guess for us. However, this should provide some help with better look-up methods, and the concept of working with the data rather than the user's view.
One thing is the revision code - yours is treating them as a string. If this is alphanumeric, it may well not compare correctly - "9" sorts/compares higher than "834" or "1JW".
See also:
Lookup(Of TKey, TElement) Class
Anonymous Types
The solution was spurred in part by #Plutonix.
Sub highlightOutdatedParts()
If resultsGrid.ColumnCount = 0 Or resultsGrid.RowCount = 0 Then Exit Sub
Dim stopwatch As New Stopwatch
stopwatch.Start()
resultsGrid.DataSource.DefaultView.Sort = "PartNumber ASC, Rev DESC"
resultsGrid.Update()
'HIGHLIGHT DATAGRIDVIEW ROWS WHERE PART NUMBERS ARE OUT OF DATE
Dim irow As Long = 0
Do While irow <= resultsGrid.RowCount - 2
' if that part with that Rev does not exist in the list, it must be out of date
Dim utdPN As String = resultsGrid.Rows(irow).Cells(4).Value.ToString().ToUpper()
Dim utdRev As String = resultsGrid.Rows(irow).Cells(6).Value.ToString().ToUpper()
Dim iirow As Long = irow + 1
'If iirow > resultsGrid.RowCount - 1 Then Exit Do
Dim activePN As String = Nothing
Dim activeRev As String = Nothing
Try
activePN = resultsGrid.Rows(iirow).Cells(4).Value.ToString().ToUpper()
activeRev = resultsGrid.Rows(iirow).Cells(6).Value.ToString().ToUpper()
Catch ex As NullReferenceException
End Try
Do While activePN = utdPN
If iirow > resultsGrid.RowCount - 1 Then Exit Do
If activeRev <> utdRev Then
resultsGrid.Rows(iirow).DefaultCellStyle.BackColor = Color.Chocolate
End If
iirow += 1
Try
activePN = resultsGrid.Rows(iirow).Cells(4).Value.ToString().ToUpper()
activeRev = resultsGrid.Rows(iirow).Cells(6).Value.ToString().ToUpper()
Catch nre As NullReferenceException
Catch aoore As ArgumentOutOfRangeException
End Try
Loop
irow = iirow
Loop
resultsGrid.Select()
stopwatch.Stop()
If Not BackgroundWorker1.IsBusy() Then
timertextbox.Text = stopwatch.Elapsed.TotalSeconds.ToString & " secs"
resultcounttextbox.Text = resultsGrid.RowCount - 1 & " results"
End If
MessageBox.Show("Highlighting completed successfully.")
End Sub
Sub FWP()
Dim i As Integer
Dim j As Integer
Dim n As Integer
n = Range("A1").Value
For i = 1 To n
For j = 1 To n
If Cells(i + 1, j) = 0 Then
Cells(i + 1, j).Value = Int(((n ^ 2) - 1 + 1) * Rnd + 1)
ElseIf Cells(i + 1, j) <> 0 Then
Cells(i + 1, j).Value = Cells(i + 1, j).Value
End If
Next j
Next i
I am trying to do a part of a homework question that asks to fill in missing spaces in a magic square in VBA. It is set up as a (n x n) matrix with n^2 numbers in; the spaces I need to fill are represented by zeros in the matrix. So far I have some code that goes through checking each individual cell value, and will leave the values alone if not 0, and if the value is 0, it replaces them with a random number between 1 and n^2. The issue is that obviously I'm getting some duplicate values, which isn't allowed, there must be only 1 of each number.
How do I code it so that there will be no duplicate numbers appearing in the grid?
I am attempting to put in a check function to see if they are already in the grid but am not sure how to do it
Thanks
There are a lot of approaches you can take, but #CMArg is right in saying that an array or dictionary is a good way of ensuring that you don't have duplicates.
What you want to avoid is a scenario where each cell takes progressively longer to populate. It isn't a problem for a very small square (e.g. 10x10), but very large squares can get ugly. (If your range is 1-100, and all numbers except 31 are already in the table, it's going to take a long time--100 guesses on average, right?--to pull the one unused number. If the range is 1-40000 (200x200), it will take 40000 guesses to fill the last cell.)
So instead of keeping a list of numbers that have already been used, think about how you can effectively go through and "cross-off" the already used numbers, so that each new cell takes exactly 1 "guess" to populate.
Here's one way you might implement it:
Class: SingleRandoms
Option Explicit
Private mUnusedValues As Scripting.Dictionary
Private mUsedValues As Scripting.Dictionary
Private Sub Class_Initialize()
Set mUnusedValues = New Scripting.Dictionary
Set mUsedValues = New Scripting.Dictionary
End Sub
Public Sub GenerateRange(minimumNumber As Long, maximumNumber As Long)
Dim i As Long
With mUnusedValues
.RemoveAll
For i = minimumNumber To maximumNumber
.Add i, i
Next
End With
End Sub
Public Function GetRandom() As Long
Dim i As Long, keyID As Long
Randomize timer
With mUnusedValues
i = .Count
keyID = Int(Rnd * i)
GetRandom = .Keys(keyID)
.Remove GetRandom
End With
mUsedValues.Add GetRandom, GetRandom
End Function
Public Property Get AvailableValues() As Scripting.Dictionary
Set AvailableValues = mUnusedValues
End Property
Public Property Get UsedValues() As Scripting.Dictionary
Set UsedValues = mUsedValues
End Property
Example of the class in action:
Public Sub getRandoms()
Dim r As SingleRandoms
Set r = New SingleRandoms
With r
.GenerateRange 1, 100
Do Until .AvailableValues.Count = 0
Debug.Print .GetRandom()
Loop
End With
End Sub
Using a collection would actually be more memory efficient and faster than using a dictionary, but the dictionary makes it easier to validate that it's doing what it's supposed to do (since you can use .Exists, etc.).
Nobody is going to do your homework for you. You would only be cheating yourself. Shame on them if they do.
I'm not sure how picky your teacher is, but there are many ways to solve this.
You can put the values of the matrix into an array.
Check if a zero value element exists, if not, break.
Then obtain your potential random number for insertion.
Iterate through the array with a for loop checking each element for this value. If it is not present, replace the zero element.
Source of algorithm idea
I took that idea and I am trying to detect if an entire polygon is inside the other polygon. Here is my code that I came up with adding an additional check for X because sometimes it will equal zero and cause a issue.
Public Shared Function ContainsOutsidePoints(ByVal ToBeChecked As Polygon, ByVal CheckAgainst As Polygon) As Boolean
For Each pt As Point In ToBeChecked.Coordinates
If CheckAgainst.Inside(pt) = False Then
Return True
End If
Next
Return False
End Function
Public Function Inside(ByVal Value As Point) As Boolean
Dim j As Integer = Lines.Count - 1
Dim pxi As Double
Dim pxj As Double
Dim pyi As Double
Dim pyj As Double
Inside = False
For i As Integer = 0 To Lines.Count - 1
pxi = Lines.Item(i).EndPointA.X
pxj = Lines.Item(j).EndPointA.X
pyi = Lines.Item(i).EndPointA.Y
pyj = Lines.Item(j).EndPointA.Y
If (pyi < Value.Y AndAlso pyj >= Value.Y OrElse _
pyj < Value.Y AndAlso pyi >= Value.Y) And _
pxi <= Value.X OrElse pxj <= Value.X AndAlso _
pxi <> pxj Then
If (pxi + (Value.Y - pyi) / (pyj - pyi) * (pxj - pxi) < Value.X) Then
Inside = Not Inside
End If
End If
j = i
Next
Return Inside
End Function
When I run it it will sometimes say polygons that I can see are not inside the other when it clearly is and sometimes it will return is inside when not all points are inside the other polygon. Is this caused by adding the additional check of the X since even less statements match the if statement requirements.
The intersection of an horizontal line with the interior of a polygon is a set of 1D intervals.
If P is inside Q, all 1D intervals of P will be wholly inside a corresponding interval of Q.
It suffices to check that this property holds for all horizontals though all vertices of both polygons.
You can do that by considering every vertex in turn, finding the intersections with the horizontals and sorting them left-to-right before checking for inclusion.
You can save operations by using the sweepline paradigm, i.e. scanning the vertices top-to-bottom and maintaining a list of the edges that straddle the current horizontal. This way you know exactly which edge will intersect; the update of the straddling list from vertex to vertex is straightforward.