' ========================================================================================================================
' ____,__, __, ____,_, _, ____ ____,__, ,____,____,
' (-/_|(-| (-| (-|_,(-|\ | (-|__|-/_|( |_/(-|_,(-|__)
' _/ |,_|__,_|__,_|__,_| \|, _|__)/ |,_| \,_|__,_| \,
'
' Copyright � 2008 Allen Baker
'
' ------------------------------------------------------------------------------------------------------------------------
' File: M015_Math
' Originator: Allen Baker (2008.11.23 13:12)
' ------------------------------------------------------------------------------------------------------------------------
' $RCSfile$
' $Revision$
' $Date$
' ========================================================================================================================
'
Option Explicit
' ========================================================================================================================
' Description
' This module provides miscellaneous mathematical routines and functions.
' ========================================================================================================================
Public Const cRoundToNearest As Long = 0
Public Const cRoundUp As Long = 1
Public Const cRoundDown As Long = 2
Private Const cDefaultRelativeEpsilon As Double = 0.000000000001 ' 99.9999999999%
Private Const cDefaultEpsilon As Double = 0.00000000000001
' 12345678901234567890
' =====================================================================================================================
' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<[ Miscellaneous ]>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' =====================================================================================================================
Private mOnBitsSet As Boolean
Private mOnBits(0 To 31) As Long
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This subroutine creates an array of bitwise masks for use by the shiftBits functions.
' -----------------------------------------------------------------------------------------------------------
Private Sub makeOnBits()
If (Not mOnBitsSet) Then
Dim idx As Long
Dim value As Long
For idx = 0 To 30
value = value + (2 ^ idx)
mOnBits(idx) = value
Next idx
mOnBits(idx) = value + &H80000000
mOnBitsSet = True
End If
End Sub
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function shifts a Long value to the left by a specified number of bytes.
'
' return
' a number equal to pValue that has been shifted pNumberOfBytes bytes
'
' param
' pValue is the value that will be shifted
' param
' pNumberOfBytes is the number of byte places pValue will be shifted
' -----------------------------------------------------------------------------------------------------------
Function shiftBytesLeft(pValue As Long, pNumberOfBytes As Long) As Long
shiftBytesLeft = shiftBitsLeft(pValue, pNumberOfBytes * 8)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function shifts a Long value to the right by a specified number of bytes.
'
' return
' a number equal to pValue that has been shifted pNumberOfByte bytes
'
' param
' pValue is the value that will be shifted
' param
' pNumberOfByte is the number of byte places pValue will be shifted
' -----------------------------------------------------------------------------------------------------------
Function shiftBytesRight(pValue As Long, pNumberOfBytes As Long) As Long
shiftBytesRight = shiftBitsRight(pValue, pNumberOfBytes * 8)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function shifts a Long value to the left by a specified number of bits.
'
' return
' a number equal to pValue that has been shifted pNumberOfBits bits
'
' param
' pValue is the value that will be shifted
' param
' pNumberOfBits is the number of bit places pValue will be shifted
' -----------------------------------------------------------------------------------------------------------
Public Function shiftBitsLeft(ByVal pValue As Long, ByVal pNumberOfBits As Long) As Long
shiftBitsLeft = pValue
If pNumberOfBits > 0 Then
makeOnBits
If (shiftBitsLeft And (2 ^ (31 - pNumberOfBits))) Then
shiftBitsLeft = ((shiftBitsLeft And mOnBits(31 - (pNumberOfBits + 1))) * (2 ^ (pNumberOfBits))) Or &H80000000
Else
shiftBitsLeft = ((shiftBitsLeft And mOnBits(31 - pNumberOfBits)) * (2 ^ pNumberOfBits))
End If
End If
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function shifts a Long value to the right by a specified number of bits.
'
' return
' a number equal to pValue that has been shifted pNumberOfBits bits
'
' param
' pValue is the value that will be shifted
' param
' pNumberOfBits is the number of bit places pValue will be shifted
' -----------------------------------------------------------------------------------------------------------
Public Function shiftBitsRight(ByVal pValue As Long, ByVal pNumberOfBits As Long) As Long
Dim i As Byte
shiftBitsRight = pValue
If pNumberOfBits > 0 Then
shiftBitsRight = Int(shiftBitsRight / (2 ^ pNumberOfBits))
End If
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function computes a linear function using the slope intercept form of a line. y = mx + b
'
' return
' this function returns a function value for x
'
' param
' x is the independent variable the the function is computed for
' param
' m is the slope
' param
' b is the y intercept
' -----------------------------------------------------------------------------------------------------------
Public Function linear(x As Double, m As Double, B As Double) As Double
linear = (m * x) + B
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function computes a quadratic function of the form y = ax^2 + bx + c
'
' return
' this function returns a function value for x
'
' param
' x is the independent variable the the function is computed for
' param
' a, b, and c are the coefficients of the terms
' -----------------------------------------------------------------------------------------------------------
Public Function quadratic(x As Double, a As Double, B As Double, C As Double) As Double
quadratic = (a * (x ^ 2)) + (B * x) + C
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function computes a cubic function of the form y = ax^3 + bx^2 + cx + d
'
' return
' this function returns a function value for x
'
' param
' x is the independent variable the the function is computed for
' param
' a, b, c, and d are the coefficients of the terms
' -----------------------------------------------------------------------------------------------------------
Public Function cubic(x As Double, a As Double, B As Double, C As Double, d As Double) As Double
cubic = (a * (x ^ 3)) + (B * (x ^ 2)) + (C * x) + d
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function computes a polynomial function of the form y = [Cn]X^n-1 + ... + [C3]X^2 + [C2]X^1 + [C1]
'
' return
' this function returns a function value for x
'
' param
' x is the independent variable that the function is computed for
' param
' pCoeffs are the coefficients of the terms
' -----------------------------------------------------------------------------------------------------------
Public Function polynomial(pX As Double, pCoeffs As Range) As Double
'
' ==============================================================================================
' default result
' ----------------------------------------------------------------------------------------------
Dim result As Double
result = 0#
'
' ==============================================================================================
' coeff recasts each coefficient as a double. term is recomputed for each coefficient with its
' corresponding power of X.
' ----------------------------------------------------------------------------------------------
Dim coeff As Double
Dim term As Double
Dim degree As Double
Dim colIdx As Long
Dim rowIdx As Long
'
' ==============================================================================================
' if the coefficients are passed in as a column of numbers ...
' ----------------------------------------------------------------------------------------------
If (pCoeffs.Columns.count >= pCoeffs.Rows.count) Then
For colIdx = pCoeffs.Columns.count To 1
coeff = pCoeffs(1, colIdx)
degree = colIdx - 1#
term = coeff * (pX ^ degree)
result = result + term
Next colIdx
'
' ==============================================================================================
' else the coefficients are passed in as a row of numbers ...
' ----------------------------------------------------------------------------------------------
Else
For rowIdx = pCoeffs.Rows.count To 1
coeff = pCoeffs(rowIdx, 1)
degree = rowIdx - 1#
term = coeff * (pX ^ degree)
result = result + term
Next rowIdx
End If
'
' ==============================================================================================
' return the result
' ----------------------------------------------------------------------------------------------
polynomial = result
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function performs a "NORMAL" rounding of real numbers to a specified number of decimal points.
'
' The built-in VBA Round function is NOT NORMAL. It performs "banker's rounding". It rounds to the
' nearest integer, and if there are two nearest integers then it goes to the even one. 1.5 rounds to 2,
' 0.5 rounds to 0.
'
' Why's that? Why not just arbitrarily say that we always round down in this situation? Why round down
' sometimes and up some other times? There actually is a good reason!
'
' This algorithm is called the Bankers' Rounding algorithm because, unsurprisingly, it's used by bankers.
' Suppose a data source provides data which is often in exactly split quantities -- half dollars, half
' cents, half shares, whatever -- but they wish to provide rounded-off quantities. Suppose further that a
' data consumer is going to derive summary statistics from the rounded data -- an average, say.
'
' Ideally when you are taking an average you want to take an average of the raw data with as much
' precision as you can get. But in the real world we often have to take averages of data which has lost
' some precision. In such a situation the Banker's Rounding algorithm produces better results because it
' does not bias half-quantities consistently down or consistently up. It assumes that on average, an
' equal number of half-quantities will be rounded up as down, and the errors will cancel out.
'
' If you don't believe me, try it. Generate a random list of numbers that end in 0.5, round them off, and
' average them. You'll find that Bankers' Rounding gives you closer results to the real average than
' "always round down" averaging.
'
' The Round, CInt and CLng functions in VBScript all use the Banker's Rounding algorithm.
'
' There are two other VBA functions which turn floats into integers. The Int function gives you the
' first integer less than or equal to its input, and the Fix function gives you the first integer closer
' to zero or equal to its input. These functions do not round to the nearest integer at all, they simply
' truncate the fractional part.
'
' return
' this function returns a rounded form of pNum
'
' param
' pNum is the number to round
' param (optional)
' pNumberOfDecimalPlaces is an optional number indicating how many places to the right of the decimal
' are included in the rounding. If not specified as a call argument, the default is 0 and whole integers
' are returned.
' param (optional)
' pRoundingOption is an optional control parameter that specifies the type of rounding to perform. The
' types are one of these three: UP, DOWN, or NEAREST. If not specified as a call argument, the default
' is NEAREST.
' -----------------------------------------------------------------------------------------------------------
Public Function normalRound _
( _
pNum As Double, _
Optional pNumberOfDecimalPlaces As Long = 0, _
Optional pRoundingOption As Long = cRoundToNearest _
) _
As Double
Dim placesFactor As Double
Dim roundFactor As Double
'
' ==============================================================================================
' this factor is used to left shift the real number until the digit in the position of the
' number of decimal places that we are rounding to is in the 1's position (whole number)
' ----------------------------------------------------------------------------------------------
placesFactor = 10 ^ pNumberOfDecimalPlaces
'
' ==============================================================================================
' based on the rounding option, compute a factor to add to the number being rounded
' ----------------------------------------------------------------------------------------------
Select Case pRoundingOption
'
' ==============================================================================================
' round UP
' ----------------------------------------------------------------------------------------------
Case cRoundUp
roundFactor = 1#
'
' ==============================================================================================
' round DOWN
' ----------------------------------------------------------------------------------------------
Case cRoundDown
roundFactor = 0#
'
' ==============================================================================================
' round to NEAREST
' ----------------------------------------------------------------------------------------------
Case cRoundToNearest
roundFactor = 0.5
'
' ==============================================================================================
' round to NEAREST
' ----------------------------------------------------------------------------------------------
Case Else
roundFactor = 0.5
End Select
'
' ==============================================================================================
' left shift the value, add the rounding factor, truncate, then right shift back to correct
' magnitude
' ----------------------------------------------------------------------------------------------
normalRound = Int((pNum * placesFactor) + roundFactor) / placesFactor
End Function
Public Function normalRoundInt _
( _
pNum As Double, _
Optional pNumberOfDecimalPlaces As Long = 0, _
Optional pRoundingOption As Long = cRoundToNearest _
) _
As Integer
normalRoundInt = CInt(normalRound(pNum, pNumberOfDecimalPlaces, pRoundingOption) + 0.01)
End Function
Public Function normalRoundLng _
( _
pNum As Double, _
Optional pNumberOfDecimalPlaces As Long = 0, _
Optional pRoundingOption As Long = cRoundToNearest _
) _
As Long
normalRoundLng = CLng(normalRound(pNum, pNumberOfDecimalPlaces, pRoundingOption) + 0.01)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function performs a "NORMAL" rounding of real numbers to the nearest multiple of a specified number
'
' return
' this function returns a rounded form of pNum
'
' param
' pNum is the number to round
' param
' pRoundToNearest is the number to which pNum is rounded to the nearest multiple
' param
' pRoundingOption is an optional control parameter that specifies the type of rounding to perform. The
' types are one of these three: UP, DOWN, or NEAREST. If not specified as a call argument, the defaule
' is NEAREST.
' -----------------------------------------------------------------------------------------------------------
Public Function normalRoundTo(pNum As Double, pRoundToNearest As Double, Optional pRoundingOption As Long = cRoundToNearest) As Double
Dim roundedMutliple As Double
Dim valueDiv As Double
Dim valueNew As Double
'
' ==============================================================================================
' if they want to round to the nearest multiple of zero, it makes no sense so just return the
' unchanged number
' ----------------------------------------------------------------------------------------------
If pRoundToNearest = 0 Then
normalRoundTo = pNum
Exit Function
End If
'
' ==============================================================================================
' if the pNum is already a multiple of pRoundToNearest, then we're done.
' ----------------------------------------------------------------------------------------------
If (fmod(pNum, pRoundToNearest) < (pRoundToNearest / 10#)) Then
normalRoundTo = pNum
Exit Function
End If
'
' ==============================================================================================
' We're basically going to use this approach:
' roundPValueToNearestPRoundTo = normalRound(pNum/pRoundToNearest)*pRoundToNearest.
' ----------------------------------------------------------------------------------------------
valueDiv = pNum / pRoundToNearest
'
' ==============================================================================================
' based on the rounding option ...
' NOTE: we do NOT use the VBA Round Function because it does BankersRounding.
' ----------------------------------------------------------------------------------------------
roundedMutliple = normalRound(valueDiv, 0, pRoundingOption)
'
' ==============================================================================================
' Calculate new "rounded-to" value
' ----------------------------------------------------------------------------------------------
normalRoundTo = roundedMutliple * pRoundToNearest
End Function
Public Function normalRoundToInt(pNum As Double, pRoundToNearest As Double, Optional pRoundingOption As Long = cRoundToNearest) As Integer
normalRoundToInt = CInt(normalRoundTo(pNum, pRoundToNearest, pRoundingOption) + 0.01)
End Function
Public Function normalRoundToLng(pNum As Double, pRoundToNearest As Double, Optional pRoundingOption As Long = cRoundToNearest) As Long
normalRoundToLng = CLng(normalRoundTo(pNum, pRoundToNearest, pRoundingOption) + 0.01)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns a rounding of pNum. It rounds pNum up to the next integer if pNum's fractional part
' is greater than or equal to pFrom's fractional part. If pNum's fractional part is less than pFrom's
' fractional part, pNum is rounded down. The absolute value of pFrom's fractional part is used.
'
' Examples:
' if pNum is 5.4 and pFrom is .5, pNum will be rounded DOWN to 5
' if pNum is 5.4 and pFrom is .4, pNum will be rounded UP to 6
' if pNum is 5.4 and pFrom is .3, pNum will be rounded UP to 6
'
' Simply put, any value of pFrom's fractional part that is less than or equal to the fractional part of pNum
' will cause pNum to be rounded UP. Any value greater will cause pNum to be rounded DOWN.
'
' return
' this function returns a rounded up form of pNum
'
' param
' pNum is the number to round up
' param
' pFrom is the fraction that marks the point at which pNum is rounded up to the next integral number.
' -----------------------------------------------------------------------------------------------------------
Public Function roundUpFrom(pNum As Double, pFrom As Double) As Integer
'
' ==============================================================================================
' only gonna use the fractional part of the absolute value of pFrom
' ----------------------------------------------------------------------------------------------
pFrom = Abs(pFrom)
pFrom = pFrom - Int(pFrom)
' roundUpFrom = Application.Round(0.5 - pFrom + pNum, 0)
roundUpFrom = normalRound(0.5 - pFrom + pNum, 0)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns the floating-point remainder of numerator/denominator.
'
' The remainder of a division operation is the result of subtracting the integral quotient multiplied by the
' denominator from the numerator:
' remainder = numerator - quotient * denominator
'
' return
' this function returns the floating-point remainder of numerator/denominator.
'
' param
' pNumerator is the numerator
' param
' pDenominator is the denominator
' -----------------------------------------------------------------------------------------------------------
Public Function fmod(pNumerator As Double, pDenominator As Double) As Double
Dim quotient As Double
quotient = pNumerator / pDenominator
fmod = pNumerator - (Fix(quotient) * pDenominator)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns the Minimum value from a parameter Array. (Amazingly, VBA does not provide its own
' Max or Min function.)
'
' Note: I copied this code from a source on the web that I can no longer identify. If you know the original
' source of this code please reference the site so that I can give the author credit for the code.
'
' Examples:
' min(1,2,empty,-1) Returns -1
' min(Array(1,2,-1),-4,-9.9) Returns -9.9
' min(1/Jan/99,2/Jan/99) Returns 1/Jan/99
'
' return
' this function returns the Min Value contained within the input (excluding empty values)
'
' param
' pValues is the paramater array
' -----------------------------------------------------------------------------------------------------------
Public Function min(ParamArray pValues() As Variant) As Variant
Dim thisItem As Variant
Dim thisElement As Variant
On Error Resume Next
For Each thisItem In pValues
If IsArray(thisItem) Then
For Each thisElement In thisItem
min = min(thisElement, min)
Next
Else
If IsEmpty(min) Then
If Not IsEmpty(thisItem) Then
min = thisItem
End If
ElseIf Not IsEmpty(thisItem) Then
If thisItem < min Then
min = thisItem
End If
End If
End If
Next
On Error GoTo 0
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns the Maximum value from a parameter Array. (Amazingly, VBA does not provide its own
' Max or Min function.)
'
' Note: I copied this code from a source on the web that I can no longer identify. If you know the original
' source of this code please reference the site so that I can give the author credit for the code.
'
' Examples:
' max(1,2,empty,-1) Returns 2
' max(Array(1,2,-1),-4,-9.9) Returns 2
' max(1/Jan/99,2/Jan/99) Returns 2/Jan/99
'
' return
' this function returns the Max Value contained within the input (excluding empty values)
'
' param
' pValues is the paramater array
' -----------------------------------------------------------------------------------------------------------
Public Function max(ParamArray pValues() As Variant) As Variant
Dim thisItem As Variant
Dim thisElement As Variant
On Error Resume Next
For Each thisItem In pValues
If IsArray(thisItem) Then
For Each thisElement In thisItem
max = max(thisElement, max)
Next
Else
If IsEmpty(max) Then
If Not IsEmpty(thisItem) Then
max = thisItem
End If
ElseIf Not IsEmpty(thisItem) Then
If thisItem > max Then
max = thisItem
End If
End If
End If
Next
On Error GoTo 0
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns TRUE or FALSE depending if the value is odd
'
' return
' this function returns TRUE if the argument passed to it is odd, otherwise, it returns FALSE
'
' param
' pValue is the value to test. This should be an integer or a long.
' -----------------------------------------------------------------------------------------------------------
Public Function isOdd(pValue As Variant) As Boolean
isOdd = Not isEven(pValue)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns TRUE or FALSE depending if the value is even
'
' return
' this function returns TRUE if the argument passed to it is even, otherwise, it returns FALSE
'
' param
' pValue is the value to test. This should be an integer or a long.
' -----------------------------------------------------------------------------------------------------------
Public Function isEven(pValue As Variant) As Boolean
Dim value As Long
value = CLng(pValue)
isEven = value Mod 2 = 0
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns determines if a given value is within the range of two other values - inclusive.
'
' return
' TRUE if pMinValue <= pValue <= pMaxValue, otherwise FALSE
'
' param
' pValue is the value that is tested
' param
' pMinValue is the value that is the low end of the range
' param
' pMaxValue is the value that is the high end of the range
' -----------------------------------------------------------------------------------------------------------
Public Function isInRange(pValue As Variant, pMinValue As Variant, pMaxValue As Variant) As Boolean
isInRange = ((pMinValue <= pValue) And (pValue <= pMaxValue))
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This subroutine returns pVal unless pVal is less than pMin or greater than pMax. If pVal is less than
' pMin, this method returns pMin. If pVal is greater than pMax, This subroutine returns pMax.
'
' return
' pVal forced into the range pMin..pMax inclusive.
'
' param
' pVal is the value to force in range
' param
' pMin is the low end of the range
' param
' pMax is the high end of the range
' -----------------------------------------------------------------------------------------------------------
Public Function forceIntoRange(pVal As Variant, pMin As Variant, pMax As Variant) As Variant
pVal = max(pVal, pMin)
pVal = min(pVal, pMax)
forceIntoRange = pVal
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This subroutine returns a rolling average.
'
' If the period is 7, a value (call it X) is 1/7th of the rolling average when it is passed in as the latest
' measurement (incr 1). On the next call, X becomes 6/49ths of the rolling average or 12.244898% of the
' rolling average. On the 3rd call (incr 3), X becomes 36/343rds of the rolling average or 10.4956268% of
' the rolling average. Etc.
'
' Incr: 1 2 3 4 5 6
'
' Mltpl
' of prv
' ratio: 1/7 6/7 6/7 6/7 6/7 6/7
'
' Ratio: 1/7 6/49 36/343 216/2401 1296/16807 7776/117649
'
' Pct: 14.2857143% 12.244898% 10.4956268% 8.9962516% 7.7110728% 6.6094909%
' -----------------------------------------------------------------------------------------------------------
Public Function rollingAvg(latestMeasurement, prevAvg, period)
rollingAvg = (latestMeasurement + (prevAvg * (period - 1))) / period
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This subroutine returns a rolling average when there is a gap in the sequence of numbers being averaged.
'
' If the period is 7, a value (call it X) is 1/7th of the rolling average when it is passed in as the latest
' measurement (incr 1). On the next call, X becomes 6/49ths of the rolling average or 12.244898% of the
' rolling average. On the 3rd call (incr 3), X becomes 36/343rds of the rolling average or 10.4956268% of
' the rolling average. Etc.
'
' Incr: 1 2 3 4 5 6
'
' Mltpl
' of prv
' ratio: 1/7 6/7 6/7 6/7 6/7 6/7
'
' Ratio: 1/7 6/49 36/343 216/2401 1296/16807 7776/117649
'
' Pct: 14.2857143% 12.244898% 10.4956268% 8.9962516% 7.7110728% 6.6094909%
' -----------------------------------------------------------------------------------------------------------
Public Function rollingAvgWithGap(latestMeasurement As Variant, prevAvg As Variant, period As Variant, gap As Variant) As Variant
Dim pa As Variant
Dim i As Long
pa = prevAvg
If (gap > 0) Then
For i = 1 To gap
pa = rollingAvg(0, pa, period)
Next i
End If
rollingAvgWithGap = rollingAvg(latestMeasurement, pa, period)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' -----------------------------------------------------------------------------------------------------------
Public Function wgtdAvg(pValues As Range, pWeights As Range) As Double
Dim rowIdx As Long
Dim colIdx As Long
Dim sum As Double
Dim count As Double
Dim value As Double
Dim weight As Double
sum = 0#
count = 0#
For rowIdx = 1 To pValues.Rows.count
For colIdx = 1 To pValues.Columns.count
value = pValues(rowIdx, colIdx)
weight = pWeights(rowIdx, colIdx)
sum = sum + (value * weight)
If (value > 0#) Then count = count + weight
Next colIdx
Next rowIdx
If (count > 0#) Then
wgtdAvg = sum / count
Else
wgtdAvg = 0#
End If
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns a random integer in the range [pLowerBound..pUpperBound] inclusive
'
' return
' a random integer in the range [pLowerBound..pUpperBound] inclusive
'
' param
' pLowerBound is the smallest integer that can be returned by this function
' param
' pUpperBound is the largest integer that can be returned by this function
' -----------------------------------------------------------------------------------------------------------
Public Function randomIntegerInRange(pLowerBound As Integer, pUpperBound As Integer) As Integer
randomIntegerInRange = Int((pUpperBound - pLowerBound + 1) * Rnd() + pLowerBound)
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function finds the biggest difference between corresponding values in two ranges. The first range is
' imagined to be a list of demands. The second range is imagined to be a corresponding list of supplies.
' This function finds the maximum of all the differences of demand over supply ((pDemandRange[n] -
' pSupplyRange[n]) / pSupplyRange[n]). As such, the pair in which the demand exceeds supply by the largest
' percentage.
'
' return
' this function returns the maximum of all instances of ((pDemandRange[n] - pSupplyRange[n]) /
' pSupplyRange[n])
'
' param
' pDemandRange is a range of values each of which is interpreted to represent the demand
' param
' pSupplyRange is a range of values each of which is interpreted to represent the supply
' -----------------------------------------------------------------------------------------------------------
Public Function maxExcessDemandPct(pDemandRange As Range, pSupplyRange As Range) As Double
Dim rowIdx As Long
Dim colIdx As Long
Dim supply As Double
Dim demand As Double
Dim excessPct As Double
Dim maximum As Double
maximum = -1000000#
For rowIdx = 1 To pSupplyRange.Rows.count
For colIdx = 1 To pSupplyRange.Columns.count
supply = pSupplyRange(rowIdx, colIdx)
demand = pDemandRange(rowIdx, colIdx)
If (supply = 0#) Then
excessPct = demand
Else
excessPct = (demand - supply) / supply
End If
maximum = max(maximum, excessPct)
Next colIdx
Next rowIdx
maxExcessDemandPct = maximum
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function finds the sum of all the instances where demand outstrips supply.
'
' return
' this function returns the sum of all the instances where demand outstrips supply.
'
' param
' pDemandRange is a range of values each of which is interpreted to represent the demand
' param
' pSupplyRange is a range of values each of which is interpreted to represent the supply
' -----------------------------------------------------------------------------------------------------------
Public Function totalExcessDemand(pDemandRange As Range, pSupplyRange As Range) As Double
Dim rowIdx As Long
Dim colIdx As Long
Dim supply As Double
Dim demand As Double
Dim total As Double
total = 0#
For rowIdx = 1 To pSupplyRange.Rows.count
For colIdx = 1 To pSupplyRange.Columns.count
supply = pSupplyRange(rowIdx, colIdx)
demand = pDemandRange(rowIdx, colIdx)
If (demand > supply) Then
total = total + (demand - supply)
End If
Next colIdx
Next rowIdx
totalExcessDemand = total
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function performs an unsophisticated comparison for equality between two Double values.
' See here for an explanation of this:
' http://www.cygnus-software.com/papers/comparingfloats/comparingfloats.htm
'
' return
' This function returns True if the difference between the two values is within a specified tolerance,
' otherwise, it returns False
'
' param
' pDbl1 is the value to compare with pDbl2 for equality within the specified tolerance of pEpsilon
' param
' pDbl2 is the value to compare with pDbl1 for equality within the specified tolerance of pEpsilon
' param (optional)
' pRelativeEpsilon is the relative tolerance or maximum relative difference allowed between pDbl1 and
' pDbl2 to call them equal. If no argument value is passed to this procedure through this optional
' parameter, its value defaults to cDefaultRelativeEpsilon.
' param (optional)
' pEpsilon is the absolute tolerance or maximum absolute difference allowed between pDbl1 and pDbl2 to
' call them equal. If no argument value is passed to this procedure through this optional parameter, its
' value defaults to cDefaultRelativeEpsilon.
' -----------------------------------------------------------------------------------------------------------
Public Function doublesAreEqual _
( _
pDbl1 As Double, _
pDbl2 As Double, _
Optional pRelativeEpsilon As Double = cDefaultRelativeEpsilon, _
Optional pEpsilon As Double = cDefaultEpsilon _
) _
As Boolean
If (Abs(pDbl1 - pDbl2) < pEpsilon) Then
doublesAreEqual = True
Exit Function
End If
Dim relativeError As Double
If (Abs(pDbl2) > Abs(pDbl1)) Then
relativeError = Abs((pDbl1 - pDbl2) / pDbl2)
Else
relativeError = Abs((pDbl1 - pDbl2) / pDbl1)
End If
If (relativeError <= pRelativeEpsilon) Then
doublesAreEqual = True
Exit Function
End If
doublesAreEqual = False
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function converts a fraction's numerator to its equivalent value over a new denominator.
'
' For Example, to convert 3/7ths to 14ths, this is the algebraic process:
' 3/7 = x/14
' 3/7 * 14 = x
' 3 * 14/7 = x
' 3 * 2 = x
' 6 = x
' 3/7ths is the same as 6/14ths
'
' So calling this function like this: equivalentNumerator(3,7,14) will return 6
'
' return
' This function returns the numerator x in the fraction x/pNewDenominator such that x/pNewDenominator
' is equivalent to the fraction pNumerator/pOldDenominator
'
' param
' pNumerator is the numerator in the fraction pNumerator/pOldDenominator
' param
' pOldDenominator is the denominator in the fraction pNumerator/pOldDenominator
' param
' pNewDenominator is the denominator in the fraction x/pNewDenominator, where x is the value returned
' by this function
' -----------------------------------------------------------------------------------------------------------
Public Function equivalentNumerator(pNumerator As Double, pOldDenominator As Double, pNewDenominator As Double) As Double
If (doublesAreEqual(pOldDenominator, pNewDenominator)) Then
equivalentNumerator = pNumerator
Else
equivalentNumerator = pNumerator * (pNewDenominator / pOldDenominator)
End If
End Function
' ===========================================================================================================
' ===========================================================================================================
' ===========================================================================================================
' This function returns the log of a number to a specified base. In other words, it returns LOG (pNumber)
' pBase
' which of course, tells you what power pBase has to be raised to to get pNumber.
' for example, LOG (200) is the number that 100 would have to be raised to to get 200.
' 100
'
' to use this function to find the number that 100 would have to be raised to to get 200, you would call it
' logBaseN(200,100)
' This ordering of parameters is to keep it consistent with Excel's LOG(number, base) function.
'
' return
' This function returns LOG (pNumber)
' pBase
'
' param
' pNumber is the is thenumber tofind the log base pBase of
' param
' pBase is the base of the Logarithm.
' -----------------------------------------------------------------------------------------------------------
Public Function logBaseN(pNumber As Double, pBase As Double) As Double
logBaseN = log(pNumber) / log(pBase)
End Function
Public Function logisticFunction(pXValue As Double, pMidpointXValue As Integer, pMaxYValue As Double, pSteepness As Double) As Double
logisticFunction = pMaxYValue / (1 + (cE ^ -(pSteepness * (pXValue - pMidpointXValue))))
End Function
Public Function logisticFunctionSteepness(pXValue As Double, pMidpointXValue As Integer, pMaxYValue As Double, pSteepness As Double) As Double
logisticFunctionSteepness = pMaxYValue / (1 + (cE ^ -(pSteepness * (pXValue - pMidpointXValue))))
End Function
Facebook