I am trying to order by date [SLED/BB] some records and to calculate and select the ones in the 75th percentile of [Blocked Quantity].
On ACCESS SQL I am not able to select in the WHERE clause the Percentile > 0.75,
I have read that this is not possible on this sw but how can I replicate this result?
p.s. I would like to avoid too many Subqueries given that this query is already quite heavy for my dataset.
SELECT
a1.[SLED/BBD],
SUM([Blocked Quantity]) AS [Blocked Qty],
(SELECT sum([Blocked Quantity])
FROM [Query002-Batches Historical] AS a2
WHERE a1.[SLED/BBD] <= a2.[SLED/BBD]) AS RunningTotal,
(SELECT SUM([Blocked Quantity])
FROM [Query002-Batches Historical]
GROUP BY 1) AS Total,
FORMAT(RunningTotal/Total,"Percent") AS Percentile
FROM [Query002-Batches Historical] AS a1
WHERE a1.[Blocked Quantity]>0 AND Percentile > 0.75
GROUP BY a1.[SLED/BBD]
ORDER BY a1.[SLED/BBD];
Though not providing the result directly, this function may help you:
Public Function GetQuartile( _
ByVal strTable As String, _
ByVal strField As String, _
ByVal bytQuartile As Byte, _
Optional ByVal bytMethod As Byte, _
Optional ByVal strFilter As String) _
As Double
' strTable : Name of the table/query to analyze.
' strField : Name of the field to analyze.
' bytQuartile: Which min/max or median/quartile to calculate.
' bytMethod: Method for calculation of lower/higher quartile.
' strFilter: Optional filter expression.
'
' Returns:
' Minimum, maximum, median or upper/lower quartile
' of strField of strTable filtered on strFilter.
'
' 2006-03-05. Cactus Data ApS, CPH.
' Reference for methods for calculation as explained here:
' http://www.daheiser.info/excel/notes/noteh.pdf
' Note: Table H-4, p. 4, has correct data for dataset 1-96 while
' datasets 1-100 to 1-97 actually are datasets 1-99 to 1-96
' shifted one column left.
' Thus, the dataset 1-100 is missing.
'
' Method 3b is not implemented as no one seems to use it.
' Neither are no example data given.
'
' Further notes on methods here:
' http://mathforum.org/library/drmath/view/60969.html
' http://www.haiweb.org/medicineprices/manual/quartiles_iTSS.pdf
'
' Data must be in ascending order by strField.
' L: Q1, Lower quartile.
' H: Q3, Higher quartile.
' M: Q2, Median.
' n: Count of elements.
' p: Calculated position of quartile.
' j: Element of dataset.
' g: Decimal part of p
' to be used for interpolation between j and j+1.
' Basic operation.
' Constant values mimic those of Excel's Quartile() function.
' Find median.
Const cbytQuartMedian As Byte = 2
' Find lower (first) quartile.
Const cbytQuartLow As Byte = 1
' Find upper (third) quartile.
Const cbytQuartHigh As Byte = 3
' Find minimum value.
Const cbytQuartMinimum As Byte = 0
' Find maximum value.
Const cbytQuartMaximum As Byte = 4
' Define default operation.
Const cbytQuartDefault = cbytQuartMedian
' Quartile calculation methods.
' Step. Mendenhall and Sincich method.
' SAS #3.
' Round up to actual element of dataset.
' L: -Int(-n/4)
' H: n-Int(-n/4)
Const cbytMethodMendenhallSincich As Byte = 1
' Average step.
' SAS #5, Minitab (%DESCRIBE), GLIM (percentile).
' Add bias of one or two on basis of n/4.
' L: (Int((n+1)/4)+Int(n/4))/2+1
' H: n-(Int((n+1)/4)+Int(n/4))/2+1
Const cbytMethodAverage As Byte = 2
' Nearest integer to np.
' SAS #2.
' Round to nearest integer on basis of n/4.
' L: Int((n+2)/4)
' H: n-Int((n+2)/4)
' Note:
' Reference contains an error in example data.
' Dataset 1-100 to 1-97 (is really 1-99 to 1-96!) should read:
' 25 25 24 24
Const cbytMethodNearestInteger As Byte = 3
' Parzen method.
' Method 1 with interpolation.
' SAS #1.
' L: n/4
' H: 3n/4
Const cbytMethodParzen As Byte = 4
' Hazen method.
' Values midway between method 1 steps.
' GLIM (interpolate).
' Add bias of 2, don't round to actual element of dataset.
' L: (n+2)/4
' H: 3(n+2)/4
Const cbytMethodHazen As Byte = 5
' Weibull method.
' SAS #4. Minitab (DECRIBE), SPSS, BMDP.
' Add bias of 1, don't round to actual element of dataset.
' L: (n+1)/4
' H: 3(n+1)/4
Const cbytMethodWeibull As Byte = 6
' Freund, J. and Perles, B., Gumbell method.
' S-PLUS, R, Excel, Star Office Calc.
' Add bias of 3, don't round to actual element of dataset.
' L: (n+3)/4
' H: (3n+1)/4
Const cbytMethodFreundPerles As Byte = 7
' Median Position.
' Median unbiased.
' L: (3n+5)/12
' H: (9n+7)/12
Const cbytMethodMedianPosition As Byte = 8
' Bernard and Bos-Levenbach.
' L: (n/4)+0.4
' H: (3n/4)/+0.6
' Note:
' Reference claims L to be (n/4)+0.31.
Const cbytMethodBernardLevenbach As Byte = 9
' Blom's Plotting Position.
' Better approximation when the distribution is normal.
' L: (4n+7)/16
' H: (12n+9)/16
Const cbytMethodBlom As Byte = 10
' Moore's first method.
' Add bias of one half step.
' L: (n+0.5)/4
' H: n-(n+0.5)/4
Const cbytMethodMoore1 As Byte = 11
' Moore's second method.
' Add bias of one or two steps on basis of (n+1)/4.
' L: (Int((n+1)/4)+Int(n/4))/2+1
' H: n-(Int((n+1)/4)+Int(n/4))/2+1
Const cbytMethodMoore2 As Byte = 12
' John Tukey's method.
' Include median from odd dataset in dataset for quartile.
' L: (1-Int(-n/2))/2
' H: n-(1-Int(-n/2))/2
Const cbytMethodTukey As Byte = 13
' Moore and McCabe (M & M), variation of John Tukey's method.
' TI-83.
' Exclude median from odd dataset in dataset for quartile.
' L: (Int(n/2)+1)/2
' H: n-(Int(n/2)+1)/2
Const cbytMethodTukeyMM As Byte = 14
' Additional variations between Weibull's and Hazen's methods, from
' (i-0.000)/(n+1.00)
' to
' (i-0.500)/(n+0.00)
'
' Variation of Weibull.
' L: n(n/4-0)/(n+1)
' H: n(3n/4-0)/(n+1)
Const cbytMethodModWeibull As Byte = 15
' Variation of Blom.
' L: n(n/4-3/8)/(n+1/4)
' H: n(3n/4-3/8)/(n+1/4)
Const cbytMethodModBlom As Byte = 16
' Variation of Tukey.
' L: n(n/4-1/3)/(n+1/3)
' H: n(3n/4-1/3)/(n+1/3)
Const cbytMethodModTukey As Byte = 17
' Variation of Cunnane.
' L: n(n/4-2/5)/(n+1/5)
' H: n(3n/4-2/5)/(n+1/5)
Const cbytMethodModCunnane As Byte = 18
' Variation of Gringorten.
' L: n(n/4-0.44)/(n+0.12)
' H: n(3n/4-0.44)/(n+0.12)
Const cbytMethodModGringorten As Byte = 19
' Variation of Hazen.
' L: n(n/4-1/2)/n
' H: n(3n/4-1/2)/n
Const cbytMethodModHazen As Byte = 20
' Define default method to calculate quartiles.
Const cbytMethodDefault = cbytMethodFreundPerles
Static dbs As DAO.Database
Static rst As DAO.Recordset
Dim strSQL As String
Dim lngNumber As Long
Dim dblPosition As Double
Dim lngPosition As Long
Dim dblInterpol As Double
Dim dblValueOne As Double
Dim dblValueTwo As Double
Dim dblQuartile As Double
' Use default calculation if choice of calculation is outside range.
If bytQuartile > 4 Then
bytQuartile = cbytQuartDefault
End If
' Use default method if choice of method is outside range.
If bytMethod = 0 Or bytMethod > 20 Then
bytMethod = cbytMethodDefault
End If
If dbs Is Nothing Then
Set dbs = CurrentDb()
End If
If Len(strTable) > 0 And Len(strField) > 0 Then
strSQL = "SELECT [" & strField & "] FROM [" & strTable & "] "
strSQL = strSQL & "WHERE ([" & strField & "] Is Not Null) "
If Len(strFilter) > 0 Then
strSQL = strSQL & "AND (" & strFilter & ") "
End If
strSQL = strSQL & "ORDER BY [" & strField & "];"
Set rst = dbs.OpenRecordset(strSQL)
With rst
If Not .EOF = True Then
If bytQuartile = cbytQuartMinimum Then
' No need to count records.
lngNumber = 1
Else
' Count records.
.MoveLast
lngNumber = .RecordCount
End If
Select Case bytQuartile
Case cbytQuartMinimum
' Current record is first record.
' Read value of this record.
Case cbytQuartMaximum
' Current record is last record.
' Read value of this record.
Case cbytQuartMedian
' Locate position of median.
dblPosition = (lngNumber + 1) / 2
Case cbytQuartLow
Select Case bytMethod
Case cbytMethodMendenhallSincich
dblPosition = -Int(-lngNumber / 4)
Case cbytMethodAverage
dblPosition = (Int((lngNumber + 1) / 4) + Int(lngNumber / 4)) / 2 + 1
Case cbytMethodNearestInteger
dblPosition = Int((lngNumber + 2) / 4)
Case cbytMethodParzen
dblPosition = lngNumber / 4
Case cbytMethodHazen
dblPosition = (lngNumber + 2) / 4
Case cbytMethodWeibull
dblPosition = (lngNumber + 1) / 4
Case cbytMethodFreundPerles
dblPosition = (lngNumber + 3) / 4
Case cbytMethodMedianPosition
dblPosition = (3 * lngNumber + 5) / 12
Case cbytMethodBernardLevenbach
dblPosition = (lngNumber / 4) + 0.4
Case cbytMethodBlom
dblPosition = (4 * lngNumber + 7) / 16
Case cbytMethodMoore1
dblPosition = (lngNumber + 0.5) / 4
Case cbytMethodMoore2
dblPosition = (Int((lngNumber + 1) / 4) + Int(lngNumber / 4)) / 2 + 1
Case cbytMethodTukey
dblPosition = (1 - Int(-lngNumber / 2)) / 2
Case cbytMethodTukeyMM
dblPosition = (Int(lngNumber / 2) + 1) / 2
Case cbytMethodModWeibull
dblPosition = lngNumber * (lngNumber / 4) / (lngNumber + 1)
Case cbytMethodModBlom
dblPosition = lngNumber * (lngNumber / 4 - 3 / 8) / (lngNumber + 1 / 4)
Case cbytMethodModTukey
dblPosition = lngNumber * (lngNumber / 4 - 1 / 3) / (lngNumber + 1 / 3)
Case cbytMethodModCunnane
dblPosition = lngNumber * (lngNumber / 4 - 2 / 5) / (lngNumber + 1 / 5)
Case cbytMethodModGringorten
dblPosition = lngNumber * (lngNumber / 4 - 0.44) / (lngNumber + 0.12)
Case cbytMethodModHazen
dblPosition = lngNumber * (lngNumber / 4 - 1 / 2) / lngNumber
End Select
Case cbytQuartHigh
Select Case bytMethod
Case cbytMethodMendenhallSincich
dblPosition = lngNumber - (-Int(-lngNumber / 4))
Case cbytMethodAverage
dblPosition = lngNumber - (Int((lngNumber + 1) / 4) + Int(lngNumber / 4)) / 2 + 1
Case cbytMethodNearestInteger
dblPosition = lngNumber - Int((lngNumber + 2) / 4)
Case cbytMethodParzen
dblPosition = 3 * lngNumber / 4
Case cbytMethodHazen
dblPosition = 3 * (lngNumber + 2) / 4
Case cbytMethodWeibull
dblPosition = 3 * (lngNumber + 1) / 4
Case cbytMethodFreundPerles
dblPosition = (3 * lngNumber + 1) / 4
Case cbytMethodMedianPosition
dblPosition = (9 * lngNumber + 7) / 12
Case cbytMethodBernardLevenbach
dblPosition = (3 * lngNumber / 4) + 0.6
Case cbytMethodBlom
dblPosition = (12 * lngNumber + 9) / 16
Case cbytMethodMoore1
dblPosition = lngNumber - (lngNumber + 0.5) / 4
Case cbytMethodMoore2
dblPosition = lngNumber - (Int((lngNumber + 1) / 4) + Int(lngNumber / 4)) / 2 + 1
Case cbytMethodTukey
dblPosition = lngNumber - (1 - Int(-lngNumber / 2)) / 2
Case cbytMethodTukeyMM
dblPosition = lngNumber - (Int(lngNumber / 2) + 1) / 2
Case cbytMethodModWeibull
dblPosition = lngNumber * (3 * lngNumber / 4) / (lngNumber + 1)
Case cbytMethodModBlom
dblPosition = lngNumber * (3 * lngNumber / 4 - 3 / 8) / (lngNumber + 1 / 4)
Case cbytMethodModTukey
dblPosition = lngNumber * (3 * lngNumber / 4 - 1 / 3) / (lngNumber + 1 / 3)
Case cbytMethodModCunnane
dblPosition = lngNumber * (3 * lngNumber / 4 - 2 / 5) / (lngNumber + 1 / 5)
Case cbytMethodModGringorten
dblPosition = lngNumber * (3 * lngNumber / 4 - 0.44) / (lngNumber + 0.12)
Case cbytMethodModHazen
dblPosition = lngNumber * (3 * lngNumber / 4 - 1 / 2) / lngNumber
End Select
End Select
Select Case bytQuartile
Case cbytQuartMinimum, cbytQuartMaximum
' Read current row.
Case Else
.MoveFirst
' Find position of first observation to retrieve.
' If lngPosition is 0, then upper position is first record.
' If lngPosition is not 0 and position is not an integer, then
' read the next observation too.
lngPosition = Fix(dblPosition)
dblInterpol = dblPosition - lngPosition
If lngNumber = 1 Then
' Nowhere else to move.
If dblInterpol < 0 Then
' Prevent values to be created by extrapolation beyond zero from observation one
' for these methods:
' cbytMethodModBlom
' cbytMethodModTukey
' cbytMethodModCunnane
' cbytMethodModGringorten
' cbytMethodModHazen
'
' Comment this line out, if reading by extrapolation *is* requested.
dblInterpol = 0
End If
ElseIf lngPosition > 1 Then
' Move to record to read.
.Move lngPosition - 1
End If
End Select
' Retrieve value from first observation.
dblValueOne = .Fields(0).Value
Select Case bytQuartile
Case cbytQuartMinimum, cbytQuartMaximum
dblQuartile = dblValueOne
Case Else
If dblInterpol = 0 Then
' Only one observation to read.
If lngPosition = 0 Then
' Return 0.
Else
dblQuartile = dblValueOne
End If
Else
If lngPosition = 0 Then
' No first observation to retrieve.
dblValueTwo = dblValueOne
If dblValueOne > 0 Then
' Use 0 as other observation.
dblValueOne = 0
Else
dblValueOne = 2 * dblValueOne
End If
Else
' Move to next observation.
.MoveNext
' Retrieve value from second observation.
dblValueTwo = .Fields(0).Value
End If
' For positive values interpolate between 0 and dblValueOne.
' For negative values interpolate between 2 * dblValueOne and dblValueOne.
' Calculate quartile using linear interpolation.
dblQuartile = dblValueOne + dblInterpol * CDec(dblValueTwo - dblValueOne)
End If
End Select
End If
.Close
End With
Else
' Reset.
Set rst = Nothing
Set dbs = Nothing
End If
''Set rst = Nothing
GetQuartile = dblQuartile
End Function
Unfortunately, the pdf referenced is off-line now and I've lost the copy I had.
Related
I constantly use the website below to track air miles round trip. Recently, the website stopped working in IE, so my code did as well. Since I use this on a work computer, I cannot download many of the other solutions that I have found in my searches and I cannot use another website without going through a lengthy process to get the site approved. Is there a way to perform the same task here in Chrome without any other downloads?
Dim ele As Object
Dim IE As New InternetExplorer
IE.Visible = True
IE.navigate "http://www.distancefromto.net"
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
'step 1
With IE
.document.getElementsByName("distance")(0).Value = Range("B2").Value
.document.getElementsByName("distance")(1).Value = Range("B3").Value & Range("E3").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim a As String
a = Trim(.document.getElementById("totaldistancemiles").Value)
Dim aa As Variant
aa = Split(a, " ")
Range("C2").Value = aa(0)
'step 2
.document.getElementsByName("distance")(0).Value = Range("B4").Value & Range("E4").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim b As String
b = Trim(.document.getElementById("totaldistancemiles").Value)
Dim bb As Variant
bb = Split(b, " ")
Range("C3").Value = bb(0)
'step 3
.document.getElementsByName("distance")(1).Value = Range("B2").Value
.document.getElementById("hae").Click
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Application.Wait (Now + TimeValue("0:00:02"))
Dim c As String
c = Trim(.document.getElementById("totaldistancemiles").Value)
Dim cc As Variant
cc = Split(c, " ")
Range("C4").Value = cc(0)
End With
IE.Quit
Any help, even a definitive "no, it's not possible" would be greatly appriciated
Thanks
Chrome:
To use Chrome - no. You would need to download selenium basic or use a different programming language e.g python.
Different site:
You could switch to using a different site (appreciate there may some minor differences on your prior figures due to the website though technically the distances shouldn’t have changed that much!). I note you say that this would be problematic. At the risk of sounding stalkerish, you have used freemaptools before so that might be an acceptable choice?
API:
If you find a site offering an API service you might be able to ditch all the above and issue an XMLHTTP request. I couldn't see your site offering an API service otherwise that would have been the obvious next choice.
#RahulChalwa mentions "[the site OP is using is itself using a wrapper around google maps API: https://maps.googleapis.com/maps/api/js/GeocodeService.Search. User can register for API and do a POST request]"; so that might be the way forward. Main documentation here.
E.g. API site: Personal and small scale use API - wheretocredit.com
Current set-up debug:
Ascertain the reason for IE no longer working in your current set-up would also be advisable, perhaps by contacting the site developers and raising your issue.
Perform the calculation (as the site does) using the Vincenty's formula or, as other sites do, using Haversine formula:
Haversine:
VBA haversine formula
Vicenty's (including sample code):
How to Calculate Distance in Excel
Vicenty's code from Contextures. I have attributed but if this should not be included here I will remove.
'*************************************************************
Private Const PI = 3.14159265358979
Private Const EPSILON As Double = 0.000000000001
Public Function distVincenty(ByVal lat1 As Double, ByVal lon1 As Double, _
ByVal lat2 As Double, ByVal lon2 As Double) As Double
'INPUTS: Latitude and Longitude of initial and
' destination points in decimal format.
'OUTPUT: Distance between the two points in Meters.
'
'======================================
' Calculate geodesic distance (in m) between two points specified by
' latitude/longitude (in numeric [decimal] degrees)
' using Vincenty inverse formula for ellipsoids
'======================================
' Code has been ported by lost_species from www.aliencoffee.co.uk to VBA
' from javascript published at:
' https://www.movable-type.co.uk/scripts/latlong-vincenty.html
' * from: Vincenty inverse formula - T Vincenty, "Direct and Inverse Solutions
' * of Geodesics on the Ellipsoid with application
' * of nested equations", Survey Review, vol XXII no 176, 1975
' * https://www.ngs.noaa.gov/PUBS_LIB/inverse.pdf
'Additional Reference: https://en.wikipedia.org/wiki/Vincenty%27s_formulae
'======================================
' Copyright lost_species 2008 LGPL
' https://www.fsf.org/licensing/licenses/lgpl.html
'======================================
' Code modifications to prevent "Formula Too Complex" errors
' in Excel (2010) VBA implementation
' provided by Jerry Latham, Microsoft MVP Excel Group, 2005-2011
' July 23 2011
'======================================
Dim low_a As Double
Dim low_b As Double
Dim f As Double
Dim L As Double
Dim U1 As Double
Dim U2 As Double
Dim sinU1 As Double
Dim sinU2 As Double
Dim cosU1 As Double
Dim cosU2 As Double
Dim lambda As Double
Dim lambdaP As Double
Dim iterLimit As Integer
Dim sinLambda As Double
Dim cosLambda As Double
Dim sinSigma As Double
Dim cosSigma As Double
Dim sigma As Double
Dim sinAlpha As Double
Dim cosSqAlpha As Double
Dim cos2SigmaM As Double
Dim C As Double
Dim uSq As Double
Dim upper_A As Double
Dim upper_B As Double
Dim deltaSigma As Double
Dim s As Double ' final result, will be returned rounded to 3 decimals (mm).
'added by JLatham to break up "Too Complex" formulas
'into pieces to properly calculate those formulas as noted below
'and to prevent overflow errors when using
'Excel 2010 x64 on Windows 7 x64 systems
Dim P1 As Double ' used to calculate a portion of a complex formula
Dim P2 As Double ' used to calculate a portion of a complex formula
Dim P3 As Double ' used to calculate a portion of a complex formula
'See https://en.wikipedia.org/wiki/World_Geodetic_System
'for information on various Ellipsoid parameters for other standards.
'low_a and low_b in meters
' === GRS-80 ===
' low_a = 6378137
' low_b = 6356752.314245
' f = 1 / 298.257223563
'
' === Airy 1830 === Reported best accuracy for England and Northern Europe.
' low_a = 6377563.396
' low_b = 6356256.910
' f = 1 / 299.3249646
'
' === International 1924 ===
' low_a = 6378388
' low_b = 6356911.946
' f = 1 / 297
'
' === Clarke Model 1880 ===
' low_a = 6378249.145
' low_b = 6356514.86955
' f = 1 / 293.465
'
' === GRS-67 ===
' low_a = 6378160
' low_b = 6356774.719
' f = 1 / 298.247167
'=== WGS-84 Ellipsoid Parameters ===
low_a = 6378137 ' +/- 2m
low_b = 6356752.3142
f = 1 / 298.257223563
'====================================
L = toRad(lon2 - lon1)
U1 = Atn((1 - f) * Tan(toRad(lat1)))
U2 = Atn((1 - f) * Tan(toRad(lat2)))
sinU1 = Sin(U1)
cosU1 = Cos(U1)
sinU2 = Sin(U2)
cosU2 = Cos(U2)
lambda = L
lambdaP = 2 * PI
iterLimit = 100 ' can be set as low as 20 if desired.
While (Abs(lambda - lambdaP) > EPSILON) And (iterLimit > 0)
iterLimit = iterLimit - 1
sinLambda = Sin(lambda)
cosLambda = Cos(lambda)
sinSigma = Sqr(((cosU2 * sinLambda) ^ 2) + _
((cosU1 * sinU2 - sinU1 * cosU2 * cosLambda) ^ 2))
If sinSigma = 0 Then
distVincenty = 0 'co-incident points
Exit Function
End If
cosSigma = sinU1 * sinU2 + cosU1 * cosU2 * cosLambda
sigma = Atan2(cosSigma, sinSigma)
sinAlpha = cosU1 * cosU2 * sinLambda / sinSigma
cosSqAlpha = 1 - sinAlpha * sinAlpha
If cosSqAlpha = 0 Then 'check for a divide by zero
cos2SigmaM = 0 '2 points on the equator
Else
cos2SigmaM = cosSigma - 2 * sinU1 * sinU2 / cosSqAlpha
End If
C = f / 16 * cosSqAlpha * (4 + f * (4 - 3 * cosSqAlpha))
lambdaP = lambda
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate lambda
'lambda = L + (1 - C) * f * sinAlpha * _
(sigma + C * sinSigma * (cos2SigmaM + C * cosSigma * _
(-1 + 2 * (cos2SigmaM ^ 2))))
'calculate portions
P1 = -1 + 2 * (cos2SigmaM ^ 2)
P2 = (sigma + C * sinSigma * (cos2SigmaM + C * cosSigma * P1))
'complete the calculation
lambda = L + (1 - C) * f * sinAlpha * P2
Wend
If iterLimit < 1 Then
MsgBox "iteration limit has been reached, something didn't work."
Exit Function
End If
uSq = cosSqAlpha * (low_a ^ 2 - low_b ^ 2) / (low_b ^ 2)
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate upper_A
'upper_A = 1 + uSq / 16384 * (4096 + uSq * _
(-768 + uSq * (320 - 175 * uSq)))
'calculate one piece of the equation
P1 = (4096 + uSq * (-768 + uSq * (320 - 175 * uSq)))
'complete the calculation
upper_A = 1 + uSq / 16384 * P1
'oddly enough, upper_B calculates without any issues - JLatham
upper_B = uSq / 1024 * (256 + uSq * (-128 + uSq * (74 - 47 * uSq)))
'the original calculation is "Too Complex" for Excel VBA to deal with
'so it is broken into segments to calculate without that issue
'the original implementation to calculate deltaSigma
'deltaSigma = upper_B * sinSigma * (cos2SigmaM + upper_B / 4 * _
(cosSigma * (-1 + 2 * cos2SigmaM ^ 2) _
- upper_B / 6 * cos2SigmaM * (-3 + 4 * sinSigma ^ 2) * _
(-3 + 4 * cos2SigmaM ^ 2)))
'calculate pieces of the deltaSigma formula
'broken into 3 pieces to prevent overflow error that may occur in
'Excel 2010 64-bit version.
P1 = (-3 + 4 * sinSigma ^ 2) * (-3 + 4 * cos2SigmaM ^ 2)
P2 = upper_B * sinSigma
P3 = (cos2SigmaM + upper_B / 4 * (cosSigma * (-1 + 2 * cos2SigmaM ^ 2) _
- upper_B / 6 * cos2SigmaM * P1))
'complete the deltaSigma calculation
deltaSigma = P2 * P3
'calculate the distance
s = low_b * upper_A * (sigma - deltaSigma)
'round distance to millimeters
distVincenty = Round(s, 3)
End Function
Function SignIt(Degree_Dec As String) As Double
'Input: a string representation of a lat or long in the
' format of 10° 27' 36" S/N or 10~ 27' 36" E/W
'OUTPUT: signed decimal value ready to convert to radians
'
Dim decimalValue As Double
Dim tempString As String
tempString = UCase(Trim(Degree_Dec))
decimalValue = Convert_Decimal(tempString)
If Right(tempString, 1) = "S" Or Right(tempString, 1) = "W" Then
decimalValue = decimalValue * -1
End If
SignIt = decimalValue
End Function
Function Convert_Degree(Decimal_Deg) As Variant
'source: https://support.microsoft.com/kb/213449
'
'converts a decimal degree representation to deg min sec
'as 10.46 returns 10° 27' 36"
'
Dim degrees As Variant
Dim minutes As Variant
Dim seconds As Variant
With Application
'Set degree to Integer of Argument Passed
degrees = Int(Decimal_Deg)
'Set minutes to 60 times the number to the right
'of the decimal for the variable Decimal_Deg
minutes = (Decimal_Deg - degrees) * 60
'Set seconds to 60 times the number to the right of the
'decimal for the variable Minute
seconds = Format(((minutes - Int(minutes)) * 60), "0")
'Returns the Result of degree conversion
'(for example, 10.46 = 10° 27' 36")
Convert_Degree = " " & degrees & "° " & Int(minutes) & "' " _
& seconds + Chr(34)
End With
End Function
Function Convert_Decimal(Degree_Deg As String) As Double
'source: https://support.microsoft.com/kb/213449
' Declare the variables to be double precision floating-point.
' Converts text angular entry to decimal equivalent, as:
' 10° 27' 36" returns 10.46
' alternative to ° is permitted: Use ~ instead, as:
' 10~ 27' 36" also returns 10.46
Dim degrees As Double
Dim minutes As Double
Dim seconds As Double
'
'modification by JLatham
'allow the user to use the ~ symbol instead of ° to denote degrees
'since ~ is available from the keyboard and ° has to be entered
'through [Alt] [0] [1] [7] [6] on the number pad.
Degree_Deg = Replace(Degree_Deg, "~", "°")
' Set degree to value before "°" of Argument Passed.
degrees = Val(Left(Degree_Deg, InStr(1, Degree_Deg, "°") - 1))
' Set minutes to the value between the "°" and the "'"
' of the text string for the variable Degree_Deg divided by
' 60. The Val function converts the text string to a number.
minutes = Val(Mid(Degree_Deg, InStr(1, Degree_Deg, "°") + 2, _
InStr(1, Degree_Deg, "'") - InStr(1, Degree_Deg, "°") - 2)) / 60
' Set seconds to the number to the right of "'" that is
' converted to a value and then divided by 3600.
seconds = Val(Mid(Degree_Deg, InStr(1, Degree_Deg, "'") + _
2, Len(Degree_Deg) - InStr(1, Degree_Deg, "'") - 2)) / 3600
Convert_Decimal = degrees + minutes + seconds
End Function
Private Function toRad(ByVal degrees As Double) As Double
toRad = degrees * (PI / 180)
End Function
Private Function Atan2(ByVal X As Double, ByVal Y As Double) As Double
' code nicked from:
' https://en.wikibooks.org/wiki/Programming:Visual_Basic_Classic
' /Simple_Arithmetic#Trigonometrical_Functions
' If you re-use this watch out: the x and y have been reversed from typical use.
If Y > 0 Then
If X >= Y Then
Atan2 = Atn(Y / X)
ElseIf X <= -Y Then
Atan2 = Atn(Y / X) + PI
Else
Atan2 = PI / 2 - Atn(X / Y)
End If
Else
If X >= -Y Then
Atan2 = Atn(Y / X)
ElseIf X <= Y Then
Atan2 = Atn(Y / X) - PI
Else
Atan2 = -Atn(X / Y) - PI / 2
End If
End If
End Function
'======================================
I have a for loop (the last loop in the code below) which fills some arrays with values through some computations.
However, for some reason, once i=5 it jumps back up to the top of the loop (the x+h part) without going through the rest of the loop.
While x < xmax
If x + h < xmax Then 'If the step is going to overshoot the desired xmax
x = x + h 'make h adequately smalller
Else
h = xmax - x
x = xmax
End If
'k(Order #, equation #)
For j = 1 To 6 'First to 6th order
'temp=riddersmethodT(temp) 'Calculate temperature of mixture
FT = 0
rho(0) = 0 'Setting FT and rho_av to 0 to be re-calculated
For i = 1 To 7
rho(0) = rho(0) + rho(i) * Y4(i) 'Calculate average density of mixture
FT = FT + Y4(i)
vol_F = vol_F + Y4(i) * MW(i) / rho(i) 'Calculating the total volumetric flowrate (m^3/s)
Next i
rho(0) = rho(0) / FT
For i = 1 To 8 'Calculating all of the k(1) values for eq 1 to 8
k(j, i) = AllODES(x, Y4, i, j, k, h, temp, diameter, vol_F, rho(0))
Next i
Next j
For i = 1 To 8
Y4Old(i) = Y4(i) 'Saving old y4 values to calc delta0
Y4(i) = Y4(i) + h * (k(1, i) * (37 / 378) + k(3, i) * (250 / 621) + k(4, i) * (125 / 594) + k(6, i) * (512 / 1771))
Y5(i) = Y4(i) + h * (k(1, i) * (2825 / 27648) + k(3, i) * (18575 / 48384) + k(4, i) * (13525 / 55296) + k(5, i) * (277 / 14336) + k(6, i) * (0.25))
delta0(i) = error
delta1(i) = Abs(Y5(i) - Y4(i))
delRatio(i) = Abs(delta0(i) / delta1(i)) 'Ratio of errors; careful of getting zeroes!
Next i
I don't understand how this can be possible seeing as i is not being manipulated within that loop. If you have any insight, please let me know!
My guess is that your final loop over i has a divide by zero somewhere. You could handle errors in your loop using something like the following:
Sub yourSub()
For i = 1 To 8
On Error GoTo ErrorHandler:
Y4Old(i) = Y4(i)
'Saving old y4 values to calc delta0
Y4(i) = Y4(i) + h * (k(1, i) * (37 / 378) + k(3, i) * (250 / 621) + k(4, i) * (125 / 594) + k(6, i) * (512 / 1771))
Y5(i) = Y4(i) + h * (k(1, i) * (2825 / 27648) + k(3, i) * (18575 / 48384) + k(4, i) * (13525 / 55296) + k(5, i) * (277 / 14336) + k(6, i) * (0.25))
delta0(i) = error
delta1(i) = Abs(Y5(i) - Y4(i))
delRatio(i) = Abs(delta0(i) / delta1(i)
Next i
Cleanup:
' do cleanup here
Exit Sub
ErrorHandler:
' handle error here
Resume Cleanup
End Sub
But it would be best to fix your match which is allowing a division by zero in the first place.
So I've been working on this for the past week. Although it can't do miracles, I can say I've got a pretty good result:
I just wanted to put this code out there for all the poor souls like me that are looking for some kind of vba macro that helps them avoid label overlaps in a scatter plot, because while doing my research on the subject, I wasn't able to find anything helpful.
Const PIXEL_TO_POINT_RATIO As Double = 0.72 '1 Pixel = 72/96*1 Point
Const tStep As Double = 0.1
Const rStep As Double = 0.1
Dim pCount As Integer
Sub ExampleMain()
RearrangeScatterLabels Sheet5
RearrangeScatterLabels Sheet25
End Sub
Sub RearrangeScatterLabels(sht As Worksheet)
Dim plot As Chart
Dim sCollection As SeriesCollection
Dim dLabels() As DataLabel
Dim dPoints() As Point
Dim xArr(), yArr(), stDevX, stDevY As Double
Dim x0, x1, y0, y1 As Double
Dim temp() As Double
Dim theta As Double
Dim r As Double
Dim isOverlapped As Boolean
Dim safetyNet, validEntry, currentPoint As Integer
Set plot = sht.ChartObjects(1).Chart 'XY chart (scatter plot)
Set sCollection = plot.SeriesCollection 'All points and labels
safetyNet = 1
pCount = (sCollection.Count - 1)
ReDim dLabels(1 To 1)
ReDim dPoints(1 To 1)
ReDim xArr(1 To 1)
ReDim yArr(1 To 1)
For pt = 1 To sCollection(1).Points.Count
For i = 1 To pCount
If sCollection(i).Points.Count <> 0 Then
'Dynamically expand the arrays
validEntry = validEntry + 1
If validEntry <> 1 Then
ReDim Preserve dLabels(1 To UBound(dLabels) + 1)
ReDim Preserve dPoints(1 To UBound(dPoints) + 1)
ReDim Preserve xArr(1 To UBound(xArr) + 1)
ReDim Preserve yArr(1 To UBound(yArr) + 1)
End If
Set dLabels(i) = sCollection(i).Points(pt).DataLabel 'Store all label objects
Set dPoints(i) = sCollection(i).Points(pt) 'Store all point objects
temp = getElementDimensions(, dPoints(i))
xArr(i) = temp(0) 'Store all points x values
yArr(i) = temp(2) 'Store all points y values
End If
Next
Next
If UBound(dLabels) < 2 Then Exit Sub
pCount = UBound(dLabels)
stDevX = Application.WorksheetFunction.StDev(xArr) 'Get standard deviation for x
stDevY = Application.WorksheetFunction.StDev(yArr) 'Get standard deviation for y
If stDevX = 0 Then stDevX = 1
If stDevY = 0 Then stDevY = 1
r = 0
For currentPoint = 1 To pCount
theta = Rnd * 2 * Application.WorksheetFunction.Pi()
x0 = xArr(currentPoint)
y0 = yArr(currentPoint)
x1 = xArr(currentPoint)
y1 = yArr(currentPoint)
isOverlapped = True
Do Until Not isOverlapped
safetyNet = safetyNet + 1
If safetyNet < 500 Then
If Not checkForOverlap(dLabels(currentPoint), dLabels, dPoints, plot) Then
'No label is within bounds and not overlapping
isOverlapped = False
r = 0
theta = Rnd * 2 * Application.WorksheetFunction.Pi()
safetyNet = 1
Else
'Move label so it does not overlap
theta = theta + tStep
r = r + rStep * tStep / (2 * Application.WorksheetFunction.Pi())
x1 = x0 + stDevX * r * Cos(theta)
y1 = y0 + stDevY * r * Sin(theta)
dLabels(currentPoint).Left = x1
dLabels(currentPoint).Top = y1
End If
Else
safetyNet = 1
Exit Do
End If
Loop
Next
End Sub
Function checkForOverlap(ByRef dLabel As DataLabel, ByRef dLabels() As DataLabel, ByRef dPoints() As Point, ByRef dChart As Chart) As Boolean
checkForOverlap = False 'Return false by default
'Detect label going over chart area
If detectOverlap(dLabel, , , dChart) Then
checkForOverlap = True
Exit Function
End If
'Detect labels overlap
For i = 1 To pCount
If Not dLabel.Left = dLabels(i).Left Then
If detectOverlap(dLabel, dLabels(i)) Then
checkForOverlap = True
Exit Function
End If
End If
Next
'Detect label overlap with point
For i = 1 To pCount
If detectOverlap(dLabel, , dPoints(i)) Then
checkForOverlap = True
Exit Function
End If
Next
End Function
Function getElementDimensions(Optional dLabel As DataLabel, Optional dPoint As Point, Optional dChart As Chart) As Double()
'Get element dimensions and compensate slack
Dim eDimensions(3) As Double
'Working in IV quadrant
If dPoint Is Nothing And dChart Is Nothing Then
'Get label dimensions and compensate padding
eDimensions(0) = dLabel.Left + PIXEL_TO_POINT_RATIO * 3 'Left
eDimensions(1) = dLabel.Left + dLabel.Width - PIXEL_TO_POINT_RATIO * 3 'Right
eDimensions(2) = dLabel.Top + PIXEL_TO_POINT_RATIO * 6 'Top
eDimensions(3) = dLabel.Top + dLabel.Height - PIXEL_TO_POINT_RATIO * 3 'Bottom
End If
If dLabel Is Nothing And dChart Is Nothing Then
'Get point dimensions
eDimensions(0) = dPoint.Left - PIXEL_TO_POINT_RATIO * 5 'Left
eDimensions(1) = dPoint.Left + PIXEL_TO_POINT_RATIO * 5 'Right
eDimensions(2) = dPoint.Top - PIXEL_TO_POINT_RATIO * 5 'Top
eDimensions(3) = dPoint.Top + PIXEL_TO_POINT_RATIO * 5 'Bottom
End If
If dPoint Is Nothing And dLabel Is Nothing Then
'Get chart dimensions
eDimensions(0) = dChart.PlotArea.Left + PIXEL_TO_POINT_RATIO * 22 'Left
eDimensions(1) = dChart.PlotArea.Left + dChart.PlotArea.Width - PIXEL_TO_POINT_RATIO * 22 'Right
eDimensions(2) = dChart.PlotArea.Top - PIXEL_TO_POINT_RATIO * 4 'Top
eDimensions(3) = dChart.PlotArea.Top + dChart.PlotArea.Height - PIXEL_TO_POINT_RATIO * 4 'Bottom
End If
getElementDimensions = eDimensions 'Return dimensions array in Points
End Function
Function detectOverlap(ByVal dLabel1 As DataLabel, Optional ByVal dLabel2 As DataLabel, Optional ByVal dPoint As Point, Optional ByVal dChart As Chart) As Boolean
'Left, Right, Top, Bottom
Dim AxL, AxR, AyT, AyB As Double 'First label coordinates
Dim BxL, BxR, ByT, ByB As Double 'Second label coordinates
Dim eDimensions() As Double 'Element dimensions
eDimensions = getElementDimensions(dLabel1)
AxL = eDimensions(0)
AxR = eDimensions(1)
AyT = eDimensions(2)
AyB = eDimensions(3)
If dPoint Is Nothing And dChart Is Nothing Then
'Compare with another label
eDimensions = getElementDimensions(dLabel2)
End If
If dLabel2 Is Nothing And dChart Is Nothing Then
'Compare with a point
eDimensions = getElementDimensions(, dPoint)
End If
If dPoint Is Nothing And dLabel2 Is Nothing Then
'Compare with chart area
eDimensions = getElementDimensions(, , dChart)
End If
BxL = eDimensions(0)
BxR = eDimensions(1)
ByT = eDimensions(2)
ByB = eDimensions(3)
If dChart Is Nothing Then
detectOverlap = (AxL <= BxR And AxR >= BxL And AyT <= ByB And AyB >= ByT) 'Reverse De Morgan's Law
Else
detectOverlap = Not (AxL >= BxL And AxR <= BxR And AyT >= ByT And AyB <= ByB) 'Is in chart bounds (working in IV quadrant)
End If
End Function
I realize the code is kinda rough and not optimized, but I can't spend more time on this project. I've left quite a few notes around to help read it, should anyone choose to continue this project. Hope this helps.
Best wishes, Schadenfreude.
Building on your function, I made a routine to randomly reposition the labels, assigning a score according to how much overlap it would cause, and thusly optimize. The results aren't great for my own data set, but I think it can be tuned easily for most usages.
There are some issues with the borders and the axis labels which maybe I'll account for later.
Option Explicit
Sub ExampleUsage()
RearrangeScatterLabels ActiveSheet.ChartObjects(1).Chart, 3
End Sub
Sub RearrangeScatterLabels(plot As Chart, Optional timelimit As Double = 5)
Dim sCollection As SeriesCollection
Set sCollection = plot.SeriesCollection
Dim pCount As Integer
pCount = sCollection(1).Points.Count
If pCount < 2 Then Exit Sub
Dim dPoints() As Point
Dim xArr() As Double ' Label center position X
Dim yArr() As Double ' Label center position Y
Dim wArr() As Double ' Label width
Dim hArr() As Double ' Label height
Dim pArr() As Double ' Marker position X
Dim qArr() As Double ' Marker position Y
Dim mArr() As Double ' Markersize
ReDim dPoints(1 To pCount)
ReDim xArr(1 To pCount)
ReDim yArr(1 To pCount)
ReDim wArr(1 To pCount)
ReDim hArr(1 To pCount)
ReDim pArr(1 To pCount)
ReDim qArr(1 To pCount)
ReDim mArr(1 To pCount)
Dim theta As Double
Dim i As Integer
Dim j As Integer
Dim dblStart As Double
' Loop through all points to get their handles and coordinates
For i = 1 To pCount
' Store all point objects
Set dPoints(i) = sCollection(1).Points(i)
' Extract their coordinates and size
pArr(i) = dPoints(i).Left
qArr(i) = dPoints(i).Top
mArr(i) = dPoints(i).MarkerSize
' Store the size of the corresponding labels
wArr(i) = dPoints(i).DataLabel.Width
hArr(i) = dPoints(i).DataLabel.Height
' Starting position (center of label) is middle below
xArr(i) = pArr(i)
yArr(i) = qArr(i) + mArr(i)
Next
Dim newX As Double
Dim newY As Double
Dim dE As Double
Dim wgtOverlap As Double
Dim wgtDistance As Double
Dim wgtClose As Double
wgtOverlap = 10000 ' Extra penalty for overlapping
wgtDistance = 10000 ' Penalty for being nearby other labels
wgtClose = 10 ' Penalty for being further from marker
' Limit the function by time
dblStart = Timer
Do Until TimerDiff(dblStart, Timer) > timelimit
' Pick a random label to move around
i = Int(Rnd * pCount + 1)
' Pick a new random position by angle
theta = Rnd * 2 * Application.WorksheetFunction.Pi()
' Determine the position it would shift to
If Abs(Sin(theta) * wArr(i)) > Abs(hArr(i) * Cos(theta)) Then
' above or below
If Sin(theta) > 0 Then
' above
newX = pArr(i) + wArr(i) * Cos(theta) / 2
newY = qArr(i) - hArr(i) / 2 - mArr(i) / 2
Else
' below
newX = pArr(i) + wArr(i) * Cos(theta) / 2
newY = qArr(i) + hArr(i) / 2 + mArr(i) / 2
End If
Else
' left or right side
If Cos(theta) < 0 Then
' left
newX = pArr(i) - wArr(i) / 2 - mArr(i) / 2
newY = qArr(i) - hArr(i) * Sin(theta) / 2
Else
' right
newX = pArr(i) + wArr(i) / 2 + mArr(i) / 2
newY = qArr(i) - hArr(i) * Sin(theta) / 2
End If
End If
' Determine increase in energy caused by this shift
dE = 0
For j = 1 To pCount
If i <> j Then
' Current overlap with labels
If 2 * Abs(xArr(i) - xArr(j)) < wArr(i) + wArr(j) _
And 2 * Abs(yArr(i) - yArr(j)) < hArr(i) + hArr(j) Then
dE = dE - Abs(xArr(i) - xArr(j) + (wArr(i) + wArr(j)) / 2) _
* Abs(yArr(i) - yArr(j) + (hArr(i) + hArr(j)) / 2)
dE = dE - wgtOverlap
End If
' New overlap with labels
If 2 * Abs(newX - xArr(j)) < wArr(i) + wArr(j) _
And 2 * Abs(newY - yArr(j)) < hArr(i) + hArr(j) Then
dE = dE + Abs(newX - xArr(j) + (wArr(i) + wArr(j)) / 2) _
* Abs(newY - yArr(j) + (hArr(i) + hArr(j)) / 2)
dE = dE + wgtOverlap
End If
' Current overlap with labels
If Abs(xArr(i) - pArr(j)) < wArr(i) / 2 + mArr(j) _
And Abs(yArr(i) - qArr(j)) < hArr(i) / 2 + mArr(j) Then
dE = dE - wgtOverlap
End If
' New overlap with points
If Abs(newX - pArr(j)) < wArr(i) / 2 + mArr(j) _
And Abs(newY - qArr(j)) < hArr(i) / 2 + mArr(j) Then
dE = dE + wgtOverlap
End If
' We like the neighbours to be far away
dE = dE - wgtDistance / ((xArr(i) - xArr(j)) ^ 2 + (yArr(i) - yArr(j)) ^ 2)
dE = dE + wgtDistance / ((newX - xArr(j)) ^ 2 + (newY - yArr(j)) ^ 2)
End If
' We like the offsets to be low
dE = dE - wgtClose * (Abs(xArr(i) - pArr(i)) + Abs(yArr(i) - qArr(i)))
dE = dE + wgtClose * (Abs(newX - pArr(i)) + Abs(newY - qArr(i)))
Next
' If it didn't get worse, adjust to new position
If dE <= 0 Then
xArr(i) = newX
yArr(i) = newY
End If
Loop
' Actually adjust the labels
For i = 1 To pCount
dPoints(i).DataLabel.Left = xArr(i) - wArr(i) / 2
dPoints(i).DataLabel.Top = yArr(i) - hArr(i) / 2
Next
End Sub
' Timer function from Peter Albert
' http://stackoverflow.com/questions/15634623
Function TimerDiff(dblTimerStart As Double, dblTimerEnd As Double)
Dim dblTemp As Double
dblTemp = dblTimerEnd - dblTimerStart
If dblTemp < -43200 Then
dblTemp = dblTemp + 86400
End If
TimerDiff = dblTemp
End Function
I have been trying to get a 2D grid going. It's for a game map.
Unfortunately, the grid is not as it should be. And I cannot figure out why.
Does anyone have an idea?
Imports Microsoft.DirectX
Imports Microsoft.DirectX.Direct3D
Public Class clsIsometric
'==================================
' SETTINGS
'==================================
Private tile_size As New Point(64, 64) 'Size of one tile in pixels
Private map_size As New Point(25, 25) 'Amount of tiles in total
Private gDevice As Device
Private bufVertex As VertexBuffer
Private bufIndex As IndexBuffer
Private gVertices() As CustomVertex.TransformedColored
Private gIndices() As Integer
'==================================
' CONSTRUCTOR
'==================================
Public Sub New(vDevice As Device)
gDevice = vDevice
End Sub
Public Sub dispose()
bufVertex.Dispose()
bufIndex.Dispose()
bufVertex = Nothing
bufIndex = Nothing
End Sub
'==================================
' RENDERING
'==================================
Public Sub buildMap()
' Recreate buffers to fit the map size
ReDim gVertices((map_size.X + 1) * (map_size.Y + 1)) ' x+1 * y+1
ReDim gIndices(map_size.X * map_size.Y * 6) ' x * y * 6
Dim k As Integer
For cX = 0 To map_size.X - 1 'Rows
For cY = 0 To map_size.Y - 1 'Columns
'VERTEX
k = cX * map_size.X + cY
gVertices(k) = New CustomVertex.TransformedColored(cX * tile_size.X, cY * tile_size.Y, 0, 1, Color.Blue.ToArgb)
Next cY
Next cX
Dim vertexPerCol As Integer = map_size.Y + 1
k = 0
For ccX = 0 To map_size.X - 1
For ccY = 0 To map_size.Y - 1
gIndices(k) = ccX * vertexPerCol + ccY ' 0
gIndices(k + 1) = (ccX + 1) * vertexPerCol + (ccY + 1) ' 1
gIndices(k + 2) = (ccX + 1) * vertexPerCol + ccY ' 2
gIndices(k + 3) = ccX * vertexPerCol + ccY ' 3
gIndices(k + 4) = ccX * vertexPerCol + (ccY + 1) ' 4
gIndices(k + 5) = (ccX + 1) * vertexPerCol + (ccY + 1) ' 5
k += 6 'Each tile has 6 indices. Increase for next tile
Next
Next
bufVertex = New VertexBuffer(GetType(CustomVertex.TransformedColored), gVertices.Length, gDevice, Usage.Dynamic Or Usage.WriteOnly, CustomVertex.TransformedColored.Format, Pool.Default)
bufIndex = New IndexBuffer(GetType(Integer), gIndices.Length, gDevice, Usage.WriteOnly, Pool.Default)
End Sub
Public Sub render()
'RENDER THE MAP
bufVertex.SetData(gVertices, 0, LockFlags.ReadOnly)
bufIndex.SetData(gIndices, 0, LockFlags.None)
gDevice.VertexFormat = CustomVertex.TransformedColored.Format
gDevice.SetStreamSource(0, bufVertex, 0)
gDevice.Indices = bufIndex
gDevice.DrawIndexedPrimitives(PrimitiveType.TriangleList, 0, 0, gVertices.Length, 0, CInt(gIndices.Length / 3))
End Sub
End Class
This should output a perfect square grid of 25 by 25 tiles. But the wireframe looks like:
http://i43.tinypic.com/2whf51c.jpg
Your loop which build the vertices seems to end too early, because you have n+1 vertices each row/column. It fills the array only to the forelast column, which leads to a shift in the vertices.
For cX = 0 To map_size.X 'Rows
For cY = 0 To map_size.Y 'Columns
'VERTEX
k = cX * (map_size.X + 1) + cY
gVertices(k) = New CustomVertex.TransformedColored(cX * tile_size.X, cY * tile_size.Y, 0, 1, Color.Blue.ToArgb)
Next cY
Next cX
I have an older program that I wrote some time ago in VB then late updated for VB.Net. The program calculates the ephemerides of comets based on orbital elements downloaded from the Minor Planet Center website. I am now trying to make an iPhone/iPad application using the same idea and the same calculations. Unfortunately I am too new at objective-c that trying to convert the extensive calculations is proving quite difficult for me. I am hoping that someone can help me out and at least give me some pointers.
In particular, I have no idea how to accomplish this in objective-c:
Dim d1 As Date = DateSerial(yr_peri%, mo_peri%, dy_peri%)
dateser# = d1.ToOADate()
dateser# = dateser# + frac_day_peri#
jdperi# = 2415018.5 + dateser#
and this:
' Find Julian Day Number of start date & time
Dim d2 As Date = DateSerial(yr%, mo%, dd%)
Dim inputdate# = d2.ToOADate()
jdp# = inputdate + 2415018.5 ' use this day for phenom (rise/set) calcs
jd# = jdp# + fd# ' add fractional days
Here is the full VB version of the calculations in case it helps to understand the context:
Public Sub calc(ByVal cname$, ByVal qq#, ByVal e#, ByVal w#, ByVal om#, ByVal I#, ByVal yr_peri%, ByVal mo_peri%, ByVal day_peri#, ByVal abs_mag#, ByVal mag_n#)
Dim ep#
Dim dy_peri%, frac_day_peri#, dateser#, jdperi#
Dim yr%, mo%, dd%, fd#
Dim jdp#, jd#, interval#
Dim twi%, p_date#, ut#, er%
Dim t#, tt#, f#, p#, g#, q#, h#, r#
Dim a1#, a2#, b1#, b2#, c1#, c2#
Dim sdt#, a#, n#, period#, m#, e0#
Dim mrs#, frs%, ers0#, drs#, jrs%, mrs1#, e2#
Dim tv#, v#, r1#, r2#, w0#, s#, s0#
Dim x#, y#, z#, ls#, ms#, es#, th#, vs#, c#, th2000#
Dim rs#, xs#, ys#, zs#, xx#, yy#, radeg#, rad#, ra#, ras$
Dim dl#, dlm#, sd#, dec#, ds$
Dim cospsi#, psi#, elong#, cosbeta#, beta#, phase#
Dim ha#, ang#, az#, sinalt#, alt#, m1#, vl#
Dim Lati$, Longi$
Dim outpt$
'----------------------------------------------
'** AA=ASTRONOMICAL ALGORITHMS BY JEAN MEEUS **
'----------------------------------------------
counter% = 0
ep# = 23.439291 ' year 2000, AA page 214
cname$ = Trim(cname$)
'Get orbital elements
MainForm.grpEphemerides.Text = "Comet: " & cname$ & " - " + when$ ' Name
'qq# = Val(comet$(ind%, 1)) ' perihelion dist
'e# = Val(comet$(ind%, 2)) ' eccentricity (1=parabola)
'w# = Val(comet$(ind%, 3)) ' arg of perihelion - little omega
'om# = Val(comet$(ind%, 4)) ' long of ascending node - big omega
'I# = Val(comet$(ind%, 5)) ' inclination
'yr_peri% = Val(comet$(ind%, 6)) ' year
'mo_peri% = Val(comet$(ind%, 7)) ' month
'day_peri# = Val(comet$(ind%, 8)) ' day
'abs_mag# = Val(comet$(ind%, 9)) ' magnitude coef #1
'mag_n# = Val(comet$(ind%, 10)) ' magnitude coef #2
' Find JD of perihelion
dy_peri% = Int(day_peri#) ' day
frac_day_peri# = day_peri# - dy_peri% ' fractional day
Dim d1 As Date = DateSerial(yr_peri%, mo_peri%, dy_peri%)
dateser# = d1.ToOADate()
dateser# = dateser# + frac_day_peri#
jdperi# = 2415018.5 + dateser#
' Start date/time
yr% = Val(MainForm.txtYear.Text)
mo% = Val(MainForm.txtMonth.Text)
dd% = Val(MainForm.txtDay.Text)
fd# = Val(MainForm.txtHour.Text) / 24 + Val(MainForm.txtMin.Text) / 1440 + Val(MainForm.txtSec.Text) / 86400
lat# = Val(MainForm.txtLat.Text)
lon# = Val(MainForm.txtLon.Text)
' Find Julian Day Number of start date & time
Dim d2 As Date = DateSerial(yr%, mo%, dd%)
Dim inputdate# = d2.ToOADate()
jdp# = inputdate + 2415018.5 ' use this day for phenom (rise/set) calcs
jd# = jdp# + fd# ' add fractional days
interval# = Val(MainForm.txtInterval.Text)
' Determine if fixed times or rise/set phenomena
If MainForm.rdbFixedTimes.Checked = True Then
twi% = 0 ' use fixed times
Else
twi% = 1 ' use twilight times
interval# = Int(interval#) ' Set integer days (fraction doesn't make sense)
If interval# < 1 Then interval# = 1 ' make sure interval is at least one day
End If
'-----------
' Loop here
'-----------
While counter% <= Val(MainForm.txtNumSteps.Text)
If twi% = 1 Then
'Serial date of this calculation
p_date# = jdp# - 2415018.5
Call phenom(p_date#, ut#, er%) ' calcs for rise/set, returns er% (among other stuff)
jd# = Int(p_date#) + 2415018.5 + ut# / 24 + 1 / 2880
If er% = 1 Then ' er%=1 means no phenom (ex: sunrise) that day
ser_date# = jd# - 2415018.5
outpt$ = Format$(ser_date#, "mm/dd/yy") + " " + "No Rise/Set Phenomena on this Date"
GoTo No_phenom
End If
End If
' Days from perihelion of comet
t# = jd# - jdperi#
' Time (in Julian Centuries (36525 days)) since 1900 Jan 0.5 ET
' AA page 151
tt# = (jd# - 2451545.0#) / 36525.0!
'-------------- CALC F,G,H,P,Q,R (PP214 IN AA) ---------------
f# = Cos(dr# * om#)
p# = -Sin(dr# * om#) * Cos(dr# * I#)
g# = Sin(dr# * om#) * Cos(dr# * ep#)
q# = Cos(dr# * om#) * Cos(dr# * I#) * Cos(dr# * ep#) - Sin(dr# * I#) * Sin(dr# * ep#)
h# = Sin(dr# * om#) * Sin(dr# * ep#)
r# = Cos(dr# * om#) * Cos(dr# * I#) * Sin(dr# * ep#) + Sin(dr# * I#) * Cos(dr# * ep#)
'---------------- CALC A1,A2,B1,B2,C1,C2 (PP214 AA) -----------------
Call rec2pol(p#, f#, a1#, a2#)
Call rec2pol(q#, g#, b1#, b2#)
Call rec2pol(r#, h#, c1#, c2#)
'--------------- SIDEREAL TIME AT GREENWICH (PP84 AA) ----------------
' In degrees
sdt# = 280.46061837 + 360.98564736629 * (jd# - 2451545) + 0.000387933 * tt# * tt# - tt# * tt# * tt# / 38710000
sdt# = sdt# - 360 * Int(sdt# / 360)
'------------------- CALC ECCENTRIC & TRUE ANOMALY --------------------
If e# < 1 Then ' elliptical motion (pp214 AA)
a# = qq# / (1 - e#) ' semi major axis (AU)
n# = 0.9856076686 / a# / Sqrt(a#) ' mean motion (deg/day)
period# = 360 / n# / 365.25
MainForm.lblOrbitInf.Text = "Semimajor axis: " + Format$(a#, "#.000") + " AU Period: " + Format$(period#, "#.00") + " Years"
m# = n# * t# ' mean anomaly
e0# = rd# * e# ' "modified" eccentricity, page 187)
'ecc anomaly (page 195)
mrs# = m# * dr#
frs% = Sign(mrs#)
mrs# = Abs(mrs#) / (2 * pi#)
mrs# = (mrs# - Int(mrs#)) * 2 * pi# * frs%
If mrs# < 0 Then mrs# = mrs# + 2 * pi#
frs% = 1
If mrs# > pi# Then frs% = -1
If mrs# > pi# Then mrs# = 2 * pi# - mrs#
ers0# = pi# / 2
drs# = pi# / 4
For jrs% = 1 To 53
mrs1# = ers0# - e# * Sin(ers0#)
ers0# = ers0# + drs# * Sign(mrs# - mrs1#)
drs# = drs# / 2
Next jrs%
ers0# = ers0# * frs%
e2# = ers0# * rd#
'alpha# = (1 - e#) / (4 * e# + .5)
'beta# = m# / (8 * e# + 1)
'signbeta% = Sgn(beta#)
'cube# = beta# + signbeta% * Sqr(beta# ^ 2 + alpha# ^ 3)
'signz% = Sgn(cube#)
'zz# = signz% * (Abs(cube#)) ^ (1 / 3)
'ss0# = zz# - alpha# / 2
'ss# = ss0# - .078 * ss0# ^ 5 / (1 + e#)
'e1# = m# + e# * (3 * ss# - 4 * ss# ^ 3)
'loop1% = 0 ' counter
1040:
'e2# = e1# + (m# + e0# * Sin(dr# * e1#) - e1#) / (1 - e# * Cos(dr# * e1#))
'If Abs(e2# - e1#) < .0000000001 Or loop1% > 1000 Then ' e2#:ecc anom found
tv# = Sqrt((1 + e#) / (1 - e#)) * Tan(dr# * e2# / 2)
v# = 2 * rd# * Atan(tv#) ' true anomaly
r1# = a# * (1 - e# * Cos(dr# * e2#)) ' dist from sun AU
GoTo 2120
'Else
' e1# = e2# ' new ecc anomaly
' loop1% = loop1% + 1
' GoTo 1040
'End If
Else ' parabolic motion (pp225 AA)
MainForm.lblOrbitInf.Text = "This comet has a parabolic orbit-semimajor axis and period not determined"
w0# = 0.0364911624 * t# / qq# / Sqrt(qq#)
s# = 0
2110:
s0# = (2 * s# * s# * s# + w0#) / 3 / (s# * s# + 1)
If Abs(s# - s0#) > 0.0000000001 Then
s# = s0#
GoTo 2110
End If
s# = s0#
v# = 2 * rd# * Atan(s#) ' true anomaly
r1# = qq# * (1 + s# * s#) ' distance from sun (AU)
End If
2120:
v# = v# - 360 * Int(v# / 360) ' true anomaly
'r1#= dist from sun in au (above)
r2# = r1# * 92955807.0# ' Dist from sun (miles)
'-------- CALC HELIOCENTRIC RECT COORD OF COMET (PP215 AA) ----------
x# = r1# * a2# * Sin(dr# * (a1# + w# + v#))
y# = r1# * b2# * Sin(dr# * (b1# + w# + v#))
z# = r1# * c2# * Sin(dr# * (c1# + w# + v#))
'-------- CALC GEOCENTRIC RECT COORD OF SUN (PP151,152 AA) ---------
ls# = 280.46645 + 36000.76983 * tt# + 0.0003032 * tt# * tt#
ls# = ls# - 360 * Int(ls# / 360)
ms# = 357.5291 + 35999.0503 * tt# - 0.0001559 * tt# * tt# - 0.00000048 * tt# * tt# * tt#
ms# = ms# - 360 * Int(ms# / 360)
es# = 0.016708617 - 0.000042037 * tt# - 0.0000001236 * tt# * tt#
c# = (1.9146 - 0.004817 * tt# - 0.000014 * tt# * tt#) * Sin(dr# * ms#) + (0.019993 - 0.000101 * tt#) * Sin(2 * dr# * ms#) + 0.00029 * Sin(3 * dr# * ms#)
th# = ls# + c# ' TH is Sun's true longitude
vs# = ms# + c# ' VS is Sun's true anomaly
' pp152 AA
th2000# = th# - 0.01397 * (yr% + mo% / 12 + dd% / 365 - 2000) ' Sun true long referred to 2000
' sun's radius vector
rs# = (1.000001018 * (1 - es# * es#)) / (1 + es# * Cos(dr# * vs#))
' rectangular coord of sun (pp159 AA)
xs# = rs# * Cos(dr# * th2000#) ' Xsun
ys# = rs# * Sin(dr# * th2000#) * Cos(dr# * ep#) ' Ysun
zs# = rs# * Sin(dr# * th2000#) * Sin(dr# * ep#) ' Zsun
'------------- CALC GEOCENTRIC RA & DEC (PP 119 IN AFFC) --------------
xx# = xs# + x#
yy# = ys# + y#
Call rec2pol(xx#, yy#, radeg#, rad#)
ra# = radeg# / 15 ' RA of comet (2000) in hours
' 0 means time
ras$ = dec2ddmm(ra#, 0) ' ra in string form
'dist from comet to earth (au)
dl# = Sqrt((xs# + x#) ^ 2 + (ys# + y#) ^ 2 + (zs# + z#) ^ 2)
dlm# = dl# * 92955807.0# ' distance from earth in miles
sd# = (zs# + z#) / dl#
'DEC of comet (2000)
dec# = rd# * Atan(sd# / Sqrt(-sd# * sd# + 1))
' 1 means angle
ds$ = dec2ddmm(dec#, 1) ' dec in string form
' Calc elongation
cospsi# = (rs# * rs# + dl# * dl# - r1# * r1#) / (2 * rs# * dl#)
psi# = -Atan(cospsi# / Sqrt(-cospsi# * cospsi# + 1)) + pi# / 2
elong# = psi# * rd#
elong# = elong# - 360 * Int(elong# / 360)
' Calc phase
cosbeta# = (r1# * r1# + dl# * dl# - rs# * rs#) / (2 * r1# * dl#)
beta# = -Atan(cosbeta# / Sqrt(-cosbeta# * cosbeta# + 1)) + pi# / 2
phase# = beta# * rd#
phase# = phase# - 360 * Int(phase# / 360)
'------------ CALCULATE ALTITUDE & AZIMUTH (AA PP89) --------------
ha# = sdt# - lon# - radeg#
yy# = Sin(dr# * ha#)
xx# = (Cos(dr# * ha#) * Sin(dr# * lat#) - Tan(dr# * dec#) * Cos(dr# * lat#))
' rectangular to polar
Call rec2pol(xx#, yy#, ang#, rad#)
az# = ang# + 180
az# = az# - 360 * Int(az# / 360)
sinalt# = Sin(dr# * lat#) * Sin(dr# * dec#) + Cos(dr# * lat#) * Cos(dr# * dec#) * Cos(dr# * ha#)
alt# = rd# * Atan(sinalt# / Sqrt(1 - sinalt# * sinalt#))
'-------------- CALC EST MAGNITUDES & ORBITAL VELOCITY (AA PP 216) ---------------
m1# = abs_mag# + 5 * Log(dl#) / Log(10) + 2.5 * mag_n# * Log(r1#) / Log(10)
If e# < 1 Then
vl# = 42.1219 * Sqrt((1 / r1#) - (1 / (2 * a#))) ' elliptical orbital velocity, page 223
Else
vl# = 42.1219 * Sqrt(1 / r1#) ' parabolic orital velocity (my approximation)
End If
'------------- Stuff for output form -------------
Dim dt As DateTime = DateTime.FromOADate(dateser#)
MainForm.lblJDperi.Text = "Date of perihelion: " + dt.ToString("dd MMM yyyy hh:mm:ss") + " UTC JD: " + Format$(jdperi#, "#.00000")
Lati$ = " "
Longi$ = " "
If lat# > 0 Then Lati$ = "N " Else Lati$ = "S "
If lon# > 0 Then Longi$ = "W" Else Longi$ = "E"
MainForm.lblLoc.Text = "Observing Location: " + Format$(lat#, "+00.0000;-00.0000") + Chr(176) + Lati$ + Format$(lon#, "+000.0000;-000.0000") + Chr(176) + Longi$
'Serial date of this calculation
ser_date# = jd# - 2415018.5
' put the main info into a string
dt = DateTime.FromOADate(ser_date#)
outpt = dt.ToString("MM/dd/yy HH:mm:ss") & " " & ras$ & " " & ds$ & " " & Format$(alt#, "+00.0;-00.0") & Chr(176) & " " & Format$(az#, "000.0") & Chr(176)
outpt = outpt & " " & Format$(r1#, "00.0000") & " " & Format$(dl#, "00.0000") & " " & Format$(m1#, "+00.0;-00.0") + " " & Format$(elong#, "000.0") & Chr(176)
No_phenom:
' put the string into the list box
MainForm.lstPosition.Items.Add(outpt)
' put the "extra" data into the array
extra#(counter%, 0) = t# ' time to perih
extra#(counter%, 1) = vl# ' speed
extra#(counter%, 2) = phase# ' phase
extra#(counter%, 3) = v# ' true anomaly
' Increment counter
counter% = counter% + 1
' New JD
jd# = jd# + interval#
jdp# = jdp# + interval#
End While ' do again until done
End Sub
I appreciate any help or direction anyone can give on converting this function to objective-c.
Regards,
Keith
When working with dates in Objective-C you will often need to work with more than 1 class unlike other languages such as C#, Java and VB.NET. For creating a date from a string or getting a string from a date you will want to use the NSDateFormatter. Now when attempting to modify or create a date with "components" (year,month,day etc.) you will want to use NSDateComponents along with the correct NSCalendar. The component solution looks like it will assist you with the DateSerial part. The line jdp# = inputdate + 2415018.5 should be convertible (if it is seconds) to
jdp = [NSDate dateWithTimeInterval:2415018.5 sinceDate:inputdate];