Posts by qskmtk

qskmtk · Aug 15th 2016

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

Apologies but I am confused.
Let me try again and please bear with me.

1) judging by the following code, I assume CurveUptakeA is a custom function. And I know it is because when I type "=CurveUptakeA" in a cell, a dialog box will pop up and I can input the parameters in order for the function to spit out a result.
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

2) If CurveUptakeA is indeed a custom function, then I'd like to understand the exact calculation it is doing.
Judging by the following code, I just assumed (and sounds like I am wrong) the calculation for CurveUptakeA is defined as CurveUptakeA + Curveuptake
CurveUptakeA = CurveUptakeA + CurveUptake(ect, monthNumber(year, month, startYear, startMonth), 1, yearsToPeak, endY, peakTime, decayFactor)

I know I am missing something here but it looks like a circular calculation. Sorry I know this must be a really stupid question.

Thanks a lot!

qskmtk · Aug 15th 2016

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

Thanks again.
Please see below for the complete coding and let me know what I am missing. Thanks a lot!

Code

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

qskmtk · Aug 15th 2016

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

Thanks.
The codes are pretty long so I was trying to keep the question short.
My ultimate question is why the CurveUptakeA function is defined as CurveUptakeA (i.e. the very function itself) +....
Please let me know if that makes sense. Thanks!

qskmtk · Aug 15th 2016

Apologize first for a very rudimentary VBA question:

(1) I came across the following coding for a custom function "CurveUptakeA"
CurveUptakeA = CurveUptakeA + CurveUptake(ect, monthNumber(year, month, startYear, startMonth), 1, yearsToPeak, endY, peakTime, decayFactor)
"CuveUptake" as a separate custom function is defined separately.

Can anyone please help me understand what calculation the above equation is doing?

(2) Where can I find some good examples of custom functions to generate s-curves?

Thanks!