Re: CurveUptakeA = CurveUptakeA + CurveUptake(ect, monthNumber(year, month, startYear

```
Option Explicit
Private Const T_MIN As Double = 0, T_MAX As Double = 1, TOLERANCE As Double = 1 / (2 ^ 10)
Private Const DEFAULT_DECAY As Double = 1, DEFAULT_PEAK As Double = 0
' defaults curving parameters (as range factors) for for yOfXSimple
'Private Const SCURVE_X1 As Double = 3 / 4, SCURVE_Y1 As Double = 0, SCURVE_X2 As Double = 1 / 2, SCURVE_Y2 As Double = 3 / 4
'Private Const RAPID_X As Double = 1 / 4, RAPID_Y As Double = 3 / 4
Private Const SCURVE_X1 As Double = 3 / 4, SCURVE_Y1 As Double = 0, SCURVE_X2 As Double = 2 / 3, SCURVE_Y2 As Double = 2 / 3
Private Const RAPID_X As Double = 1 / 4, RAPID_Y As Double = 8.5 / 10
Enum eCurveType
ectAnalog = 0 ' analog-based curve coefficients
ectScurve = 1 ' slow, s-curve
' ectLinear = 2 ' medium, linear
ectRapid = 3 ' fast, "reverse exponential"
ectLinear = 4 ' linear
End Enum
Function CurveUptakeA(ect As Double, year As Integer, startYear As Integer, startMonth As Integer, yearsToPeak As Double, endY As Double, _
Optional peakTime As Double = DEFAULT_PEAK, Optional decayFactor As Double = DEFAULT_DECAY) As Double
Dim startY As Double, monthsToPeak As Double
startY = 0
monthsToPeak = yearsToPeak * 12
' validation
If 1 > startMonth Or startMonth > 12 Then Err.Raise 0
CurveUptakeA = 0
Dim month As Integer
For month = 1 To 12
CurveUptakeA = CurveUptakeA + CurveUptake(ect, monthNumber(year, month, startYear, startMonth), 1, yearsToPeak, endY, peakTime, decayFactor)
Next month
CurveUptakeA = CurveUptakeA / 12
End Function
Function monthNumber(year As Integer, month As Integer, startYear As Integer, startMonth As Integer) As Integer
monthNumber = (year - startYear) * 12 + month - startMonth + 1
End Function
Function CurveUptake(ect As Double, x As Double, startX As Double, yearsToPeak As Double, endY As Double, _
Optional peakTime As Double = DEFAULT_PEAK, Optional decayFactor As Double = DEFAULT_DECAY) As Double
Dim startY As Double, endX As Double, timeToPeak As Double
timeToPeak = yearsToPeak * 12
startX = startX - 1
endX = startX + timeToPeak
startY = 0
Dim factor As Double ' a factor used for cases 1 to 3
Select Case ect
Case 0
CurveUptake = yOfXAnalog(x, startX, startY, endX, endY, peakTime, decayFactor)
Case 1 To 2
factor = ect - ectScurve
CurveUptake = factor * yOfXAnalog(x, startX, startY, endX, endY, peakTime, decayFactor) _
+ (1 - factor) * yOfXSCurve(x, startX, startY, endX, endY, peakTime, decayFactor)
Case 2 To 3
factor = ectRapid - ect
CurveUptake = factor * yOfXAnalog(x, startX, startY, endX, endY, peakTime, decayFactor) _
+ (1 - factor) * yOfXRapid(x, startX, startY, endX, endY, peakTime, decayFactor)
Case 4
CurveUptake = yOfXLinear(x, startX, startY, endX, endY, peakTime, decayFactor)
Case Else
Err.Raise 0
End Select
End Function
' here are the different "standard curve types"
' they are all functions of the "normalized, simple inputs"
' normalized meaning X and Y, simple meaning the two gravitational skewpoints (x1,y1)(x2,y2) are not needed
' these functions are used as components of the CurveUptake formulae
Private Function yOfXSCurve(x As Double, startX As Double, startY As Double, endX As Double, endY As Double, _
Optional peakTime As Double = DEFAULT_PEAK, Optional decayFactor As Double = DEFAULT_DECAY) As Double
yOfXSCurve = yOfX(x, startX, startY, endX, endY, startX + (endX - startX) * SCURVE_X1, startY + (endY - startY) * SCURVE_Y1, startX + (endX - startX) * SCURVE_X2, startY + (endY - startY) * SCURVE_Y2, peakTime, decayFactor)
End Function
Private Function yOfXLinear(x As Double, startX As Double, startY As Double, endX As Double, endY As Double, _
Optional peakTime As Double = DEFAULT_PEAK, Optional decayFactor As Double = DEFAULT_DECAY) As Double
yOfXLinear = yOfX(x, startX, startY, endX, endY, , , , , peakTime, decayFactor)
End Function
Private Function yOfXRapid(x As Double, startX As Double, startY As Double, endX As Double, endY As Double, _
Optional peakTime As Double = DEFAULT_PEAK, Optional decayFactor As Double = DEFAULT_DECAY) As Double
yOfXRapid = yOfX(x, startX, startY, endX, endY, startX + (endX - startX) * RAPID_X, startY + (endY - startY) * RAPID_Y, , , peakTime, decayFactor)
End Function
Private Function yOfXAnalog(x As Double, startX As Double, startY As Double, endX As Double, endY As Double, _
Optional peakTime As Double = DEFAULT_PEAK, Optional decayFactor As Double = DEFAULT_DECAY) As Double
' gravitational skewpoints
Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
x1 = startX + 3.5
y1 = startY
' finding the SECOND gravitational skewpoint
Dim xfactors(), yfactors(), analog As Integer
xfactors = [{-1,8,10,10,15,15,15,35}]
yfactors = [{-1,.90,.85,.80,.80,.65,.30,.30}]
analog = WorksheetFunction.Floor((endX - startX) / 12, 1)
analog = WorksheetFunction.Max(2, analog)
analog = WorksheetFunction.Min(8, analog)
x2 = startX + (endX - startX) * (xfactors(analog) / (analog * 12))
y2 = yfactors(analog) * endY
yOfXAnalog = yOfX(x, startX, startY, endX, endY, x1, y1, x2, y2, peakTime, decayFactor)
End Function
'* HERE THERE BE DRAGONS *'
' all parameters should be Double, but micro$oft IsMissing fails on any type other than Variant
Function yOfX(x As Double, _
startX As Double, startY As Double, _
endX As Double, endY As Double, _
Optional point1X As Variant, Optional point1Y As Variant, _
Optional point2X As Variant, Optional point2Y As Variant, _
Optional peakTime As Double = DEFAULT_PEAK, _
Optional decayFactor As Double = DEFAULT_DECAY) As Double
If IsMissing(point1X) Or IsMissing(point1Y) Then
point1X = startX
point1Y = startY
End If
If IsMissing(point2X) Or IsMissing(point2Y) Then
point2X = point1X
point2Y = point1Y
End If
If IsMissing(peakTime) Then peakTime = (endX - startX) / 2
' validation
If endX <= startX Then Err.Raise 0
If x <= startX Then
yOfX = startY
Exit Function
End If
If x >= endX Then
yOfX = startY + (endY - startY) * decayFactor ^ WorksheetFunction.Max(0, x - endX - peakTime)
Exit Function
End If
Dim cX As Double, bX As Double, aX As Double
cX = 3 * (point1X - startX)
bX = 3 * (point2X - point1X) - cX
aX = endX - startX - cX - bX
Dim cY As Double, bY As Double, aY As Double
cY = 3 * (point1Y - startY)
bY = 3 * (point2Y - point1Y) - cY
aY = endY - startY - cY - bY
yOfX = yOfT(tOfX(x, startX, cX, bX, aX), startY, cY, bY, aY)
End Function
' THESE TWO FUNCTIONS MUST BE "MONOTONICALLY INCREASING"
' THESE TWO FUNCTIONS MUST BE "CONTINUOUS"
'
Private Function xOfT(t As Double, startX As Double, cX As Double, bX As Double, aX As Double) As Double
xOfT = aX * (t ^ 3) + bX * (t ^ 2) + cX * t + startX
End Function
Private Function yOfT(t As Double, startY As Double, cY As Double, bY As Double, aY As Double) As Double
yOfT = aY * (t ^ 3) + bY * (t ^ 2) + cY * t + startY
End Function
' recursion would have been more elegant, but less stable
Private Function tOfX(x As Double, startX As Double, cX As Double, bX As Double, aX As Double) As Double
Dim mi As Double, ma As Double, guess As Double ' t values
Dim xOfGuess As Double
mi = T_MIN
ma = T_MAX
Do
guess = (mi + ma) / 2
xOfGuess = xOfT(guess, startX, cX, bX, aX)
mi = IIf(xOfGuess < x, guess, mi)
ma = IIf(xOfGuess > x, guess, ma)
Loop While Abs(x - xOfGuess) > TOLERANCE
tOfX = guess
End Function
'
Public Function CurveLinearTrend(x As Double, startX As Double, startValue As Double, peakPeriod As Double, peakShare As Double) As Double
If x >= peakPeriod Then
CurveLinearTrend = peakShare
Else
CurveLinearTrend = startValue + CurveUptake(4, x, startX + 1, (peakPeriod - startX) / 12, peakShare - startValue)
End If
End Function
```

Display More