-
Mar 12th, 2018, 04:33 PM
#41
Re: Round Function
>Round17 is far better
And can be made to go a little faster if you cache the PowersOfTen in an array like we've done above; albeit it only makes much difference if nPlaces is changing often because Round17 already caches the previous 10^n value.
Happy Monday.
-
Mar 12th, 2018, 05:44 PM
#42
Thread Starter
Frenzied Member
Re: Round Function
After Magic Ink inspection, I decide to make a more generic Round function for four types, using the old formulas, one for double/single and another for currency and decimals.
there is no check for i, so if i is <0 or 1>28 then we get error (so we can make something after "there" label
Code:
Static Function MyRound(a As Variant, Optional ByVal i As Integer = 0)
Dim c As Variant, j As VbVarType
Dim n(1 To 28) As Single, d(1 To 28) As Double, cur(1 To 28) As Currency, dec(1 To 28) As Variant
Dim sg(-1 To 1) As Single, sg4(-1 To 1) As Double, sg8(-1 To 1) As Currency
j = VarType(a)
If j < vbSingle Then MyRound = a: Exit Function
On Error GoTo there
If n(1) = 0 Then
sg(-1) = CSng(-0.5)
sg(1) = CSng(0.5)
sg4(-1) = -0.5
sg4(1) = 0.5
sg8(-1) = CCur(-0.5)
sg8(1) = CCur(0.5)
For c = 1& To 6&
n(c) = CSng(10 ^ c)
Next c
For c = 7& To 28&
n(c) = CSng(-1)
Next c
For c = 1& To 13&
d(c) = CDbl(10 ^ c)
Next c
For c = 14& To 28&
d(c) = CDbl(-1)
Next c
For c = 1& To 3&
cur(c) = CCur(10 ^ c)
Next c
For c = 4& To 28&
cur(c) = CCur(-1)
Next c
For c = 1& To 28&
dec(c) = CDec(10 ^ c)
Next c
End If
If i = 0 Then
MyRound = Sgn(a) * Int(Abs(a) + 0.5)
Exit Function
Else
c = Fix(a)
Select Case j
Case vbSingle
If n(i) > 0 Then
c = sg(Sgn(a))
MyRound = Fix(a * n(i) + c) / n(i)
Else
MyRound = a
End If
Exit Function
Case vbDouble
c = sg4(Sgn(a))
If d(i) > 0 Then
MyRound = Fix(a * d(i) + c) / d(i)
Else
MyRound = a
End If
Exit Function
Case vbCurrency
If cur(i) > 0 Then
c = sg8(Sgn(a))
MyRound = Fix(a) + Fix((a - Fix(a)) * cur(i) + c) / cur(i)
Else
MyRound = a
End If
Exit Function
Case vbDecimal
c = sg8(Sgn(a))
MyRound = Fix(a) + Fix((a - Fix(a)) * dec(i) + c) / dec(i)
Exit Function
Case Else
MyRound = a
Exit Function
End Select
End If
there:
Err.Clear
MyRound = a
End Function
-
Mar 12th, 2018, 05:51 PM
#43
Re: Round Function
Here, try this (just for Doubles):
Code:
Option Explicit
'
Private Declare Function GetMem8 Lib "msvbvm60.dll" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
'
Private Sub Form_Load()
Dim d(1 To 18) As Double
Dim i As Long
'
' Round 2.
i = i + 1: d(i) = 19322.9149762498
i = i + 1: d(i) = 7128.67488301856
i = i + 1: d(i) = 3405.6346598971
i = i + 1: d(i) = 11845.2649299012
i = i + 1: d(i) = 9619.9046555863
i = i + 1: d(i) = 24279.2349044191
i = i + 1: d(i) = 10410.9149161682
i = i + 1: d(i) = 22709.3647900926
'
' Round 6.
i = i + 1: d(i) = 14956.5797034607
i = i + 1: d(i) = 25130.4875794754
i = i + 1: d(i) = 17507.2561684953
i = i + 1: d(i) = 24622.0718804703
i = i + 1: d(i) = 15650.3628674853
i = i + 1: d(i) = 9610.27850545508
i = i + 1: d(i) = 22653.4705344545
'
' Round 2, but some 5s in third spot.
i = i + 1: d(i) = 33.675
i = i + 1: d(i) = 12345.445
i = i + 1: d(i) = 124412344.985
For i = 1 To 8
Debug.Print Round5sUp(d(i), 2)
Next i
For i = 9 To 15
Debug.Print Round5sUp(d(i), 6)
Next i
For i = 16 To 18
Debug.Print Round5sUp(d(i), 2)
Next i
Unload Me
End Sub
Private Function Round5sUp(d As Double, Optional NumDigitsAfterDecimal As Long) As Double
Round5sUp = Round(IncDblBySmallest(d), NumDigitsAfterDecimal)
End Function
Private Function IncDblBySmallest(d As Double) As Double
' Sign bit is ignored. This is an "absolute" increment.
' There are some extremely rare cases where it'll do nothing.
'
Dim c As Currency
Dim l(1 To 2) As Long
'
' Make sure all mantissa bits aren't 1.
GetMem8 d, l(1)
If l(1) <> &HFFFFFFFF And (l(2) And &HFFFFF) <> &HFFFFF Then
GetMem8 d, c
c = c + 0.0001@
GetMem8 c, IncDblBySmallest
Else
IncDblBySmallest = d
End If
End Function
It should always round up except in some wildly rare cases. I'll let y'all figure out what those might be.
I tested it with all the numbers in post #39, as well as three more numbers. Test with d(16) was that anomalous case (33.675). Test with d(17) and d(18) are specifically against Banker's rounding just to test that.
Enjoy,
Elroy
EDIT1: I didn't do any speed-tests, but this should all be relatively fast. No typecasting and just some minimal integer (i.e., Currency) math, a bit of bitwise logic, and memory copies. Well, and use of the VB6 Round() function.
EDIT2: Made a small change. It worked the way it was, but it works even better now.
EDIT3: I feel somewhat compelled to outline what I did. Basically, I took an IEEE Double, and, within the limits of its precision and also ignoring where the decimal point was, I incremented it by the smallest possible amount allowed. To further explain, here's the layout of an IEEE Double:
Now, we see that the fraction (what I call mantissa) portion is 52 bits. Another way to think of it is, these 52 bits are quite similar to a 52-bit-unsigned-integer. Therefore, if we increment this 52-bit integer, we've incremented our Double by the smallest possible amount. And, this is an absolute-value increment, because we're ignoring the sign-bit.
The easiest (and fastest) way for me to increment this 52-bit integer was to first stuff it into a Currency. However, I did have one limitation: if all 52 bits of the mantissa were 1s, I could still increment my Currency, but it would roll into the 53rd bit of the Currency, turning all the others to zero, and that would be a problem. There's also the potential problem of a Currency value of -.0001@ (all Currency bits as 1), but excluding the 52-bits of the mantissa all being 1s already takes care of this.
So, I've also ignored the sign-bit of the Currency, but this is of no consequence. Counting bits from zero, the bits 52-thru-63 of the Currency will remain unchanged. They will just go directly back into the Double. Therefore, since I'm staying away from both the sign-bit of the Currency and the sign-bit of the Double, this is an "absolute value" increment.
As a further FYI, I'm also staying away from the exponent (i.e., where the decimal point is) portion of the Double.
After the increment, all rounding of 5s should be UP.
Will this affect anything else? Well, in extreme cases, it might. If we're using ALL of our precision of our Double, and we're only rounding off ONE decimal point from ALL that precision, we could get some strange results. However, those are rather bizarre cases. It's much more typical to be rounding to far fewer digits than the significance of a Double.
I'll welcome any anomalous numbers that anyone can come up with.
Last edited by Elroy; Mar 12th, 2018 at 06:50 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
-
Mar 13th, 2018, 02:36 AM
#44
Thread Starter
Frenzied Member
-
Mar 13th, 2018, 06:30 AM
#45
Re: Round Function
>I'll welcome any anomalous numbers that anyone can come up with
Sorry to oblige...
Code:
Round5sUp Round17
(1)0.85 rounded to 1 places 0.8 0.9
(2)0.85 rounded to 1 places 0.8 0.9
(3)0.85 rounded to 1 places 0.8 0.9
(4)0.945 rounded to 2 places 0.94 0.95
(5)0.345 rounded to 2 places 0.34 0.35
(6)0.945 rounded to 2 places 0.94 0.95
(7)0.825 rounded to 2 places 0.82 0.83
(8)0.945 rounded to 2 places 0.94 0.95
(9)0.205 rounded to 2 places 0.2 0.21
(10)0.0705 rounded to 3 places 0.07 0.071
(11)0.97205 rounded to 4 places 0.972 0.9721
(12)0.02625 rounded to 4 places 0.0262 0.0263
(13)0.83405 rounded to 4 places 0.834 0.8341
(14)0.101445 rounded to 5 places 0.10144 0.10145
(15)0.365345 rounded to 5 places 0.36534 0.36535
(16)0.243105 rounded to 5 places 0.2431 0.24311
(17)0.166285 rounded to 5 places 0.16628 0.16629
(18)0.866705 rounded to 5 places 0.8667 0.86671
(19)0.773785 rounded to 5 places 0.77378 0.77379
(20)0.45436865 rounded to 7 places 0.4543686 0.4543687
(21)0.22695905 rounded to 7 places 0.226959 0.2269591
(22)0.816621125 rounded to 8 places 0.81662112 0.81662113
(23)0.965752125 rounded to 8 places 0.96575212 0.96575213
(24)0.393720865 rounded to 8 places 0.39372086 0.39372087
(25)0.04375350475 rounded to 10 places 0.0437535048 0.0437535047
(26)0.48036676645 rounded to 10 places 0.4803667664 0.4803667665
(27)0.22661966085 rounded to 10 places 0.2266196608 0.2266196609
(28)0.44251817465 rounded to 10 places 0.4425181746 0.4425181747
(29)0.23104429245 rounded to 10 places 0.2310442924 0.2310442925
Although Round17 appears to get it wrong on line 25!
Last edited by Magic Ink; Mar 13th, 2018 at 06:46 AM.
-
Mar 13th, 2018, 10:03 AM
#46
Re: Round Function
So when the numbers get long (the significant figures in a Double approach 13) the going gets tough for even the best numeric methods. An alternative can be to use strings and hammer them into shape e.g.;
Code:
Option Explicit
Public Function RoundDbl$(ByVal n As Double, ByVal places&, Optional ByVal formatResult As Boolean = False)
'Double version
Dim i&
Static dp$, p#, Prevn#, PrevNPlaces&, PrevResult$
Static PrevFormat As Boolean, WeMustSupplyLeadingZero As Boolean
Static PowersOfTen(-15 To 15) As Double
If p = 0 Then
WeMustSupplyLeadingZero = Asc(CStr(0.1)) <> 48 'By default OS will usually supply them; affected by OS regional settings
p = 1#
dp$ = dpChar$()
For i = -15 To 15
PowersOfTen(i) = 10 ^ i
Next
End If
If PrevNPlaces = places Then
If n = Prevn Then
If formatResult = PrevFormat Then
RoundDbl$ = PrevResult$
Exit Function
End If
End If
Else
p = PowersOfTen(places)
PrevNPlaces = places
End If
Prevn = n
PrevFormat = formatResult
If places < 0 Then n = Fix(n)
RoundDbl$ = n
'Fix is about 3* quicker than If InStrB(RoundDbl$, dp$) Then
If n <> Fix(n) Then
'its a fractional number having a decimal portion
Select Case Len(RoundDbl$) - InStr(RoundDbl$, dp$) ' length of the decimal portion
Case places 'the number already has the required number of places
'do nothing
Case places + 1 ' the original figure is one place longer than required
'CDbl is quicker than if Right$(RoundDbl$, 1) = "5"
If CDbl(Right$(RoundDbl$, 1)) = 5 Then
' has a 5 in the position requiring round off
'make sure it will be rounded up, that is away from zero
Mid$(RoundDbl$, Len(RoundDbl$), 1) = "6"
'CDbl is about .3 quicker than Val
n = CDbl(RoundDbl$)
End If
RoundDbl$ = Int(n * p + 0.5) / p
Case Else
RoundDbl$ = Int(n * p + 0.5) / p
End Select
ElseIf places < 0 Then
RoundDbl$ = CLng(Int(n * p + 0.5!) / p)
'Else
'its a whole number and places are =>0 so there is no need to round it
End If
If formatResult Then
'leading zero
If WeMustSupplyLeadingZero Then
If InStrB(RoundDbl$, dp$) = 1 Then
RoundDbl$ = "0" & RoundDbl$
ElseIf InStrB(RoundDbl$, "-" & dp$) = 1 Then
RoundDbl$ = " " & RoundDbl$
Mid$(RoundDbl$, 1, 3) = "-0" & dp$
End If
End If
'trailing dp and zeroes
If places > 0 Then
If InStrB(RoundDbl$, dp$) = 0 Then RoundDbl$ = RoundDbl$ & dp$ & "0"
While Len(RoundDbl$) - InStr(RoundDbl$, dp$) < places
RoundDbl$ = RoundDbl$ & "0"
Wend
End If
End If
PrevResult$ = RoundDbl$
End Function
Public Function dpChar$()
dpChar$ = Mid$(Format$(0.1, "fixed"), 2, 1)
End Function
Not quite so quick but not a slug, plus the option is there to format the result.
Code:
RoundDbl$ Round17
(1)0.5016495585 rounded to 9 places 0.501649559 0.501649558
(2)0.4638797045 rounded to 9 places 0.463879705 0.463879704
(3)0.5210062265 rounded to 9 places 0.521006227 0.521006226
(4)0.30522066355 rounded to 10 places 0.3052206636 0.3052206635
(5)0.34599637985 rounded to 10 places 0.3459963799 0.3459963798
(6)0.38670396805 rounded to 10 places 0.3867039681 0.386703968
(7)0.15154999495 rounded to 10 places 0.151549995 0.1515499949
Last edited by Magic Ink; Mar 15th, 2018 at 02:22 PM.
-
Mar 13th, 2018, 11:22 AM
#47
Re: Round Function
Originally Posted by Magic Ink
>I'll welcome any anomalous numbers that anyone can come up with
Sorry to oblige...[
haha, no problem. I suspected people might find some problem areas. I suppose we could increment by .0002@ (rather than .0001@) and see what happens. But we'd need to make sure we had at least two zeros in the IEEE Double mantissa before we did that, to make sure we didn't overflow that mantissa.
There is just obviously some machine-epsilon at work when doing this rounding. Apparently, when comparing the base-2 number to the corresponding base-10 number, numbers that are closer than this machine-epsilon are rounded to the nearest base-10 number before any rounding (or other) work is performed. That's all I can think of that's happening.
Originally Posted by Magic Ink
So when the numbers get long (the significant figures in a Double approach 13) the going gets tough for even the best numeric methods. An alternative can be to use strings and hammer them into shape e.g.;
Also, as stated in post #27, you could convert to Decimal and get it done. That post shows how to fix the anomalies for Bankers rounding. However, George's add .5 and Fix() trick could be incorporated into that to make a bullet-proof Round5sUp function. It's just not going to be speedy.
But isn't that the sacrifice? We can either continue to use the IEEE Double floating-point-processor, or we can code everything to some form of integer (or maybe binary-coded-decimal), and do the rounding from there. I see no absolutely bullet-proof alternative. Rounding base-2 numbers to look perfectly correct when displayed as base-10 is just always going to have problems at the edges.
Here's my test code for post#27 for Bankers rounding. It gets all of your trials from post #45 correct:
Code:
Option Explicit
Private Sub Form_Load()
Dim d(1 To 25) As Double
Dim i As Long
Dim rnd As Long
'
i = i + 1: d(i) = 0.85 ' 0.8
i = i + 1: d(i) = 0.945 ' 0.94
i = i + 1: d(i) = 0.345 ' 0.34
i = i + 1: d(i) = 0.825 ' 0.82
i = i + 1: d(i) = 0.205 ' 0.2
i = i + 1: d(i) = 0.0705 ' 0.07
i = i + 1: d(i) = 0.97205 ' 0.972
i = i + 1: d(i) = 0.02625 ' 0.0262
i = i + 1: d(i) = 0.83405 ' 0.834
i = i + 1: d(i) = 0.101445 ' 0.10144
i = i + 1: d(i) = 0.365345 ' 0.36534
i = i + 1: d(i) = 0.243105 ' 0.2431
i = i + 1: d(i) = 0.166285 ' 0.16628
i = i + 1: d(i) = 0.866705 ' 0.8667
i = i + 1: d(i) = 0.773785 ' 0.77378
i = i + 1: d(i) = 0.45436865 ' 0.4543686
i = i + 1: d(i) = 0.22695905 ' 0.226959
i = i + 1: d(i) = 0.816621125 ' 0.81662112
i = i + 1: d(i) = 0.965752125 ' 0.96575212
i = i + 1: d(i) = 0.393720865 ' 0.39372086
i = i + 1: d(i) = 0.04375350475 ' 0.0437535048
i = i + 1: d(i) = 0.48036676645 ' 0.4803667664
i = i + 1: d(i) = 0.22661966085 ' 0.2266196608
i = i + 1: d(i) = 0.44251817465 ' 0.4425181746
i = i + 1: d(i) = 0.23104429245 ' 0.2310442924
rnd = 1
For i = 1 To 1
Debug.Print DblRound(d(i), rnd)
Next i
rnd = 2
For i = 2 To 5
Debug.Print DblRound(d(i), rnd)
Next i
rnd = 3
For i = 6 To 6
Debug.Print DblRound(d(i), rnd)
Next i
rnd = 4
For i = 7 To 9
Debug.Print DblRound(d(i), rnd)
Next i
rnd = 5
For i = 10 To 15
Debug.Print DblRound(d(i), rnd)
Next i
rnd = 7
For i = 16 To 17
Debug.Print DblRound(d(i), rnd)
Next i
rnd = 8
For i = 18 To 20
Debug.Print DblRound(d(i), rnd)
Next i
rnd = 10
For i = 21 To 25
Debug.Print DblRound(d(i), rnd)
Next i
End Sub
Private Function DblRound(d As Double, Optional ByVal decs As Integer) As Double
' This corrects for the occasional errors in the Banker's rounding in the Round() function with IEEE Doubles.
Dim e As Integer
'
e = CInt(Split(Format$(d, "Scientific"), "E")(1))
DblRound = CDbl(Round(CDec(d * 10# ^ -e), decs + e)) * 10# ^ e
End Function
All The Best,
Elroy
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|