Page 2 of 2 FirstFirst 12
Results 41 to 47 of 47

Thread: Round Function

  1. #41
    Frenzied Member
    Join Date
    Mar 2008
    Posts
    1,210

    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.

  2. #42

    Thread Starter
    Frenzied Member
    Join Date
    May 2014
    Location
    Kallithea Attikis, Greece
    Posts
    1,289

    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

  3. #43
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    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:

    Name:  IEEE_Double.jpg
Views: 173
Size:  12.5 KB

    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.

  4. #44

    Thread Starter
    Frenzied Member
    Join Date
    May 2014
    Location
    Kallithea Attikis, Greece
    Posts
    1,289

    Re: Round Function

    Very Good Elroy.

  5. #45
    Frenzied Member
    Join Date
    Mar 2008
    Posts
    1,210

    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.

  6. #46
    Frenzied Member
    Join Date
    Mar 2008
    Posts
    1,210

    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.

  7. #47
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Round Function

    Quote Originally Posted by Magic Ink View Post
    >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.

    Quote Originally Posted by Magic Ink View Post
    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.

Page 2 of 2 FirstFirst 12

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width