diff --git a/HSPEXP/HSPFOutputReports.vb b/HSPEXP/HSPFOutputReports.vb index 8ebb67fe5..161cdb6f5 100644 --- a/HSPEXP/HSPFOutputReports.vb +++ b/HSPEXP/HSPFOutputReports.vb @@ -208,8 +208,8 @@ Module HSPFOutputReports Directory.CreateDirectory(pOutFolderName) File.Copy(pTestPath & pBaseName & ".uci", pOutFolderName & pBaseName & ".uci", overwrite:=True) - 'read binary output files for later use in wq reports, qa reports, or receiving models - If pConstituents.Count > 0 Or pBATHTUB Or pWASP Or pModelQAQC Then + 'read binary output files for later use in qa reports + If pModelQAQC Then Dim lOpenHspfBinDataSource As New atcDataSource Logger.Dbg(Now & " Opening the binary output files.") For i As Integer = 0 To aHspfUci.FilesBlock.Count @@ -260,6 +260,23 @@ Module HSPFOutputReports DoExpertSystemStats(aHspfUci, lRunMade) End If + 'read binary output files again for later use in wq reports or receiving models + If pConstituents.Count > 0 Or pBATHTUB Or pWASP Then + Dim lOpenHspfBinDataSource As New atcDataSource + Logger.Dbg(Now & " Opening the binary output files.") + For i As Integer = 0 To aHspfUci.FilesBlock.Count + If aHspfUci.FilesBlock.Value(i).Typ = "BINO" Then + Dim lHspfBinFileName As String = AbsolutePath(aHspfUci.FilesBlock.Value(i).Name.Trim, CurDir()) + lOpenHspfBinDataSource = atcDataManager.DataSourceBySpecification(lHspfBinFileName) + If lOpenHspfBinDataSource Is Nothing Then + If atcDataManager.OpenDataSource(lHspfBinFileName) Then + lOpenHspfBinDataSource = atcDataManager.DataSourceBySpecification(lHspfBinFileName) + End If + End If + End If + Next i + End If + 'Write input file for BATHTUB If pBATHTUB Then If pOutputLocations.Count > 0 Then @@ -318,7 +335,13 @@ Module HSPFOutputReports Logger.Dbg(Now & " HSPEXP+ Complete") Logger.Msg("HSPEXP+ is complete") - OpenFile(pOutFolderName) + If pWASP Then + Dim lOutputFolder As String = System.IO.Path.Combine(pTestPath, "WASP") + OpenFile(lOutputFolder) + Else + OpenFile(pOutFolderName) + End If + If pModelQAQC Then OpenFile(pOutFolderName & "ModelQAQC.htm") End Using diff --git a/HSPEXP/StartUp.Designer.vb b/HSPEXP/StartUp.Designer.vb index c104e3a31..f6b68ad4c 100644 --- a/HSPEXP/StartUp.Designer.vb +++ b/HSPEXP/StartUp.Designer.vb @@ -504,7 +504,6 @@ Partial Class StartUp ' Me.GroupBox1.Controls.Add(Me.chkWASP) Me.GroupBox1.Controls.Add(Me.chkBathtub) - Me.GroupBox1.Enabled = False Me.GroupBox1.Location = New System.Drawing.Point(18, 491) Me.GroupBox1.Name = "GroupBox1" Me.GroupBox1.Size = New System.Drawing.Size(418, 55) @@ -564,7 +563,6 @@ Partial Class StartUp Me.Padding = New System.Windows.Forms.Padding(5) Me.StartPosition = System.Windows.Forms.FormStartPosition.CenterScreen Me.Text = "HSPEXP+ " - Me.TransparencyKey = System.Drawing.SystemColors.ActiveBorder Me.GroupBox3.ResumeLayout(False) Me.GroupBox3.PerformLayout() Me.Plotting.ResumeLayout(False) diff --git a/HSPEXP/WASP.vb b/HSPEXP/WASP.vb index 292474b39..f2fb0342c 100644 --- a/HSPEXP/WASP.vb +++ b/HSPEXP/WASP.vb @@ -17,7 +17,7 @@ Module WASP Dim lWaspProject As New atcWASPProject Dim lOutputFolder As String = System.IO.Path.Combine(aOutputfolder, "WASP") FileIO.FileSystem.CreateDirectory(lOutputFolder) - Dim lFileName As String = System.IO.Path.Combine(lOutputFolder, "WASP8_R" & aReachId.ToString & ".inp") + Dim lFileName As String = System.IO.Path.Combine(lOutputFolder, "WASP_R" & aReachId.ToString & ".inp") lWaspProject.SDate = Date.FromOADate(aSDateJ) lWaspProject.EDate = Date.FromOADate(aEDateJ) @@ -64,7 +64,7 @@ Module WASP lWaspProject.WASPConstituents.Add(New clsWASPConstituent("Inorganic Solids 3", "", "")) lWaspProject.WASPConstituents.Add(New clsWASPConstituent("Phytoplankton 1", "", "")) lWaspProject.WASPConstituents.Add(New clsWASPConstituent("Phytoplankton 2", "", "")) - lWaspProject.WASPConstituents.Add(New clsWASPConstituent(" Phytoplankton 3", "", "")) + lWaspProject.WASPConstituents.Add(New clsWASPConstituent("Phytoplankton 3", "", "")) lWaspProject.WASPConstituents.Add(New clsWASPConstituent("Total Inorganic C", "", "")) lWaspProject.WASPConstituents.Add(New clsWASPConstituent("Alkalinity", "", "")) @@ -327,19 +327,19 @@ Module WASP ' End If 'Next 'alternate scheme to write individual and composite timeseries - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "RO", lConvFactF, aSDateJ, aEDateJ, lOutputFolder) 'Flow - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "TAM-INTOT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Ammonia Nitrogen - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "NO3-INTOT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Nitrate Nitrogen - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "N-TOTORG-IN", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Dissolved Organic Nitrogen - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "PO4-INTOT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Inorganic Phosphate - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "P-TOTORG-IN", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Dissolved Organic Phosphorus - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "PHYTO-IN", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Phytoplankton Chla - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "BODIN", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'CBOD 1(Ultimate) - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "DOXIN", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Dissolved Oxygen - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "C-REFORG-IN", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Detrital Carbon - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "N-REFORG-IN", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Detrital Nitrogen - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "P-REFORG-IN", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Detrital Phosphorus - WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "ISED-TOT", lConvFactT, aSDateJ, aEDateJ, lOutputFolder) 'Solids + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "RO", lConvFactF, aSDateJ, aEDateJ, lOutputFolder) 'Flow + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "TAM-OUTTOT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Ammonia Nitrogen + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "NO3-OUTTOT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Nitrate Nitrogen + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "N-TOTORG-OUT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Dissolved Organic Nitrogen + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "PO4-OUTTOT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Inorganic Phosphate + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "P-TOTORG-OUT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Dissolved Organic Phosphorus + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "PHYTO-OUT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Phytoplankton Chla + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "BODOUTTOT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'CBOD 1(Ultimate) + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "DOXOUTTOT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Dissolved Oxygen + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "C-REFORG-OUT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Detrital Carbon + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "N-REFORG-OUT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Detrital Nitrogen + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "P-REFORG-OUT", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Detrital Phosphorus + WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "R", "ROSED-TOT", lConvFactT, aSDateJ, aEDateJ, lOutputFolder) 'Solids WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "L", "PERO", lConvFactV, aSDateJ, aEDateJ, lOutputFolder) 'Flow WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "L", "SOSED", lConvFactT, aSDateJ, aEDateJ, lOutputFolder) 'Solids WriteHSPFTimeseriesForWASP(aBinaryData, lReach, "L", "PODOXM", lConvFactP, aSDateJ, aEDateJ, lOutputFolder) 'Dissolved Oxygen @@ -529,7 +529,7 @@ Module WASP Dim lSW As IO.StreamWriter = Nothing lSW = New IO.StreamWriter(lFileName, False) For t As Integer = 1 To lTimeseries.Values.Count - 1 - lSW.WriteLine("{0,8:0.000} {1,9:0.00000}", t, lTimeseries.Values(t)) + lSW.WriteLine("{0,8:0.000},{1,9:0.00000}", t, lTimeseries.Values(t)) Next lSW.Flush() lSW.Close() @@ -564,16 +564,16 @@ Module WASP lConstituent = "SOQUAL-BOD" End If End If - Dim lFileName As String = System.IO.Path.Combine(aOutputfolder, "WASP_" & lContributingLandId.Replace(":", "") & "to" & lDownstreamReachId.Replace(":", "") & "_" & aConstituent & ".txt") + Dim lFileName As String = System.IO.Path.Combine(aOutputfolder, "WASP_" & lContributingLandId.Replace(":", "") & "to" & lDownstreamReachId.Replace(":", "") & "_" & lConstituent & ".txt") Dim lTimeseries As atcTimeseries = Nothing - lTimeseries = aBinaryData.DataSets.FindData("Location", lContributingLandId).FindData("Constituent", aConstituent)(0) + lTimeseries = aBinaryData.DataSets.FindData("Location", lContributingLandId).FindData("Constituent", lConstituent)(0) If lTimeseries IsNot Nothing Then lTimeseries = Aggregate(lTimeseries, atcTimeUnit.TUDay, 1, atcTran.TranSumDiv) * aConvFact * lMult lTimeseries = SubsetByDate(lTimeseries, aSDateJ, aEDateJ, Nothing) Dim lSW As IO.StreamWriter = Nothing lSW = New IO.StreamWriter(lFileName, False) For t As Integer = 1 To lTimeseries.Values.Count - 1 - lSW.WriteLine("{0,8:0.000} {1,9:0.00000}", t, lTimeseries.Values(t)) + lSW.WriteLine("{0,8:0.000},{1,9:0.00000}", t, lTimeseries.Values(t)) Next lSW.Flush() lSW.Close() @@ -596,7 +596,7 @@ Module WASP Dim lSW As IO.StreamWriter = Nothing lSW = New IO.StreamWriter(lFileName, False) For t As Integer = 1 To lCompositeTimeseries.Values.Count - 1 - lSW.WriteLine("{0,8:0.000} {1,9:0.00000}", t, lCompositeTimeseries.Values(t)) + lSW.WriteLine("{0,8:0.000},{1,9:0.00000}", t, lCompositeTimeseries.Values(t)) Next lSW.Flush() lSW.Close() diff --git a/HSPEXP/install.txt b/HSPEXP/install.txt index 0f04278b7..6b1003dc5 100644 --- a/HSPEXP/install.txt +++ b/HSPEXP/install.txt @@ -1,5 +1,6 @@ -Date: 11/19/2018 +Date: 2/1/2019 HSPEXP+3.0beta is the development version for the next version of HSPEXP+. + Features: 1. This version includes Model QA/QC report. The model QA/QC report is under development and it must be used with extreme caution. @@ -8,6 +9,7 @@ Bugs Fixed: 2. The location of help file was not coded properly in the previous version. That has been fixed. 3. The reports did not include adsorption/desorption and scour/deposition of TAM and PO4. That has been fixed. 4. The reports did not output labile and refractory organic P data for impervious areas. That has been fixed. +5. The expert system statistics computation for percentiles now excludes missing observed values. Date: 06/15/2018 diff --git a/atcClimateAssessmentTool/atcVariation.vb b/atcClimateAssessmentTool/atcVariation.vb index fdb169eb5..ca91cdf16 100644 --- a/atcClimateAssessmentTool/atcVariation.vb +++ b/atcClimateAssessmentTool/atcVariation.vb @@ -1,1046 +1,1046 @@ -Imports atcData -Imports atcEvents -Imports atcUtility -Imports MapWinUtility - -Public Class atcVariation - Private pNaN As Double = atcUtility.GetNaN - - 'Parameters for Hamon - Private pDegF As Boolean - - 'WestBranch of Patux - 'Private pCTS() As Double = {0, 0.0045, 0.01, 0.01, 0.01, 0.0085, 0.0085, 0.0085, 0.0085, 0.0085, 0.0095, 0.0095, 0.0095} - 'Monocacy - CBP - Private pCTS() As Double = {0, 0.0057, 0.0057, 0.0057, 0.0057, 0.0057, 0.0057, _ - 0.0057, 0.0057, 0.0057, 0.0057, 0.0057, 0.0057} - - Private pName As String - Private pDataSets As atcTimeseriesGroup - - Public Const PETstationUseClosest As String = "(Closest)" - - Public PETtemperature As atcTimeseriesGroup - Public PETprecipitation As atcTimeseriesGroup - Public PETelevation As Integer = Integer.MinValue - Public PETstationID As String = PETstationUseClosest - Private Shared PETswatStations As atcMetCmp.SwatWeatherStations - - Private pComputationSource As atcTimeseriesSource - Private pOperation As String - 'Public AddRemovePer As String - Private pSelected As Boolean - - 'TODO: make rest of public variables into properties - Public Seasons As atcSeasonBase - Public Min As Double - Public Max As Double - Public Increment As Double - Private pIncrementsSinceStart As Integer - Public CurrentValue As Double - - Public UseEvents As Boolean - Public EventThreshold As Double - Public EventDaysGapAllowed As Double - 'Public EventGapDisplayUnits As String - Public EventHigh As Boolean - - Public EventVolumeHigh As Boolean - Public EventVolumeThreshold As Double - - Public EventDurationHigh As Boolean - Public EventDurationDays As Double - 'Public EventDurationDisplayUnits As String - - Public IntensifyVolumeFraction As Double - - Public IsInput As Boolean - - Public ColorAboveMax As System.Drawing.Color - Public ColorBelowMin As System.Drawing.Color - Public ColorDefault As System.Drawing.Color - - Public Overridable Property Name() As String - Get - Return pName - End Get - Set(ByVal newValue As String) - pName = newValue - End Set - End Property - - Public Overridable Property DataSets() As atcTimeseriesGroup - Get - Return pDataSets - End Get - Set(ByVal newValue As atcTimeseriesGroup) - pDataSets = newValue - End Set - End Property - - Public Overridable Property ComputationSource() As atcTimeseriesSource - Get - Return pComputationSource - End Get - Set(ByVal newValue As atcTimeseriesSource) - pComputationSource = newValue - End Set - End Property - - Public Overridable Property Operation() As String - Get - Return pOperation - End Get - Set(ByVal newValue As String) - pOperation = newValue - End Set - End Property - - Public Overridable Property Selected() As Boolean - Get - Return pSelected - End Get - Set(ByVal newValue As Boolean) - pSelected = newValue - End Set - End Property - - Public Overridable ReadOnly Property Iterations() As Integer - Get - If Increment = 0 Then - Return 1 - Else - Try - Return (Max - Min) / Increment + 1 - Catch ex As Exception - Return 1 - End Try - End If - End Get - End Property - - Public Overridable Function StartIteration() As atcTimeseriesGroup - Me.CurrentValue = Me.Min - pIncrementsSinceStart = 0 - Return VaryData() - End Function - - Public Overridable Function NextIteration() As atcTimeseriesGroup - pIncrementsSinceStart += 1 - If pIncrementsSinceStart < Iterations Then - Me.CurrentValue = Me.Min + Me.Increment * pIncrementsSinceStart - Return VaryData() - Else - Return Nothing - End If - End Function - - ''' - ''' Divide the data in lOriginalData into a group of two atcTimeseries. - ''' First in group contains all values in the selected events and/or seasons, - ''' Second includes all other values. - ''' - ''' timeseries to split into selected and not selected - ''' Return argument: populated with one timeseries per selected event - ''' found in aOriginalData if events are in use, - ''' not set if events are not in use - ''' Group of two timeseries - Public Function SplitData(ByVal aOriginalData As atcTimeseries, _ - ByRef aEvents As atcTimeseriesGroup) As atcTimeseriesGroup - Dim lSplitData As atcTimeseriesGroup = Nothing - If UseEvents Then - Dim lEvent As atcTimeseries - aEvents = EventSplit(aOriginalData, Nothing, EventThreshold, EventDaysGapAllowed, EventHigh) - - 'Remove events outside selected seasons - If Seasons IsNot Nothing Then - For lEventIndex As Integer = aEvents.Count - 1 To 0 Step -1 - lEvent = aEvents.ItemByIndex(lEventIndex) - - 'Find peak value of event - Dim lPeakIndex As Integer = 1 - For lValueIndex As Integer = 2 To lEvent.numValues - If lEvent.Value(lValueIndex) > lEvent.Value(lPeakIndex) Then - lPeakIndex = lValueIndex - End If - Next - - 'If peak is not in season, remove this event - If Not Seasons.SeasonSelected(Seasons.SeasonIndex(lEvent.Dates.Value(lPeakIndex))) Then - aEvents.RemoveAt(lEventIndex) - End If - Next - End If - - 'Remove events outside target volume threshold - Try - If Not Double.IsNaN(EventVolumeThreshold) Then - For lEventIndex As Integer = aEvents.Count - 1 To 0 Step -1 - Dim lEventVolume As Double = aEvents.ItemByIndex(lEventIndex).Attributes.GetValue("Sum") - If EventVolumeHigh Then - If lEventVolume < EventVolumeThreshold Then - aEvents.RemoveAt(lEventIndex) - End If - Else - If lEventVolume > EventVolumeThreshold Then - aEvents.RemoveAt(lEventIndex) - End If - End If - Next - End If - Catch e As Exception - Logger.Dbg("VaryDataException-EventVolumeThreshold " & e.Message) - End Try - - 'Remove events outside target duration threshold - If Not Double.IsNaN(EventDurationDays) Then - For lEventIndex As Integer = aEvents.Count - 1 To 0 Step -1 - Dim lEventDuration As Double = atcSynopticAnalysis.atcSynopticAnalysisPlugin.DataSetDuration(aEvents.ItemByIndex(lEventIndex)) - If EventDurationHigh Then - If lEventDuration < EventDurationDays Then - aEvents.RemoveAt(lEventIndex) - End If - Else - If lEventDuration > EventDurationDays Then - aEvents.RemoveAt(lEventIndex) - End If - End If - Next - End If - - 'If Operation <> "Intensify" Then - If aEvents.Count > 0 Then - lSplitData = New atcTimeseriesGroup(MergeTimeseries(aEvents)) - lSplitData.Add(aOriginalData) - End If - 'End If - - Else - If Seasons Is Nothing Then - lSplitData = New atcTimeseriesGroup(aOriginalData) - Else - lSplitData = Seasons.SplitBySelected(aOriginalData, Nothing) - End If - End If - Return lSplitData - End Function - - Private Function VaryDataIntensify(ByRef lSplitData As atcTimeseriesGroup, ByRef lEvents As atcTimeseriesGroup) As atcTimeseries - Dim lEvent As atcTimeseries - Dim lArgsMath As New atcDataAttributes - Dim lTotalVolume As Double = lSplitData(0).Attributes.GetValue("Sum") - Dim lEventIntensifyFactor As Double - Dim lCurrentVolume As Double = 0 - Dim lTargetChange As Double = CurrentValue / 100 * lTotalVolume - Dim lNewEventTotalVolume As Double = 0.0 - - Try - If Not Double.IsNaN(IntensifyVolumeFraction) Then - Dim lTargetVolumeToIntensify As Double = lTotalVolume * IntensifyVolumeFraction - Logger.Dbg("TargetChange " & DecimalAlign(lTargetChange) & " TargetVolumeToIntensify " & DecimalAlign(lTargetVolumeToIntensify)) - 'sort events by volume - Logger.Dbg("Intensify " & DecimalAlign(IntensifyVolumeFraction) & " CurrentValue " & DecimalAlign(CurrentValue)) - Dim lNewEvents As New System.Collections.SortedList(lEvents.Count) - For Each lEvent In lEvents - Dim lEventVolume As Double = lEvent.Attributes.GetValue("Sum") - While lNewEvents.IndexOfKey(lEventVolume) >= 0 - lEventVolume += 0.00000001 - End While - lNewEvents.Add(lEventVolume, lEvent) - lNewEventTotalVolume += lEventVolume - Next - lEvents.Clear() - Logger.Dbg(" TotalVolume " & DecimalAlign(lTotalVolume) & _ - " EventTotalVolume " & DecimalAlign(lNewEventTotalVolume) & _ - " PercentOfVolume " & DecimalAlign(100 * (lNewEventTotalVolume / lTotalVolume))) - - If CurrentValue > 0.0 Then - For lEventIndex As Integer = lNewEvents.Count - 1 To 0 Step -1 - lEvent = lNewEvents.GetByIndex(lEventIndex) - Dim lAddFromThisEvent As Double = lNewEvents.GetKey(lEventIndex) - lCurrentVolume += lAddFromThisEvent - 'Logger.Dbg("CurrentVolumeAdded " & lCurrentVolumeChange & " FromThisEvent " & lAddFromThisEvent) - - If lEventIndex = lNewEvents.Count - 1 Then 'details of biggest event - Dim lEventStr As String = " Event " & lEventIndex - lEventStr &= " Sum " & DecimalAlign(lEvent.Attributes.GetValue("Sum")) - lEventStr &= " NumVals " & lEvent.numValues - lEventStr &= " Starts " & DumpDate(lEvent.Dates.Value(1)) - Logger.Dbg(lEventStr) - End If - - lEvents.Add(lEvent) - If lCurrentVolume > lTargetVolumeToIntensify Then - Logger.Dbg("Intensify " & lNewEvents.Count - lEventIndex & " of " & lNewEvents.Count) - Exit For - End If - Next lEventIndex - Else - For lEventIndex As Integer = 0 To lNewEvents.Count - 1 - lEvent = lNewEvents.GetByIndex(lEventIndex) - lCurrentVolume += lNewEvents.GetKey(lEventIndex) - ' Logger.Dbg("CurrentVolumeRemoved " & lCurrentVolumeChange) - lEvents.Add(lEvent) - If lCurrentVolume > lTargetVolumeToIntensify Then - Logger.Dbg("NegativeIntensify " & lEventIndex & " of " & lNewEvents.Count) - Exit For - End If - Next - End If - End If - Catch e As Exception - Logger.Dbg("VaryDataException-EventIntensifyFactor " & e.Message) - End Try - - Logger.Dbg(" CurrentVolume " & DecimalAlign(lCurrentVolume) & _ - " TargetChange " & DecimalAlign(lTargetChange)) - lEventIntensifyFactor = lTargetChange / lCurrentVolume - Logger.Dbg("EventIntensifyFactor " & DecimalAlign(lEventIntensifyFactor)) - Dim lSplitTS As atcTimeseries = MergeTimeseries(lEvents) - - ComputationSource.DataSets.Clear() - lArgsMath.Clear() - lArgsMath.SetValue("timeseries", lSplitTS) - lArgsMath.SetValue("Number", 1 + lEventIntensifyFactor) - ComputationSource.Open("Multiply", lArgsMath) - If lSplitData.Count > 1 Then - Return MergeTimeseries(New atcTimeseriesGroup(ComputationSource.DataSets(0), lSplitData.ItemByIndex(1))) - Else - Return ComputationSource.DataSets(0) - End If - End Function - - Private Function VaryDataPenmanMonteith(ByVal aOriginalData As atcTimeseries, ByVal aPETtemperature As atcTimeseries, ByVal aPETprecipitation As atcTimeseries) As atcTimeseries - Dim lModifiedTS As atcTimeseries = Nothing - Dim lLatitude As Double = aOriginalData.Attributes.GetValue("Latitude", 39) - Dim lLongitude As Double = aOriginalData.Attributes.GetValue("Longitude", -999) - Dim PETstation As atcMetCmp.SwatWeatherStation = Nothing - - If PETswatStations Is Nothing Then - PETswatStations = New atcMetCmp.SwatWeatherStations - End If - - If PETswatStations IsNot Nothing Then - If Not String.IsNullOrEmpty(PETstationID) AndAlso PETstationID <> PETstationUseClosest Then 'Find by station's Name, NameKey or ID - Dim lStationID As String = PETstationID.ToLower - For Each lSearchStation As atcMetCmp.SwatWeatherStation In PETswatStations - If lSearchStation.Id.ToLower = lStationID OrElse _ - lSearchStation.Name.ToLower = lStationID OrElse _ - lSearchStation.NameKey.ToLower = lStationID Then - PETstation = lSearchStation - Exit For - End If - Next - End If - - If PETstation Is Nothing Then 'Find by lat/lon of original TS - If lLatitude > -90 AndAlso lLongitude > -360 Then - PETstation = PETswatStations.Closest(lLatitude, lLongitude, 1).Values(0) - End If - End If - End If - - If PETstation Is Nothing Then - Throw New ApplicationException("VaryData: PET station not found") - ElseIf Double.IsNaN(PETelevation) Then - Throw New ApplicationException("VaryData: Elevation not found for PET") - Else - lModifiedTS = atcMetCmp.PanEvaporationTimeseriesComputedByPenmanMonteith( _ - PETelevation, _ - aPETprecipitation, _ - aPETtemperature, _ - Nothing, PETstation) - - If aOriginalData.Attributes.GetValue("tu") < 4 Then - 'Disaggragate the daily PMET timeseries into hourly - lModifiedTS = atcMetCmp.DisSolPet(lModifiedTS, Nothing, 2, lLatitude) - End If - End If - Return lModifiedTS - End Function - - Private Function VaryDataAddMultiply(ByVal lOriginalData As atcTimeseries, ByRef lSplitData As atcTimeseriesGroup) As atcTimeseries - Dim lArgsMath As New atcDataAttributes - If lSplitData IsNot Nothing AndAlso lSplitData.Count > 0 Then - Dim lSplitTS As atcTimeseries = lSplitData.ItemByIndex(0) - ComputationSource.DataSets.Clear() - lArgsMath.Clear() - lArgsMath.SetValue("timeseries", lSplitTS) - lArgsMath.SetValue("Number", CurrentValue) - ComputationSource.Open(Operation, lArgsMath) - Dim lModifiedTS As atcTimeseries = ComputationSource.DataSets(0) - If lModifiedTS.Dates = lOriginalData.Dates Then - lModifiedTS.Dates = lModifiedTS.Dates.Clone - End If - - If lSplitData.Count > 1 Then - Return MergeTimeseries(New atcTimeseriesGroup(ComputationSource.DataSets(0), lSplitData.ItemByIndex(1))) - Else - Return ComputationSource.DataSets(0) - End If - Else - Return lOriginalData.Clone - End If - End Function - - Protected Overridable Function VaryData() As atcTimeseriesGroup - Dim lModifiedGroup As New atcTimeseriesGroup - Dim lDataSetIndex As Integer = 0 - - For Each lOriginalData As atcTimeseries In DataSets - Dim lEvents As atcTimeseriesGroup = Nothing - Dim lSplitData As atcTimeseriesGroup = SplitData(lOriginalData, lEvents) - Dim lModifiedTS As atcTimeseries = Nothing - - Select Case Operation - Case "AddEvents" : lModifiedTS = AddRemoveEventsVolumeFraction(lOriginalData, CurrentValue/100, lEvents, 0) - Case "Intensify" : lModifiedTS = VaryDataIntensify(lSplitData, lEvents) - Case "Hamon" - If PETtemperature.Count > lDataSetIndex Then - Dim lLatitude As Double = lOriginalData.Attributes.GetValue("Latitude", 39) - lModifiedTS = atcMetCmp.PanEvaporationTimeseriesComputedByHamonX(PETtemperature(lDataSetIndex), Nothing, pDegF, lLatitude, pCTS) - If lOriginalData.Attributes.GetValue("tu") < 4 Then - lModifiedTS = atcMetCmp.DisSolPet(lModifiedTS, Nothing, 2, lLatitude) - End If - End If - - Case "Penman-Monteith" - If PETprecipitation.Count <= lDataSetIndex OrElse PETprecipitation(lDataSetIndex) Is Nothing Then - Throw New ApplicationException("VaryData: Precipitation not found for PET") - ElseIf PETtemperature.Count <= lDataSetIndex OrElse PETtemperature(lDataSetIndex) Is Nothing Then - Throw New ApplicationException("VaryData: Temperature not found for PET") - Else - lModifiedTS = VaryDataPenmanMonteith(lOriginalData, PETtemperature(lDataSetIndex), PETprecipitation(lDataSetIndex)) - End If - Case Else - lModifiedTS = VaryDataAddMultiply(lOriginalData, lSplitData) - End Select - - If lModifiedTS Is Nothing Then - Throw New ApplicationException("VaryData: No data computed") - End If - - Dim lMostOriginal As atcTimeseries = MostOriginal(lOriginalData) - With lModifiedTS.Attributes - .SetValue("CAToriginal", lMostOriginal) - .SetValue("ID", lOriginalData.Attributes.GetValue("ID")) - .SetValue("Location", lOriginalData.Attributes.GetValue("Location")) - .SetValue("Constituent", lOriginalData.Attributes.GetValue("Constituent")) - .SetValue("History 1", lOriginalData.Attributes.GetValue("History 1").ToString) - If lOriginalData.Attributes.ContainsAttribute("TSTYPE") Then - .SetValue("TSTYPE", lOriginalData.Attributes.GetValue("TSTYPE")) - End If - End With - - lModifiedGroup.Add(lMostOriginal, lModifiedTS) - - lDataSetIndex += 1 - Next - Return lModifiedGroup - End Function - - Private Function MostOriginal(ByVal aTimeseries As atcTimeseries) As atcTimeseries - Dim lMostOriginal As atcTimeseries = aTimeseries - While lMostOriginal.Attributes.ContainsAttribute("CAToriginal") - lMostOriginal = lMostOriginal.Attributes.GetValue("CAToriginal") - End While - Return lMostOriginal - End Function - - ''' - ''' - ''' - ''' Original data values - ''' Amount to change total volume, (-0.5=remove 50%, 0=no change, 0.5=add 50%) - ''' Events available for adding - ''' Random number seed - ''' - ''' - Private Shared Function AddRemoveEventsVolumeFraction(ByVal aTimeseries As atcTimeseries, _ - ByVal aVolumeChangeFraction As Double, _ - ByVal aEventsToSearch As atcTimeseriesGroup, _ - ByVal aSeed As Integer) As atcTimeseries - Dim lNewTimeseries As atcTimeseries = aTimeseries.Clone - Dim lMaxEventIndex As Integer = aEventsToSearch.Count 'exclusive upper value, random less than - Dim lFoundIndexes As New Generic.List(Of Integer) - Dim lRandom As New Random(aSeed) - Dim lAdd As Boolean = True - Dim lValueIndex As Integer - Dim lValueLastIndex As Integer - Dim lOriginalVolume As Double = aTimeseries.Attributes.GetValue("Sum") - Dim lCurrentVolume As Double = lOriginalVolume - Dim lTargetVolume As Double = lOriginalVolume * (1 + aVolumeChangeFraction) - Dim lChangeIndex As Integer - - If aVolumeChangeFraction < 0 Then lAdd = False - - Logger.Dbg("OriginalVolume " & DecimalAlign(lOriginalVolume) & _ - " Target Volume " & DecimalAlign(lTargetVolume) & _ - " ChangeFraction " & DecimalAlign(aVolumeChangeFraction) & _ - " Event Count " & aEventsToSearch.Count) - - 'While adding and not yet added enough, or removing and not yet removed enough - While (lAdd AndAlso (lCurrentVolume < lTargetVolume)) OrElse _ - ((Not lAdd) AndAlso (lCurrentVolume > lTargetVolume)) - Dim lCheckIndex As Integer = lRandom.Next(0, lMaxEventIndex) - If Not lFoundIndexes.Contains(lCheckIndex) Then - Dim lEvent As atcTimeseries = aEventsToSearch.ItemByIndex(lCheckIndex) - lFoundIndexes.Add(lCheckIndex) - If lFoundIndexes.Count = aEventsToSearch.Count Then 'all events have been used, start over - If lAdd Then - Logger.Dbg(" ---- All events have been used, start adding over") - lFoundIndexes.Clear() - Else - Logger.Dbg(" ***** All events have been used, nothing more to remove!") - Exit While - End If - End If - - Dim lEventStr As String = " Event " & lCheckIndex - lEventStr &= " Sum " & DecimalAlign(lEvent.Attributes.GetValue("Sum")) - lEventStr &= " NumVals " & lEvent.numValues - lEventStr &= " Starts " & DumpDate(lEvent.Dates.Value(1)) - Logger.Dbg(lEventStr) - - 'Find starting index of event and add it or remove it - If lAdd Then - lValueIndex = lRandom.Next(1, lNewTimeseries.numValues - lEvent.numValues) - Logger.Dbg(" Add at " & DumpDate(lNewTimeseries.Dates.Value(lValueIndex))) - lValueLastIndex = lValueIndex + lEvent.numValues - 1 - lChangeIndex = lValueIndex - While lChangeIndex <= lValueLastIndex AndAlso _ - Not Double.IsNaN(lNewTimeseries.Values(lChangeIndex)) AndAlso _ - lCurrentVolume < lTargetVolume - 'lCurrentVolume -= lNewTimeseries.Values(lIndex) - 'add to old value - Dim lAddValue As Double = lEvent.Values(lChangeIndex - lValueIndex + 1) - lNewTimeseries.Values(lChangeIndex) += lAddValue - lCurrentVolume += lAddValue - lChangeIndex += 1 - End While - Else 'remove - lValueIndex = FindDateAtOrAfter(lNewTimeseries.Dates.Values, lEvent.Dates.Value(1)) - Logger.Dbg(" Remove at " & DumpDate(lNewTimeseries.Dates.Value(lValueIndex).ToString)) - lValueLastIndex = lValueIndex + lEvent.numValues - 1 - lChangeIndex = lValueIndex - While lChangeIndex <= lValueLastIndex AndAlso _ - Not Double.IsNaN(lNewTimeseries.Values(lChangeIndex)) AndAlso _ - lCurrentVolume > lTargetVolume - lCurrentVolume -= lNewTimeseries.Values(lChangeIndex) - lNewTimeseries.Values(lChangeIndex) = 0.0 - lChangeIndex += 1 - End While - End If - Logger.Dbg(" CurrentVolume " & DecimalAlign(lCurrentVolume)) - End If - End While - - lChangeIndex -= 1 - Dim lFinalVolumeAdjustment As Double = lCurrentVolume - lTargetVolume - If lChangeIndex >= 0 AndAlso (lNewTimeseries.Values(lChangeIndex) - lFinalVolumeAdjustment) > 0 Then - Logger.Dbg(" Final Volume Adjustment " & DecimalAlign(lFinalVolumeAdjustment) & _ - " on " & DecimalAlign(lNewTimeseries.Values(lChangeIndex)) & _ - " at " & DumpDate(lNewTimeseries.Dates.Value(lChangeIndex))) - lNewTimeseries.Values(lChangeIndex) -= lFinalVolumeAdjustment - Else - Dim lDbgStr As String = " ***** Fail Final Volume Adjustment " & DecimalAlign(lFinalVolumeAdjustment) & " " & lChangeIndex - If lChangeIndex > 0 Then lDbgStr &= " " & DecimalAlign(lNewTimeseries.Values(lChangeIndex)) - Logger.Dbg(lDbgStr) - End If - - lNewTimeseries.Attributes.DiscardCalculated() - - Dim lOperation As String - If lAdd Then lOperation = "Added " Else lOperation = "Removed " - - Dim lSum As Double = lNewTimeseries.Attributes.GetValue("Sum") - Dim lStr As String = lOperation & lFoundIndexes.Count & " events to change total volume " & DoubleString(aVolumeChangeFraction) - lStr &= " (actual change = " & DoubleString((lSum - lOriginalVolume) / lOriginalVolume) & ")" - lStr &= " Total Volume " & DecimalAlign(lSum) - Logger.Dbg(lStr) - - Return lNewTimeseries - End Function - - Private Function DoubleArraySum(ByVal aValues() As Double, ByVal aStart As Integer, ByVal aCount As Integer) As Double - DoubleArraySum = 0 - Dim lBeyondLastIndex As Integer = aStart + aCount - While aStart < lBeyondLastIndex - DoubleArraySum += aValues(aStart) - aStart += 1 - End While - End Function - - Private Function AddRemoveEventsTotalVolume(ByVal aTimeseries As atcTimeseries, ByVal aTargetVolumeChange As Double, ByVal aEventsToSearch As atcTimeseriesGroup, ByVal aSeed As Integer) As atcTimeseries - ' Private Function FindEventsTotalVolume(ByVal aTargetTotalVolume As Double, ByVal aEventsToSearch As atcDataGroup, ByVal aSeed As Integer) As atcDataGroup - 'Dim lEventsFound As New atcDataGroup - Dim lNewTimeseries As atcTimeseries = aTimeseries.Clone - Dim lMaxEventIndex As Integer = aEventsToSearch.Count - 1 - Dim lFoundIndexes As New Generic.List(Of Integer) - Dim lVolumeFound As Double = 0 - Dim lRandom As New Random(aSeed) - Dim lAdd As Boolean = True - Dim lValueIndex As Integer - Dim lLastValueIndex As Integer - - If aTargetVolumeChange < 0 Then - lVolumeFound = aTargetVolumeChange - aTargetVolumeChange = 0 - lAdd = False - End If - - While lVolumeFound < aTargetVolumeChange - Dim lCheckIndex As Integer = lRandom.Next(0, lMaxEventIndex) - If Not lFoundIndexes.Contains(lCheckIndex) Then - Dim lEvent As atcTimeseries = aEventsToSearch.ItemByIndex(lCheckIndex) - lFoundIndexes.Add(lCheckIndex) - 'lEventsFound.Add(lEvent) - lVolumeFound += lEvent.Attributes.GetValue("Sum") - - 'Find starting index of event - If lAdd Then - lValueIndex = lRandom.Next(1, aTimeseries.numValues - lEvent.numValues) - Else - lValueIndex = FindDateAtOrAfter(lNewTimeseries.Dates.Values, lEvent.Dates.Value(1)) - End If - lLastValueIndex = lValueIndex + lEvent.numValues - 1 - - 'Reduce event volume by volume being replaced - For lScanReplaced As Integer = lValueIndex To lLastValueIndex - lVolumeFound -= lNewTimeseries.Values(lScanReplaced) - Next - - If lAdd Then - Array.Copy(lEvent.Values, 1, lNewTimeseries.Values, lValueIndex, lEvent.numValues) - Else - Array.Clear(lNewTimeseries.Values, lValueIndex, lEvent.numValues) - End If - - End If - End While - - Dim lOperation As String - If lAdd Then lOperation = "Added " Else lOperation = "Removed " - - Dim lStr As String = lOperation & lFoundIndexes.Count & " events to change total volume " & DoubleString(aTargetVolumeChange) - lStr &= " (actual change = " & DoubleString(lNewTimeseries.Attributes.GetValue("Sum") - aTimeseries.Attributes.GetValue("Sum")) & ")" - Logger.Dbg(lStr) - - Return lNewTimeseries - - End Function - - Public Overridable Function Clone() As atcVariation - Dim newVariation As New atcVariation - Me.CopyTo(newVariation) - Return newVariation - End Function - - Sub Clear() - - 'Parameters for Hamon - TODO: don't hard code these - pDegF = True - - pName = "" - pDataSets = New atcTimeseriesGroup - pComputationSource = Nothing - pOperation = "Add" - pSelected = False - - Seasons = Nothing - Min = pNaN - Max = pNaN - Increment = pNaN - pIncrementsSinceStart = 0 - CurrentValue = pNaN - - UseEvents = False - EventThreshold = pNaN - EventDaysGapAllowed = 0 - 'EventGapDisplayUnits = "" - EventHigh = True - IntensifyVolumeFraction = pNaN - 'AddRemovePer = "Entire Span" - - EventVolumeHigh = True - EventVolumeThreshold = pNaN - - EventDurationHigh = True - EventDurationDays = pNaN - 'EventDurationDisplayUnits = "" - - IsInput = False - - ColorAboveMax = System.Drawing.Color.OrangeRed - ColorBelowMin = System.Drawing.Color.DeepSkyBlue - ColorDefault = System.Drawing.Color.White - - PETtemperature = New atcTimeseriesGroup - PETprecipitation = New atcTimeseriesGroup - PETelevation = Integer.MinValue - PETstationID = PETstationUseClosest - End Sub - - Public Overridable Sub CopyTo(ByVal aTargetVariation As atcVariation) - With aTargetVariation - .Name = Name - .UseEvents = UseEvents - If UseEvents Then - .EventDaysGapAllowed = EventDaysGapAllowed - '.EventGapDisplayUnits = EventGapDisplayUnits - .EventHigh = EventHigh - .EventThreshold = EventThreshold - .EventVolumeHigh = EventVolumeHigh - .EventVolumeThreshold = EventVolumeThreshold - .EventDurationHigh = EventDurationHigh - .EventDurationDays = EventDurationDays - .IntensifyVolumeFraction = IntensifyVolumeFraction - End If - - If DataSets IsNot Nothing Then .DataSets = DataSets.Clone() - If PETtemperature IsNot Nothing Then .PETtemperature = PETtemperature.Clone() - If PETprecipitation IsNot Nothing Then .PETprecipitation = PETprecipitation.Clone() - .PETelevation = PETelevation - .PETstationID = PETstationID - - .ComputationSource = ComputationSource - .Operation = Operation.Clone() - If Seasons Is Nothing Then - .Seasons = Nothing - Else - .Seasons = Seasons.Clone - End If - .Selected = Selected - .Min = Min - .Max = Max - .Increment = Increment - '.AddRemovePer = AddRemovePer - .IsInput = IsInput - .CurrentValue = CurrentValue - .ColorAboveMax = ColorAboveMax - .ColorBelowMin = ColorBelowMin - .ColorDefault = ColorDefault - End With - End Sub - - Protected Overridable Property EventsXML() As String - Get - If UseEvents Then - Return " " & vbCrLf - '& " GapDisplayUnits='" & EventGapDisplayUnits & "' " _ - '& " DurationDisplayUnits='" & EventDurationDisplayUnits & "' " _ - Else - Return "" - End If - End Get - Set(ByVal newValue As String) - Dim lXMLDoc As New Xml.XmlDocument - Try - lXMLDoc.LoadXml(newValue) - Dim lXML As Xml.XmlNode = lXMLDoc.FirstChild - If lXML.Name.ToLower.Equals("events") Then - UseEvents = True - EventThreshold = GetAtt(lXML, "Threshold", EventThreshold) - EventHigh = GetAtt(lXML, "High", EventHigh) - IntensifyVolumeFraction = GetAtt(lXML, "FlashVolumeFraction", IntensifyVolumeFraction) 'supports old name - IntensifyVolumeFraction = GetAtt(lXML, "IntensifyVolumeFraction", IntensifyVolumeFraction) - If IntensifyVolumeFraction > 1 Then IntensifyVolumeFraction -= 1 'Backward compatible with files saved when this was centered at 100% - EventDaysGapAllowed = GetAtt(lXML, "GapDays", EventDaysGapAllowed) - 'EventGapDisplayUnits = lXML.GetAttrValue("GapDisplayUnits") - - EventVolumeHigh = GetAtt(lXML, "VolumeHigh", EventVolumeHigh) - EventVolumeThreshold = GetAtt(lXML, "VolumeThreshold", EventVolumeThreshold) - - EventDurationHigh = GetAtt(lXML, "DurationHigh", EventDurationHigh) - EventDurationDays = GetAtt(lXML, "DurationDays", EventDurationDays) - 'EventDurationDisplayUnits = lXML.GetAttrValue("DurationDisplayUnits") - End If - Catch e As Exception - Logger.Msg("Could not read Events XML:" & vbCrLf & newValue & vbCrLf & e.Message, "CAT Events XML Problem") - End Try - End Set - End Property - - Private Function GetAtt(ByVal aNode As Xml.XmlNode, ByVal aAttributeName As String, Optional ByVal aDefault As Object = "") As Object - Dim lAttribute As Xml.XmlAttribute = aNode.Attributes.GetNamedItem(aAttributeName) - If lAttribute IsNot Nothing Then - Return lAttribute.InnerText - Else - Return aDefault - End If - End Function - - Protected Overridable Property SeasonsXML() As String - Get - If Seasons Is Nothing Then - Return "" - Else - Return " " & vbCrLf _ - & " " & Seasons.SeasonsSelectedXML & " " & vbCrLf - End If - End Get - Set(ByVal newValue As String) - Dim lXMLdoc As New Xml.XmlDocument - Try - lXMLdoc.LoadXml(newValue) - Dim lXML As Xml.XmlNode = lXMLdoc.FirstChild - If lXML.Name.ToLower.Equals("seasons") Then - Dim lSeasonTypeName As String = GetAtt(lXML, "Type") - For Each lSeasonType As Type In atcData.atcSeasonBase.AllSeasonTypes - If lSeasonType.Name.Equals(lSeasonTypeName) Then - Seasons = lSeasonType.InvokeMember(Nothing, Reflection.BindingFlags.CreateInstance, Nothing, Nothing, New Object() {}) - If lXML.InnerXml.Contains("<") Then - Seasons.SeasonsSelectedXML = lXML.InnerXml - End If - End If - Next - End If - Catch ex As Exception - Logger.Msg("Unable to parse:" & vbCrLf & newValue, "CAT Seasons XML Problem") - End Try - End Set - End Property - - Private Function GetDataGroupXML(ByVal aDataGroup As atcTimeseriesGroup, ByVal aTag As String) As String - If aDataGroup Is Nothing OrElse aDataGroup.Count = 0 Then - Return "" - Else - Dim lXML As String = " <" & aTag & " count='" & aDataGroup.Count & "'>" & vbCrLf - For lIndex As Integer = 0 To aDataGroup.Count - 1 - Dim lDataSet As atcDataSet = aDataGroup.Item(lIndex) - Dim lDataKey As String = aDataGroup.Keys(lIndex) - If Not lDataSet Is Nothing Then - lXML &= " " & vbCrLf - End If - End Function - - Private Sub SetDataGroupXML(ByRef aDataGroup As atcTimeseriesGroup, ByVal aTag As String, ByVal aXML As String) - Dim lXMLdoc As New Xml.XmlDocument - Try - lXMLdoc.LoadXml(aXML) - aDataGroup = New atcTimeseriesGroup - For Each lXML As Xml.XmlNode In lXMLdoc.FirstChild.ChildNodes - Dim lKey As String = GetAtt(lXML, "Key") - Dim lID As String = GetAtt(lXML, "ID") - Dim lHistory As String = GetAtt(lXML, "History") - If lID.Length > 0 Then - Dim lDataGroup As atcTimeseriesGroup = Nothing - If lHistory.Length > 10 Then - Dim lSourceSpecification As String = lHistory.Substring(10).ToLower - Dim lDataSource As atcTimeseriesSource = atcDataManager.DataSourceBySpecification(lSourceSpecification) - If lDataSource IsNot Nothing Then - lDataGroup = lDataSource.DataSets.FindData("ID", lID, 2) - If lDataGroup.Count > 0 Then - Logger.Dbg("Found data set #" & lID & " in " & lSourceSpecification) - Else - lDataGroup = Nothing - End If - End If - End If - If lDataGroup Is Nothing Then - lDataGroup = atcDataManager.DataSets.FindData("ID", lID, 2) - End If - If lDataGroup.Count > 0 Then - Logger.Dbg("Found data set #" & lID & " without a specification") - If lDataGroup.Count > 1 Then Logger.Dbg("Warning: more than one data set matched ID " & lID) - aDataGroup.Add(lKey, lDataGroup.ItemByIndex(0)) - Else - Logger.Msg("No data found with ID " & lID, "Variation from XML") - End If - Else - If lKey Is Nothing OrElse lKey.Length = 0 Then - Logger.Dbg("No data set ID found in XML, skipping: ", lXML.OuterXml) - End If - aDataGroup.Add(lKey, Nothing) - End If - Next - Catch e As Exception - Logger.Msg("Unable to parse:" & vbCrLf & aXML & vbCrLf & e.Message, "CAT Data Group XML Problem") - End Try - End Sub - - Public Overridable Property XML() As String - Get - Dim lXML As String = "" & vbCrLf _ - & " " & ToXML(Name) & "" & vbCrLf - If PETelevation > Integer.MinValue Then - lXML &= " " & PETelevation & "" & vbCrLf - End If - If Not String.IsNullOrEmpty(PETstationID) Then - lXML &= " " & PETstationID & "" & vbCrLf - End If - If Not Double.IsNaN(Min) Then - lXML &= " " & Min & "" & vbCrLf - End If - If Not Double.IsNaN(Max) Then - lXML &= " " & Max & "" & vbCrLf - End If - If Not Double.IsNaN(Increment) Then - lXML &= " " & Increment & "" & vbCrLf - End If - If IsInput Then - lXML &= " " & IsInput & "" & vbCrLf - End If - lXML &= " " & ToXML(Operation) & "" & vbCrLf - 'lXML &= " " & AddRemovePer & "" & vbCrLf - If Not ComputationSource Is Nothing Then - lXML &= " " & ToXML(ComputationSource.Name) & "" & vbCrLf - End If - lXML &= " " & Selected & "" & vbCrLf _ - & GetDataGroupXML(DataSets, "DataSets") _ - & GetDataGroupXML(PETtemperature, "PETtemperature") _ - & GetDataGroupXML(PETprecipitation, "PETprecipitation") _ - & EventsXML _ - & SeasonsXML _ - & "" & vbCrLf - Return lXML - End Get - Set(ByVal newValue As String) - Dim lXMLdoc As New Xml.XmlDocument - Try - lXMLdoc.LoadXml(newValue) - For Each lXML As Xml.XmlNode In lXMLdoc.FirstChild.ChildNodes - With lXML - Select Case .Name.ToLower - Case "name" : Name = .InnerText - Case "elevation" : PETelevation = CInt(.InnerText) - Case "stationid" : PETstationID = .InnerText - Case "min" : Min = CDbl(.InnerText) - Case "max" : Max = CDbl(.InnerText) - Case "increment" : Increment = CDbl(.InnerText) - Case "isinput" : IsInput = CBool(.InnerText) - Case "operation" - Operation = .InnerText - If Operation = "Flash" Then Operation = "Intensify" - 'Case "addremoveper" : AddRemovePer = .Content - Case "computationsource" - ComputationSource = atcDataManager.DataSourceByName(.InnerText) - If ComputationSource Is Nothing Then - Select Case .InnerText - Case "Timeseries::Math" - ComputationSource = New atcTimeseriesMath.atcTimeseriesMath - Case Else - Logger.Msg("UnknownComputationSource " & .InnerText) - End Select - End If - Case "datasets" : SetDataGroupXML(DataSets, "DataSets", .OuterXml) - Case "pettemperature" : SetDataGroupXML(PETtemperature, "PETtemperature", .OuterXml) - Case "petprecipitation" : SetDataGroupXML(PETprecipitation, "PETprecipitation", .OuterXml) - Case "selected" - Selected = .InnerText.ToLower.Equals("true") - Case "seasons" : SeasonsXML = .OuterXml - Case "events" : EventsXML = .OuterXml - End Select - End With - Next - Catch e As Exception - Logger.Msg("Unable to parse:" & vbCrLf & newValue, "CAT Variation XML Problem") - End Try - If ComputationSource Is Nothing Then - ComputationSource = New atcTimeseriesMath.atcTimeseriesMath - End If - End Set - End Property - - Public Overrides Function ToString() As String - Dim lString As String = Name & " " & Operation & " " - - Select Case Operation - Case "Hamon", "Penman-Monteith" - If PETtemperature IsNot Nothing AndAlso PETtemperature.Count > 0 Then - If PETtemperature.Count = 1 Then - lString &= "Temp: " & PETtemperature(0).ToString & " " - Else - lString &= "Temp: (" & PETtemperature.Count & ")" - End If - End If - If PETprecipitation IsNot Nothing AndAlso PETprecipitation.Count > 0 AndAlso Not Operation.Equals("Hamon") Then - If PETprecipitation.Count = 1 Then - lString &= "Precip: " & PETprecipitation(0).ToString & " " - Else - lString &= "Precip: (" & PETprecipitation.Count & ")" - End If - End If - If PETelevation > Integer.MinValue AndAlso Not Operation.Equals("Hamon") Then - lString &= "Elev: " & PETelevation - End If - If Not String.IsNullOrEmpty(PETstationID) AndAlso PETstationID <> PETstationUseClosest Then - lString &= "Station: " & PETstationID - End If - Case Else - If Max <= Min Then - lString &= DoubleString(Min) - Else - If Not Double.IsNaN(Min) Then lString &= "from " & DoubleString(Min) - If Not Double.IsNaN(Max) Then lString &= " to " & DoubleString(Max) - If Not Double.IsNaN(Increment) Then lString &= " step " & DoubleString(Increment) - End If - End Select - - If Seasons IsNot Nothing Then - lString &= " " & atcSeasons.atcSeasonPlugin.SeasonClassNameToLabel(Seasons.GetType.Name) _ - & ": " & Seasons.SeasonsSelectedString - End If - Return lString - End Function - - Private Shared Function DoubleString(ByVal aNumber As Double) As String - Dim lStr As String = Format(aNumber, "0.000") - Dim lDecimalPos As Integer = lStr.IndexOf("."c) - If lDecimalPos >= 0 Then - 'Trim trailing zeroes after decimal point - lStr = lStr.TrimEnd("0"c) - 'Trim trailing decimal point - If lStr.Length = lDecimalPos + 1 Then lStr = lStr.Substring(0, lDecimalPos) - End If - If lStr.Length = 0 Then lStr = "0" - Return lStr - End Function - - Public Sub New() - Clear() - End Sub - - Protected Overrides Sub Finalize() - If pDataSets IsNot Nothing Then - pDataSets.Dispose() - pDataSets = Nothing - End If - If PETtemperature IsNot Nothing Then - PETtemperature.Dispose() - PETtemperature = Nothing - End If - If PETprecipitation IsNot Nothing Then - PETprecipitation.Dispose() - PETprecipitation = Nothing - End If - pComputationSource = Nothing - Seasons = Nothing - MyBase.Finalize() - End Sub -End Class +Imports atcData +Imports atcEvents +Imports atcUtility +Imports MapWinUtility + +Public Class atcVariation + Private pNaN As Double = atcUtility.GetNaN + + 'Parameters for Hamon + Private pDegF As Boolean + + 'WestBranch of Patux + 'Private pCTS() As Double = {0, 0.0045, 0.01, 0.01, 0.01, 0.0085, 0.0085, 0.0085, 0.0085, 0.0085, 0.0095, 0.0095, 0.0095} + 'Monocacy - CBP + Private pCTS() As Double = {0, 0.0057, 0.0057, 0.0057, 0.0057, 0.0057, 0.0057, _ + 0.0057, 0.0057, 0.0057, 0.0057, 0.0057, 0.0057} + + Private pName As String + Private pDataSets As atcTimeseriesGroup + + Public Const PETstationUseClosest As String = "(Closest)" + + Public PETtemperature As atcTimeseriesGroup + Public PETprecipitation As atcTimeseriesGroup + Public PETelevation As Integer = Integer.MinValue + Public PETstationID As String = PETstationUseClosest + Private Shared PETswatStations As atcMetCmp.SwatWeatherStations + + Private pComputationSource As atcTimeseriesSource + Private pOperation As String + 'Public AddRemovePer As String + Private pSelected As Boolean + + 'TODO: make rest of public variables into properties + Public Seasons As atcSeasonBase + Public Min As Double + Public Max As Double + Public Increment As Double + Private pIncrementsSinceStart As Integer + Public CurrentValue As Double + + Public UseEvents As Boolean + Public EventThreshold As Double + Public EventDaysGapAllowed As Double + 'Public EventGapDisplayUnits As String + Public EventHigh As Boolean + + Public EventVolumeHigh As Boolean + Public EventVolumeThreshold As Double + + Public EventDurationHigh As Boolean + Public EventDurationDays As Double + 'Public EventDurationDisplayUnits As String + + Public IntensifyVolumeFraction As Double + + Public IsInput As Boolean + + Public ColorAboveMax As System.Drawing.Color + Public ColorBelowMin As System.Drawing.Color + Public ColorDefault As System.Drawing.Color + + Public Overridable Property Name() As String + Get + Return pName + End Get + Set(ByVal newValue As String) + pName = newValue + End Set + End Property + + Public Overridable Property DataSets() As atcTimeseriesGroup + Get + Return pDataSets + End Get + Set(ByVal newValue As atcTimeseriesGroup) + pDataSets = newValue + End Set + End Property + + Public Overridable Property ComputationSource() As atcTimeseriesSource + Get + Return pComputationSource + End Get + Set(ByVal newValue As atcTimeseriesSource) + pComputationSource = newValue + End Set + End Property + + Public Overridable Property Operation() As String + Get + Return pOperation + End Get + Set(ByVal newValue As String) + pOperation = newValue + End Set + End Property + + Public Overridable Property Selected() As Boolean + Get + Return pSelected + End Get + Set(ByVal newValue As Boolean) + pSelected = newValue + End Set + End Property + + Public Overridable ReadOnly Property Iterations() As Integer + Get + If Increment = 0 Then + Return 1 + Else + Try + Return (Max - Min) / Increment + 1 + Catch ex As Exception + Return 1 + End Try + End If + End Get + End Property + + Public Overridable Function StartIteration() As atcTimeseriesGroup + Me.CurrentValue = Me.Min + pIncrementsSinceStart = 0 + Return VaryData() + End Function + + Public Overridable Function NextIteration() As atcTimeseriesGroup + pIncrementsSinceStart += 1 + If pIncrementsSinceStart < Iterations Then + Me.CurrentValue = Me.Min + Me.Increment * pIncrementsSinceStart + Return VaryData() + Else + Return Nothing + End If + End Function + + ''' + ''' Divide the data in lOriginalData into a group of two atcTimeseries. + ''' First in group contains all values in the selected events and/or seasons, + ''' Second includes all other values. + ''' + ''' timeseries to split into selected and not selected + ''' Return argument: populated with one timeseries per selected event + ''' found in aOriginalData if events are in use, + ''' not set if events are not in use + ''' Group of two timeseries + Public Function SplitData(ByVal aOriginalData As atcTimeseries, _ + ByRef aEvents As atcTimeseriesGroup) As atcTimeseriesGroup + Dim lSplitData As atcTimeseriesGroup = Nothing + If UseEvents Then + Dim lEvent As atcTimeseries + aEvents = EventSplit(aOriginalData, Nothing, EventThreshold, EventDaysGapAllowed, EventHigh) + + 'Remove events outside selected seasons + If Seasons IsNot Nothing Then + For lEventIndex As Integer = aEvents.Count - 1 To 0 Step -1 + lEvent = aEvents.ItemByIndex(lEventIndex) + + 'Find peak value of event + Dim lPeakIndex As Integer = 1 + For lValueIndex As Integer = 2 To lEvent.numValues + If lEvent.Value(lValueIndex) > lEvent.Value(lPeakIndex) Then + lPeakIndex = lValueIndex + End If + Next + + 'If peak is not in season, remove this event + If Not Seasons.SeasonSelected(Seasons.SeasonIndex(lEvent.Dates.Value(lPeakIndex))) Then + aEvents.RemoveAt(lEventIndex) + End If + Next + End If + + 'Remove events outside target volume threshold + Try + If Not Double.IsNaN(EventVolumeThreshold) Then + For lEventIndex As Integer = aEvents.Count - 1 To 0 Step -1 + Dim lEventVolume As Double = aEvents.ItemByIndex(lEventIndex).Attributes.GetValue("Sum") + If EventVolumeHigh Then + If lEventVolume < EventVolumeThreshold Then + aEvents.RemoveAt(lEventIndex) + End If + Else + If lEventVolume > EventVolumeThreshold Then + aEvents.RemoveAt(lEventIndex) + End If + End If + Next + End If + Catch e As Exception + Logger.Dbg("VaryDataException-EventVolumeThreshold " & e.Message) + End Try + + 'Remove events outside target duration threshold + If Not Double.IsNaN(EventDurationDays) Then + For lEventIndex As Integer = aEvents.Count - 1 To 0 Step -1 + Dim lEventDuration As Double = atcSynopticAnalysis.atcSynopticAnalysisPlugin.DataSetDuration(aEvents.ItemByIndex(lEventIndex)) + If EventDurationHigh Then + If lEventDuration < EventDurationDays Then + aEvents.RemoveAt(lEventIndex) + End If + Else + If lEventDuration > EventDurationDays Then + aEvents.RemoveAt(lEventIndex) + End If + End If + Next + End If + + 'If Operation <> "Intensify" Then + If aEvents.Count > 0 Then + lSplitData = New atcTimeseriesGroup(MergeTimeseries(aEvents)) + lSplitData.Add(aOriginalData) + End If + 'End If + + Else + If Seasons Is Nothing Then + lSplitData = New atcTimeseriesGroup(aOriginalData) + Else + lSplitData = Seasons.SplitBySelected(aOriginalData, Nothing) + End If + End If + Return lSplitData + End Function + + Private Function VaryDataIntensify(ByRef lSplitData As atcTimeseriesGroup, ByRef lEvents As atcTimeseriesGroup) As atcTimeseries + Dim lEvent As atcTimeseries + Dim lArgsMath As New atcDataAttributes + Dim lTotalVolume As Double = lSplitData(0).Attributes.GetValue("Sum") + Dim lEventIntensifyFactor As Double + Dim lCurrentVolume As Double = 0 + Dim lTargetChange As Double = CurrentValue / 100 * lTotalVolume + Dim lNewEventTotalVolume As Double = 0.0 + + Try + If Not Double.IsNaN(IntensifyVolumeFraction) Then + Dim lTargetVolumeToIntensify As Double = lTotalVolume * IntensifyVolumeFraction + Logger.Dbg("TargetChange " & DecimalAlign(lTargetChange) & " TargetVolumeToIntensify " & DecimalAlign(lTargetVolumeToIntensify)) + 'sort events by volume + Logger.Dbg("Intensify " & DecimalAlign(IntensifyVolumeFraction) & " CurrentValue " & DecimalAlign(CurrentValue)) + Dim lNewEvents As New System.Collections.SortedList(lEvents.Count) + For Each lEvent In lEvents + Dim lEventVolume As Double = lEvent.Attributes.GetValue("Sum") + While lNewEvents.IndexOfKey(lEventVolume) >= 0 + lEventVolume += 0.00000001 + End While + lNewEvents.Add(lEventVolume, lEvent) + lNewEventTotalVolume += lEventVolume + Next + lEvents.Clear() + Logger.Dbg(" TotalVolume " & DecimalAlign(lTotalVolume) & _ + " EventTotalVolume " & DecimalAlign(lNewEventTotalVolume) & _ + " PercentOfVolume " & DecimalAlign(100 * (lNewEventTotalVolume / lTotalVolume))) + + If CurrentValue > 0.0 Then + For lEventIndex As Integer = lNewEvents.Count - 1 To 0 Step -1 + lEvent = lNewEvents.GetByIndex(lEventIndex) + Dim lAddFromThisEvent As Double = lNewEvents.GetKey(lEventIndex) + lCurrentVolume += lAddFromThisEvent + 'Logger.Dbg("CurrentVolumeAdded " & lCurrentVolumeChange & " FromThisEvent " & lAddFromThisEvent) + + If lEventIndex = lNewEvents.Count - 1 Then 'details of biggest event + Dim lEventStr As String = " Event " & lEventIndex + lEventStr &= " Sum " & DecimalAlign(lEvent.Attributes.GetValue("Sum")) + lEventStr &= " NumVals " & lEvent.numValues + lEventStr &= " Starts " & DumpDate(lEvent.Dates.Value(1)) + Logger.Dbg(lEventStr) + End If + + lEvents.Add(lEvent) + If lCurrentVolume > lTargetVolumeToIntensify Then + Logger.Dbg("Intensify " & lNewEvents.Count - lEventIndex & " of " & lNewEvents.Count) + Exit For + End If + Next lEventIndex + Else + For lEventIndex As Integer = 0 To lNewEvents.Count - 1 + lEvent = lNewEvents.GetByIndex(lEventIndex) + lCurrentVolume += lNewEvents.GetKey(lEventIndex) + ' Logger.Dbg("CurrentVolumeRemoved " & lCurrentVolumeChange) + lEvents.Add(lEvent) + If lCurrentVolume > lTargetVolumeToIntensify Then + Logger.Dbg("NegativeIntensify " & lEventIndex & " of " & lNewEvents.Count) + Exit For + End If + Next + End If + End If + Catch e As Exception + Logger.Dbg("VaryDataException-EventIntensifyFactor " & e.Message) + End Try + + Logger.Dbg(" CurrentVolume " & DecimalAlign(lCurrentVolume) & _ + " TargetChange " & DecimalAlign(lTargetChange)) + lEventIntensifyFactor = lTargetChange / lCurrentVolume + Logger.Dbg("EventIntensifyFactor " & DecimalAlign(lEventIntensifyFactor)) + Dim lSplitTS As atcTimeseries = MergeTimeseries(lEvents) + + ComputationSource.DataSets.Clear() + lArgsMath.Clear() + lArgsMath.SetValue("timeseries", lSplitTS) + lArgsMath.SetValue("Number", 1 + lEventIntensifyFactor) + ComputationSource.Open("Multiply", lArgsMath) + If lSplitData.Count > 1 Then + Return MergeTimeseries(New atcTimeseriesGroup(ComputationSource.DataSets(0), lSplitData.ItemByIndex(1))) + Else + Return ComputationSource.DataSets(0) + End If + End Function + + Private Function VaryDataPenmanMonteith(ByVal aOriginalData As atcTimeseries, ByVal aPETtemperature As atcTimeseries, ByVal aPETprecipitation As atcTimeseries) As atcTimeseries + Dim lModifiedTS As atcTimeseries = Nothing + Dim lLatitude As Double = aOriginalData.Attributes.GetValue("Latitude", 39) + Dim lLongitude As Double = aOriginalData.Attributes.GetValue("Longitude", -999) + Dim PETstation As atcMetCmp.SwatWeatherStation = Nothing + + If PETswatStations Is Nothing Then + PETswatStations = New atcMetCmp.SwatWeatherStations + End If + + If PETswatStations IsNot Nothing Then + If Not String.IsNullOrEmpty(PETstationID) AndAlso PETstationID <> PETstationUseClosest Then 'Find by station's Name, NameKey or ID + Dim lStationID As String = PETstationID.ToLower + For Each lSearchStation As atcMetCmp.SwatWeatherStation In PETswatStations + If lSearchStation.Id.ToLower = lStationID OrElse _ + lSearchStation.Name.ToLower = lStationID OrElse _ + lSearchStation.NameKey.ToLower = lStationID Then + PETstation = lSearchStation + Exit For + End If + Next + End If + + If PETstation Is Nothing Then 'Find by lat/lon of original TS + If lLatitude > -90 AndAlso lLongitude > -360 Then + PETstation = PETswatStations.Closest(lLatitude, lLongitude, 1).Values(0) + End If + End If + End If + + If PETstation Is Nothing Then + Throw New ApplicationException("VaryData: PET station not found") + ElseIf Double.IsNaN(PETelevation) Then + Throw New ApplicationException("VaryData: Elevation not found for PET") + Else + lModifiedTS = atcMetCmp.PanEvaporationTimeseriesComputedByPenmanMonteith( _ + PETelevation, _ + aPETprecipitation, _ + aPETtemperature, _ + Nothing, PETstation) + + If aOriginalData.Attributes.GetValue("tu") < 4 Then + 'Disaggragate the daily PMET timeseries into hourly + lModifiedTS = atcMetCmp.DisSolPet(lModifiedTS, Nothing, 2, lLatitude) + End If + End If + Return lModifiedTS + End Function + + Private Function VaryDataAddMultiply(ByVal lOriginalData As atcTimeseries, ByRef lSplitData As atcTimeseriesGroup) As atcTimeseries + Dim lArgsMath As New atcDataAttributes + If lSplitData IsNot Nothing AndAlso lSplitData.Count > 0 Then + Dim lSplitTS As atcTimeseries = lSplitData.ItemByIndex(0) + ComputationSource.DataSets.Clear() + lArgsMath.Clear() + lArgsMath.SetValue("timeseries", lSplitTS) + lArgsMath.SetValue("Number", CurrentValue) + ComputationSource.Open(Operation, lArgsMath) + Dim lModifiedTS As atcTimeseries = ComputationSource.DataSets(0) + If lModifiedTS.Dates = lOriginalData.Dates Then + lModifiedTS.Dates = lModifiedTS.Dates.Clone + End If + + If lSplitData.Count > 1 Then + Return MergeTimeseries(New atcTimeseriesGroup(ComputationSource.DataSets(0), lSplitData.ItemByIndex(1))) + Else + Return ComputationSource.DataSets(0) + End If + Else + Return lOriginalData.Clone + End If + End Function + + Protected Overridable Function VaryData() As atcTimeseriesGroup + Dim lModifiedGroup As New atcTimeseriesGroup + Dim lDataSetIndex As Integer = 0 + + For Each lOriginalData As atcTimeseries In DataSets + Dim lEvents As atcTimeseriesGroup = Nothing + Dim lSplitData As atcTimeseriesGroup = SplitData(lOriginalData, lEvents) + Dim lModifiedTS As atcTimeseries = Nothing + + Select Case Operation + Case "AddEvents" : lModifiedTS = AddRemoveEventsVolumeFraction(lOriginalData, CurrentValue/100, lEvents, 0) + Case "Intensify" : lModifiedTS = VaryDataIntensify(lSplitData, lEvents) + Case "Hamon" + If PETtemperature.Count > lDataSetIndex Then + Dim lLatitude As Double = lOriginalData.Attributes.GetValue("Latitude", 39) + lModifiedTS = atcMetCmp.PanEvaporationTimeseriesComputedByHamonX(PETtemperature(lDataSetIndex), Nothing, pDegF, lLatitude, pCTS) + If lOriginalData.Attributes.GetValue("tu") < 4 Then + lModifiedTS = atcMetCmp.DisSolPet(lModifiedTS, Nothing, 2, lLatitude) + End If + End If + + Case "Penman-Monteith" + If PETprecipitation.Count <= lDataSetIndex OrElse PETprecipitation(lDataSetIndex) Is Nothing Then + Throw New ApplicationException("VaryData: Precipitation not found for PET") + ElseIf PETtemperature.Count <= lDataSetIndex OrElse PETtemperature(lDataSetIndex) Is Nothing Then + Throw New ApplicationException("VaryData: Temperature not found for PET") + Else + lModifiedTS = VaryDataPenmanMonteith(lOriginalData, PETtemperature(lDataSetIndex), PETprecipitation(lDataSetIndex)) + End If + Case Else + lModifiedTS = VaryDataAddMultiply(lOriginalData, lSplitData) + End Select + + If lModifiedTS Is Nothing Then + Throw New ApplicationException("VaryData: No data computed") + End If + + Dim lMostOriginal As atcTimeseries = MostOriginal(lOriginalData) + With lModifiedTS.Attributes + .SetValue("CAToriginal", lMostOriginal) + .SetValue("ID", lOriginalData.Attributes.GetValue("ID")) + .SetValue("Location", lOriginalData.Attributes.GetValue("Location")) + .SetValue("Constituent", lOriginalData.Attributes.GetValue("Constituent")) + .SetValue("History 1", lOriginalData.Attributes.GetValue("History 1").ToString) + If lOriginalData.Attributes.ContainsAttribute("TSTYPE") Then + .SetValue("TSTYPE", lOriginalData.Attributes.GetValue("TSTYPE")) + End If + End With + + lModifiedGroup.Add(lMostOriginal, lModifiedTS) + + lDataSetIndex += 1 + Next + Return lModifiedGroup + End Function + + Private Function MostOriginal(ByVal aTimeseries As atcTimeseries) As atcTimeseries + Dim lMostOriginal As atcTimeseries = aTimeseries + While lMostOriginal.Attributes.ContainsAttribute("CAToriginal") + lMostOriginal = lMostOriginal.Attributes.GetValue("CAToriginal") + End While + Return lMostOriginal + End Function + + ''' + ''' + ''' + ''' Original data values + ''' Amount to change total volume, (-0.5=remove 50%, 0=no change, 0.5=add 50%) + ''' Events available for adding + ''' Random number seed + ''' + ''' + Private Shared Function AddRemoveEventsVolumeFraction(ByVal aTimeseries As atcTimeseries, _ + ByVal aVolumeChangeFraction As Double, _ + ByVal aEventsToSearch As atcTimeseriesGroup, _ + ByVal aSeed As Integer) As atcTimeseries + Dim lNewTimeseries As atcTimeseries = aTimeseries.Clone + Dim lMaxEventIndex As Integer = aEventsToSearch.Count 'exclusive upper value, random less than + Dim lFoundIndexes As New Generic.List(Of Integer) + Dim lRandom As New Random(aSeed) + Dim lAdd As Boolean = True + Dim lValueIndex As Integer + Dim lValueLastIndex As Integer + Dim lOriginalVolume As Double = aTimeseries.Attributes.GetValue("Sum") + Dim lCurrentVolume As Double = lOriginalVolume + Dim lTargetVolume As Double = lOriginalVolume * (1 + aVolumeChangeFraction) + Dim lChangeIndex As Integer + + If aVolumeChangeFraction < 0 Then lAdd = False + + Logger.Dbg("OriginalVolume " & DecimalAlign(lOriginalVolume) & _ + " Target Volume " & DecimalAlign(lTargetVolume) & _ + " ChangeFraction " & DecimalAlign(aVolumeChangeFraction) & _ + " Event Count " & aEventsToSearch.Count) + + 'While adding and not yet added enough, or removing and not yet removed enough + While (lAdd AndAlso (lCurrentVolume < lTargetVolume)) OrElse _ + ((Not lAdd) AndAlso (lCurrentVolume > lTargetVolume)) + Dim lCheckIndex As Integer = lRandom.Next(0, lMaxEventIndex) + If Not lFoundIndexes.Contains(lCheckIndex) Then + Dim lEvent As atcTimeseries = aEventsToSearch.ItemByIndex(lCheckIndex) + lFoundIndexes.Add(lCheckIndex) + If lFoundIndexes.Count = aEventsToSearch.Count Then 'all events have been used, start over + If lAdd Then + Logger.Dbg(" ---- All events have been used, start adding over") + lFoundIndexes.Clear() + Else + Logger.Dbg(" ***** All events have been used, nothing more to remove!") + Exit While + End If + End If + + Dim lEventStr As String = " Event " & lCheckIndex + lEventStr &= " Sum " & DecimalAlign(lEvent.Attributes.GetValue("Sum")) + lEventStr &= " NumVals " & lEvent.numValues + lEventStr &= " Starts " & DumpDate(lEvent.Dates.Value(1)) + Logger.Dbg(lEventStr) + + 'Find starting index of event and add it or remove it + If lAdd Then + lValueIndex = lRandom.Next(1, lNewTimeseries.numValues - lEvent.numValues) + Logger.Dbg(" Add at " & DumpDate(lNewTimeseries.Dates.Value(lValueIndex))) + lValueLastIndex = lValueIndex + lEvent.numValues - 1 + lChangeIndex = lValueIndex + While lChangeIndex <= lValueLastIndex AndAlso _ + Not Double.IsNaN(lNewTimeseries.Values(lChangeIndex)) AndAlso _ + lCurrentVolume < lTargetVolume + 'lCurrentVolume -= lNewTimeseries.Values(lIndex) + 'add to old value + Dim lAddValue As Double = lEvent.Values(lChangeIndex - lValueIndex + 1) + lNewTimeseries.Values(lChangeIndex) += lAddValue + lCurrentVolume += lAddValue + lChangeIndex += 1 + End While + Else 'remove + lValueIndex = FindDateAtOrAfter(lNewTimeseries.Dates.Values, lEvent.Dates.Value(1)) + Logger.Dbg(" Remove at " & DumpDate(lNewTimeseries.Dates.Value(lValueIndex).ToString)) + lValueLastIndex = lValueIndex + lEvent.numValues - 1 + lChangeIndex = lValueIndex + While lChangeIndex <= lValueLastIndex AndAlso _ + Not Double.IsNaN(lNewTimeseries.Values(lChangeIndex)) AndAlso _ + lCurrentVolume > lTargetVolume + lCurrentVolume -= lNewTimeseries.Values(lChangeIndex) + lNewTimeseries.Values(lChangeIndex) = 0.0 + lChangeIndex += 1 + End While + End If + Logger.Dbg(" CurrentVolume " & DecimalAlign(lCurrentVolume)) + End If + End While + + lChangeIndex -= 1 + Dim lFinalVolumeAdjustment As Double = lCurrentVolume - lTargetVolume + If lChangeIndex >= 0 AndAlso (lNewTimeseries.Values(lChangeIndex) - lFinalVolumeAdjustment) > 0 Then + Logger.Dbg(" Final Volume Adjustment " & DecimalAlign(lFinalVolumeAdjustment) & _ + " on " & DecimalAlign(lNewTimeseries.Values(lChangeIndex)) & _ + " at " & DumpDate(lNewTimeseries.Dates.Value(lChangeIndex))) + lNewTimeseries.Values(lChangeIndex) -= lFinalVolumeAdjustment + Else + Dim lDbgStr As String = " ***** Fail Final Volume Adjustment " & DecimalAlign(lFinalVolumeAdjustment) & " " & lChangeIndex + If lChangeIndex > 0 Then lDbgStr &= " " & DecimalAlign(lNewTimeseries.Values(lChangeIndex)) + Logger.Dbg(lDbgStr) + End If + + lNewTimeseries.Attributes.DiscardCalculated() + + Dim lOperation As String + If lAdd Then lOperation = "Added " Else lOperation = "Removed " + + Dim lSum As Double = lNewTimeseries.Attributes.GetValue("Sum") + Dim lStr As String = lOperation & lFoundIndexes.Count & " events to change total volume " & DoubleString(aVolumeChangeFraction) + lStr &= " (actual change = " & DoubleString((lSum - lOriginalVolume) / lOriginalVolume) & ")" + lStr &= " Total Volume " & DecimalAlign(lSum) + Logger.Dbg(lStr) + + Return lNewTimeseries + End Function + + Private Function DoubleArraySum(ByVal aValues() As Double, ByVal aStart As Integer, ByVal aCount As Integer) As Double + DoubleArraySum = 0 + Dim lBeyondLastIndex As Integer = aStart + aCount + While aStart < lBeyondLastIndex + DoubleArraySum += aValues(aStart) + aStart += 1 + End While + End Function + + Private Function AddRemoveEventsTotalVolume(ByVal aTimeseries As atcTimeseries, ByVal aTargetVolumeChange As Double, ByVal aEventsToSearch As atcTimeseriesGroup, ByVal aSeed As Integer) As atcTimeseries + ' Private Function FindEventsTotalVolume(ByVal aTargetTotalVolume As Double, ByVal aEventsToSearch As atcDataGroup, ByVal aSeed As Integer) As atcDataGroup + 'Dim lEventsFound As New atcDataGroup + Dim lNewTimeseries As atcTimeseries = aTimeseries.Clone + Dim lMaxEventIndex As Integer = aEventsToSearch.Count - 1 + Dim lFoundIndexes As New Generic.List(Of Integer) + Dim lVolumeFound As Double = 0 + Dim lRandom As New Random(aSeed) + Dim lAdd As Boolean = True + Dim lValueIndex As Integer + Dim lLastValueIndex As Integer + + If aTargetVolumeChange < 0 Then + lVolumeFound = aTargetVolumeChange + aTargetVolumeChange = 0 + lAdd = False + End If + + While lVolumeFound < aTargetVolumeChange + Dim lCheckIndex As Integer = lRandom.Next(0, lMaxEventIndex) + If Not lFoundIndexes.Contains(lCheckIndex) Then + Dim lEvent As atcTimeseries = aEventsToSearch.ItemByIndex(lCheckIndex) + lFoundIndexes.Add(lCheckIndex) + 'lEventsFound.Add(lEvent) + lVolumeFound += lEvent.Attributes.GetValue("Sum") + + 'Find starting index of event + If lAdd Then + lValueIndex = lRandom.Next(1, aTimeseries.numValues - lEvent.numValues) + Else + lValueIndex = FindDateAtOrAfter(lNewTimeseries.Dates.Values, lEvent.Dates.Value(1)) + End If + lLastValueIndex = lValueIndex + lEvent.numValues - 1 + + 'Reduce event volume by volume being replaced + For lScanReplaced As Integer = lValueIndex To lLastValueIndex + lVolumeFound -= lNewTimeseries.Values(lScanReplaced) + Next + + If lAdd Then + Array.Copy(lEvent.Values, 1, lNewTimeseries.Values, lValueIndex, lEvent.numValues) + Else + Array.Clear(lNewTimeseries.Values, lValueIndex, lEvent.numValues) + End If + + End If + End While + + Dim lOperation As String + If lAdd Then lOperation = "Added " Else lOperation = "Removed " + + Dim lStr As String = lOperation & lFoundIndexes.Count & " events to change total volume " & DoubleString(aTargetVolumeChange) + lStr &= " (actual change = " & DoubleString(lNewTimeseries.Attributes.GetValue("Sum") - aTimeseries.Attributes.GetValue("Sum")) & ")" + Logger.Dbg(lStr) + + Return lNewTimeseries + + End Function + + Public Overridable Function Clone() As atcVariation + Dim newVariation As New atcVariation + Me.CopyTo(newVariation) + Return newVariation + End Function + + Sub Clear() + + 'Parameters for Hamon - TODO: don't hard code these + pDegF = True + + pName = "" + pDataSets = New atcTimeseriesGroup + pComputationSource = Nothing + pOperation = "Add" + pSelected = False + + Seasons = Nothing + Min = pNaN + Max = pNaN + Increment = pNaN + pIncrementsSinceStart = 0 + CurrentValue = pNaN + + UseEvents = False + EventThreshold = pNaN + EventDaysGapAllowed = 0 + 'EventGapDisplayUnits = "" + EventHigh = True + IntensifyVolumeFraction = pNaN + 'AddRemovePer = "Entire Span" + + EventVolumeHigh = True + EventVolumeThreshold = pNaN + + EventDurationHigh = True + EventDurationDays = pNaN + 'EventDurationDisplayUnits = "" + + IsInput = False + + ColorAboveMax = System.Drawing.Color.OrangeRed + ColorBelowMin = System.Drawing.Color.DeepSkyBlue + ColorDefault = System.Drawing.Color.White + + PETtemperature = New atcTimeseriesGroup + PETprecipitation = New atcTimeseriesGroup + PETelevation = Integer.MinValue + PETstationID = PETstationUseClosest + End Sub + + Public Overridable Sub CopyTo(ByVal aTargetVariation As atcVariation) + With aTargetVariation + .Name = Name + .UseEvents = UseEvents + If UseEvents Then + .EventDaysGapAllowed = EventDaysGapAllowed + '.EventGapDisplayUnits = EventGapDisplayUnits + .EventHigh = EventHigh + .EventThreshold = EventThreshold + .EventVolumeHigh = EventVolumeHigh + .EventVolumeThreshold = EventVolumeThreshold + .EventDurationHigh = EventDurationHigh + .EventDurationDays = EventDurationDays + .IntensifyVolumeFraction = IntensifyVolumeFraction + End If + + If DataSets IsNot Nothing Then .DataSets = DataSets.Clone() + If PETtemperature IsNot Nothing Then .PETtemperature = PETtemperature.Clone() + If PETprecipitation IsNot Nothing Then .PETprecipitation = PETprecipitation.Clone() + .PETelevation = PETelevation + .PETstationID = PETstationID + + .ComputationSource = ComputationSource + .Operation = Operation.Clone() + If Seasons Is Nothing Then + .Seasons = Nothing + Else + .Seasons = Seasons.Clone + End If + .Selected = Selected + .Min = Min + .Max = Max + .Increment = Increment + '.AddRemovePer = AddRemovePer + .IsInput = IsInput + .CurrentValue = CurrentValue + .ColorAboveMax = ColorAboveMax + .ColorBelowMin = ColorBelowMin + .ColorDefault = ColorDefault + End With + End Sub + + Protected Overridable Property EventsXML() As String + Get + If UseEvents Then + Return " " & vbCrLf + '& " GapDisplayUnits='" & EventGapDisplayUnits & "' " _ + '& " DurationDisplayUnits='" & EventDurationDisplayUnits & "' " _ + Else + Return "" + End If + End Get + Set(ByVal newValue As String) + Dim lXMLDoc As New Xml.XmlDocument + Try + lXMLDoc.LoadXml(newValue) + Dim lXML As Xml.XmlNode = lXMLDoc.FirstChild + If lXML.Name.ToLower.Equals("events") Then + UseEvents = True + EventThreshold = GetAtt(lXML, "Threshold", EventThreshold) + EventHigh = GetAtt(lXML, "High", EventHigh) + IntensifyVolumeFraction = GetAtt(lXML, "FlashVolumeFraction", IntensifyVolumeFraction) 'supports old name + IntensifyVolumeFraction = GetAtt(lXML, "IntensifyVolumeFraction", IntensifyVolumeFraction) + If IntensifyVolumeFraction > 1 Then IntensifyVolumeFraction -= 1 'Backward compatible with files saved when this was centered at 100% + EventDaysGapAllowed = GetAtt(lXML, "GapDays", EventDaysGapAllowed) + 'EventGapDisplayUnits = lXML.GetAttrValue("GapDisplayUnits") + + EventVolumeHigh = GetAtt(lXML, "VolumeHigh", EventVolumeHigh) + EventVolumeThreshold = GetAtt(lXML, "VolumeThreshold", EventVolumeThreshold) + + EventDurationHigh = GetAtt(lXML, "DurationHigh", EventDurationHigh) + EventDurationDays = GetAtt(lXML, "DurationDays", EventDurationDays) + 'EventDurationDisplayUnits = lXML.GetAttrValue("DurationDisplayUnits") + End If + Catch e As Exception + Logger.Msg("Could not read Events XML:" & vbCrLf & newValue & vbCrLf & e.Message, "CAT Events XML Problem") + End Try + End Set + End Property + + Private Function GetAtt(ByVal aNode As Xml.XmlNode, ByVal aAttributeName As String, Optional ByVal aDefault As Object = "") As Object + Dim lAttribute As Xml.XmlAttribute = aNode.Attributes.GetNamedItem(aAttributeName) + If lAttribute IsNot Nothing Then + Return lAttribute.InnerText + Else + Return aDefault + End If + End Function + + Protected Overridable Property SeasonsXML() As String + Get + If Seasons Is Nothing Then + Return "" + Else + Return " " & vbCrLf _ + & " " & Seasons.SeasonsSelectedXML & " " & vbCrLf + End If + End Get + Set(ByVal newValue As String) + Dim lXMLdoc As New Xml.XmlDocument + Try + lXMLdoc.LoadXml(newValue) + Dim lXML As Xml.XmlNode = lXMLdoc.FirstChild + If lXML.Name.ToLower.Equals("seasons") Then + Dim lSeasonTypeName As String = GetAtt(lXML, "Type") + For Each lSeasonType As Type In atcData.atcSeasonBase.AllSeasonTypes + If lSeasonType.Name.Equals(lSeasonTypeName) Then + Seasons = lSeasonType.InvokeMember(Nothing, Reflection.BindingFlags.CreateInstance, Nothing, Nothing, New Object() {}) + If lXML.InnerXml.Contains("<") Then + Seasons.SeasonsSelectedXML = lXML.InnerXml + End If + End If + Next + End If + Catch ex As Exception + Logger.Msg("Unable to parse:" & vbCrLf & newValue, "CAT Seasons XML Problem") + End Try + End Set + End Property + + Private Function GetDataGroupXML(ByVal aDataGroup As atcTimeseriesGroup, ByVal aTag As String) As String + If aDataGroup Is Nothing OrElse aDataGroup.Count = 0 Then + Return "" + Else + Dim lXML As String = " <" & aTag & " count='" & aDataGroup.Count & "'>" & vbCrLf + For lIndex As Integer = 0 To aDataGroup.Count - 1 + Dim lDataSet As atcDataSet = aDataGroup.Item(lIndex) + Dim lDataKey As String = aDataGroup.Keys(lIndex).ToString + If Not lDataSet Is Nothing Then + lXML &= " " & vbCrLf + End If + End Function + + Private Sub SetDataGroupXML(ByRef aDataGroup As atcTimeseriesGroup, ByVal aTag As String, ByVal aXML As String) + Dim lXMLdoc As New Xml.XmlDocument + Try + lXMLdoc.LoadXml(aXML) + aDataGroup = New atcTimeseriesGroup + For Each lXML As Xml.XmlNode In lXMLdoc.FirstChild.ChildNodes + Dim lKey As String = GetAtt(lXML, "Key") + Dim lID As String = GetAtt(lXML, "ID") + Dim lHistory As String = GetAtt(lXML, "History") + If lID.Length > 0 Then + Dim lDataGroup As atcTimeseriesGroup = Nothing + If lHistory.Length > 10 Then + Dim lSourceSpecification As String = lHistory.Substring(10).ToLower + Dim lDataSource As atcTimeseriesSource = atcDataManager.DataSourceBySpecification(lSourceSpecification) + If lDataSource IsNot Nothing Then + lDataGroup = lDataSource.DataSets.FindData("ID", lID, 2) + If lDataGroup.Count > 0 Then + Logger.Dbg("Found data set #" & lID & " in " & lSourceSpecification) + Else + lDataGroup = Nothing + End If + End If + End If + If lDataGroup Is Nothing Then + lDataGroup = atcDataManager.DataSets.FindData("ID", lID, 2) + End If + If lDataGroup.Count > 0 Then + Logger.Dbg("Found data set #" & lID & " without a specification") + If lDataGroup.Count > 1 Then Logger.Dbg("Warning: more than one data set matched ID " & lID) + aDataGroup.Add(lKey, lDataGroup.ItemByIndex(0)) + Else + Logger.Msg("No data found with ID " & lID, "Variation from XML") + End If + Else + If lKey Is Nothing OrElse lKey.Length = 0 Then + Logger.Dbg("No data set ID found in XML, skipping: ", lXML.OuterXml) + End If + aDataGroup.Add(lKey, Nothing) + End If + Next + Catch e As Exception + Logger.Msg("Unable to parse:" & vbCrLf & aXML & vbCrLf & e.Message, "CAT Data Group XML Problem") + End Try + End Sub + + Public Overridable Property XML() As String + Get + Dim lXML As String = "" & vbCrLf _ + & " " & ToXML(Name) & "" & vbCrLf + If PETelevation > Integer.MinValue Then + lXML &= " " & PETelevation & "" & vbCrLf + End If + If Not String.IsNullOrEmpty(PETstationID) Then + lXML &= " " & PETstationID & "" & vbCrLf + End If + If Not Double.IsNaN(Min) Then + lXML &= " " & Min & "" & vbCrLf + End If + If Not Double.IsNaN(Max) Then + lXML &= " " & Max & "" & vbCrLf + End If + If Not Double.IsNaN(Increment) Then + lXML &= " " & Increment & "" & vbCrLf + End If + If IsInput Then + lXML &= " " & IsInput & "" & vbCrLf + End If + lXML &= " " & ToXML(Operation) & "" & vbCrLf + 'lXML &= " " & AddRemovePer & "" & vbCrLf + If Not ComputationSource Is Nothing Then + lXML &= " " & ToXML(ComputationSource.Name) & "" & vbCrLf + End If + lXML &= " " & Selected & "" & vbCrLf _ + & GetDataGroupXML(DataSets, "DataSets") _ + & GetDataGroupXML(PETtemperature, "PETtemperature") _ + & GetDataGroupXML(PETprecipitation, "PETprecipitation") _ + & EventsXML _ + & SeasonsXML _ + & "" & vbCrLf + Return lXML + End Get + Set(ByVal newValue As String) + Dim lXMLdoc As New Xml.XmlDocument + Try + lXMLdoc.LoadXml(newValue) + For Each lXML As Xml.XmlNode In lXMLdoc.FirstChild.ChildNodes + With lXML + Select Case .Name.ToLower + Case "name" : Name = .InnerText + Case "elevation" : PETelevation = CInt(.InnerText) + Case "stationid" : PETstationID = .InnerText + Case "min" : Min = CDbl(.InnerText) + Case "max" : Max = CDbl(.InnerText) + Case "increment" : Increment = CDbl(.InnerText) + Case "isinput" : IsInput = CBool(.InnerText) + Case "operation" + Operation = .InnerText + If Operation = "Flash" Then Operation = "Intensify" + 'Case "addremoveper" : AddRemovePer = .Content + Case "computationsource" + ComputationSource = atcDataManager.DataSourceByName(.InnerText) + If ComputationSource Is Nothing Then + Select Case .InnerText + Case "Timeseries::Math" + ComputationSource = New atcTimeseriesMath.atcTimeseriesMath + Case Else + Logger.Msg("UnknownComputationSource " & .InnerText) + End Select + End If + Case "datasets" : SetDataGroupXML(DataSets, "DataSets", .OuterXml) + Case "pettemperature" : SetDataGroupXML(PETtemperature, "PETtemperature", .OuterXml) + Case "petprecipitation" : SetDataGroupXML(PETprecipitation, "PETprecipitation", .OuterXml) + Case "selected" + Selected = .InnerText.ToLower.Equals("true") + Case "seasons" : SeasonsXML = .OuterXml + Case "events" : EventsXML = .OuterXml + End Select + End With + Next + Catch e As Exception + Logger.Msg("Unable to parse:" & vbCrLf & newValue, "CAT Variation XML Problem") + End Try + If ComputationSource Is Nothing Then + ComputationSource = New atcTimeseriesMath.atcTimeseriesMath + End If + End Set + End Property + + Public Overrides Function ToString() As String + Dim lString As String = Name & " " & Operation & " " + + Select Case Operation + Case "Hamon", "Penman-Monteith" + If PETtemperature IsNot Nothing AndAlso PETtemperature.Count > 0 Then + If PETtemperature.Count = 1 Then + lString &= "Temp: " & PETtemperature(0).ToString & " " + Else + lString &= "Temp: (" & PETtemperature.Count & ")" + End If + End If + If PETprecipitation IsNot Nothing AndAlso PETprecipitation.Count > 0 AndAlso Not Operation.Equals("Hamon") Then + If PETprecipitation.Count = 1 Then + lString &= "Precip: " & PETprecipitation(0).ToString & " " + Else + lString &= "Precip: (" & PETprecipitation.Count & ")" + End If + End If + If PETelevation > Integer.MinValue AndAlso Not Operation.Equals("Hamon") Then + lString &= "Elev: " & PETelevation + End If + If Not String.IsNullOrEmpty(PETstationID) AndAlso PETstationID <> PETstationUseClosest Then + lString &= "Station: " & PETstationID + End If + Case Else + If Max <= Min Then + lString &= DoubleString(Min) + Else + If Not Double.IsNaN(Min) Then lString &= "from " & DoubleString(Min) + If Not Double.IsNaN(Max) Then lString &= " to " & DoubleString(Max) + If Not Double.IsNaN(Increment) Then lString &= " step " & DoubleString(Increment) + End If + End Select + + If Seasons IsNot Nothing Then + lString &= " " & atcSeasons.atcSeasonPlugin.SeasonClassNameToLabel(Seasons.GetType.Name) _ + & ": " & Seasons.SeasonsSelectedString + End If + Return lString + End Function + + Private Shared Function DoubleString(ByVal aNumber As Double) As String + Dim lStr As String = Format(aNumber, "0.000") + Dim lDecimalPos As Integer = lStr.IndexOf("."c) + If lDecimalPos >= 0 Then + 'Trim trailing zeroes after decimal point + lStr = lStr.TrimEnd("0"c) + 'Trim trailing decimal point + If lStr.Length = lDecimalPos + 1 Then lStr = lStr.Substring(0, lDecimalPos) + End If + If lStr.Length = 0 Then lStr = "0" + Return lStr + End Function + + Public Sub New() + Clear() + End Sub + + Protected Overrides Sub Finalize() + If pDataSets IsNot Nothing Then + pDataSets.Dispose() + pDataSets = Nothing + End If + If PETtemperature IsNot Nothing Then + PETtemperature.Dispose() + PETtemperature = Nothing + End If + If PETprecipitation IsNot Nothing Then + PETprecipitation.Dispose() + PETprecipitation = Nothing + End If + pComputationSource = Nothing + Seasons = Nothing + MyBase.Finalize() + End Sub +End Class diff --git a/atcData/modTimeseriesMath.vb b/atcData/modTimeseriesMath.vb index aad3354a9..6e3bf7410 100644 --- a/atcData/modTimeseriesMath.vb +++ b/atcData/modTimeseriesMath.vb @@ -1,1963 +1,1963 @@ -Imports atcUtility -Imports MapWinUtility - -''' Math utility functions -Public Module modTimeseriesMath - - Private pNaN As Double = GetNaN() - Private pMaxValue As Double = GetMaxValue() - - ''' Search through an array of dates looking for a date - ''' Array of dates to search - ''' Date to search for - ''' Index of data to begin search at (default is 0) - ''' Index of first date on or after date searched for - ''' - Public Function FindDateAtOrAfter(ByVal aDatesToSearch() As Double, ByVal aDate As Double, _ - Optional ByVal aStartAt As Integer = 0) As Integer - aDate -= JulianMillisecond 'Allow for floating point error - Dim lIndex As Integer = Array.BinarySearch(aDatesToSearch, aDate) - If lIndex < 0 Then - lIndex = lIndex Xor -1 - End If - Return lIndex - End Function - - ''' Creates a timeseries copied from orginal that only contains dates within specifed range - ''' Original timeseries - ''' Starting Julian date - ''' Ending Julian date - ''' Data Source to assign to newly created subset timeseries, can be 'Nothing' - ''' Reference to new timeseries - ''' if aDataSource is 'Nothing' only a reference to a new timeseries is returned - Public Function SubsetByDate(ByVal aTimeseries As atcTimeseries, _ - ByVal aStartDate As Double, _ - ByVal aEndDate As Double, _ - ByVal aDataSource As atcTimeseriesSource) As atcTimeseries - - If aTimeseries Is Nothing OrElse aTimeseries.Dates Is Nothing Then Return Nothing - - Dim lPointTimeseries As Boolean = aTimeseries.Attributes.GetValue("Point", False) - Dim lStart As Integer = FindDateAtOrAfter(aTimeseries.Dates.Values, aStartDate) - Dim lEnd As Integer = FindDateAtOrAfter(aTimeseries.Dates.Values, aEndDate, lStart) - If lEnd > aTimeseries.numValues Then 'adjust end to actual end - lEnd = aTimeseries.numValues - End If - 'Back up one time step for mean data or point data after end - If Not lPointTimeseries OrElse - (lEnd > 0 AndAlso aTimeseries.Dates.Value(lEnd) > aEndDate) Then - lEnd -= 1 - End If - - Dim lnewTS As New atcTimeseries(aDataSource) - lnewTS.Dates = New atcTimeseries(aDataSource) - lnewTS.Attributes.SetValue("Original ID", aTimeseries.OriginalParentID) - Dim lNumNewValues As Integer = lEnd - lStart + 1 - - If lNumNewValues > 0 Then - Dim lNewValues(lNumNewValues) As Double - Dim lNewDates(lNumNewValues) As Double - lNewValues(0) = GetNaN() - - If lPointTimeseries Then - lNewDates(0) = GetNaN() - System.Array.Copy(aTimeseries.Dates.Values, lStart, lNewDates, 1, lNumNewValues) - System.Array.Copy(aTimeseries.Values, lStart, lNewValues, 1, lNumNewValues) - Else - System.Array.Copy(aTimeseries.Dates.Values, lStart, lNewDates, 0, lNumNewValues + 1) - System.Array.Copy(aTimeseries.Values, lStart + 1, lNewValues, 1, lNumNewValues) - End If - - lnewTS.Values = lNewValues - lnewTS.Dates.Values = lNewDates - CopyBaseAttributes(aTimeseries, lnewTS, lNumNewValues, lStart + 1, 1) - lnewTS.Attributes.SetValue("SJDAY", aStartDate) - lnewTS.Attributes.SetValue("EJDAY", aEndDate) - lnewTS.Attributes.SetValue("Point", lPointTimeseries) - Else - CopyBaseAttributes(aTimeseries, lnewTS) - End If - Return lnewTS - End Function - - ''' - ''' Trim a timeseries if needed to make it start and end at the desired year boundary. - ''' Useful when complete calendar or water years are needed. - ''' - ''' Original timeseries - ''' Month containing first value of the year - ''' Day containing first value of the year - ''' Data Source to assign to newly created subset timeseries, can be Nothing - ''' Optional first year of data to include in subset - ''' Optional last year of data to include in subset - ''' Optional month containing last value of the year - ''' Optional day containing last value of the year - ''' New subset timeseries - ''' - ''' If omitted or zero, aFirstYear or aLastYear will not be used to limit the subset. - ''' If omitted or zero, aEndMonth/aEndDay will default to the day before aStartMonth/aStartDay. - ''' - Public Function SubsetByDateBoundary(ByVal aTimeseries As atcTimeseries, _ - ByVal aStartMonth As Integer, _ - ByVal aStartDay As Integer, _ - ByVal aDataSource As atcTimeseriesSource, _ - Optional ByVal aFirstYear As Integer = 0, _ - Optional ByVal aLastYear As Integer = 0, _ - Optional ByVal aEndMonth As Integer = 0, _ - Optional ByVal aEndDay As Integer = 0) As atcTimeseries - - If aEndMonth = 0 Then - aEndMonth = aStartMonth 'Will be rolled back a day later - End If - - If aEndDay = 0 Then - aEndDay = aStartDay 'Will be rolled back a day later - End If - - aTimeseries.EnsureValuesRead() - - If aTimeseries.numValues < 1 Then - Return aTimeseries - End If - - If aFirstYear > 0 AndAlso (aEndMonth < aStartMonth OrElse (aEndMonth = aStartMonth AndAlso aEndDay < aStartDay)) Then - 'Convert water year into calendar year - aFirstYear -= 1 - End If - - Dim lStartDate As Double = aTimeseries.Dates.Value(0) - If Double.IsNaN(lStartDate) Then lStartDate = aTimeseries.Dates.Value(1) - Dim lStartTimeseriesDate As Date = Date.FromOADate(lStartDate) - With lStartTimeseriesDate - 'Roll back end of year by one day if it matches beginning of year - If aEndMonth = aStartMonth AndAlso aEndDay = aStartDay Then - aEndDay -= 1 - If aEndDay = 0 Then - aEndMonth -= 1 - If aEndMonth = 0 Then aEndMonth = 12 - aEndDay = DayMon(.Year, aEndMonth) - End If - End If - - Dim lStartYear As Integer = .Year - If aFirstYear > lStartYear Then - lStartYear = aFirstYear - Else - If .Month > aStartMonth Then - lStartYear += 1 - ElseIf .Month = aStartMonth Then - If .Day > aStartDay Then - lStartYear += 1 - End If - End If - End If - lStartDate = Jday(lStartYear, aStartMonth, aStartDay, 0, 0, 0) - End With - - Dim lEndDate As Double - Dim lEndTimeseriesDate As Date = Date.FromOADate(aTimeseries.Dates.Value(aTimeseries.Dates.numValues)) - With lEndTimeseriesDate - Dim lEndYear As Integer = .Year - If aLastYear > 0 AndAlso aLastYear < lEndYear Then - lEndYear = aLastYear - Else - If .Month < aEndMonth Then - lEndYear -= 1 - ElseIf .Month = aEndMonth Then - If .Day < aEndDay Then - lEndYear -= 1 - End If - End If - End If - lEndDate = Jday(lEndYear, aEndMonth, aEndDay, 24, 0, 0) 'hour 24 = end of last day - End With - - SubsetByDateBoundary = SubsetByDate(aTimeseries, lStartDate, lEndDate, aDataSource) - SubsetByDateBoundary.Attributes.Add("seasbg", aStartMonth) - SubsetByDateBoundary.Attributes.Add("seadbg", aStartDay) - SubsetByDateBoundary.Attributes.Add("seasnd", aEndMonth) - SubsetByDateBoundary.Attributes.Add("seadnd", aEndDay) - - End Function - - ''' Copy any attributes that copies inherit from aFromDataSet into aToDataSet - ''' Dataset containing attributes to copy - ''' Dataset to copy attributes into - ''' Number of values to copy value attributes of - ''' Start index for copying value attributes from - ''' Start index for copying value attributes to - ''' Copies only general attributes if aNumValues is omitted or is less than 1, - ''' Also copies value attributes if aNumValues > 0 - Public Sub CopyBaseAttributes(ByVal aFromDataset As atcTimeseries, ByVal aToDataSet As atcTimeseries, _ - Optional ByVal aNumValues As Integer = 0, _ - Optional ByVal aStartFrom As Integer = 0, _ - Optional ByVal aStartTo As Integer = 0) - - For Each lAttribute As atcDefinedValue In aFromDataset.Attributes - If lAttribute.Definition.CopiesInherit Then - aToDataSet.Attributes.SetValue(lAttribute.Definition, lAttribute.Value) - End If - Next - - If aFromDataset.ValueAttributesExist Then - For lIndex As Integer = 0 To aNumValues - 1 - If aFromDataset.ValueAttributesExist(lIndex + aStartFrom) Then - For Each lAttribute As atcDefinedValue In aFromDataset.ValueAttributes(lIndex + aStartFrom) - If lAttribute.Definition.CopiesInherit Then - aToDataSet.ValueAttributes(lIndex + aStartTo).SetValue(lAttribute.Definition, lAttribute.Value) - End If - Next - End If - Next - End If - End Sub - - ''' Merge a group of atcTimeseries - ''' Group of atcTimeseries to merge - ''' True to skip missing values, False to include missing values in result - ''' atcTimeseries containing all unique dates from the group - ''' Each atcTimeseries in aGroup is assumed to be in order by date within itself. - ''' If duplicate dates exist in aGroup, some values will be left out of result. - Public Function MergeTimeseries(ByVal aGroup As atcTimeseriesGroup, _ - ByVal aSkipMissing As Boolean, _ - ByVal aTran As atcTran) As atcTimeseries - Dim lNewTS As New atcTimeseries(Nothing) 'will contain new (merged) dates - If aGroup IsNot Nothing AndAlso aGroup.Count > 0 Then - lNewTS.Dates = MergeDates(aGroup, aSkipMissing) - Dim lTotalNumValues As Long = lNewTS.Dates.numValues - lNewTS.numValues = lTotalNumValues - lNewTS.Value(0) = pNaN - - Dim lOldTS As atcTimeseries 'points to current timeseries from aGroup - Dim lMaxGroupIndex As Integer = aGroup.Count - 1 - Dim lNextIndex() As Integer - - ReDim lNextIndex(aGroup.Count - 1) - - For lIndex As Integer = 0 To lMaxGroupIndex - lNextIndex(lIndex) = 1 - Next - - MergeAttributes(aGroup, lNewTS) - Dim lNumToAverage As Integer = 0 - For lNewIndex As Integer = 1 To lTotalNumValues - Dim lCurrentDate As Double = lNewTS.Dates.Value(lNewIndex) - lNumToAverage = 0 - For lIndex As Integer = 0 To lMaxGroupIndex - lOldTS = aGroup.Item(lIndex) - While lNextIndex(lIndex) <= lOldTS.numValues AndAlso lOldTS.Dates.Value(lNextIndex(lIndex)) - JulianMillisecond < lCurrentDate - lNumToAverage += 1 - 'If Native, always just use latest value. - 'OrElse, If this is the first value, use it for all tran except CountMissing (which needs counts not values) - If aTran = atcTran.TranNative OrElse (aTran <> atcTran.TranCountMissing AndAlso lNumToAverage = 1) Then - lNewTS.Value(lNewIndex) = lOldTS.Value(lNextIndex(lIndex)) - Else - Select Case aTran - Case atcTran.TranAverSame, atcTran.TranSumDiv - lNewTS.Value(lNewIndex) += lOldTS.Value(lNextIndex(lIndex)) - Case atcTran.TranCountMissing - If Double.IsNaN(lOldTS.Value(lNextIndex(lIndex))) Then lNewTS.Value(lNewIndex) += 1 - Case atcTran.TranMax - If lOldTS.Value(lNextIndex(lIndex)) > lNewTS.Value(lNewIndex) Then - lOldTS.Value(lNextIndex(lIndex)) = lOldTS.Value(lNextIndex(lIndex)) - End If - Case atcTran.TranMin - If lOldTS.Value(lNextIndex(lIndex)) < lNewTS.Value(lNewIndex) Then - lOldTS.Value(lNextIndex(lIndex)) = lOldTS.Value(lNextIndex(lIndex)) - End If - End Select - End If - lNextIndex(lIndex) += 1 - End While - Next - If aTran = atcTran.TranAverSame AndAlso lNumToAverage > 1 Then - lNewTS.Value(lNewIndex) /= lNumToAverage - End If - Next - End If - Return lNewTS - End Function - - ''' Merge a group of atcTimeseries - ''' Group of atcTimeseries to merge - ''' True to skip missing values, False to include missing values in result - ''' atcTimeseries containing all unique dates from the group - ''' Each atcTimeseries in aGroup is assumed to be in order by date within itself. - ''' If duplicate dates exist in aGroup, some values will be left out of result. - Public Function MergeTimeseries(ByVal aGroup As atcTimeseriesGroup, _ - Optional ByVal aFilterNoData As Boolean = False) As atcTimeseries - Dim lNewTS As New atcTimeseries(Nothing) 'will contain new (merged) dates - lNewTS.Dates = New atcTimeseries(Nothing) - If aGroup IsNot Nothing AndAlso aGroup.Count > 0 Then - Dim lNewIndex As Integer - Dim lTotalNumValues As Integer = 0 - Dim lOldTS As atcTimeseries 'points to current timeseries from aGroup - Dim lMinDate As Double = pMaxValue - Dim lDateZero As Double = pNaN - Dim lMaxGroupIndex As Integer = aGroup.Count - 1 - Dim lIndex As Integer - Dim lMinIndex As Integer - Dim lNextIndex() As Integer - Dim lNextDate() As Double - - ReDim lNextIndex(aGroup.Count - 1) - ReDim lNextDate(aGroup.Count - 1) - - MergeAttributes(aGroup, lNewTS) - 'lNewTS.Attributes.AddHistory("Merged " & aGroup.Count) - - 'Count total number of values and set up - For lIndex = 0 To lMaxGroupIndex - lOldTS = aGroup.Item(lIndex) - Try - lTotalNumValues += lOldTS.numValues - GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lIndex), lNextDate(lIndex)) - 'Find minimum starting date and take date before from that TS - If lNextDate(lIndex) < lMinDate Then - lMinDate = lNextDate(lIndex) - lDateZero = lOldTS.Dates.Value(lNextIndex(lIndex) - 1) - End If - Catch 'Can't get dates values from this TS - lNextIndex(lIndex) = -1 - End Try - Next - - If lTotalNumValues > 0 Then - lNewTS.numValues = lTotalNumValues - lNewTS.Dates.numValues = lTotalNumValues - If lMinDate < pMaxValue Then - lNewTS.Dates.Value(0) = lDateZero - Else - lNewTS.Dates.Value(0) = pNaN - End If - lNewTS.Value(0) = pNaN - - For lNewIndex = 1 To lTotalNumValues - 'Find earliest date not yet used - lMinIndex = -1 - lMinDate = pMaxValue - For lIndex = 0 To lMaxGroupIndex - If lNextIndex(lIndex) > 0 AndAlso lNextDate(lIndex) < lMinDate Then - lMinIndex = lIndex - lMinDate = lNextDate(lIndex) - End If - Next - - 'TODO: could make common cases faster with Array.Copy - 'Now that we have found lMinDate, could also find the lNextMinDate when the - 'minimum date from a different TS happens, then find out how many more values - 'from this TS are earlier than lNextMinDate, then copy all of them to the - 'new TS at once - - 'Add earliest date and value to new TS - If lMinIndex >= 0 Then - 'Logger.Dbg("---found min date in data set " & lMinIndex) - lOldTS = aGroup.Item(lMinIndex) - If lOldTS.ValueAttributesGetValue(lNextIndex(lMinIndex), "Inserted", False) Then - 'Logger.Dbg("---discarding inserted value") - 'This value was inserted during splitting and will now be discarded - lNewIndex -= 1 - lTotalNumValues -= 1 - GetNextDateIndex(lOldTS, aFilterNoData, _ - lNextIndex(lMinIndex), _ - lNextDate(lMinIndex)) - Else - 'Logger.Dbg("---MergeTimeseries adding date " & lMinDate & " value " & lOldTS.Value(lNextIndex(lMinIndex)) & " from dataset " & lMinIndex) - lNewTS.Dates.Value(lNewIndex) = lMinDate - lNewTS.Value(lNewIndex) = lOldTS.Value(lNextIndex(lMinIndex)) - If lOldTS.ValueAttributesExist(lNextIndex(lMinIndex)) Then - lNewTS.ValueAttributes(lNewIndex) = lOldTS.ValueAttributes(lNextIndex(lMinIndex)) - End If - - GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lMinIndex), lNextDate(lMinIndex)) - - For lIndex = 0 To lMaxGroupIndex - 'Discard next value from any TS that falls within one millisecond - 'Don't need Math.Abs because we already found minimum - While lNextIndex(lIndex) > 0 AndAlso (lNextDate(lIndex) - lMinDate) < JulianMillisecond - lOldTS = aGroup.Item(lIndex) - 'Logger.Dbg("---MergeTimeseries discarding date " & DumpDate(lNextDate(lIndex)) & " value " & lOldTS.Value(lNextIndex(lIndex)) & " from dataset " & lIndex) - lTotalNumValues -= 1 'This duplicate no longer counts toward total - GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lIndex), lNextDate(lIndex)) - End While - Next - End If - Else 'out of values in all the datasets - 'Logger.Dbg("Warning:MergeTimeseries:Ran out of values at " & lNewIndex & " of " & lTotalNumValues) - lTotalNumValues = lNewIndex - 1 - Exit For - End If - Next - If lTotalNumValues < lNewTS.numValues Then - lNewTS.numValues = lTotalNumValues - lNewTS.Dates.numValues = lTotalNumValues - End If - End If - End If - Return lNewTS - End Function - - ''' - ''' Find the first starting date, last ending date, and common time period of a group of Timeseries - ''' - ''' Group to search for start and end dates - ''' Earliest start date of any timeseries in group (beginning of interval for constant interval) - ''' Latest ending date of any timeseries in group - ''' Beginning of the period shared by all in group (beginning of interval for constant interval) - ''' Ending of the period shared by all in group - ''' True if there is a common period of all timeseries in the group, false if one timeseries begins only after another ends. - ''' All arguments except aGroup are ByRef - Public Function CommonDates(ByVal aGroup As atcTimeseriesGroup, _ - ByRef aFirstStart As Double, _ - ByRef aLastEnd As Double, _ - ByRef aCommonStart As Double, _ - ByRef aCommonEnd As Double) As Boolean - aFirstStart = GetMaxValue() - aLastEnd = GetMinValue() - - aCommonStart = GetMinValue() - aCommonEnd = GetMaxValue() - - If aGroup IsNot Nothing Then - Dim lMaxProgress As Long = aGroup.Count - Dim lCurrentProgress As Long = 0 - Dim lShowingProgress As Boolean = lMaxProgress > 50 - Using lProgressLevel As New ProgressLevel(False, Not lShowingProgress) - If lShowingProgress Then Logger.Status("Reading data and finding common dates") - For Each lTs As atcData.atcTimeseries In aGroup - If lTs.Dates.numValues > 0 Then - Dim lThisDate As Double = lTs.Dates.Value(0) - If Double.IsNaN(lThisDate) Then lThisDate = lTs.Dates.Value(1) - If lThisDate < aFirstStart Then aFirstStart = lThisDate - If lThisDate > aCommonStart Then aCommonStart = lThisDate - lThisDate = lTs.Dates.Value(lTs.Dates.numValues) - If lThisDate > aLastEnd Then aLastEnd = lThisDate - If lThisDate < aCommonEnd Then aCommonEnd = lThisDate - End If - If lShowingProgress Then - lCurrentProgress += 1 - Logger.Progress(lCurrentProgress, lMaxProgress) - End If - Next - End Using - End If - - Return aCommonStart > GetMinValue() AndAlso aCommonEnd < GetMaxValue() AndAlso aCommonStart < aCommonEnd - - End Function - - ''' Merge the dates from a group of atcTimeseries - ''' Group of atcTimeseries to merge the dates of - ''' True to skip missing values, False to include missing values in result - ''' atcTimeseries containing all unique dates from the group - ''' Each atcTimeseries in aGroup is assumed to be in order by date within itself. - Public Function MergeDates(ByVal aGroup As atcTimeseriesGroup, _ - Optional ByVal aFilterNoData As Boolean = False) As atcTimeseries - Dim lNewDates As New Generic.List(Of Double) - Dim lTotalNumValues As Long = 0 - Dim lOldTS As atcTimeseries 'points to current timeseries from aGroup - Dim lMinDate As Double = pMaxValue - Dim lMaxGroupIndex As Integer = aGroup.Count - 1 - Dim lIndex As Integer - Dim lMinIndex As Integer - Dim lNextIndex() As Integer - Dim lNextDate() As Double - - ReDim lNextIndex(aGroup.Count - 1) - ReDim lNextDate(aGroup.Count - 1) - - 'Count total number of values and set up - For lIndex = 0 To lMaxGroupIndex - lOldTS = aGroup.Item(lIndex) - Try - lTotalNumValues += lOldTS.numValues - GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lIndex), lNextDate(lIndex)) - 'Find minimum starting date and take date before from that TS - If lNextDate(lIndex) < lMinDate Then - lMinDate = lOldTS.Dates.Value(lNextIndex(lIndex) - 1) - End If - Catch 'Can't get dates values from this TS - lNextIndex(lIndex) = -1 - End Try - Next - - If lTotalNumValues > 0 Then - If lMinDate < pMaxValue Then - lNewDates.Add(lMinDate) - Else - lNewDates.Add(pNaN) - End If - - Do - 'Find earliest date not yet used - lMinIndex = -1 - lMinDate = pMaxValue - For lIndex = 0 To lMaxGroupIndex - If lNextIndex(lIndex) > 0 AndAlso lNextDate(lIndex) < lMinDate Then - lMinIndex = lIndex - lMinDate = lNextDate(lIndex) - End If - Next - - 'TODO: could make common cases faster with Array.Copy - 'Now that we have found lMinDate, could also find the lNextMinDate when the - 'minimum date from a different TS happens, then find out how many more values - 'from this TS are earlier than lNextMinDate, then copy all of them to the - 'new TS at once - - 'add earliest date - If lMinIndex >= 0 Then - 'Logger.Dbg("---found min date in data set " & lMinIndex) - lOldTS = aGroup.Item(lMinIndex) - If lOldTS.ValueAttributesGetValue(lNextIndex(lMinIndex), "Inserted", False) Then - 'Logger.Dbg("---discarding inserted value") - 'This value was inserted during splitting and will now be discarded - GetNextDateIndex(lOldTS, aFilterNoData, _ - lNextIndex(lMinIndex), _ - lNextDate(lMinIndex)) - Else - 'Logger.Dbg("---MergeTimeseries adding date " & lMinDate & " value " & lOldTS.Value(lNextIndex(lMinIndex)) & " from dataset " & lMinIndex) - lNewDates.Add(lMinDate) - - GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lMinIndex), lNextDate(lMinIndex)) - - For lIndex = 0 To lMaxGroupIndex - 'Discard next value from any TS that falls within one millisecond - 'Don't need Math.Abs because we already found minimum - While lNextIndex(lIndex) > 0 AndAlso (lNextDate(lIndex) - lMinDate) < JulianMillisecond - lOldTS = aGroup.Item(lIndex) - 'Logger.Dbg("---MergeTimeseries discarding date " & DumpDate(lNextDate(lIndex)) & " value " & lOldTS.Value(lNextIndex(lIndex)) & " from dataset " & lIndex) - GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lIndex), lNextDate(lIndex)) - End While - Next - End If - Else 'out of values in all the datasets - 'Logger.Dbg("Warning:MergeTimeseries:Ran out of values at " & lNewIndex & " of " & lTotalNumValues) - Exit Do - End If - Loop - End If - Logger.Dbg("Merged dates from " & aGroup.Count & " timeseries, found " & lNewDates.Count - 1 & " unique dates from " & lTotalNumValues & " total values.") - Dim lNewTS As New atcTimeseries(Nothing) - lNewTS.Values = lNewDates.ToArray - Return lNewTS - End Function - - ''' - ''' - ''' - ''' - ''' - ''' - Private Sub GetNextDateIndex(ByVal aTs As atcTimeseries, _ - ByVal aFilterNoData As Boolean, _ - ByRef aIndex As Integer, _ - ByRef aNextDate As Double) - aIndex += 1 - While aIndex <= aTs.numValues - If (Not aFilterNoData) OrElse (Not Double.IsNaN(aTs.Value(aIndex))) Then - If aTs.ValueAttributesGetValue(aIndex, "Inserted", False) Then - ' Found NaN inserted at edge of season split, always skip these, they are not a value and they are not Missing/NoData - aIndex += 1 - Else - aNextDate = aTs.Dates.Value(aIndex) - Exit While - End If - Else - aIndex += 1 - End If - End While - If aIndex > aTs.numValues Then - aNextDate = pNaN 'is this necessary? - aIndex = -1 'out of values - End If - End Sub - - Public Sub MergeAttributes(ByVal aGroup As atcTimeseriesGroup, ByVal aTarget As atcTimeseries) - For Each lAttribute As atcDefinedValue In aGroup(0).Attributes - If lAttribute.Definition.CopiesInherit Then - Dim lMatch As Boolean = True - For Each lData As atcDataSet In aGroup - Try 'Hard-coded SeasonDefinition to avoid exception (it can't use <>) - If lAttribute.Definition.Name = "SeasonDefinition" OrElse - lData.Attributes.GetValue(lAttribute.Definition.Name) <> lAttribute.Value Then - lMatch = False - Exit For 'Skip checking other datasets for this attribute, move on to next attribute - End If - Catch 'Can't test for equality, don't assign this one a value in aTarget - lMatch = False - Exit For - End Try - Next - If lMatch Then aTarget.Attributes.SetValue(lAttribute.Definition, lAttribute.Value, lAttribute.Arguments) - End If - Next - End Sub - - Public Function TimeseriesGroupFromArguments(ByVal aArgs As atcDataAttributes) As atcDataGroup - Dim ltsGroup As atcDataGroup = Nothing - If aArgs IsNot Nothing Then - ltsGroup = DatasetOrGroupToGroup(aArgs.GetValue("Timeseries")) - If ltsGroup Is Nothing OrElse ltsGroup.Count < 1 Then - ltsGroup = DatasetOrGroupToGroup(aArgs.GetValue("OneOrMoreTimeseries")) - End If - End If - Return ltsGroup - End Function - - Public Function DatasetOrGroupToGroup(ByVal aObject As Object) As atcDataGroup - If IsNothing(aObject) Then - Logger.Dbg("DatasetOrGroupToGroup = Nothing") - Return Nothing - Else - Select Case aObject.GetType.Name - Case "atcDataGroup", "atcTimeseriesGroup" : Return aObject - Case "atcTimeseries" : Return New atcTimeseriesGroup(CType(aObject, atcTimeseries)) - Case "atcDataSet" : Return New atcDataGroup(aObject) - Case Else - Logger.Dbg("DatasetOrGroupToGroup: Unrecognized type '" & aObject.GetType.Name & "'") - Return Nothing - End Select - End If - End Function - - ''' Fill values in constant interval timeseries with specified values. - ''' Timeseries to fill - ''' Time units (1-sec, 2-min, 3-hour, 4-day, 5-month, 6-year, 7-century) - ''' Timestep (number of units of aTU per time step) - ''' Value to Fill data gaps with. - ''' Value indicating missing data. - ''' Value indicating accumulated data. - ''' - ''' Filled timeseries - ''' - ''' Assumes dates are at the end of each value's interval and that the - ''' 0th position in the Dates array is the beginning of the first interval. - ''' - Public Function FillValues(ByVal aOldTSer As atcTimeseries, _ - ByVal aTU As atcTimeUnit, _ - Optional ByVal aTS As Long = 1, _ - Optional ByVal aFillVal As Double = 0, _ - Optional ByVal aMissVal As Double = -999, _ - Optional ByVal aAccumVal As Double = -999, _ - Optional ByVal aDataSource As atcTimeseriesSource = Nothing) As atcTimeseries - - If aOldTSer IsNot Nothing AndAlso aOldTSer.numValues > 0 Then - Dim lDate(5) As Integer - Dim lNewNumVals As Integer - Dim lNewInd As Integer - Dim lOldInd As Integer - Dim lDateOld As Double - Dim lValOld As Double - Dim lNewVals() As Double - Dim lNewDates() As Double = NewDates(aOldTSer, aTU, aTS) - - If lNewDates.GetUpperBound(0) > 0 Then 'dates for new timeseries set - lNewNumVals = lNewDates.GetUpperBound(0) - ReDim lNewVals(lNewNumVals) - lNewVals(0) = pNaN - lOldInd = 1 - lDateOld = aOldTSer.Dates.Value(lOldInd) - lNewInd = 1 - Dim lAnyValueAttributes As Boolean = aOldTSer.ValueAttributesExist - Dim lNewValueAttributes(lNewDates.GetUpperBound(0)) As atcDataAttributes - - While lNewInd <= lNewNumVals - While lNewInd <= lNewNumVals AndAlso lNewDates(lNewInd) < lDateOld - JulianMillisecond 'Fill values not present in original data - Select Case lValOld - Case aMissVal - If aOldTSer.Value(lOldInd) = aMissVal Then - lNewVals(lNewInd) = aMissVal - lNewValueAttributes(lNewInd) = New atcDataAttributes - lNewValueAttributes(lNewInd).SetValue("Missing", True) - Else - lNewVals(lNewInd) = aFillVal - lNewValueAttributes(lNewInd) = New atcDataAttributes - lNewValueAttributes(lNewInd).SetValue("Filled", True) - End If - Case aAccumVal - lNewVals(lNewInd) = aAccumVal - lNewValueAttributes(lNewInd) = New atcDataAttributes - lNewValueAttributes(lNewInd).SetValue("Accumulated", True) - Case Else - lNewVals(lNewInd) = aFillVal - lNewValueAttributes(lNewInd) = New atcDataAttributes - lNewValueAttributes(lNewInd).SetValue("Filled", True) - End Select - lNewInd += 1 - End While - If lNewInd <= lNewNumVals Then - lValOld = aOldTSer.Value(lOldInd) - lNewVals(lNewInd) = lValOld - If lAnyValueAttributes AndAlso aOldTSer.ValueAttributesExist(lOldInd) Then - lNewValueAttributes(lNewInd) = aOldTSer.ValueAttributes(lOldInd) - End If - lNewInd += 1 - lOldInd += 1 - If lOldInd <= aOldTSer.numValues Then - lDateOld = aOldTSer.Dates.Value(lOldInd) - End If - End If - End While - - Dim lNewTSer As New atcTimeseries(aDataSource) - CopyBaseAttributes(aOldTSer, lNewTSer) - lNewTSer.Dates = New atcTimeseries(Nothing) - lNewTSer.Dates.Values = lNewDates - lNewTSer.Values = lNewVals - For lNewInd = 1 To lNewValueAttributes.GetUpperBound(0) - If lNewValueAttributes(lNewInd) IsNot Nothing Then - lNewTSer.ValueAttributes(lNewInd) = lNewValueAttributes(lNewInd) - End If - Next - With lNewTSer.Attributes - '.SetValue("point", False) - .SetValue("tu", aTU) - .SetValue("ts", aTS) - .SetValue("TSFILL", aFillVal) - .SetValue("MVal", aMissVal) - .SetValue("MAcc", aAccumVal) - End With - - Return lNewTSer - Else - Logger.Dbg("Problem with dates in Timeseries " & aOldTSer.ToString & ".") - Return Nothing - End If - Else - If aOldTSer Is Nothing Then - Logger.Dbg("OldTSer is nothing.") - Else - Logger.Dbg("No data values in Timeseries " & aOldTSer.ToString & ".") - End If - - Return Nothing - End If - End Function - - ''' - ''' Fill missing periods in a timeseries using interpolation - ''' - ''' Timeseries containing missing values - ''' Max span, in Julian Days, over which interpolation is allowed - ''' Array returning length of each missing period filled - ''' Missing value indicator - ''' atcTimeseries clone of original timeseries along with interpolated values - ''' - Public Function FillMissingByInterpolation(ByVal aOldTSer As atcTimeseries, _ - Optional ByVal aMaxFillLength As Double = Double.NaN, _ - Optional ByVal aFillInstances As ArrayList = Nothing, _ - Optional ByVal aMissingValue As Double = Double.NaN) As atcTimeseries - Dim lNewTSer As atcTimeseries = aOldTSer.Clone - - Dim lInd As Integer = 1 - Dim lIndPrevNotMissing As Integer = 1 - Dim lIndNextNotMissing As Integer - Logger.Dbg("FillMissingByInterp: NumValues:" & lNewTSer.numValues & " MaxFillLength, days:" & aMaxFillLength) - While lInd <= lNewTSer.numValues - If Double.IsNaN(lNewTSer.Value(lInd)) OrElse Math.Abs(lNewTSer.Value(lInd) - aMissingValue) < 0.00001 Then 'look for next good value - lIndNextNotMissing = FindNextNotMissing(lNewTSer, lInd, aMissingValue) - Dim lMissingLength As Double - With lNewTSer.Dates 'find missing length - lMissingLength = .Value(lIndNextNotMissing) - .Value(lIndPrevNotMissing) - End With - 'Logger.Dbg("FillMissingByInterp:Missing:", lInd, lIndPrevNotMissing, lIndNextNotMissing, lMissingLength) - If Double.IsNaN(aMaxFillLength) OrElse lMissingLength < aMaxFillLength Then - If Not aFillInstances Is Nothing AndAlso lInd = lIndPrevNotMissing + 1 Then - '1st interval of a missing period, log/record it - Logger.Dbg("FillMissingByInterp: Starting " & DumpDate(lNewTSer.Dates.Value(lInd)) & ", interpolating over a span of " & lMissingLength & " days.") - aFillInstances.Add(lMissingLength) - End If - With lNewTSer - If Double.IsNaN(.Value(lIndPrevNotMissing)) Then 'missing at start, use first good value - .Value(lInd) = .Value(lIndNextNotMissing) - 'Logger.Dbg("FillMissingByInterp:UseFirstNotMissing:" & .Value(lInd)) - ElseIf Double.IsNaN(.Value(lIndNextNotMissing)) Then 'missing at end, use last good value - .Value(lInd) = .Value(lIndPrevNotMissing) - 'Logger.Dbg("FillMissingByInterp:UseLastNotMissing:" & .Value(lInd)) - Else 'values prev and next, interpolate - Dim lFracMissing As Double - With .Dates - lFracMissing = (.Value(lInd) - .Value(lIndPrevNotMissing)) / - (.Value(lIndNextNotMissing) - .Value(lIndPrevNotMissing)) - End With - Dim lIncValue As Double = lFracMissing * (.Value(lIndNextNotMissing) - .Value(lIndPrevNotMissing)) - .Value(lInd) = .Value(lIndPrevNotMissing) + lIncValue - 'Logger.Dbg("FillMissingByInterp:Interp:" & .Value(lInd) & ":" & lFracMissing & ":" & lIncValue) - End If - End With - End If - Else 'good value, remember index - lIndPrevNotMissing = lInd - End If - lInd += 1 - End While - Return lNewTSer - End Function - - Private Function FindNextNotMissing(ByVal aTser As atcTimeseries, ByVal aInd As Integer, Optional ByVal aMissingValue As Double = Double.NaN) As Integer - Dim lInd As Integer = aInd - While Double.IsNaN(aTser.Value(lInd)) OrElse Math.Abs(aTser.Value(lInd) - aMissingValue) < 0.00001 - lInd += 1 - If lInd >= aTser.numValues Then - Return aTser.numValues - End If - End While - Return lInd - End Function - - ''' Aggregate specified timeseries to interval specified - ''' Timeseries to aggregate - ''' Time units to aggregate to - ''' Time step to aggregate to (number of time units) - ''' Transformation to use in aggregation - ''' Data Source to assign to newly created subset timeseries, can be Nothing - ''' Aggregated timeseries - ''' - Public Function Aggregate(ByVal aTimeseries As atcTimeseries, _ - ByVal aTU As atcTimeUnit, _ - ByVal aTS As Integer, _ - ByVal aTran As atcTran, _ - Optional ByVal aDataSource As atcTimeseriesSource = Nothing) As atcTimeseries - If aTimeseries.Attributes.GetValue("tu") = aTU AndAlso _ - aTimeseries.Attributes.GetValue("ts") = aTS Then - ' Already have desired time unit and time step, clone so we consistently return a new TS - Return aTimeseries.Clone(aDataSource) - Else - Dim lNewDates() As Double = NewDates(aTimeseries, aTU, aTS) - Dim lNumNewVals As Integer = lNewDates.GetUpperBound(0) - If lNumNewVals > 0 Then - Dim lNaN As Double = GetNaN() - Dim lNewTSer As New atcTimeseries(aDataSource) - lNewTSer.Dates = New atcTimeseries(aDataSource) - CopyBaseAttributes(aTimeseries, lNewTSer) - lNewTSer.SetInterval(aTU, aTS) - lNewTSer.Attributes.SetValue("point", False) - If aTimeseries.ValueAttributesExist Then 'TODO:: Something with value attributes - End If - lNewTSer.Dates.Values = lNewDates - Dim lNewIndex As Integer = 1 - Dim lNewVals(lNumNewVals) As Double - Dim lDateNew As Double = lNewDates(1) - Dim lDateOld As Double - Dim lValOld As Double - Dim lOldIndex As Integer = 1 - Dim lPrevDateOld As Double = lNewDates(0) 'old and new TSers should have same start date - Dim lPrevDateNew As Double = lNewDates(0) - Dim lOverlapStart As Double - Dim lOverlapEnd As Double - Dim lNumOldVals As Integer = aTimeseries.numValues - Dim lFraction As Double 'Fraction of the new time step that is being filled by the current old value - Dim lCumuFrac As Double 'Cumulative Fraction of the current new time step that has been filled from aTimeseries - - If aTimeseries.numValues > 0 Then - lValOld = aTimeseries.Value(1) - lDateOld = aTimeseries.Dates.Value(1) - End If - - Select Case aTran - Case atcTran.TranAverSame, atcTran.TranSumDiv - While lNewIndex <= lNumNewVals - lDateNew = lNewDates(lNewIndex) - lNewVals(lNewIndex) = 0 - While lPrevDateOld < lDateNew And lOldIndex <= lNumOldVals - If lPrevDateOld > lPrevDateNew Then lOverlapStart = lPrevDateOld Else lOverlapStart = lPrevDateNew - If lDateNew > lDateOld Then lOverlapEnd = lDateOld Else lOverlapEnd = lDateNew - lFraction = (lOverlapEnd - lOverlapStart) / (lDateNew - lPrevDateNew) - lCumuFrac += lFraction - If aTran = atcTran.TranSumDiv Then - lFraction = (lOverlapEnd - lOverlapStart) / (lDateOld - lPrevDateOld) - End If - lNewVals(lNewIndex) += lFraction * lValOld - If lPrevDateOld < lDateNew Then - If lDateOld > lDateNew Then 'use remaining part of this old interval on next new interval - lPrevDateOld = lDateNew - If aTran = atcTran.TranSumDiv Then lValOld = lValOld - lValOld * lFraction - Else -NextOldVal: - lPrevDateOld = lDateOld - lOldIndex = lOldIndex + 1 - If lOldIndex <= lNumOldVals Then - lDateOld = aTimeseries.Dates.Value(lOldIndex) - lValOld = aTimeseries.Value(lOldIndex) - If Double.IsNaN(lValOld) AndAlso aTimeseries.ValueAttributesGetValue(lOldIndex, "Inserted", False) Then - lCumuFrac += (lDateOld - lPrevDateOld) / (lDateNew - lPrevDateNew) - GoTo NextOldVal - End If - End If - 'lCumuFrac = 0 - End If - End If - End While - lPrevDateNew = lDateNew - If aTran = atcTran.TranSumDiv AndAlso lCumuFrac > 0.01 AndAlso lCumuFrac < 0.999 Then - lNewVals(lNewIndex) = lNewVals(lNewIndex) / lCumuFrac - lCumuFrac = 0 - End If - lNewIndex = lNewIndex + 1 - End While - Case atcTran.TranMax - Dim lMinValue As Double = GetMinValue() - While lNewIndex <= lNumNewVals - lDateNew = lNewDates(lNewIndex) - lNewVals(lNewIndex) = lMinValue - While lDateOld <= lDateNew AndAlso lOldIndex <= lNumOldVals - If lValOld > lNewVals(lNewIndex) Then lNewVals(lNewIndex) = lValOld - lOldIndex = lOldIndex + 1 - If lOldIndex <= lNumOldVals Then - lDateOld = aTimeseries.Dates.Value(lOldIndex) - lValOld = aTimeseries.Value(lOldIndex) - End If - End While - If lNewVals(lNewIndex) = lMinValue Then - lNewVals(lNewIndex) = lNaN - End If - lNewIndex = lNewIndex + 1 - End While - - Case atcTran.TranMin - Dim lMaxValue As Double = GetMaxValue() - While lNewIndex <= lNumNewVals - lDateNew = lNewDates(lNewIndex) - lNewVals(lNewIndex) = lMaxValue - While lDateOld <= lDateNew AndAlso lOldIndex <= lNumOldVals - If lValOld < lNewVals(lNewIndex) Then lNewVals(lNewIndex) = lValOld - lOldIndex = lOldIndex + 1 - If lOldIndex <= lNumOldVals Then - lDateOld = aTimeseries.Dates.Value(lOldIndex) - lValOld = aTimeseries.Value(lOldIndex) - End If - End While - If lNewVals(lNewIndex) = lMaxValue Then - lNewVals(lNewIndex) = lNaN - End If - lNewIndex = lNewIndex + 1 - End While - Case atcTran.TranCountMissing - While lNewIndex <= lNumNewVals - lDateNew = lNewDates(lNewIndex) - lNewVals(lNewIndex) = 0 - While lDateOld <= lDateNew AndAlso lOldIndex <= lNumOldVals - If Double.IsNaN(lValOld) Then lNewVals(lNewIndex) += 1 - lOldIndex = lOldIndex + 1 - If lOldIndex <= lNumOldVals Then - lDateOld = aTimeseries.Dates.Value(lOldIndex) - lValOld = aTimeseries.Value(lOldIndex) - End If - End While - lNewIndex = lNewIndex + 1 - End While - End Select - lNewTSer.Values = lNewVals - Return lNewTSer - Else - Return Nothing - End If - End If - End Function - - ''' Aggregate specified timeseries to interval specified, using the specified attribute value for each time step - ''' Timeseries to aggregate - ''' Time units to aggregate to - ''' Time step to aggregate to (number of time units) - ''' Attribute to compute from values in aTimeseries within each new time step to use in new Timeseries - ''' Data Source to assign to newly created subset timeseries, can be Nothing - ''' Aggregated timeseries - Public Function AggregateByAttribute(ByVal aTimeseries As atcTimeseries, _ - ByVal aTU As atcTimeUnit, _ - ByVal aTS As Integer, _ - ByVal aAttributeName As String, _ - ByVal aDataSource As atcTimeseriesSource) As atcTimeseries - If aTimeseries.Attributes.GetValue("tu") = aTU AndAlso _ - aTimeseries.Attributes.GetValue("ts") = aTS Then - ' Already have desired time unit and time step, clone so we consistently return a new TS - Return aTimeseries.Clone(aDataSource) - Else - Dim lNewDates() As Double = NewDates(aTimeseries, aTU, aTS) - Dim lNumNewVals As Integer = lNewDates.GetUpperBound(0) - If lNumNewVals > 0 Then - Dim lNaN As Double = GetNaN() - Dim lNewTSer As New atcTimeseries(aDataSource) - lNewTSer.Dates = New atcTimeseries(aDataSource) - CopyBaseAttributes(aTimeseries, lNewTSer) - lNewTSer.SetInterval(aTU, aTS) - lNewTSer.Attributes.SetValue("point", False) - If aTimeseries.ValueAttributesExist Then 'TODO:: Something with value attributes - End If - lNewTSer.Dates.Values = lNewDates - Dim lNewIndex As Integer = 1 - Dim lNewVals(lNumNewVals) As Double - Dim lDateNew As Double = lNewDates(1) - Dim lDateOld As Double - Dim lValOld As Double - Dim lOldIndex As Integer = 1 - Dim lPrevDateOld As Double = lNewDates(0) 'old and new TSers should have same start date - Dim lPrevDateNew As Double = lNewDates(0) - Dim lNumOldVals As Integer = aTimeseries.numValues - - If aTimeseries.numValues > 0 Then - lValOld = aTimeseries.Value(1) - lDateOld = aTimeseries.Dates.Value(1) - End If - - While lNewIndex <= lNumNewVals - Dim lThisTimeStepTs As atcTimeseries = SubsetByDate(aTimeseries, lNewDates(lNewIndex - 1), lNewDates(lNewIndex), Nothing) - lDateNew = lNewDates(lNewIndex) - lNewVals(lNewIndex) = lThisTimeStepTs.Attributes.GetValue(aAttributeName, lNaN) - lNewIndex = lNewIndex + 1 - End While - lNewTSer.Values = lNewVals - Return lNewTSer - Else - Return Nothing - End If - End If - End Function - - 'Build Date array for a timeseries with start/end of aTSer and time units/step of aTU/aTS - Public Function NewDates(ByVal aTSer As atcTimeseries, ByVal aTU As atcTimeUnit, ByVal aTS As Integer) As Double() - Dim lSJDay As Double - Dim lEJDay As Double - If aTU >= atcTimeUnit.TUSecond AndAlso aTU <= atcTimeUnit.TUCentury Then - 'get start date/time for existing TSer - aTSer.EnsureValuesRead() - Dim lDate(5) As Integer - If aTSer.Dates.Value(0) <= 0 OrElse Double.IsNaN(aTSer.Dates.Value(0)) Then - If aTSer.Attributes.ContainsAttribute("tu") Then - J2Date(TimAddJ(aTSer.Dates.Value(1), aTSer.Attributes.GetValue("tu"), aTSer.Attributes.GetValue("ts", 1), -1), lDate) - ElseIf aTSer.numValues > 1 Then - J2Date(aTSer.Dates.Value(1) - (aTSer.Dates.Value(2) - aTSer.Dates.Value(1)), lDate) - End If - Else - J2Date(aTSer.Dates.Value(0), lDate) - End If - Dim lSDate(5) As Integer - Select Case aTU - Case atcTimeUnit.TUSecond - Case atcTimeUnit.TUMinute - lDate(5) = 0 'clear seconds - Case atcTimeUnit.TUHour - lDate(4) = 0 'clear minutes - lDate(5) = 0 'clear seconds - Case atcTimeUnit.TUDay - lDate(3) = 0 'clear hours - lDate(4) = 0 'clear minutes - lDate(5) = 0 'clear seconds - Case atcTimeUnit.TUMonth - lDate(2) = 1 'set to beginning of month - lDate(3) = 0 'clear hours - lDate(4) = 0 'clear minutes - lDate(5) = 0 'clear seconds - Case atcTimeUnit.TUYear - 'Skip setting month and day to allow drought/flood years to be preserved - 'lDate(1) = 1 'set to beginning of Jan - 'lDate(2) = 1 'set to beginning of month - lDate(3) = 0 'clear hours - lDate(4) = 0 'clear minutes - lDate(5) = 0 'clear seconds - Case atcTimeUnit.TUCentury - lDate(0) = Math.Floor(lDate(0) / 100) * 100 - lDate(1) = 1 'set to beginning of Jan - lDate(2) = 1 'set to beginning of month - lDate(3) = 0 'clear hours - lDate(4) = 0 'clear minutes - lDate(5) = 0 'clear seconds - End Select - lSJDay = Date2J(lDate) - For lEndIndex As Integer = aTSer.numValues To 0 Step -1 - If Not Double.IsNaN(aTSer.Value(lEndIndex)) Then - lEJDay = aTSer.Dates.Value(lEndIndex) - Exit For - End If - Next - End If - Return NewDates(lSJDay, lEJDay, aTU, aTS) - End Function - - ''' - ''' Build a constant-interval date array - ''' - ''' Beginning of the first interval - ''' End of the last interval - ''' Time Units - ''' Time Step (number of Time Units per step) - Public Function NewDates(ByVal aStartDate As Double, ByVal aEndDate As Double, ByVal aTU As atcTimeUnit, ByVal aTS As Integer) As Double() - Dim lNewDates(0) As Double - If aTU >= atcTimeUnit.TUSecond AndAlso aTU <= atcTimeUnit.TUCentury Then - Dim lNewNumDates As Integer = timdifJ(aStartDate, aEndDate, aTU, aTS) - ReDim lNewDates(lNewNumDates) - lNewDates(0) = aStartDate - For i As Integer = 1 To lNewNumDates - lNewDates(i) = TimAddJ(aStartDate, aTU, aTS, i) - Next - End If - Return lNewDates - End Function - - Public Function NewTimeseries(ByVal aStartDate As Double, ByVal aEndDate As Double, _ - ByVal aTU As atcTimeUnit, ByVal aTS As Integer, _ - Optional ByVal aDataSource As atcTimeseriesSource = Nothing, _ - Optional ByVal aSetAllValues As Double = 0) As atcTimeseries - Dim lDates As New atcTimeseries(aDataSource) - lDates.Values = NewDates(aStartDate, aEndDate, aTU, aTS) - Dim lNewTimeseries As New atcTimeseries(aDataSource) - lNewTimeseries.Dates = lDates - lNewTimeseries.numValues = lNewTimeseries.Dates.numValues - lNewTimeseries.Value(0) = GetNaN() - Try - If Double.IsNaN(aSetAllValues) OrElse aSetAllValues <> 0 Then - For lIndex As Integer = 1 To lNewTimeseries.numValues - lNewTimeseries.Value(lIndex) = aSetAllValues - Next - End If - Catch 'For some reason, the above If sometimes triggers an exception when aSetAllValuesis NaN, same loop as above - For lIndex As Integer = 1 To lNewTimeseries.numValues - lNewTimeseries.Value(lIndex) = aSetAllValues - Next - End Try - lNewTimeseries.SetInterval(aTU, aTS) - Return lNewTimeseries - End Function - - - ''Make bins, sort data values into the bins, and assign collection of Bins as new attribute - 'Public Sub MakeBins(ByVal aTS As atcTimeseries, Optional ByVal aMaxBinSize As Integer = 100) - ' Dim lNumValues As Integer = aTS.numValues - ' Dim lCurValue As Double - ' Dim lBinIndex As Integer - ' Dim lCurBin As New ArrayList - ' Dim lBins As New atcCollection - ' lBins.Add(aTS.Attributes.GetValue("Max"), lCurBin) - - ' Logger.Dbg("Sorting " & lNumValues & " values into bins of at most " & aMaxBinSize) - ' For lOldIndex As Integer = 1 To lNumValues - ' lCurValue = aTS.Value(lOldIndex) - - ' 'find first bin with maximum >= lCurValue - ' lBinIndex = 0 - ' While lCurValue > lBins.Keys(lBinIndex) - ' lBinIndex += 1 - ' End While - ' lCurBin = lBins.Item(lBinIndex) - - ' 'Insert in numeric order within bin - ' Dim lInsertIndex As Integer = 0 - ' Dim lLastIndex As Integer = lCurBin.Count - 1 - ' If lLastIndex > -1 Then 'Find position to insert - ' While lCurValue > lCurBin.Item(lInsertIndex) - ' lInsertIndex += 1 - ' If lInsertIndex > lLastIndex Then Exit While - ' End While - ' End If - ' lCurBin.Insert(lInsertIndex, lCurValue) - - ' If lCurBin.Count > aMaxBinSize Then - ' SplitBin(lBins, lCurBin, lBinIndex) - ' End If - - ' Next - ' Logger.Dbg("Created " & lBins.Count & " bins") - ' For lBinIndex = 0 To lBins.Count - 1 - ' lCurBin = lBins.Item(lBinIndex) - ' Logger.Dbg("Bin " & lBinIndex & " (" & lBins.Keys(lBinIndex) & ") contains " & lCurBin.Count) - ' For Each lCurValue In lCurBin - ' Logger.Dbg(DoubleToString(lCurValue)) - ' Next - ' lNumValues -= lCurBin.Count - ' Next - ' If lNumValues <> 0 Then - ' Logger.Dbg("Wrong number of values in bins -- " & lNumValues & " were in dataset but not in bins") - ' End If - ' aTS.Attributes.SetValue("Bins", lBins) - 'End Sub - - 'Make bins, sort data values into the bins - 'Default maximum bin size is 1% of total number of values - Public Function MakeBins(ByVal aTS As atcTimeseries, Optional ByVal aMaxBinSize As Integer = 0) As atcCollection - Dim lNumValues As Integer = aTS.numValues - Dim lCurValue As Double - Dim lCurBinMax As Double = aTS.Attributes.GetValue("Max") - Dim lBinIndex As Integer = 0 - Dim lCurBin As New ArrayList - Dim lBins As New atcCollection 'Keys of lBins are the maximum value in each bin - lBins.Add(lCurBinMax, lCurBin) 'First bin created is assigned maximum value for dataset - 'Bins created later are inserted before this bin, which remains the "last" bin containing the highest values - If aMaxBinSize < 1 Then - aMaxBinSize = lNumValues / 100 'Default to max of 1% of values in each bin - If aMaxBinSize < 10 Then aMaxBinSize = 10 - End If - 'Logger.Progress("Sorting values from " & aTS.ToString & " into bins. ", 0, lNumValues) - For lOldIndex As Integer = 1 To lNumValues - lCurValue = aTS.Value(lOldIndex) - If Not Double.IsNaN(lCurValue) Then - 'If the previously used bin does not fit, find first bin with maximum >= lCurValue - 'If lCurValue > lCurBinMax OrElse (lBinIndex > 0 AndAlso lCurValue < lBins.Keys.Item(lBinIndex - 1)) Then - lBinIndex = BinarySearchFirstGreaterDoubleArrayList(lBins.Keys, lCurValue) - lCurBin = lBins.Item(lBinIndex) - 'lCurBinMax = lBins.Keys.Item(lBinIndex) - 'End If - - 'Insert in numeric order within bin - Dim lInsertIndex As Integer = BinarySearchFirstGreaterDoubleArrayList(lCurBin, lCurValue) - lCurBin.Insert(lInsertIndex, lCurValue) - - If lCurBin.Count > aMaxBinSize Then - SplitBin(lBins, lCurBin, lBinIndex) - ' lCurBin = lBins.Item(lBinIndex) - ' lCurBinMax = lBins.Keys.Item(lBinIndex) - 'Logger.Progress("Sorting values into " & lBins.Count & " bins", lOldIndex, lNumValues) - End If - End If - Next - Logger.Dbg("Sorted values into " & lBins.Count & " bins", lNumValues, lNumValues) - 'For lBinIndex = 0 To lBins.Count - 1 - ' lCurBin = lBins.Item(lBinIndex) - ' Logger.Dbg("Bin " & lBinIndex & " (" & lBins.Keys(lBinIndex) & ") contains " & lCurBin.Count) - ' For Each lCurValue In lCurBin - ' Logger.Dbg(DoubleToString(lCurValue)) - ' Next - ' lNumValues -= lCurBin.Count - 'Next - 'If lNumValues <> 0 Then - ' Logger.Dbg("Wrong number of values in bins -- " & lNumValues & " were in dataset but not in bins") - 'End If - Return lBins - End Function - - 'aBins = collection of bins - 'aBin = bin to be split in half - 'aBinIndex = current index of aBin in aBins - Private Sub SplitBin(ByVal aBins As atcCollection, ByVal aBin As ArrayList, ByVal aBinIndex As Integer) - Dim lSplitStart As Integer = 0 - Dim lSplitCount As Integer = aBin.Count / 2 - Dim lNewBin As New ArrayList(aBin.GetRange(lSplitStart, lSplitCount)) - aBin.RemoveRange(lSplitStart, lSplitCount) - aBins.Insert(aBinIndex, lNewBin.Item(lSplitCount - 1), lNewBin) - End Sub - - Public Function GetPercentileOf(ByVal aTser As atcTimeseries, ByVal aValue As Double) As Double - Dim lPercentile As Double = pNaN - If aTser IsNot Nothing AndAlso Not Double.IsNaN(aValue) Then - Dim ValueIndex As Integer = 0 - Dim lBins As atcCollection = aTser.Attributes.GetValue("Bins", Nothing) - If lBins IsNot Nothing Then - For Each lBin As ArrayList In lBins - If aValue < lBin(0) Then Exit For - If aValue > lBin(lBin.Count - 1) Then - ValueIndex += lBin.Count - 1 - Else - Dim lBinValueIndex As Integer = BinarySearchFirstGreaterDoubleArrayList(lBin, aValue) - ValueIndex += lBinValueIndex - End If - Next - lPercentile = ValueIndex * 100.0 / aTser.numValues - End If - End If - Return lPercentile - End Function - - ''' - ''' Binary search through an ArrayList containing Double values sorted in ascending order - ''' - ''' Array to search - ''' Value to search for - ''' Return the index of the first value >= aValue - ''' Returns aArray.Count if aArray contains no values >= aValue - Private Function BinarySearchFirstGreaterDoubleArrayList(ByVal aArray As ArrayList, ByVal aValue As Double) As Integer - Dim lHigher As Integer = aArray.Count - 1 - If lHigher < 0 Then Return 0 'No values present to compare to - Dim lLower As Integer = -1 'Note: this starts one *lower than* start of where to search in array - Dim lProbe As Integer - While (lHigher - lLower > 1) - lProbe = (lHigher + lLower) / 2 - If aArray(lProbe) < aValue Then - lLower = lProbe - Else - lHigher = lProbe - End If - End While - If aValue > aArray(lHigher) Then - Return lHigher + 1 - Else - Return lHigher - End If - End Function - - ''' - ''' Assign integers from one to the number of non-missing values to the Rank value attributes - ''' - ''' Values to compute ranks of - ''' If True, lowest value gets rank of 1, if False, highest value gets rank of 1 - ''' - ''' If True, identical values get the same rank and next rank is not assigned, ex: (5, 5, 9, 7) get ranks (1, 1, 4, 3) - ''' If False and aLowToHigh is False, earlier value gets lower rank (5, 5, 9, 7) get ranks (1, 2, 4, 3) - ''' If False and aLowToHigh is True, later value gets lower rank (5, 5, 9, 7) get ranks (2, 1, 4, 3) - ''' - ''' - Public Sub ComputeRanks(ByVal aTimeseries As atcTimeseries, _ - ByVal aLowToHigh As Boolean, _ - ByVal aAllowTies As Boolean) - Dim lNaN As Double = GetNaN() - Dim lValue As Double - Dim lValuesSorted As New Generic.List(Of Double) - Dim lFirstValue As Boolean = True - For Each lValue In aTimeseries.Values - If lFirstValue Then - lFirstValue = False - ElseIf Not Double.IsNaN(lValue) Then - lValuesSorted.Add(lValue) - End If - Next - lValuesSorted.Sort() - Dim lRank As Integer - Dim lLastIndex As Integer = aTimeseries.numValues - For lIndex As Integer = 1 To lLastIndex - lValue = aTimeseries.Value(lIndex) - If Not Double.IsNaN(lValue) Then - If aLowToHigh Then - ' 1 = lowest value - For lRank = 1 To lValuesSorted.Count - If lValuesSorted(lRank - 1) >= lValue Then - If Not aAllowTies Then - lValuesSorted(lRank - 1) = lNaN - End If - aTimeseries.ValueAttributes(lIndex).SetValue("Rank", lRank) - Exit For - End If - Next - Else 'High to Low, 1 = highest value - If aAllowTies Then - For lRank = 1 To lValuesSorted.Count - If lValuesSorted(lValuesSorted.Count - lRank) <= lValue Then - aTimeseries.ValueAttributes(lIndex).SetValue("Rank", lRank) - Exit For - End If - Next - Else 'Give earlier value higher rank in a tie by stepping backward through ranks - For lRank = lValuesSorted.Count To 1 Step -1 - If lValuesSorted(lValuesSorted.Count - lRank) >= lValue Then - lValuesSorted(lValuesSorted.Count - lRank) = lNaN - aTimeseries.ValueAttributes(lIndex).SetValue("Rank", lRank) - Exit For - End If - Next - End If - End If - End If - Next - End Sub - - ''' Compute sum value at specified percentile of specified timeseries - ''' Timeseries to analyze. - ''' Percentile to compute. - ''' Computed percentile stored in attribute within timeseries with attribute name built from percentile value prefixed with '%Sum' - Public Sub ComputePercentileSum(ByVal aTimeseries As atcTimeseries, ByVal aPercentile As Double) - Dim lAttrName As String = "%sum" & Format(aPercentile, "00.####") - Dim lNumValues As Integer = aTimeseries.numValues - Select Case lNumValues - Case Is < 1 - 'Can't compute with no values - Case 1 - aTimeseries.Attributes.SetValue(lAttrName, aTimeseries.Value(0)) - Case Else - Dim lBins As atcCollection = aTimeseries.Attributes.GetValue("Bins") - Dim lCountPercentileDone As Integer = aPercentile * lNumValues / 100.0 - 1 - If lCountPercentileDone < 0 Then lCountPercentileDone = 0 - If lCountPercentileDone >= lNumValues Then lCountPercentileDone = lNumValues - 1 - - Dim lSum As Double = 0 - Dim lCount As Integer = 0 - For Each lBin As ArrayList In lBins - For Each lValue As Double In lBin - If lCount >= lCountPercentileDone Then GoTo Finished - lCount += 1 - lSum += lValue - Next - Next -Finished: - aTimeseries.Attributes.SetValue(lAttrName, lSum) - End Select - End Sub - - ''' Compute value at specified percentile of specified timeseries - ''' Timeseries to analyze. - ''' Percentile to compute. - ''' The value from aTimeseries closest to the specified percentile position - ''' Computed percentile stored in attribute within timeseries with attribute name built from percentile value prefixed with '%' - Public Function ComputePercentile(ByVal aTimeseries As atcTimeseries, ByVal aPercentile As Double) As Double - Dim lAttrName As String = "%" & Format(aPercentile, "00.####") - Dim lNumValues As Integer = aTimeseries.numValues - aTimeseries.Attributes.GetValue("Count Missing") - Dim lReturnValue As Double - Select Case lNumValues - Case Is < 1 - 'Can't compute with no values - lReturnValue = GetNaN() - Case 1 - lReturnValue = aTimeseries.Value(0) - aTimeseries.Attributes.SetValue(lAttrName, lReturnValue) - Case Else - Dim lBins As atcCollection = aTimeseries.Attributes.GetValue("Bins") - 'TODO: could interpolate between closest two values rather than choosing closest one, should we? - Dim lAccumulatedCount As Integer = 0 - Dim lNextAccumulatedCount As Integer = 0 - Dim lBinIndex As Integer = -1 - Dim lPercentileIndex As Integer = aPercentile * lNumValues / 100.0 - 1 - If lPercentileIndex < 0 Then lPercentileIndex = 0 - If lPercentileIndex >= lNumValues Then lPercentileIndex = lNumValues - 1 - While lNextAccumulatedCount <= lPercentileIndex - lAccumulatedCount = lNextAccumulatedCount - lBinIndex += 1 - lNextAccumulatedCount = lAccumulatedCount + lBins(lBinIndex).Count - End While - Dim lBin As ArrayList = lBins(lBinIndex) - lReturnValue = lBin.Item(lPercentileIndex - lAccumulatedCount) - aTimeseries.Attributes.SetValue(lAttrName, lReturnValue) - End Select - Return lReturnValue - End Function - - ''' - ''' Fit a line through a set of data points using least squares regression. - ''' - ''' - ''' - ''' 'a' coefficient in regression line (y=ax+b) - ''' 'b' coefficient in regression line (y=ax+b) - ''' 'r squared', the coefficient of determination - ''' from fortran-newaqt-FITLIN; x, y values can't be the same values - Public Sub FitLine(ByVal aTSerX As atcTimeseries, ByVal aTSerY As atcTimeseries, _ - ByRef aACoef As Double, ByRef aBCoef As Double, ByRef aRSquare As Double, ByRef aNote As String) - aNote = "" - If aTSerX.numValues <> aTSerY.numValues Then - aNote &= aTSerX.ToString & " has " & aTSerX.numValues & " values, " & _ - aTSerY.ToString & " has " & aTSerY.numValues & "." & vbCrLf - End If - If Math.Abs(aTSerX.Dates.Value(0) - aTSerY.Dates.Value(0)) > JulianSecond Then - aNote &= aTSerX.ToString & " starts on " & aTSerX.Dates.Value(0).ToString & ", " & - aTSerY.ToString & " starts on " & aTSerY.Dates.Value(0).ToString & "." & vbCrLf - End If - If aNote.Length > 0 Then - Throw New ApplicationException("Time series are not compatible." & vbCrLf & aNote) - End If - - Dim lSumX As Double = 0.0 - Dim lValX As Double - Dim lAvgX As Double - - Dim lSumY As Double = 0.0 - Dim lValY As Double - Dim lAvgY As Double - Dim lSkipCount As Integer = 0 - Dim lGoodCount As Integer = 0 - - For lIndex As Integer = 1 To aTSerX.numValues - lValX = aTSerX.Value(lIndex) - lValY = aTSerY.Value(lIndex) - If Not Double.IsNaN(lValX) AndAlso Not Double.IsNaN(lValY) Then - lSumX += lValX - lSumY += lValY - lGoodCount += 1 - Else - lSkipCount += 1 - If lSkipCount = 1 Then - aNote = "Skipped missing index " & lIndex - End If - End If - Next - If aNote.Length > 0 AndAlso lSkipCount > 1 Then - aNote &= " and " & lSkipCount - 1 & " more" & vbCrLf - End If - - If (lGoodCount > 0) Then 'go ahead and compute lSumX > 0.0 AndAlso lSumY > 0.0 AndAlso - Try 'Added Try Catch for linear regression for cases when timeseries has only 0 values. - lAvgX = lSumX / lGoodCount - lAvgY = lSumY / lGoodCount - - Dim lSum3 As Double = 0.0 - Dim lSum4 As Double = 0.0 - For lIndex As Integer = 1 To aTSerX.numValues - lValX = aTSerX.Value(lIndex) - lValY = aTSerY.Value(lIndex) - If Not Double.IsNaN(lValX) AndAlso Not Double.IsNaN(lValY) Then - lSum3 += (lValX - lAvgX) * (lValY - lAvgY) - lSum4 += (lValY - lAvgY) * (lValY - lAvgY) - End If - Next lIndex - aACoef = lSum3 / lSum4 - aBCoef = lAvgX - (aACoef * lAvgY) - - Dim lSum5 As Double = 0 - Dim lSum6 As Double = 0 - For lIndex As Integer = 1 To aTSerX.numValues - lValX = aTSerX.Value(lIndex) - lValY = aTSerY.Value(lIndex) - If Not Double.IsNaN(lValX) AndAlso Not Double.IsNaN(lValY) Then - lSum5 += ((aACoef * lValY + aBCoef - lAvgX) * (aACoef * lValY) + aBCoef - lAvgX) - lSum6 += (lValX - lAvgX) * (lValX - lAvgX) - End If - Next lIndex - aRSquare = lSum5 / lSum6 - aRSquare = ComputeR(aTSerX, aTSerY) ^ 2 - Catch ex As Exception 'Should I add a statement saying that linear regression could not be calculated? - aACoef = GetNaN() - aBCoef = GetNaN() - aRSquare = GetNaN() - End Try - - Else 'regression doesnt make sense, return NaN - aACoef = GetNaN() - aBCoef = GetNaN() - aRSquare = GetNaN() - End If - If aNote.Length > 0 Then - Logger.Dbg("Note:" & aNote) - End If - End Sub - - Public Function ComputeR(ByVal aTSerX As atcTimeseries, ByVal aTSerY As atcTimeseries) As Double - - Dim lNote As String = "" - If aTSerX.numValues <> aTSerY.numValues Then - lNote &= aTSerX.ToString & " has " & aTSerX.numValues & " values, " & _ - aTSerY.ToString & " has " & aTSerY.numValues & "." & vbCrLf - End If - If Math.Abs(aTSerX.Dates.Value(0) - aTSerY.Dates.Value(0)) > JulianSecond Then - lNote &= aTSerX.ToString & " starts on " & aTSerX.Dates.Value(0).ToString & ", " & - aTSerY.ToString & " starts on " & aTSerY.Dates.Value(0).ToString & "." & vbCrLf - End If - If lNote.Length > 0 Then - Throw New ApplicationException("Time series are not compatible." & vbCrLf & lNote) - End If - - Dim x As Double - Dim y As Double - Dim lSkipCount As Integer = 0 - Dim lGoodCount As Integer = 0 - - Dim sumOfX As Double = 0 - Dim sumOfY As Double = 0 - Dim sumOfXSq As Double = 0 - Dim sumOfYSq As Double = 0 - Dim ssX As Double = 0 - Dim ssY As Double = 0 - Dim sumCodeviates As Double = 0 - Dim sCo As Double = 0 - - For lIndex As Integer = 1 To aTSerX.numValues - x = aTSerX.Value(lIndex) - y = aTSerY.Value(lIndex) - If Not Double.IsNaN(x) AndAlso Not Double.IsNaN(y) Then - sumCodeviates += (x * y) - sumOfX += x - sumOfY += y - sumOfXSq += (x * x) - sumOfYSq += (y * y) - lGoodCount += 1 - Else - lSkipCount += 1 - End If - Next - - If (sumOfX > 0.0 AndAlso sumOfY > 0.0 AndAlso lGoodCount > 0) Then 'go ahead and compute - - ssX = sumOfXSq - ((sumOfX * sumOfX) / lGoodCount) - ssY = sumOfYSq - ((sumOfY * sumOfY) / lGoodCount) - Dim RNumerator As Double = (lGoodCount * sumCodeviates) - (sumOfX * sumOfY) - - Dim RDenom As Double = (lGoodCount * sumOfXSq - sumOfX ^ 2) * (lGoodCount * sumOfYSq - sumOfY ^ 2) - Dim dblR As Double = RNumerator / Math.Sqrt(RDenom) - Return dblR - 'sCo = sumCodeviates - ((sumOfX * sumOfY) / lGoodCount) - 'Dim dblSlope As Double = sCo / ssX - 'Dim meanX As Double = sumOfX / lGoodCount - 'Dim meanY As Double = sumOfY / lGoodCount - 'Dim dblYintercept As Double = meanY - (dblSlope * meanX) - - 'Console.WriteLine( “R-Squared: {0}”, Math.Pow( dblR, 2 ) ) ; - 'Console.WriteLine( “Y-Intercept: {0}”, dblYIntercept ) ; - 'Console.WriteLine( “Slope: {0}”, dblSlope ) ; - 'Console.ReadLine() ; - - 'aACoef = dblSlope - 'aBCoef = dblYintercept - 'aRSquare = dblR ^ 2 - - Else 'regression doesnt make sense, return NaN - Return GetNaN() - 'aACoef = GetNaN() - 'aBCoef = GetNaN() - 'aRSquare = GetNaN() - End If - - End Function - - ''' Perform a math operation on one or more timeseries - ''' Math operation - ''' Arguments needed by math operation - ''' Timeseries containing result of math operation - ''' Args are each usually either Double or atcTimeseries - Public Function DoMath(ByVal aOperationName As String, _ - ByVal aArgs As atcDataAttributes) As atcTimeseries - Dim lArgCount As Integer = 0 - - Dim lNumber As Double = GetNaN() - Dim lHaveNumber As Boolean = False - Dim lNumberFirst As Boolean = False - If aArgs.ContainsAttribute("Number") AndAlso Not aArgs.GetValue("Number") Is Nothing Then - Dim lValue As Double = aArgs.GetValue("Number", pNaN) - If Not Double.IsNaN(lValue) Then - lHaveNumber = True - lArgCount += 1 - lNumber = lValue - lNumberFirst = aArgs.ItemByIndex(0).Definition.Name.ToLower = "number" - End If - End If - - Dim lTSgroup As atcTimeseriesGroup = TimeseriesGroupFromArguments(aArgs) - If lTSgroup Is Nothing OrElse lTSgroup.Count < 1 Then - Throw New ApplicationException(aOperationName & " did not get a Timeseries argument") - End If - - Dim lTSFirst As atcTimeseries = lTSgroup.Item(0) - Dim lTSOriginal As atcTimeseries = Nothing - If lTSgroup.Count > 1 Then - lTSOriginal = lTSgroup.Item(1) 'default the current ts to the one after the first - End If - - For Each lTs As atcTimeseries In lTSgroup - lTs.EnsureValuesRead() - Next - - Dim lValueIndex As Integer - Dim lValueIndexLast As Integer = lTSFirst.numValues - If lValueIndexLast < 1 Then - Throw New ApplicationException("Cannot compute " & aOperationName & " of empty dataset") - End If - Dim lNewVals() As Double ' If this gets populated, it will be turned into an atcTimeseries at the end - ReDim lNewVals(lValueIndexLast) - Array.Copy(lTSFirst.Values, lNewVals, lValueIndexLast + 1) 'copy values from firstTS - lArgCount += lTSgroup.Count - - 'TODO: check here for number of arguments instead of in each case? - - Dim lTSIndex As Integer - Select Case aOperationName.ToLower - Case "add", "+" - For lValueIndex = 0 To lValueIndexLast - If lHaveNumber Then lNewVals(lValueIndex) += lNumber - For lTSIndex = 1 To lTSgroup.Count - 1 - lTSOriginal = lTSgroup.Item(lTSIndex) - lNewVals(lValueIndex) += lTSOriginal.Value(lValueIndex) - Next - Next - - Case "subtract", "-" - For lValueIndex = 0 To lValueIndexLast - If lHaveNumber Then - If lNumberFirst Then - lNewVals(lValueIndex) = lNumber - lNewVals(lValueIndex) - Else - lNewVals(lValueIndex) -= lNumber - End If - End If - For lTSIndex = 1 To lTSgroup.Count - 1 - lTSOriginal = lTSgroup.Item(lTSIndex) - lNewVals(lValueIndex) -= lTSOriginal.Value(lValueIndex) - Next - Next - - Case "multiply", "*" - For lValueIndex = 0 To lValueIndexLast - If lHaveNumber Then lNewVals(lValueIndex) *= lNumber - For lTSIndex = 1 To lTSgroup.Count - 1 - lTSOriginal = lTSgroup.Item(lTSIndex) - lNewVals(lValueIndex) *= lTSOriginal.Value(lValueIndex) - Next - Next - - Case "divide", "/" - If lHaveNumber AndAlso Math.Abs(lNumber) < 0.000001 Then - Throw New ApplicationException(aOperationName & " divisor too close to zero (" & lNumber & ")") - End If - For lValueIndex = 0 To lValueIndexLast - If lHaveNumber Then - If lNumberFirst Then - lNewVals(lValueIndex) = lNumber / lNewVals(lValueIndex) - Else - lNewVals(lValueIndex) /= lNumber - End If - End If - For lTSIndex = 1 To lTSgroup.Count - 1 - lTSOriginal = lTSgroup.Item(lTSIndex) - lNewVals(lValueIndex) /= lTSOriginal.Value(lValueIndex) - Next - Next - - Case "mean" - For lValueIndex = 0 To lValueIndexLast - If lHaveNumber Then lNewVals(lValueIndex) += lNumber - For lTSIndex = 1 To lTSgroup.Count - 1 - lTSOriginal = lTSgroup.Item(lTSIndex) - lNewVals(lValueIndex) += lTSOriginal.Value(lValueIndex) - Next - lNewVals(lValueIndex) /= lArgCount - Next - - Case "geometric mean" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = Math.Log10(lNewVals(lValueIndex)) - If lHaveNumber Then lNewVals(lValueIndex) += Math.Log10(lNumber) - For lTSIndex = 1 To lTSgroup.Count - 1 - lTSOriginal = lTSgroup.Item(lTSIndex) - lNewVals(lValueIndex) += Math.Log10(lTSOriginal.Value(lValueIndex)) - Next - lNewVals(lValueIndex) = 10 ^ (lNewVals(lValueIndex) / lArgCount) - Next - - Case "min each date" - For lValueIndex = 0 To lValueIndexLast - If lHaveNumber Then - If lNumber < lNewVals(lValueIndex) Then lNewVals(lValueIndex) = lNumber - End If - For lTSIndex = 1 To lTSgroup.Count - 1 - lTSOriginal = lTSgroup.Item(lTSIndex) - If lTSOriginal.Value(lValueIndex) < lNewVals(lValueIndex) Then - lNewVals(lValueIndex) = lTSOriginal.Value(lValueIndex) - End If - Next - Next - - Case "max each date" - For lValueIndex = 0 To lValueIndexLast - If lHaveNumber Then - If lNumber > lNewVals(lValueIndex) Then lNewVals(lValueIndex) = lNumber - End If - For lTSIndex = 1 To lTSgroup.Count - 1 - lTSOriginal = lTSgroup.Item(lTSIndex) - If lTSOriginal.Value(lValueIndex) > lNewVals(lValueIndex) Then - lNewVals(lValueIndex) = lTSOriginal.Value(lValueIndex) - End If - Next - Next - - Case "exponent", "exp", "^", "**" - If lArgCount <> 2 Then - Err.Raise(vbObjectError + 512, , aOperationName & " required two arguments but got " & lArgCount) - ElseIf lHaveNumber Then - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) ^= lNumber - Next - Else - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) ^= lTSOriginal.Value(lValueIndex) - Next - End If - - Case "e**", "e ^ x" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = Math.Exp(lNewVals(lValueIndex)) - Next - - Case "10**", "10 ^ x" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = 10 ^ (lNewVals(lValueIndex)) - Next - - Case "log 10" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = Math.Log10(lNewVals(lValueIndex)) - Next - - Case "log e" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = Math.Log(lNewVals(lValueIndex)) - Next - - 'Case "line" - ' For valNum = 1 To NVALS - ' argNum = 1 - ' GoSub SetCurArgVal - ' dataval(valNum) = curArgVal - ' argNum = 2 - ' GoSub SetCurArgVal - ' dataval(valNum) = dataval(valNum) * curArgVal - ' argNum = 3 - ' GoSub SetCurArgVal - ' dataval(valNum) = dataval(valNum) + curArgVal - ' Next - - Case "sqrt" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = Math.Sqrt(lNewVals(lValueIndex)) - Next - - Case "abs", "absolute value" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = Math.Abs(lNewVals(lValueIndex)) - Next - - Case "ctof", "celsiustofahrenheit", "celsius to fahrenheit", "celsius to f" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = lNewVals(lValueIndex) * 9 / 5 + 32 - Next - - Case "ftoc", "fahrenheittocelsius", "fahrenheit to celsius", "f to celsius" - For lValueIndex = 0 To lValueIndexLast - lNewVals(lValueIndex) = (lNewVals(lValueIndex) - 32) * 5 / 9 - Next - - Case "subset by date" - If aArgs.ContainsAttribute("Start Date") AndAlso _ - aArgs.GetValue("Start Date") IsNot Nothing AndAlso _ - aArgs.ContainsAttribute("End Date") AndAlso _ - aArgs.GetValue("End Date") IsNot Nothing Then - Dim lArg As Object = aArgs.GetValue("Start Date") - If TypeOf (lArg) Is String Then - lArg = System.DateTime.Parse(lArg).ToOADate - End If - Dim lStartDate As Double = CDbl(lArg) - lArg = aArgs.GetValue("End Date") - If TypeOf (lArg) Is String Then - lArg = System.DateTime.Parse(lArg).ToOADate - End If - Dim EndDate As Double = CDbl(lArg) - Return SubsetByDate(lTSFirst, lStartDate, EndDate, Nothing) - End If - ReDim lNewVals(-1) 'Don't create new timeseries below - Case "subset by date boundary" - Dim lBoundaryMonth As Integer = aArgs.GetValue("Boundary Month") - Dim lBoundaryDay As Integer = aArgs.GetValue("Boundary Day") - Return SubsetByDateBoundary(lTSFirst, lBoundaryMonth, lBoundaryDay, Nothing) - - Case "merge" - Return MergeTimeseries(lTSgroup) - - Case "running sum" - 'TODO: ignore missing values - is this ok? - Dim lVal, lSum As Double - For lValueIndex = 1 To lValueIndexLast - lVal = lNewVals(lValueIndex) - If Not Double.IsNaN(lVal) Then - lNewVals(lValueIndex) += lSum - lSum = lNewVals(lValueIndex) - End If - Next - - 'Case "weight" - ' For valNum = 1 To NVALS - ' dataval(valNum) = 0 - ' argNum = 1 - ' While argNum < Nargs - ' GoSub SetCurArgVal - ' weightVal = curArgVal - ' argNum = argNum + 1 - ' GoSub SetCurArgVal - ' dataval(valNum) = dataval(valNum) + curArgVal * weightVal - ' argNum = argNum + 1 - ' End While - ' Next - 'Case "interpolate" - Case Else - ReDim lNewVals(-1) 'Don't create new timeseries - Err.Raise(vbObjectError + 512, , aOperationName & " not implemented") - End Select - - If lNewVals.GetUpperBound(0) >= 0 Then - Dim lNewTS As atcTimeseries = New atcTimeseries(Nothing) - lNewTS.Values = lNewVals - - If Not lTSFirst Is Nothing Then - lNewTS.Dates = lTSFirst.Dates - Else - Err.Raise(vbObjectError + 512, , "Did not get dates for new computed timeseries " & aOperationName) - End If - - If Not lTSgroup Is Nothing AndAlso lTSgroup.Count > 0 Then - If lTSgroup.Count = 1 Then - lNewTS.Attributes.SetValue("Original ID", lTSgroup.Item(0).OriginalParentID) - 'Else - ' lNewTS.Attributes.SetValue("Parent Timeseries Group", lTSgroup) - End If - End If - If lHaveNumber Then - lNewTS.Attributes.SetValue("Parent Constant", lNumber) - End If - - CopyBaseAttributes(lTSFirst, lNewTS, lNewTS.numValues + 1, 0, 0) - 'TODO: update attributes as appropriate! - - Dim lDateNow As Date = Now - lNewTS.Attributes.SetValue("Date Created", lDateNow) - lNewTS.Attributes.SetValue("Date Modified", lDateNow) - - Return lNewTS - End If - Return Nothing - End Function - - ''' - ''' Test whether aTimeseries contains provisional values by looking for P=True value attribute - ''' - Public Function HasProvisionalValues(ByVal aTimeseries As atcTimeseries) As Boolean - If aTimeseries.ValueAttributesExist Then - Dim lProvisionalAttribute As String = aTimeseries.Attributes.GetValue("ProvisionalValueAttribute", "P") - For lIndex As Integer = 0 To aTimeseries.numValues - If aTimeseries.ValueAttributesGetValue(lIndex, lProvisionalAttribute, False) Then - If Not Double.IsNaN(aTimeseries.Value(lIndex)) Then - Return True - End If - End If - Next - End If - Return False - End Function - - Public Sub SplitProvisional(ByVal aTimeseries As atcTimeseries, _ - ByRef aProvisionalTS As atcTimeseries, _ - ByRef aNonProvisionalTS As atcTimeseries) - aNonProvisionalTS = New atcTimeseries(Nothing) - aNonProvisionalTS.Dates = New atcTimeseries(Nothing) - aNonProvisionalTS.numValues = aTimeseries.numValues - aProvisionalTS = New atcTimeseries(Nothing) - aProvisionalTS.Dates = New atcTimeseries(Nothing) - aProvisionalTS.numValues = aTimeseries.numValues - - Dim lProvisionalNumValuesAdded As Integer = 0 - Dim lNonProvisionalNumValuesAdded As Integer = 0 - Dim lAddTo As atcTimeseries - Dim lAddIndex As Integer - Dim lProvisionalAttribute As String = aTimeseries.Attributes.GetValue("ProvisionalValueAttribute", "P") - - For lIndex As Integer = 1 To aTimeseries.numValues - If aTimeseries.ValueAttributesGetValue(lIndex, lProvisionalAttribute, False) Then - lAddTo = aProvisionalTS - lProvisionalNumValuesAdded += 1 - lAddIndex = lProvisionalNumValuesAdded - Else - lAddTo = aNonProvisionalTS - lNonProvisionalNumValuesAdded += 1 - lAddIndex = lNonProvisionalNumValuesAdded - End If - - lAddTo.Value(lAddIndex) = aTimeseries.Value(lIndex) - lAddTo.Dates.Value(lAddIndex) = aTimeseries.Dates.Value(lIndex) - If lAddIndex = 1 Then - lAddTo.Value(0) = pNaN - lAddTo.Dates.Value(0) = aTimeseries.Dates.Value(lIndex - 1) - End If - If aTimeseries.ValueAttributesExist(lIndex) Then - lAddTo.ValueAttributes(lAddIndex) = aTimeseries.ValueAttributes(lIndex) - End If - Next - aProvisionalTS.numValues = lProvisionalNumValuesAdded - aNonProvisionalTS.numValues = lNonProvisionalNumValuesAdded - - Dim lCopiedAttributes As atcDataAttributes = aTimeseries.Attributes.Copy - lCopiedAttributes.DiscardCalculated() - - aProvisionalTS.Attributes.ChangeTo(lCopiedAttributes) - aNonProvisionalTS.Attributes.ChangeTo(lCopiedAttributes) - aProvisionalTS.Attributes.SetValue("ParentSerial", aTimeseries.Serial) - aNonProvisionalTS.Attributes.SetValue("ParentSerial", aTimeseries.Serial) - End Sub -End Module +Imports atcUtility +Imports MapWinUtility + +''' Math utility functions +Public Module modTimeseriesMath + + Private pNaN As Double = GetNaN() + Private pMaxValue As Double = GetMaxValue() + + ''' Search through an array of dates looking for a date + ''' Array of dates to search + ''' Date to search for + ''' Index of data to begin search at (default is 0) + ''' Index of first date on or after date searched for + ''' + Public Function FindDateAtOrAfter(ByVal aDatesToSearch() As Double, ByVal aDate As Double, _ + Optional ByVal aStartAt As Integer = 0) As Integer + aDate -= JulianMillisecond 'Allow for floating point error + Dim lIndex As Integer = Array.BinarySearch(aDatesToSearch, aDate) + If lIndex < 0 Then + lIndex = lIndex Xor -1 + End If + Return lIndex + End Function + + ''' Creates a timeseries copied from orginal that only contains dates within specifed range + ''' Original timeseries + ''' Starting Julian date + ''' Ending Julian date + ''' Data Source to assign to newly created subset timeseries, can be 'Nothing' + ''' Reference to new timeseries + ''' if aDataSource is 'Nothing' only a reference to a new timeseries is returned + Public Function SubsetByDate(ByVal aTimeseries As atcTimeseries, _ + ByVal aStartDate As Double, _ + ByVal aEndDate As Double, _ + ByVal aDataSource As atcTimeseriesSource) As atcTimeseries + + If aTimeseries Is Nothing OrElse aTimeseries.Dates Is Nothing Then Return Nothing + + Dim lPointTimeseries As Boolean = aTimeseries.Attributes.GetValue("Point", False) + Dim lStart As Integer = FindDateAtOrAfter(aTimeseries.Dates.Values, aStartDate) + Dim lEnd As Integer = FindDateAtOrAfter(aTimeseries.Dates.Values, aEndDate, lStart) + If lEnd > aTimeseries.numValues Then 'adjust end to actual end + lEnd = aTimeseries.numValues + End If + 'Back up one time step for mean data or point data after end + If Not lPointTimeseries OrElse + (lEnd > 0 AndAlso aTimeseries.Dates.Value(lEnd) > aEndDate) Then + lEnd -= 1 + End If + + Dim lnewTS As New atcTimeseries(aDataSource) + lnewTS.Dates = New atcTimeseries(aDataSource) + lnewTS.Attributes.SetValue("Original ID", aTimeseries.OriginalParentID) + Dim lNumNewValues As Integer = lEnd - lStart + 1 + + If lNumNewValues > 0 Then + Dim lNewValues(lNumNewValues) As Double + Dim lNewDates(lNumNewValues) As Double + lNewValues(0) = GetNaN() + + If lPointTimeseries Then + lNewDates(0) = GetNaN() + System.Array.Copy(aTimeseries.Dates.Values, lStart, lNewDates, 1, lNumNewValues) + System.Array.Copy(aTimeseries.Values, lStart, lNewValues, 1, lNumNewValues) + Else + System.Array.Copy(aTimeseries.Dates.Values, lStart, lNewDates, 0, lNumNewValues + 1) + System.Array.Copy(aTimeseries.Values, lStart + 1, lNewValues, 1, lNumNewValues) + End If + + lnewTS.Values = lNewValues + lnewTS.Dates.Values = lNewDates + CopyBaseAttributes(aTimeseries, lnewTS, lNumNewValues, lStart + 1, 1) + lnewTS.Attributes.SetValue("SJDAY", aStartDate) + lnewTS.Attributes.SetValue("EJDAY", aEndDate) + lnewTS.Attributes.SetValue("Point", lPointTimeseries) + Else + CopyBaseAttributes(aTimeseries, lnewTS) + End If + Return lnewTS + End Function + + ''' + ''' Trim a timeseries if needed to make it start and end at the desired year boundary. + ''' Useful when complete calendar or water years are needed. + ''' + ''' Original timeseries + ''' Month containing first value of the year + ''' Day containing first value of the year + ''' Data Source to assign to newly created subset timeseries, can be Nothing + ''' Optional first year of data to include in subset + ''' Optional last year of data to include in subset + ''' Optional month containing last value of the year + ''' Optional day containing last value of the year + ''' New subset timeseries + ''' + ''' If omitted or zero, aFirstYear or aLastYear will not be used to limit the subset. + ''' If omitted or zero, aEndMonth/aEndDay will default to the day before aStartMonth/aStartDay. + ''' + Public Function SubsetByDateBoundary(ByVal aTimeseries As atcTimeseries, _ + ByVal aStartMonth As Integer, _ + ByVal aStartDay As Integer, _ + ByVal aDataSource As atcTimeseriesSource, _ + Optional ByVal aFirstYear As Integer = 0, _ + Optional ByVal aLastYear As Integer = 0, _ + Optional ByVal aEndMonth As Integer = 0, _ + Optional ByVal aEndDay As Integer = 0) As atcTimeseries + + If aEndMonth = 0 Then + aEndMonth = aStartMonth 'Will be rolled back a day later + End If + + If aEndDay = 0 Then + aEndDay = aStartDay 'Will be rolled back a day later + End If + + aTimeseries.EnsureValuesRead() + + If aTimeseries.numValues < 1 Then + Return aTimeseries + End If + + If aFirstYear > 0 AndAlso (aEndMonth < aStartMonth OrElse (aEndMonth = aStartMonth AndAlso aEndDay < aStartDay)) Then + 'Convert water year into calendar year + aFirstYear -= 1 + End If + + Dim lStartDate As Double = aTimeseries.Dates.Value(0) + If Double.IsNaN(lStartDate) Then lStartDate = aTimeseries.Dates.Value(1) + Dim lStartTimeseriesDate As Date = Date.FromOADate(lStartDate) + With lStartTimeseriesDate + 'Roll back end of year by one day if it matches beginning of year + If aEndMonth = aStartMonth AndAlso aEndDay = aStartDay Then + aEndDay -= 1 + If aEndDay = 0 Then + aEndMonth -= 1 + If aEndMonth = 0 Then aEndMonth = 12 + aEndDay = DayMon(.Year, aEndMonth) + End If + End If + + Dim lStartYear As Integer = .Year + If aFirstYear > lStartYear Then + lStartYear = aFirstYear + Else + If .Month > aStartMonth Then + lStartYear += 1 + ElseIf .Month = aStartMonth Then + If .Day > aStartDay Then + lStartYear += 1 + End If + End If + End If + lStartDate = Jday(lStartYear, aStartMonth, aStartDay, 0, 0, 0) + End With + + Dim lEndDate As Double + Dim lEndTimeseriesDate As Date = Date.FromOADate(aTimeseries.Dates.Value(aTimeseries.Dates.numValues)) + With lEndTimeseriesDate + Dim lEndYear As Integer = .Year + If aLastYear > 0 AndAlso aLastYear < lEndYear Then + lEndYear = aLastYear + Else + If .Month < aEndMonth Then + lEndYear -= 1 + ElseIf .Month = aEndMonth Then + If .Day < aEndDay Then + lEndYear -= 1 + End If + End If + End If + lEndDate = Jday(lEndYear, aEndMonth, aEndDay, 24, 0, 0) 'hour 24 = end of last day + End With + + SubsetByDateBoundary = SubsetByDate(aTimeseries, lStartDate, lEndDate, aDataSource) + SubsetByDateBoundary.Attributes.Add("seasbg", aStartMonth) + SubsetByDateBoundary.Attributes.Add("seadbg", aStartDay) + SubsetByDateBoundary.Attributes.Add("seasnd", aEndMonth) + SubsetByDateBoundary.Attributes.Add("seadnd", aEndDay) + + End Function + + ''' Copy any attributes that copies inherit from aFromDataSet into aToDataSet + ''' Dataset containing attributes to copy + ''' Dataset to copy attributes into + ''' Number of values to copy value attributes of + ''' Start index for copying value attributes from + ''' Start index for copying value attributes to + ''' Copies only general attributes if aNumValues is omitted or is less than 1, + ''' Also copies value attributes if aNumValues > 0 + Public Sub CopyBaseAttributes(ByVal aFromDataset As atcTimeseries, ByVal aToDataSet As atcTimeseries, _ + Optional ByVal aNumValues As Integer = 0, _ + Optional ByVal aStartFrom As Integer = 0, _ + Optional ByVal aStartTo As Integer = 0) + + For Each lAttribute As atcDefinedValue In aFromDataset.Attributes + If lAttribute.Definition.CopiesInherit Then + aToDataSet.Attributes.SetValue(lAttribute.Definition, lAttribute.Value) + End If + Next + + If aFromDataset.ValueAttributesExist Then + For lIndex As Integer = 0 To aNumValues - 1 + If aFromDataset.ValueAttributesExist(lIndex + aStartFrom) Then + For Each lAttribute As atcDefinedValue In aFromDataset.ValueAttributes(lIndex + aStartFrom) + If lAttribute.Definition.CopiesInherit Then + aToDataSet.ValueAttributes(lIndex + aStartTo).SetValue(lAttribute.Definition, lAttribute.Value) + End If + Next + End If + Next + End If + End Sub + + ''' Merge a group of atcTimeseries + ''' Group of atcTimeseries to merge + ''' True to skip missing values, False to include missing values in result + ''' atcTimeseries containing all unique dates from the group + ''' Each atcTimeseries in aGroup is assumed to be in order by date within itself. + ''' If duplicate dates exist in aGroup, some values will be left out of result. + Public Function MergeTimeseries(ByVal aGroup As atcTimeseriesGroup, _ + ByVal aSkipMissing As Boolean, _ + ByVal aTran As atcTran) As atcTimeseries + Dim lNewTS As New atcTimeseries(Nothing) 'will contain new (merged) dates + If aGroup IsNot Nothing AndAlso aGroup.Count > 0 Then + lNewTS.Dates = MergeDates(aGroup, aSkipMissing) + Dim lTotalNumValues As Long = lNewTS.Dates.numValues + lNewTS.numValues = lTotalNumValues + lNewTS.Value(0) = pNaN + + Dim lOldTS As atcTimeseries 'points to current timeseries from aGroup + Dim lMaxGroupIndex As Integer = aGroup.Count - 1 + Dim lNextIndex() As Integer + + ReDim lNextIndex(aGroup.Count - 1) + + For lIndex As Integer = 0 To lMaxGroupIndex + lNextIndex(lIndex) = 1 + Next + + MergeAttributes(aGroup, lNewTS) + Dim lNumToAverage As Integer = 0 + For lNewIndex As Integer = 1 To lTotalNumValues + Dim lCurrentDate As Double = lNewTS.Dates.Value(lNewIndex) + lNumToAverage = 0 + For lIndex As Integer = 0 To lMaxGroupIndex + lOldTS = aGroup.Item(lIndex) + While lNextIndex(lIndex) <= lOldTS.numValues AndAlso lOldTS.Dates.Value(lNextIndex(lIndex)) - JulianMillisecond < lCurrentDate + lNumToAverage += 1 + 'If Native, always just use latest value. + 'OrElse, If this is the first value, use it for all tran except CountMissing (which needs counts not values) + If aTran = atcTran.TranNative OrElse (aTran <> atcTran.TranCountMissing AndAlso lNumToAverage = 1) Then + lNewTS.Value(lNewIndex) = lOldTS.Value(lNextIndex(lIndex)) + Else + Select Case aTran + Case atcTran.TranAverSame, atcTran.TranSumDiv + lNewTS.Value(lNewIndex) += lOldTS.Value(lNextIndex(lIndex)) + Case atcTran.TranCountMissing + If Double.IsNaN(lOldTS.Value(lNextIndex(lIndex))) Then lNewTS.Value(lNewIndex) += 1 + Case atcTran.TranMax + If lOldTS.Value(lNextIndex(lIndex)) > lNewTS.Value(lNewIndex) Then + lOldTS.Value(lNextIndex(lIndex)) = lOldTS.Value(lNextIndex(lIndex)) + End If + Case atcTran.TranMin + If lOldTS.Value(lNextIndex(lIndex)) < lNewTS.Value(lNewIndex) Then + lOldTS.Value(lNextIndex(lIndex)) = lOldTS.Value(lNextIndex(lIndex)) + End If + End Select + End If + lNextIndex(lIndex) += 1 + End While + Next + If aTran = atcTran.TranAverSame AndAlso lNumToAverage > 1 Then + lNewTS.Value(lNewIndex) /= lNumToAverage + End If + Next + End If + Return lNewTS + End Function + + ''' Merge a group of atcTimeseries + ''' Group of atcTimeseries to merge + ''' True to skip missing values, False to include missing values in result + ''' atcTimeseries containing all unique dates from the group + ''' Each atcTimeseries in aGroup is assumed to be in order by date within itself. + ''' If duplicate dates exist in aGroup, some values will be left out of result. + Public Function MergeTimeseries(ByVal aGroup As atcTimeseriesGroup, _ + Optional ByVal aFilterNoData As Boolean = False) As atcTimeseries + Dim lNewTS As New atcTimeseries(Nothing) 'will contain new (merged) dates + lNewTS.Dates = New atcTimeseries(Nothing) + If aGroup IsNot Nothing AndAlso aGroup.Count > 0 Then + Dim lNewIndex As Integer + Dim lTotalNumValues As Integer = 0 + Dim lOldTS As atcTimeseries 'points to current timeseries from aGroup + Dim lMinDate As Double = pMaxValue + Dim lDateZero As Double = pNaN + Dim lMaxGroupIndex As Integer = aGroup.Count - 1 + Dim lIndex As Integer + Dim lMinIndex As Integer + Dim lNextIndex() As Integer + Dim lNextDate() As Double + + ReDim lNextIndex(aGroup.Count - 1) + ReDim lNextDate(aGroup.Count - 1) + + MergeAttributes(aGroup, lNewTS) + 'lNewTS.Attributes.AddHistory("Merged " & aGroup.Count) + + 'Count total number of values and set up + For lIndex = 0 To lMaxGroupIndex + lOldTS = aGroup.Item(lIndex) + Try + lTotalNumValues += lOldTS.numValues + GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lIndex), lNextDate(lIndex)) + 'Find minimum starting date and take date before from that TS + If lNextDate(lIndex) < lMinDate Then + lMinDate = lNextDate(lIndex) + lDateZero = lOldTS.Dates.Value(lNextIndex(lIndex) - 1) + End If + Catch 'Can't get dates values from this TS + lNextIndex(lIndex) = -1 + End Try + Next + + If lTotalNumValues > 0 Then + lNewTS.numValues = lTotalNumValues + lNewTS.Dates.numValues = lTotalNumValues + If lMinDate < pMaxValue Then + lNewTS.Dates.Value(0) = lDateZero + Else + lNewTS.Dates.Value(0) = pNaN + End If + lNewTS.Value(0) = pNaN + + For lNewIndex = 1 To lTotalNumValues + 'Find earliest date not yet used + lMinIndex = -1 + lMinDate = pMaxValue + For lIndex = 0 To lMaxGroupIndex + If lNextIndex(lIndex) > 0 AndAlso lNextDate(lIndex) < lMinDate Then + lMinIndex = lIndex + lMinDate = lNextDate(lIndex) + End If + Next + + 'TODO: could make common cases faster with Array.Copy + 'Now that we have found lMinDate, could also find the lNextMinDate when the + 'minimum date from a different TS happens, then find out how many more values + 'from this TS are earlier than lNextMinDate, then copy all of them to the + 'new TS at once + + 'Add earliest date and value to new TS + If lMinIndex >= 0 Then + 'Logger.Dbg("---found min date in data set " & lMinIndex) + lOldTS = aGroup.Item(lMinIndex) + If lOldTS.ValueAttributesGetValue(lNextIndex(lMinIndex), "Inserted", False) Then + 'Logger.Dbg("---discarding inserted value") + 'This value was inserted during splitting and will now be discarded + lNewIndex -= 1 + lTotalNumValues -= 1 + GetNextDateIndex(lOldTS, aFilterNoData, _ + lNextIndex(lMinIndex), _ + lNextDate(lMinIndex)) + Else + 'Logger.Dbg("---MergeTimeseries adding date " & lMinDate & " value " & lOldTS.Value(lNextIndex(lMinIndex)) & " from dataset " & lMinIndex) + lNewTS.Dates.Value(lNewIndex) = lMinDate + lNewTS.Value(lNewIndex) = lOldTS.Value(lNextIndex(lMinIndex)) + If lOldTS.ValueAttributesExist(lNextIndex(lMinIndex)) Then + lNewTS.ValueAttributes(lNewIndex) = lOldTS.ValueAttributes(lNextIndex(lMinIndex)) + End If + + GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lMinIndex), lNextDate(lMinIndex)) + + For lIndex = 0 To lMaxGroupIndex + 'Discard next value from any TS that falls within one millisecond + 'Don't need Math.Abs because we already found minimum + While lNextIndex(lIndex) > 0 AndAlso (lNextDate(lIndex) - lMinDate) < JulianMillisecond + lOldTS = aGroup.Item(lIndex) + 'Logger.Dbg("---MergeTimeseries discarding date " & DumpDate(lNextDate(lIndex)) & " value " & lOldTS.Value(lNextIndex(lIndex)) & " from dataset " & lIndex) + lTotalNumValues -= 1 'This duplicate no longer counts toward total + GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lIndex), lNextDate(lIndex)) + End While + Next + End If + Else 'out of values in all the datasets + 'Logger.Dbg("Warning:MergeTimeseries:Ran out of values at " & lNewIndex & " of " & lTotalNumValues) + lTotalNumValues = lNewIndex - 1 + Exit For + End If + Next + If lTotalNumValues < lNewTS.numValues Then + lNewTS.numValues = lTotalNumValues + lNewTS.Dates.numValues = lTotalNumValues + End If + End If + End If + Return lNewTS + End Function + + ''' + ''' Find the first starting date, last ending date, and common time period of a group of Timeseries + ''' + ''' Group to search for start and end dates + ''' Earliest start date of any timeseries in group (beginning of interval for constant interval) + ''' Latest ending date of any timeseries in group + ''' Beginning of the period shared by all in group (beginning of interval for constant interval) + ''' Ending of the period shared by all in group + ''' True if there is a common period of all timeseries in the group, false if one timeseries begins only after another ends. + ''' All arguments except aGroup are ByRef + Public Function CommonDates(ByVal aGroup As atcTimeseriesGroup, _ + ByRef aFirstStart As Double, _ + ByRef aLastEnd As Double, _ + ByRef aCommonStart As Double, _ + ByRef aCommonEnd As Double) As Boolean + aFirstStart = GetMaxValue() + aLastEnd = GetMinValue() + + aCommonStart = GetMinValue() + aCommonEnd = GetMaxValue() + + If aGroup IsNot Nothing Then + Dim lMaxProgress As Long = aGroup.Count + Dim lCurrentProgress As Long = 0 + Dim lShowingProgress As Boolean = lMaxProgress > 50 + Using lProgressLevel As New ProgressLevel(False, Not lShowingProgress) + If lShowingProgress Then Logger.Status("Reading data and finding common dates") + For Each lTs As atcData.atcTimeseries In aGroup + If lTs.Dates.numValues > 0 Then + Dim lThisDate As Double = lTs.Dates.Value(0) + If Double.IsNaN(lThisDate) Then lThisDate = lTs.Dates.Value(1) + If lThisDate < aFirstStart Then aFirstStart = lThisDate + If lThisDate > aCommonStart Then aCommonStart = lThisDate + lThisDate = lTs.Dates.Value(lTs.Dates.numValues) + If lThisDate > aLastEnd Then aLastEnd = lThisDate + If lThisDate < aCommonEnd Then aCommonEnd = lThisDate + End If + If lShowingProgress Then + lCurrentProgress += 1 + Logger.Progress(lCurrentProgress, lMaxProgress) + End If + Next + End Using + End If + + Return aCommonStart > GetMinValue() AndAlso aCommonEnd < GetMaxValue() AndAlso aCommonStart < aCommonEnd + + End Function + + ''' Merge the dates from a group of atcTimeseries + ''' Group of atcTimeseries to merge the dates of + ''' True to skip missing values, False to include missing values in result + ''' atcTimeseries containing all unique dates from the group + ''' Each atcTimeseries in aGroup is assumed to be in order by date within itself. + Public Function MergeDates(ByVal aGroup As atcTimeseriesGroup, _ + Optional ByVal aFilterNoData As Boolean = False) As atcTimeseries + Dim lNewDates As New Generic.List(Of Double) + Dim lTotalNumValues As Long = 0 + Dim lOldTS As atcTimeseries 'points to current timeseries from aGroup + Dim lMinDate As Double = pMaxValue + Dim lMaxGroupIndex As Integer = aGroup.Count - 1 + Dim lIndex As Integer + Dim lMinIndex As Integer + Dim lNextIndex() As Integer + Dim lNextDate() As Double + + ReDim lNextIndex(aGroup.Count - 1) + ReDim lNextDate(aGroup.Count - 1) + + 'Count total number of values and set up + For lIndex = 0 To lMaxGroupIndex + lOldTS = aGroup.Item(lIndex) + Try + lTotalNumValues += lOldTS.numValues + GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lIndex), lNextDate(lIndex)) + 'Find minimum starting date and take date before from that TS + If lNextDate(lIndex) < lMinDate Then + lMinDate = lOldTS.Dates.Value(lNextIndex(lIndex) - 1) + End If + Catch 'Can't get dates values from this TS + lNextIndex(lIndex) = -1 + End Try + Next + + If lTotalNumValues > 0 Then + If lMinDate < pMaxValue Then + lNewDates.Add(lMinDate) + Else + lNewDates.Add(pNaN) + End If + + Do + 'Find earliest date not yet used + lMinIndex = -1 + lMinDate = pMaxValue + For lIndex = 0 To lMaxGroupIndex + If lNextIndex(lIndex) > 0 AndAlso lNextDate(lIndex) < lMinDate Then + lMinIndex = lIndex + lMinDate = lNextDate(lIndex) + End If + Next + + 'TODO: could make common cases faster with Array.Copy + 'Now that we have found lMinDate, could also find the lNextMinDate when the + 'minimum date from a different TS happens, then find out how many more values + 'from this TS are earlier than lNextMinDate, then copy all of them to the + 'new TS at once + + 'add earliest date + If lMinIndex >= 0 Then + 'Logger.Dbg("---found min date in data set " & lMinIndex) + lOldTS = aGroup.Item(lMinIndex) + If lOldTS.ValueAttributesGetValue(lNextIndex(lMinIndex), "Inserted", False) Then + 'Logger.Dbg("---discarding inserted value") + 'This value was inserted during splitting and will now be discarded + GetNextDateIndex(lOldTS, aFilterNoData, _ + lNextIndex(lMinIndex), _ + lNextDate(lMinIndex)) + Else + 'Logger.Dbg("---MergeTimeseries adding date " & lMinDate & " value " & lOldTS.Value(lNextIndex(lMinIndex)) & " from dataset " & lMinIndex) + lNewDates.Add(lMinDate) + + GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lMinIndex), lNextDate(lMinIndex)) + + For lIndex = 0 To lMaxGroupIndex + 'Discard next value from any TS that falls within one millisecond + 'Don't need Math.Abs because we already found minimum + While lNextIndex(lIndex) > 0 AndAlso (lNextDate(lIndex) - lMinDate) < JulianMillisecond + lOldTS = aGroup.Item(lIndex) + 'Logger.Dbg("---MergeTimeseries discarding date " & DumpDate(lNextDate(lIndex)) & " value " & lOldTS.Value(lNextIndex(lIndex)) & " from dataset " & lIndex) + GetNextDateIndex(lOldTS, aFilterNoData, lNextIndex(lIndex), lNextDate(lIndex)) + End While + Next + End If + Else 'out of values in all the datasets + 'Logger.Dbg("Warning:MergeTimeseries:Ran out of values at " & lNewIndex & " of " & lTotalNumValues) + Exit Do + End If + Loop + End If + Logger.Dbg("Merged dates from " & aGroup.Count & " timeseries, found " & lNewDates.Count - 1 & " unique dates from " & lTotalNumValues & " total values.") + Dim lNewTS As New atcTimeseries(Nothing) + lNewTS.Values = lNewDates.ToArray + Return lNewTS + End Function + + ''' + ''' + ''' + ''' + ''' + ''' + Private Sub GetNextDateIndex(ByVal aTs As atcTimeseries, _ + ByVal aFilterNoData As Boolean, _ + ByRef aIndex As Integer, _ + ByRef aNextDate As Double) + aIndex += 1 + While aIndex <= aTs.numValues + If (Not aFilterNoData) OrElse (Not Double.IsNaN(aTs.Value(aIndex))) Then + If aTs.ValueAttributesGetValue(aIndex, "Inserted", False) Then + ' Found NaN inserted at edge of season split, always skip these, they are not a value and they are not Missing/NoData + aIndex += 1 + Else + aNextDate = aTs.Dates.Value(aIndex) + Exit While + End If + Else + aIndex += 1 + End If + End While + If aIndex > aTs.numValues Then + aNextDate = pNaN 'is this necessary? + aIndex = -1 'out of values + End If + End Sub + + Public Sub MergeAttributes(ByVal aGroup As atcTimeseriesGroup, ByVal aTarget As atcTimeseries) + For Each lAttribute As atcDefinedValue In aGroup(0).Attributes + If lAttribute.Definition.CopiesInherit Then + Dim lMatch As Boolean = True + For Each lData As atcDataSet In aGroup + Try 'Hard-coded SeasonDefinition to avoid exception (it can't use <>) + If lAttribute.Definition.Name = "SeasonDefinition" OrElse + lData.Attributes.GetValue(lAttribute.Definition.Name) <> lAttribute.Value Then + lMatch = False + Exit For 'Skip checking other datasets for this attribute, move on to next attribute + End If + Catch 'Can't test for equality, don't assign this one a value in aTarget + lMatch = False + Exit For + End Try + Next + If lMatch Then aTarget.Attributes.SetValue(lAttribute.Definition, lAttribute.Value, lAttribute.Arguments) + End If + Next + End Sub + + Public Function TimeseriesGroupFromArguments(ByVal aArgs As atcDataAttributes) As atcDataGroup + Dim ltsGroup As atcDataGroup = Nothing + If aArgs IsNot Nothing Then + ltsGroup = DatasetOrGroupToGroup(aArgs.GetValue("Timeseries")) + If ltsGroup Is Nothing OrElse ltsGroup.Count < 1 Then + ltsGroup = DatasetOrGroupToGroup(aArgs.GetValue("OneOrMoreTimeseries")) + End If + End If + Return ltsGroup + End Function + + Public Function DatasetOrGroupToGroup(ByVal aObject As Object) As atcDataGroup + If IsNothing(aObject) Then + Logger.Dbg("DatasetOrGroupToGroup = Nothing") + Return Nothing + Else + Select Case aObject.GetType.Name + Case "atcDataGroup", "atcTimeseriesGroup" : Return aObject + Case "atcTimeseries" : Return New atcTimeseriesGroup(CType(aObject, atcTimeseries)) + Case "atcDataSet" : Return New atcDataGroup(aObject) + Case Else + Logger.Dbg("DatasetOrGroupToGroup: Unrecognized type '" & aObject.GetType.Name & "'") + Return Nothing + End Select + End If + End Function + + ''' Fill values in constant interval timeseries with specified values. + ''' Timeseries to fill + ''' Time units (1-sec, 2-min, 3-hour, 4-day, 5-month, 6-year, 7-century) + ''' Timestep (number of units of aTU per time step) + ''' Value to Fill data gaps with. + ''' Value indicating missing data. + ''' Value indicating accumulated data. + ''' + ''' Filled timeseries + ''' + ''' Assumes dates are at the end of each value's interval and that the + ''' 0th position in the Dates array is the beginning of the first interval. + ''' + Public Function FillValues(ByVal aOldTSer As atcTimeseries, _ + ByVal aTU As atcTimeUnit, _ + Optional ByVal aTS As Long = 1, _ + Optional ByVal aFillVal As Double = 0, _ + Optional ByVal aMissVal As Double = -999, _ + Optional ByVal aAccumVal As Double = -999, _ + Optional ByVal aDataSource As atcTimeseriesSource = Nothing) As atcTimeseries + + If aOldTSer IsNot Nothing AndAlso aOldTSer.numValues > 0 Then + Dim lDate(5) As Integer + Dim lNewNumVals As Integer + Dim lNewInd As Integer + Dim lOldInd As Integer + Dim lDateOld As Double + Dim lValOld As Double + Dim lNewVals() As Double + Dim lNewDates() As Double = NewDates(aOldTSer, aTU, aTS) + + If lNewDates.GetUpperBound(0) > 0 Then 'dates for new timeseries set + lNewNumVals = lNewDates.GetUpperBound(0) + ReDim lNewVals(lNewNumVals) + lNewVals(0) = pNaN + lOldInd = 1 + lDateOld = aOldTSer.Dates.Value(lOldInd) + lNewInd = 1 + Dim lAnyValueAttributes As Boolean = aOldTSer.ValueAttributesExist + Dim lNewValueAttributes(lNewDates.GetUpperBound(0)) As atcDataAttributes + + While lNewInd <= lNewNumVals + While lNewInd <= lNewNumVals AndAlso lNewDates(lNewInd) < lDateOld - JulianMillisecond 'Fill values not present in original data + Select Case lValOld + Case aMissVal + If aOldTSer.Value(lOldInd) = aMissVal Then + lNewVals(lNewInd) = aMissVal + lNewValueAttributes(lNewInd) = New atcDataAttributes + lNewValueAttributes(lNewInd).SetValue("Missing", True) + Else + lNewVals(lNewInd) = aFillVal + lNewValueAttributes(lNewInd) = New atcDataAttributes + lNewValueAttributes(lNewInd).SetValue("Filled", True) + End If + Case aAccumVal + lNewVals(lNewInd) = aAccumVal + lNewValueAttributes(lNewInd) = New atcDataAttributes + lNewValueAttributes(lNewInd).SetValue("Accumulated", True) + Case Else + lNewVals(lNewInd) = aFillVal + lNewValueAttributes(lNewInd) = New atcDataAttributes + lNewValueAttributes(lNewInd).SetValue("Filled", True) + End Select + lNewInd += 1 + End While + If lNewInd <= lNewNumVals Then + lValOld = aOldTSer.Value(lOldInd) + lNewVals(lNewInd) = lValOld + If lAnyValueAttributes AndAlso aOldTSer.ValueAttributesExist(lOldInd) Then + lNewValueAttributes(lNewInd) = aOldTSer.ValueAttributes(lOldInd) + End If + lNewInd += 1 + lOldInd += 1 + If lOldInd <= aOldTSer.numValues Then + lDateOld = aOldTSer.Dates.Value(lOldInd) + End If + End If + End While + + Dim lNewTSer As New atcTimeseries(aDataSource) + CopyBaseAttributes(aOldTSer, lNewTSer) + lNewTSer.Dates = New atcTimeseries(Nothing) + lNewTSer.Dates.Values = lNewDates + lNewTSer.Values = lNewVals + For lNewInd = 1 To lNewValueAttributes.GetUpperBound(0) + If lNewValueAttributes(lNewInd) IsNot Nothing Then + lNewTSer.ValueAttributes(lNewInd) = lNewValueAttributes(lNewInd) + End If + Next + With lNewTSer.Attributes + '.SetValue("point", False) + .SetValue("tu", aTU) + .SetValue("ts", aTS) + .SetValue("TSFILL", aFillVal) + .SetValue("MVal", aMissVal) + .SetValue("MAcc", aAccumVal) + End With + + Return lNewTSer + Else + Logger.Dbg("Problem with dates in Timeseries " & aOldTSer.ToString & ".") + Return Nothing + End If + Else + If aOldTSer Is Nothing Then + Logger.Dbg("OldTSer is nothing.") + Else + Logger.Dbg("No data values in Timeseries " & aOldTSer.ToString & ".") + End If + + Return Nothing + End If + End Function + + ''' + ''' Fill missing periods in a timeseries using interpolation + ''' + ''' Timeseries containing missing values + ''' Max span, in Julian Days, over which interpolation is allowed + ''' Array returning length of each missing period filled + ''' Missing value indicator + ''' atcTimeseries clone of original timeseries along with interpolated values + ''' + Public Function FillMissingByInterpolation(ByVal aOldTSer As atcTimeseries, _ + Optional ByVal aMaxFillLength As Double = Double.NaN, _ + Optional ByVal aFillInstances As ArrayList = Nothing, _ + Optional ByVal aMissingValue As Double = Double.NaN) As atcTimeseries + Dim lNewTSer As atcTimeseries = aOldTSer.Clone + + Dim lInd As Integer = 1 + Dim lIndPrevNotMissing As Integer = 1 + Dim lIndNextNotMissing As Integer + Logger.Dbg("FillMissingByInterp: NumValues:" & lNewTSer.numValues & " MaxFillLength, days:" & aMaxFillLength) + While lInd <= lNewTSer.numValues + If Double.IsNaN(lNewTSer.Value(lInd)) OrElse Math.Abs(lNewTSer.Value(lInd) - aMissingValue) < 0.00001 Then 'look for next good value + lIndNextNotMissing = FindNextNotMissing(lNewTSer, lInd, aMissingValue) + Dim lMissingLength As Double + With lNewTSer.Dates 'find missing length + lMissingLength = .Value(lIndNextNotMissing) - .Value(lIndPrevNotMissing) + End With + 'Logger.Dbg("FillMissingByInterp:Missing:", lInd, lIndPrevNotMissing, lIndNextNotMissing, lMissingLength) + If Double.IsNaN(aMaxFillLength) OrElse lMissingLength < aMaxFillLength Then + If Not aFillInstances Is Nothing AndAlso lInd = lIndPrevNotMissing + 1 Then + '1st interval of a missing period, log/record it + Logger.Dbg("FillMissingByInterp: Starting " & DumpDate(lNewTSer.Dates.Value(lInd)) & ", interpolating over a span of " & lMissingLength & " days.") + aFillInstances.Add(lMissingLength) + End If + With lNewTSer + If Double.IsNaN(.Value(lIndPrevNotMissing)) Then 'missing at start, use first good value + .Value(lInd) = .Value(lIndNextNotMissing) + 'Logger.Dbg("FillMissingByInterp:UseFirstNotMissing:" & .Value(lInd)) + ElseIf Double.IsNaN(.Value(lIndNextNotMissing)) Then 'missing at end, use last good value + .Value(lInd) = .Value(lIndPrevNotMissing) + 'Logger.Dbg("FillMissingByInterp:UseLastNotMissing:" & .Value(lInd)) + Else 'values prev and next, interpolate + Dim lFracMissing As Double + With .Dates + lFracMissing = (.Value(lInd) - .Value(lIndPrevNotMissing)) / + (.Value(lIndNextNotMissing) - .Value(lIndPrevNotMissing)) + End With + Dim lIncValue As Double = lFracMissing * (.Value(lIndNextNotMissing) - .Value(lIndPrevNotMissing)) + .Value(lInd) = .Value(lIndPrevNotMissing) + lIncValue + 'Logger.Dbg("FillMissingByInterp:Interp:" & .Value(lInd) & ":" & lFracMissing & ":" & lIncValue) + End If + End With + End If + Else 'good value, remember index + lIndPrevNotMissing = lInd + End If + lInd += 1 + End While + Return lNewTSer + End Function + + Private Function FindNextNotMissing(ByVal aTser As atcTimeseries, ByVal aInd As Integer, Optional ByVal aMissingValue As Double = Double.NaN) As Integer + Dim lInd As Integer = aInd + While Double.IsNaN(aTser.Value(lInd)) OrElse Math.Abs(aTser.Value(lInd) - aMissingValue) < 0.00001 + lInd += 1 + If lInd >= aTser.numValues Then + Return aTser.numValues + End If + End While + Return lInd + End Function + + ''' Aggregate specified timeseries to interval specified + ''' Timeseries to aggregate + ''' Time units to aggregate to + ''' Time step to aggregate to (number of time units) + ''' Transformation to use in aggregation + ''' Data Source to assign to newly created subset timeseries, can be Nothing + ''' Aggregated timeseries + ''' + Public Function Aggregate(ByVal aTimeseries As atcTimeseries, _ + ByVal aTU As atcTimeUnit, _ + ByVal aTS As Integer, _ + ByVal aTran As atcTran, _ + Optional ByVal aDataSource As atcTimeseriesSource = Nothing) As atcTimeseries + If aTimeseries.Attributes.GetValue("tu") = aTU AndAlso _ + aTimeseries.Attributes.GetValue("ts") = aTS Then + ' Already have desired time unit and time step, clone so we consistently return a new TS + Return aTimeseries.Clone(aDataSource) + Else + Dim lNewDates() As Double = NewDates(aTimeseries, aTU, aTS) + Dim lNumNewVals As Integer = lNewDates.GetUpperBound(0) + If lNumNewVals > 0 Then + Dim lNaN As Double = GetNaN() + Dim lNewTSer As New atcTimeseries(aDataSource) + lNewTSer.Dates = New atcTimeseries(aDataSource) + CopyBaseAttributes(aTimeseries, lNewTSer) + lNewTSer.SetInterval(aTU, aTS) + lNewTSer.Attributes.SetValue("point", False) + If aTimeseries.ValueAttributesExist Then 'TODO:: Something with value attributes + End If + lNewTSer.Dates.Values = lNewDates + Dim lNewIndex As Integer = 1 + Dim lNewVals(lNumNewVals) As Double + Dim lDateNew As Double = lNewDates(1) + Dim lDateOld As Double + Dim lValOld As Double + Dim lOldIndex As Integer = 1 + Dim lPrevDateOld As Double = lNewDates(0) 'old and new TSers should have same start date + Dim lPrevDateNew As Double = lNewDates(0) + Dim lOverlapStart As Double + Dim lOverlapEnd As Double + Dim lNumOldVals As Integer = aTimeseries.numValues + Dim lFraction As Double 'Fraction of the new time step that is being filled by the current old value + Dim lCumuFrac As Double 'Cumulative Fraction of the current new time step that has been filled from aTimeseries + + If aTimeseries.numValues > 0 Then + lValOld = aTimeseries.Value(1) + lDateOld = aTimeseries.Dates.Value(1) + End If + + Select Case aTran + Case atcTran.TranAverSame, atcTran.TranSumDiv + While lNewIndex <= lNumNewVals + lDateNew = lNewDates(lNewIndex) + lNewVals(lNewIndex) = 0 + While lPrevDateOld < lDateNew And lOldIndex <= lNumOldVals + If lPrevDateOld > lPrevDateNew Then lOverlapStart = lPrevDateOld Else lOverlapStart = lPrevDateNew + If lDateNew > lDateOld Then lOverlapEnd = lDateOld Else lOverlapEnd = lDateNew + lFraction = (lOverlapEnd - lOverlapStart) / (lDateNew - lPrevDateNew) + lCumuFrac += lFraction + If aTran = atcTran.TranSumDiv Then + lFraction = (lOverlapEnd - lOverlapStart) / (lDateOld - lPrevDateOld) + End If + lNewVals(lNewIndex) += lFraction * lValOld + If lPrevDateOld < lDateNew Then + If lDateOld > lDateNew Then 'use remaining part of this old interval on next new interval + lPrevDateOld = lDateNew + If aTran = atcTran.TranSumDiv Then lValOld = lValOld - lValOld * lFraction + Else +NextOldVal: + lPrevDateOld = lDateOld + lOldIndex = lOldIndex + 1 + If lOldIndex <= lNumOldVals Then + lDateOld = aTimeseries.Dates.Value(lOldIndex) + lValOld = aTimeseries.Value(lOldIndex) + If Double.IsNaN(lValOld) AndAlso aTimeseries.ValueAttributesGetValue(lOldIndex, "Inserted", False) Then + lCumuFrac += (lDateOld - lPrevDateOld) / (lDateNew - lPrevDateNew) + GoTo NextOldVal + End If + End If + 'lCumuFrac = 0 + End If + End If + End While + lPrevDateNew = lDateNew + If aTran = atcTran.TranSumDiv AndAlso lCumuFrac > 0.01 AndAlso lCumuFrac < 0.999 Then + lNewVals(lNewIndex) = lNewVals(lNewIndex) / lCumuFrac + lCumuFrac = 0 + End If + lNewIndex = lNewIndex + 1 + End While + Case atcTran.TranMax + Dim lMinValue As Double = GetMinValue() + While lNewIndex <= lNumNewVals + lDateNew = lNewDates(lNewIndex) + lNewVals(lNewIndex) = lMinValue + While lDateOld <= lDateNew AndAlso lOldIndex <= lNumOldVals + If lValOld > lNewVals(lNewIndex) Then lNewVals(lNewIndex) = lValOld + lOldIndex = lOldIndex + 1 + If lOldIndex <= lNumOldVals Then + lDateOld = aTimeseries.Dates.Value(lOldIndex) + lValOld = aTimeseries.Value(lOldIndex) + End If + End While + If lNewVals(lNewIndex) = lMinValue Then + lNewVals(lNewIndex) = lNaN + End If + lNewIndex = lNewIndex + 1 + End While + + Case atcTran.TranMin + Dim lMaxValue As Double = GetMaxValue() + While lNewIndex <= lNumNewVals + lDateNew = lNewDates(lNewIndex) + lNewVals(lNewIndex) = lMaxValue + While lDateOld <= lDateNew AndAlso lOldIndex <= lNumOldVals + If lValOld < lNewVals(lNewIndex) Then lNewVals(lNewIndex) = lValOld + lOldIndex = lOldIndex + 1 + If lOldIndex <= lNumOldVals Then + lDateOld = aTimeseries.Dates.Value(lOldIndex) + lValOld = aTimeseries.Value(lOldIndex) + End If + End While + If lNewVals(lNewIndex) = lMaxValue Then + lNewVals(lNewIndex) = lNaN + End If + lNewIndex = lNewIndex + 1 + End While + Case atcTran.TranCountMissing + While lNewIndex <= lNumNewVals + lDateNew = lNewDates(lNewIndex) + lNewVals(lNewIndex) = 0 + While lDateOld <= lDateNew AndAlso lOldIndex <= lNumOldVals + If Double.IsNaN(lValOld) Then lNewVals(lNewIndex) += 1 + lOldIndex = lOldIndex + 1 + If lOldIndex <= lNumOldVals Then + lDateOld = aTimeseries.Dates.Value(lOldIndex) + lValOld = aTimeseries.Value(lOldIndex) + End If + End While + lNewIndex = lNewIndex + 1 + End While + End Select + lNewTSer.Values = lNewVals + Return lNewTSer + Else + Return Nothing + End If + End If + End Function + + ''' Aggregate specified timeseries to interval specified, using the specified attribute value for each time step + ''' Timeseries to aggregate + ''' Time units to aggregate to + ''' Time step to aggregate to (number of time units) + ''' Attribute to compute from values in aTimeseries within each new time step to use in new Timeseries + ''' Data Source to assign to newly created subset timeseries, can be Nothing + ''' Aggregated timeseries + Public Function AggregateByAttribute(ByVal aTimeseries As atcTimeseries, _ + ByVal aTU As atcTimeUnit, _ + ByVal aTS As Integer, _ + ByVal aAttributeName As String, _ + ByVal aDataSource As atcTimeseriesSource) As atcTimeseries + If aTimeseries.Attributes.GetValue("tu") = aTU AndAlso _ + aTimeseries.Attributes.GetValue("ts") = aTS Then + ' Already have desired time unit and time step, clone so we consistently return a new TS + Return aTimeseries.Clone(aDataSource) + Else + Dim lNewDates() As Double = NewDates(aTimeseries, aTU, aTS) + Dim lNumNewVals As Integer = lNewDates.GetUpperBound(0) + If lNumNewVals > 0 Then + Dim lNaN As Double = GetNaN() + Dim lNewTSer As New atcTimeseries(aDataSource) + lNewTSer.Dates = New atcTimeseries(aDataSource) + CopyBaseAttributes(aTimeseries, lNewTSer) + lNewTSer.SetInterval(aTU, aTS) + lNewTSer.Attributes.SetValue("point", False) + If aTimeseries.ValueAttributesExist Then 'TODO:: Something with value attributes + End If + lNewTSer.Dates.Values = lNewDates + Dim lNewIndex As Integer = 1 + Dim lNewVals(lNumNewVals) As Double + Dim lDateNew As Double = lNewDates(1) + Dim lDateOld As Double + Dim lValOld As Double + Dim lOldIndex As Integer = 1 + Dim lPrevDateOld As Double = lNewDates(0) 'old and new TSers should have same start date + Dim lPrevDateNew As Double = lNewDates(0) + Dim lNumOldVals As Integer = aTimeseries.numValues + + If aTimeseries.numValues > 0 Then + lValOld = aTimeseries.Value(1) + lDateOld = aTimeseries.Dates.Value(1) + End If + + While lNewIndex <= lNumNewVals + Dim lThisTimeStepTs As atcTimeseries = SubsetByDate(aTimeseries, lNewDates(lNewIndex - 1), lNewDates(lNewIndex), Nothing) + lDateNew = lNewDates(lNewIndex) + lNewVals(lNewIndex) = lThisTimeStepTs.Attributes.GetValue(aAttributeName, lNaN) + lNewIndex = lNewIndex + 1 + End While + lNewTSer.Values = lNewVals + Return lNewTSer + Else + Return Nothing + End If + End If + End Function + + 'Build Date array for a timeseries with start/end of aTSer and time units/step of aTU/aTS + Public Function NewDates(ByVal aTSer As atcTimeseries, ByVal aTU As atcTimeUnit, ByVal aTS As Integer) As Double() + Dim lSJDay As Double + Dim lEJDay As Double + If aTU >= atcTimeUnit.TUSecond AndAlso aTU <= atcTimeUnit.TUCentury Then + 'get start date/time for existing TSer + aTSer.EnsureValuesRead() + Dim lDate(5) As Integer + If aTSer.Dates.Value(0) <= 0 OrElse Double.IsNaN(aTSer.Dates.Value(0)) Then + If aTSer.Attributes.ContainsAttribute("tu") Then + J2Date(TimAddJ(aTSer.Dates.Value(1), aTSer.Attributes.GetValue("tu"), aTSer.Attributes.GetValue("ts", 1), -1), lDate) + ElseIf aTSer.numValues > 1 Then + J2Date(aTSer.Dates.Value(1) - (aTSer.Dates.Value(2) - aTSer.Dates.Value(1)), lDate) + End If + Else + J2Date(aTSer.Dates.Value(0), lDate) + End If + Dim lSDate(5) As Integer + Select Case aTU + Case atcTimeUnit.TUSecond + Case atcTimeUnit.TUMinute + lDate(5) = 0 'clear seconds + Case atcTimeUnit.TUHour + lDate(4) = 0 'clear minutes + lDate(5) = 0 'clear seconds + Case atcTimeUnit.TUDay + lDate(3) = 0 'clear hours + lDate(4) = 0 'clear minutes + lDate(5) = 0 'clear seconds + Case atcTimeUnit.TUMonth + lDate(2) = 1 'set to beginning of month + lDate(3) = 0 'clear hours + lDate(4) = 0 'clear minutes + lDate(5) = 0 'clear seconds + Case atcTimeUnit.TUYear + 'Skip setting month and day to allow drought/flood years to be preserved + 'lDate(1) = 1 'set to beginning of Jan + 'lDate(2) = 1 'set to beginning of month + lDate(3) = 0 'clear hours + lDate(4) = 0 'clear minutes + lDate(5) = 0 'clear seconds + Case atcTimeUnit.TUCentury + lDate(0) = Math.Floor(lDate(0) / 100) * 100 + lDate(1) = 1 'set to beginning of Jan + lDate(2) = 1 'set to beginning of month + lDate(3) = 0 'clear hours + lDate(4) = 0 'clear minutes + lDate(5) = 0 'clear seconds + End Select + lSJDay = Date2J(lDate) + For lEndIndex As Integer = aTSer.numValues To 0 Step -1 + If Not Double.IsNaN(aTSer.Value(lEndIndex)) Then + lEJDay = aTSer.Dates.Value(lEndIndex) + Exit For + End If + Next + End If + Return NewDates(lSJDay, lEJDay, aTU, aTS) + End Function + + ''' + ''' Build a constant-interval date array + ''' + ''' Beginning of the first interval + ''' End of the last interval + ''' Time Units + ''' Time Step (number of Time Units per step) + Public Function NewDates(ByVal aStartDate As Double, ByVal aEndDate As Double, ByVal aTU As atcTimeUnit, ByVal aTS As Integer) As Double() + Dim lNewDates(0) As Double + If aTU >= atcTimeUnit.TUSecond AndAlso aTU <= atcTimeUnit.TUCentury Then + Dim lNewNumDates As Integer = timdifJ(aStartDate, aEndDate, aTU, aTS) + ReDim lNewDates(lNewNumDates) + lNewDates(0) = aStartDate + For i As Integer = 1 To lNewNumDates + lNewDates(i) = TimAddJ(aStartDate, aTU, aTS, i) + Next + End If + Return lNewDates + End Function + + Public Function NewTimeseries(ByVal aStartDate As Double, ByVal aEndDate As Double, _ + ByVal aTU As atcTimeUnit, ByVal aTS As Integer, _ + Optional ByVal aDataSource As atcTimeseriesSource = Nothing, _ + Optional ByVal aSetAllValues As Double = 0) As atcTimeseries + Dim lDates As New atcTimeseries(aDataSource) + lDates.Values = NewDates(aStartDate, aEndDate, aTU, aTS) + Dim lNewTimeseries As New atcTimeseries(aDataSource) + lNewTimeseries.Dates = lDates + lNewTimeseries.numValues = lNewTimeseries.Dates.numValues + lNewTimeseries.Value(0) = GetNaN() + Try + If Double.IsNaN(aSetAllValues) OrElse aSetAllValues <> 0 Then + For lIndex As Integer = 1 To lNewTimeseries.numValues + lNewTimeseries.Value(lIndex) = aSetAllValues + Next + End If + Catch 'For some reason, the above If sometimes triggers an exception when aSetAllValuesis NaN, same loop as above + For lIndex As Integer = 1 To lNewTimeseries.numValues + lNewTimeseries.Value(lIndex) = aSetAllValues + Next + End Try + lNewTimeseries.SetInterval(aTU, aTS) + Return lNewTimeseries + End Function + + + ''Make bins, sort data values into the bins, and assign collection of Bins as new attribute + 'Public Sub MakeBins(ByVal aTS As atcTimeseries, Optional ByVal aMaxBinSize As Integer = 100) + ' Dim lNumValues As Integer = aTS.numValues + ' Dim lCurValue As Double + ' Dim lBinIndex As Integer + ' Dim lCurBin As New ArrayList + ' Dim lBins As New atcCollection + ' lBins.Add(aTS.Attributes.GetValue("Max"), lCurBin) + + ' Logger.Dbg("Sorting " & lNumValues & " values into bins of at most " & aMaxBinSize) + ' For lOldIndex As Integer = 1 To lNumValues + ' lCurValue = aTS.Value(lOldIndex) + + ' 'find first bin with maximum >= lCurValue + ' lBinIndex = 0 + ' While lCurValue > lBins.Keys(lBinIndex) + ' lBinIndex += 1 + ' End While + ' lCurBin = lBins.Item(lBinIndex) + + ' 'Insert in numeric order within bin + ' Dim lInsertIndex As Integer = 0 + ' Dim lLastIndex As Integer = lCurBin.Count - 1 + ' If lLastIndex > -1 Then 'Find position to insert + ' While lCurValue > lCurBin.Item(lInsertIndex) + ' lInsertIndex += 1 + ' If lInsertIndex > lLastIndex Then Exit While + ' End While + ' End If + ' lCurBin.Insert(lInsertIndex, lCurValue) + + ' If lCurBin.Count > aMaxBinSize Then + ' SplitBin(lBins, lCurBin, lBinIndex) + ' End If + + ' Next + ' Logger.Dbg("Created " & lBins.Count & " bins") + ' For lBinIndex = 0 To lBins.Count - 1 + ' lCurBin = lBins.Item(lBinIndex) + ' Logger.Dbg("Bin " & lBinIndex & " (" & lBins.Keys(lBinIndex) & ") contains " & lCurBin.Count) + ' For Each lCurValue In lCurBin + ' Logger.Dbg(DoubleToString(lCurValue)) + ' Next + ' lNumValues -= lCurBin.Count + ' Next + ' If lNumValues <> 0 Then + ' Logger.Dbg("Wrong number of values in bins -- " & lNumValues & " were in dataset but not in bins") + ' End If + ' aTS.Attributes.SetValue("Bins", lBins) + 'End Sub + + 'Make bins, sort data values into the bins + 'Default maximum bin size is 1% of total number of values + Public Function MakeBins(ByVal aTS As atcTimeseries, Optional ByVal aMaxBinSize As Integer = 0) As atcCollection + Dim lNumValues As Integer = aTS.numValues + Dim lCurValue As Double + Dim lCurBinMax As Double = aTS.Attributes.GetValue("Max") + Dim lBinIndex As Integer = 0 + Dim lCurBin As New ArrayList + Dim lBins As New atcCollection 'Keys of lBins are the maximum value in each bin + lBins.Add(lCurBinMax, lCurBin) 'First bin created is assigned maximum value for dataset + 'Bins created later are inserted before this bin, which remains the "last" bin containing the highest values + If aMaxBinSize < 1 Then + aMaxBinSize = lNumValues / 100 'Default to max of 1% of values in each bin + If aMaxBinSize < 10 Then aMaxBinSize = 10 + End If + 'Logger.Progress("Sorting values from " & aTS.ToString & " into bins. ", 0, lNumValues) + For lOldIndex As Integer = 1 To lNumValues + lCurValue = aTS.Value(lOldIndex) + If Not Double.IsNaN(lCurValue) Then + 'If the previously used bin does not fit, find first bin with maximum >= lCurValue + 'If lCurValue > lCurBinMax OrElse (lBinIndex > 0 AndAlso lCurValue < lBins.Keys.Item(lBinIndex - 1)) Then + lBinIndex = BinarySearchFirstGreaterDoubleArrayList(lBins.Keys, lCurValue) + lCurBin = lBins.Item(lBinIndex) + 'lCurBinMax = lBins.Keys.Item(lBinIndex) + 'End If + + 'Insert in numeric order within bin + Dim lInsertIndex As Integer = BinarySearchFirstGreaterDoubleArrayList(lCurBin, lCurValue) + lCurBin.Insert(lInsertIndex, lCurValue) + + If lCurBin.Count > aMaxBinSize Then + SplitBin(lBins, lCurBin, lBinIndex) + ' lCurBin = lBins.Item(lBinIndex) + ' lCurBinMax = lBins.Keys.Item(lBinIndex) + 'Logger.Progress("Sorting values into " & lBins.Count & " bins", lOldIndex, lNumValues) + End If + End If + Next + Logger.Dbg("Sorted values into " & lBins.Count & " bins", lNumValues, lNumValues) + 'For lBinIndex = 0 To lBins.Count - 1 + ' lCurBin = lBins.Item(lBinIndex) + ' Logger.Dbg("Bin " & lBinIndex & " (" & lBins.Keys(lBinIndex) & ") contains " & lCurBin.Count) + ' For Each lCurValue In lCurBin + ' Logger.Dbg(DoubleToString(lCurValue)) + ' Next + ' lNumValues -= lCurBin.Count + 'Next + 'If lNumValues <> 0 Then + ' Logger.Dbg("Wrong number of values in bins -- " & lNumValues & " were in dataset but not in bins") + 'End If + Return lBins + End Function + + 'aBins = collection of bins + 'aBin = bin to be split in half + 'aBinIndex = current index of aBin in aBins + Private Sub SplitBin(ByVal aBins As atcCollection, ByVal aBin As ArrayList, ByVal aBinIndex As Integer) + Dim lSplitStart As Integer = 0 + Dim lSplitCount As Integer = aBin.Count / 2 + Dim lNewBin As New ArrayList(aBin.GetRange(lSplitStart, lSplitCount)) + aBin.RemoveRange(lSplitStart, lSplitCount) + aBins.Insert(aBinIndex, lNewBin.Item(lSplitCount - 1), lNewBin) + End Sub + + Public Function GetPercentileOf(ByVal aTser As atcTimeseries, ByVal aValue As Double) As Double + Dim lPercentile As Double = pNaN + If aTser IsNot Nothing AndAlso Not Double.IsNaN(aValue) Then + Dim ValueIndex As Integer = 0 + Dim lBins As atcCollection = aTser.Attributes.GetValue("Bins", Nothing) + If lBins IsNot Nothing Then + For Each lBin As ArrayList In lBins + If aValue < lBin(0) Then Exit For + If aValue > lBin(lBin.Count - 1) Then + ValueIndex += lBin.Count - 1 + Else + Dim lBinValueIndex As Integer = BinarySearchFirstGreaterDoubleArrayList(lBin, aValue) + ValueIndex += lBinValueIndex + End If + Next + lPercentile = ValueIndex * 100.0 / aTser.numValues + End If + End If + Return lPercentile + End Function + + ''' + ''' Binary search through an ArrayList containing Double values sorted in ascending order + ''' + ''' Array to search + ''' Value to search for + ''' Return the index of the first value >= aValue + ''' Returns aArray.Count if aArray contains no values >= aValue + Private Function BinarySearchFirstGreaterDoubleArrayList(ByVal aArray As ArrayList, ByVal aValue As Double) As Integer + Dim lHigher As Integer = aArray.Count - 1 + If lHigher < 0 Then Return 0 'No values present to compare to + Dim lLower As Integer = -1 'Note: this starts one *lower than* start of where to search in array + Dim lProbe As Integer + While (lHigher - lLower > 1) + lProbe = (lHigher + lLower) / 2 + If aArray(lProbe) < aValue Then + lLower = lProbe + Else + lHigher = lProbe + End If + End While + If aValue > aArray(lHigher) Then + Return lHigher + 1 + Else + Return lHigher + End If + End Function + + ''' + ''' Assign integers from one to the number of non-missing values to the Rank value attributes + ''' + ''' Values to compute ranks of + ''' If True, lowest value gets rank of 1, if False, highest value gets rank of 1 + ''' + ''' If True, identical values get the same rank and next rank is not assigned, ex: (5, 5, 9, 7) get ranks (1, 1, 4, 3) + ''' If False and aLowToHigh is False, earlier value gets lower rank (5, 5, 9, 7) get ranks (1, 2, 4, 3) + ''' If False and aLowToHigh is True, later value gets lower rank (5, 5, 9, 7) get ranks (2, 1, 4, 3) + ''' + ''' + Public Sub ComputeRanks(ByVal aTimeseries As atcTimeseries, _ + ByVal aLowToHigh As Boolean, _ + ByVal aAllowTies As Boolean) + Dim lNaN As Double = GetNaN() + Dim lValue As Double + Dim lValuesSorted As New Generic.List(Of Double) + Dim lFirstValue As Boolean = True + For Each lValue In aTimeseries.Values + If lFirstValue Then + lFirstValue = False + ElseIf Not Double.IsNaN(lValue) Then + lValuesSorted.Add(lValue) + End If + Next + lValuesSorted.Sort() + Dim lRank As Integer + Dim lLastIndex As Integer = aTimeseries.numValues + For lIndex As Integer = 1 To lLastIndex + lValue = aTimeseries.Value(lIndex) + If Not Double.IsNaN(lValue) Then + If aLowToHigh Then + ' 1 = lowest value + For lRank = 1 To lValuesSorted.Count + If lValuesSorted(lRank - 1) >= lValue Then + If Not aAllowTies Then + lValuesSorted(lRank - 1) = lNaN + End If + aTimeseries.ValueAttributes(lIndex).SetValue("Rank", lRank) + Exit For + End If + Next + Else 'High to Low, 1 = highest value + If aAllowTies Then + For lRank = 1 To lValuesSorted.Count + If lValuesSorted(lValuesSorted.Count - lRank) <= lValue Then + aTimeseries.ValueAttributes(lIndex).SetValue("Rank", lRank) + Exit For + End If + Next + Else 'Give earlier value higher rank in a tie by stepping backward through ranks + For lRank = lValuesSorted.Count To 1 Step -1 + If lValuesSorted(lValuesSorted.Count - lRank) >= lValue Then + lValuesSorted(lValuesSorted.Count - lRank) = lNaN + aTimeseries.ValueAttributes(lIndex).SetValue("Rank", lRank) + Exit For + End If + Next + End If + End If + End If + Next + End Sub + + ''' Compute sum value at specified percentile of specified timeseries + ''' Timeseries to analyze. + ''' Percentile to compute. + ''' Computed percentile stored in attribute within timeseries with attribute name built from percentile value prefixed with '%Sum' + Public Sub ComputePercentileSum(ByVal aTimeseries As atcTimeseries, ByVal aPercentile As Double) + Dim lAttrName As String = "%sum" & Format(aPercentile, "00.####") + Dim lNumValues As Integer = aTimeseries.numValues - aTimeseries.Attributes.GetValue("Count Missing") + Select Case lNumValues + Case Is < 1 + 'Can't compute with no values + Case 1 + aTimeseries.Attributes.SetValue(lAttrName, aTimeseries.Value(0)) + Case Else + Dim lBins As atcCollection = aTimeseries.Attributes.GetValue("Bins") + Dim lCountPercentileDone As Integer = aPercentile * lNumValues / 100.0 - 1 + If lCountPercentileDone < 0 Then lCountPercentileDone = 0 + If lCountPercentileDone >= lNumValues Then lCountPercentileDone = lNumValues - 1 + + Dim lSum As Double = 0 + Dim lCount As Integer = 0 + For Each lBin As ArrayList In lBins + For Each lValue As Double In lBin + If lCount >= lCountPercentileDone Then GoTo Finished + lCount += 1 + lSum += lValue + Next + Next +Finished: + aTimeseries.Attributes.SetValue(lAttrName, lSum) + End Select + End Sub + + ''' Compute value at specified percentile of specified timeseries + ''' Timeseries to analyze. + ''' Percentile to compute. + ''' The value from aTimeseries closest to the specified percentile position + ''' Computed percentile stored in attribute within timeseries with attribute name built from percentile value prefixed with '%' + Public Function ComputePercentile(ByVal aTimeseries As atcTimeseries, ByVal aPercentile As Double) As Double + Dim lAttrName As String = "%" & Format(aPercentile, "00.####") + Dim lNumValues As Integer = aTimeseries.numValues - aTimeseries.Attributes.GetValue("Count Missing") + Dim lReturnValue As Double + Select Case lNumValues + Case Is < 1 + 'Can't compute with no values + lReturnValue = GetNaN() + Case 1 + lReturnValue = aTimeseries.Value(0) + aTimeseries.Attributes.SetValue(lAttrName, lReturnValue) + Case Else + Dim lBins As atcCollection = aTimeseries.Attributes.GetValue("Bins") + 'TODO: could interpolate between closest two values rather than choosing closest one, should we? + Dim lAccumulatedCount As Integer = 0 + Dim lNextAccumulatedCount As Integer = 0 + Dim lBinIndex As Integer = -1 + Dim lPercentileIndex As Integer = aPercentile * lNumValues / 100.0 - 1 + If lPercentileIndex < 0 Then lPercentileIndex = 0 + If lPercentileIndex >= lNumValues Then lPercentileIndex = lNumValues - 1 + While lNextAccumulatedCount <= lPercentileIndex + lAccumulatedCount = lNextAccumulatedCount + lBinIndex += 1 + lNextAccumulatedCount = lAccumulatedCount + lBins(lBinIndex).Count + End While + Dim lBin As ArrayList = lBins(lBinIndex) + lReturnValue = lBin.Item(lPercentileIndex - lAccumulatedCount) + aTimeseries.Attributes.SetValue(lAttrName, lReturnValue) + End Select + Return lReturnValue + End Function + + ''' + ''' Fit a line through a set of data points using least squares regression. + ''' + ''' + ''' + ''' 'a' coefficient in regression line (y=ax+b) + ''' 'b' coefficient in regression line (y=ax+b) + ''' 'r squared', the coefficient of determination + ''' from fortran-newaqt-FITLIN; x, y values can't be the same values + Public Sub FitLine(ByVal aTSerX As atcTimeseries, ByVal aTSerY As atcTimeseries, _ + ByRef aACoef As Double, ByRef aBCoef As Double, ByRef aRSquare As Double, ByRef aNote As String) + aNote = "" + If aTSerX.numValues <> aTSerY.numValues Then + aNote &= aTSerX.ToString & " has " & aTSerX.numValues & " values, " & _ + aTSerY.ToString & " has " & aTSerY.numValues & "." & vbCrLf + End If + If Math.Abs(aTSerX.Dates.Value(0) - aTSerY.Dates.Value(0)) > JulianSecond Then + aNote &= aTSerX.ToString & " starts on " & aTSerX.Dates.Value(0).ToString & ", " & + aTSerY.ToString & " starts on " & aTSerY.Dates.Value(0).ToString & "." & vbCrLf + End If + If aNote.Length > 0 Then + Throw New ApplicationException("Time series are not compatible." & vbCrLf & aNote) + End If + + Dim lSumX As Double = 0.0 + Dim lValX As Double + Dim lAvgX As Double + + Dim lSumY As Double = 0.0 + Dim lValY As Double + Dim lAvgY As Double + Dim lSkipCount As Integer = 0 + Dim lGoodCount As Integer = 0 + + For lIndex As Integer = 1 To aTSerX.numValues + lValX = aTSerX.Value(lIndex) + lValY = aTSerY.Value(lIndex) + If Not Double.IsNaN(lValX) AndAlso Not Double.IsNaN(lValY) Then + lSumX += lValX + lSumY += lValY + lGoodCount += 1 + Else + lSkipCount += 1 + If lSkipCount = 1 Then + aNote = "Skipped missing index " & lIndex + End If + End If + Next + If aNote.Length > 0 AndAlso lSkipCount > 1 Then + aNote &= " and " & lSkipCount - 1 & " more" & vbCrLf + End If + + If (lGoodCount > 0) Then 'go ahead and compute lSumX > 0.0 AndAlso lSumY > 0.0 AndAlso + Try 'Added Try Catch for linear regression for cases when timeseries has only 0 values. + lAvgX = lSumX / lGoodCount + lAvgY = lSumY / lGoodCount + + Dim lSum3 As Double = 0.0 + Dim lSum4 As Double = 0.0 + For lIndex As Integer = 1 To aTSerX.numValues + lValX = aTSerX.Value(lIndex) + lValY = aTSerY.Value(lIndex) + If Not Double.IsNaN(lValX) AndAlso Not Double.IsNaN(lValY) Then + lSum3 += (lValX - lAvgX) * (lValY - lAvgY) + lSum4 += (lValY - lAvgY) * (lValY - lAvgY) + End If + Next lIndex + aACoef = lSum3 / lSum4 + aBCoef = lAvgX - (aACoef * lAvgY) + + Dim lSum5 As Double = 0 + Dim lSum6 As Double = 0 + For lIndex As Integer = 1 To aTSerX.numValues + lValX = aTSerX.Value(lIndex) + lValY = aTSerY.Value(lIndex) + If Not Double.IsNaN(lValX) AndAlso Not Double.IsNaN(lValY) Then + lSum5 += ((aACoef * lValY + aBCoef - lAvgX) * (aACoef * lValY) + aBCoef - lAvgX) + lSum6 += (lValX - lAvgX) * (lValX - lAvgX) + End If + Next lIndex + aRSquare = lSum5 / lSum6 + aRSquare = ComputeR(aTSerX, aTSerY) ^ 2 + Catch ex As Exception 'Should I add a statement saying that linear regression could not be calculated? + aACoef = GetNaN() + aBCoef = GetNaN() + aRSquare = GetNaN() + End Try + + Else 'regression doesnt make sense, return NaN + aACoef = GetNaN() + aBCoef = GetNaN() + aRSquare = GetNaN() + End If + If aNote.Length > 0 Then + Logger.Dbg("Note:" & aNote) + End If + End Sub + + Public Function ComputeR(ByVal aTSerX As atcTimeseries, ByVal aTSerY As atcTimeseries) As Double + + Dim lNote As String = "" + If aTSerX.numValues <> aTSerY.numValues Then + lNote &= aTSerX.ToString & " has " & aTSerX.numValues & " values, " & _ + aTSerY.ToString & " has " & aTSerY.numValues & "." & vbCrLf + End If + If Math.Abs(aTSerX.Dates.Value(0) - aTSerY.Dates.Value(0)) > JulianSecond Then + lNote &= aTSerX.ToString & " starts on " & aTSerX.Dates.Value(0).ToString & ", " & + aTSerY.ToString & " starts on " & aTSerY.Dates.Value(0).ToString & "." & vbCrLf + End If + If lNote.Length > 0 Then + Throw New ApplicationException("Time series are not compatible." & vbCrLf & lNote) + End If + + Dim x As Double + Dim y As Double + Dim lSkipCount As Integer = 0 + Dim lGoodCount As Integer = 0 + + Dim sumOfX As Double = 0 + Dim sumOfY As Double = 0 + Dim sumOfXSq As Double = 0 + Dim sumOfYSq As Double = 0 + Dim ssX As Double = 0 + Dim ssY As Double = 0 + Dim sumCodeviates As Double = 0 + Dim sCo As Double = 0 + + For lIndex As Integer = 1 To aTSerX.numValues + x = aTSerX.Value(lIndex) + y = aTSerY.Value(lIndex) + If Not Double.IsNaN(x) AndAlso Not Double.IsNaN(y) Then + sumCodeviates += (x * y) + sumOfX += x + sumOfY += y + sumOfXSq += (x * x) + sumOfYSq += (y * y) + lGoodCount += 1 + Else + lSkipCount += 1 + End If + Next + + If (sumOfX > 0.0 AndAlso sumOfY > 0.0 AndAlso lGoodCount > 0) Then 'go ahead and compute + + ssX = sumOfXSq - ((sumOfX * sumOfX) / lGoodCount) + ssY = sumOfYSq - ((sumOfY * sumOfY) / lGoodCount) + Dim RNumerator As Double = (lGoodCount * sumCodeviates) - (sumOfX * sumOfY) + + Dim RDenom As Double = (lGoodCount * sumOfXSq - sumOfX ^ 2) * (lGoodCount * sumOfYSq - sumOfY ^ 2) + Dim dblR As Double = RNumerator / Math.Sqrt(RDenom) + Return dblR + 'sCo = sumCodeviates - ((sumOfX * sumOfY) / lGoodCount) + 'Dim dblSlope As Double = sCo / ssX + 'Dim meanX As Double = sumOfX / lGoodCount + 'Dim meanY As Double = sumOfY / lGoodCount + 'Dim dblYintercept As Double = meanY - (dblSlope * meanX) + + 'Console.WriteLine( “R-Squared: {0}”, Math.Pow( dblR, 2 ) ) ; + 'Console.WriteLine( “Y-Intercept: {0}”, dblYIntercept ) ; + 'Console.WriteLine( “Slope: {0}”, dblSlope ) ; + 'Console.ReadLine() ; + + 'aACoef = dblSlope + 'aBCoef = dblYintercept + 'aRSquare = dblR ^ 2 + + Else 'regression doesnt make sense, return NaN + Return GetNaN() + 'aACoef = GetNaN() + 'aBCoef = GetNaN() + 'aRSquare = GetNaN() + End If + + End Function + + ''' Perform a math operation on one or more timeseries + ''' Math operation + ''' Arguments needed by math operation + ''' Timeseries containing result of math operation + ''' Args are each usually either Double or atcTimeseries + Public Function DoMath(ByVal aOperationName As String, _ + ByVal aArgs As atcDataAttributes) As atcTimeseries + Dim lArgCount As Integer = 0 + + Dim lNumber As Double = GetNaN() + Dim lHaveNumber As Boolean = False + Dim lNumberFirst As Boolean = False + If aArgs.ContainsAttribute("Number") AndAlso Not aArgs.GetValue("Number") Is Nothing Then + Dim lValue As Double = aArgs.GetValue("Number", pNaN) + If Not Double.IsNaN(lValue) Then + lHaveNumber = True + lArgCount += 1 + lNumber = lValue + lNumberFirst = aArgs.ItemByIndex(0).Definition.Name.ToLower = "number" + End If + End If + + Dim lTSgroup As atcTimeseriesGroup = TimeseriesGroupFromArguments(aArgs) + If lTSgroup Is Nothing OrElse lTSgroup.Count < 1 Then + Throw New ApplicationException(aOperationName & " did not get a Timeseries argument") + End If + + Dim lTSFirst As atcTimeseries = lTSgroup.Item(0) + Dim lTSOriginal As atcTimeseries = Nothing + If lTSgroup.Count > 1 Then + lTSOriginal = lTSgroup.Item(1) 'default the current ts to the one after the first + End If + + For Each lTs As atcTimeseries In lTSgroup + lTs.EnsureValuesRead() + Next + + Dim lValueIndex As Integer + Dim lValueIndexLast As Integer = lTSFirst.numValues + If lValueIndexLast < 1 Then + Throw New ApplicationException("Cannot compute " & aOperationName & " of empty dataset") + End If + Dim lNewVals() As Double ' If this gets populated, it will be turned into an atcTimeseries at the end + ReDim lNewVals(lValueIndexLast) + Array.Copy(lTSFirst.Values, lNewVals, lValueIndexLast + 1) 'copy values from firstTS + lArgCount += lTSgroup.Count + + 'TODO: check here for number of arguments instead of in each case? + + Dim lTSIndex As Integer + Select Case aOperationName.ToLower + Case "add", "+" + For lValueIndex = 0 To lValueIndexLast + If lHaveNumber Then lNewVals(lValueIndex) += lNumber + For lTSIndex = 1 To lTSgroup.Count - 1 + lTSOriginal = lTSgroup.Item(lTSIndex) + lNewVals(lValueIndex) += lTSOriginal.Value(lValueIndex) + Next + Next + + Case "subtract", "-" + For lValueIndex = 0 To lValueIndexLast + If lHaveNumber Then + If lNumberFirst Then + lNewVals(lValueIndex) = lNumber - lNewVals(lValueIndex) + Else + lNewVals(lValueIndex) -= lNumber + End If + End If + For lTSIndex = 1 To lTSgroup.Count - 1 + lTSOriginal = lTSgroup.Item(lTSIndex) + lNewVals(lValueIndex) -= lTSOriginal.Value(lValueIndex) + Next + Next + + Case "multiply", "*" + For lValueIndex = 0 To lValueIndexLast + If lHaveNumber Then lNewVals(lValueIndex) *= lNumber + For lTSIndex = 1 To lTSgroup.Count - 1 + lTSOriginal = lTSgroup.Item(lTSIndex) + lNewVals(lValueIndex) *= lTSOriginal.Value(lValueIndex) + Next + Next + + Case "divide", "/" + If lHaveNumber AndAlso Math.Abs(lNumber) < 0.000001 Then + Throw New ApplicationException(aOperationName & " divisor too close to zero (" & lNumber & ")") + End If + For lValueIndex = 0 To lValueIndexLast + If lHaveNumber Then + If lNumberFirst Then + lNewVals(lValueIndex) = lNumber / lNewVals(lValueIndex) + Else + lNewVals(lValueIndex) /= lNumber + End If + End If + For lTSIndex = 1 To lTSgroup.Count - 1 + lTSOriginal = lTSgroup.Item(lTSIndex) + lNewVals(lValueIndex) /= lTSOriginal.Value(lValueIndex) + Next + Next + + Case "mean" + For lValueIndex = 0 To lValueIndexLast + If lHaveNumber Then lNewVals(lValueIndex) += lNumber + For lTSIndex = 1 To lTSgroup.Count - 1 + lTSOriginal = lTSgroup.Item(lTSIndex) + lNewVals(lValueIndex) += lTSOriginal.Value(lValueIndex) + Next + lNewVals(lValueIndex) /= lArgCount + Next + + Case "geometric mean" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = Math.Log10(lNewVals(lValueIndex)) + If lHaveNumber Then lNewVals(lValueIndex) += Math.Log10(lNumber) + For lTSIndex = 1 To lTSgroup.Count - 1 + lTSOriginal = lTSgroup.Item(lTSIndex) + lNewVals(lValueIndex) += Math.Log10(lTSOriginal.Value(lValueIndex)) + Next + lNewVals(lValueIndex) = 10 ^ (lNewVals(lValueIndex) / lArgCount) + Next + + Case "min each date" + For lValueIndex = 0 To lValueIndexLast + If lHaveNumber Then + If lNumber < lNewVals(lValueIndex) Then lNewVals(lValueIndex) = lNumber + End If + For lTSIndex = 1 To lTSgroup.Count - 1 + lTSOriginal = lTSgroup.Item(lTSIndex) + If lTSOriginal.Value(lValueIndex) < lNewVals(lValueIndex) Then + lNewVals(lValueIndex) = lTSOriginal.Value(lValueIndex) + End If + Next + Next + + Case "max each date" + For lValueIndex = 0 To lValueIndexLast + If lHaveNumber Then + If lNumber > lNewVals(lValueIndex) Then lNewVals(lValueIndex) = lNumber + End If + For lTSIndex = 1 To lTSgroup.Count - 1 + lTSOriginal = lTSgroup.Item(lTSIndex) + If lTSOriginal.Value(lValueIndex) > lNewVals(lValueIndex) Then + lNewVals(lValueIndex) = lTSOriginal.Value(lValueIndex) + End If + Next + Next + + Case "exponent", "exp", "^", "**" + If lArgCount <> 2 Then + Err.Raise(vbObjectError + 512, , aOperationName & " required two arguments but got " & lArgCount) + ElseIf lHaveNumber Then + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) ^= lNumber + Next + Else + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) ^= lTSOriginal.Value(lValueIndex) + Next + End If + + Case "e**", "e ^ x" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = Math.Exp(lNewVals(lValueIndex)) + Next + + Case "10**", "10 ^ x" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = 10 ^ (lNewVals(lValueIndex)) + Next + + Case "log 10" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = Math.Log10(lNewVals(lValueIndex)) + Next + + Case "log e" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = Math.Log(lNewVals(lValueIndex)) + Next + + 'Case "line" + ' For valNum = 1 To NVALS + ' argNum = 1 + ' GoSub SetCurArgVal + ' dataval(valNum) = curArgVal + ' argNum = 2 + ' GoSub SetCurArgVal + ' dataval(valNum) = dataval(valNum) * curArgVal + ' argNum = 3 + ' GoSub SetCurArgVal + ' dataval(valNum) = dataval(valNum) + curArgVal + ' Next + + Case "sqrt" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = Math.Sqrt(lNewVals(lValueIndex)) + Next + + Case "abs", "absolute value" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = Math.Abs(lNewVals(lValueIndex)) + Next + + Case "ctof", "celsiustofahrenheit", "celsius to fahrenheit", "celsius to f" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = lNewVals(lValueIndex) * 9 / 5 + 32 + Next + + Case "ftoc", "fahrenheittocelsius", "fahrenheit to celsius", "f to celsius" + For lValueIndex = 0 To lValueIndexLast + lNewVals(lValueIndex) = (lNewVals(lValueIndex) - 32) * 5 / 9 + Next + + Case "subset by date" + If aArgs.ContainsAttribute("Start Date") AndAlso _ + aArgs.GetValue("Start Date") IsNot Nothing AndAlso _ + aArgs.ContainsAttribute("End Date") AndAlso _ + aArgs.GetValue("End Date") IsNot Nothing Then + Dim lArg As Object = aArgs.GetValue("Start Date") + If TypeOf (lArg) Is String Then + lArg = System.DateTime.Parse(lArg).ToOADate + End If + Dim lStartDate As Double = CDbl(lArg) + lArg = aArgs.GetValue("End Date") + If TypeOf (lArg) Is String Then + lArg = System.DateTime.Parse(lArg).ToOADate + End If + Dim EndDate As Double = CDbl(lArg) + Return SubsetByDate(lTSFirst, lStartDate, EndDate, Nothing) + End If + ReDim lNewVals(-1) 'Don't create new timeseries below + Case "subset by date boundary" + Dim lBoundaryMonth As Integer = aArgs.GetValue("Boundary Month") + Dim lBoundaryDay As Integer = aArgs.GetValue("Boundary Day") + Return SubsetByDateBoundary(lTSFirst, lBoundaryMonth, lBoundaryDay, Nothing) + + Case "merge" + Return MergeTimeseries(lTSgroup) + + Case "running sum" + 'TODO: ignore missing values - is this ok? + Dim lVal, lSum As Double + For lValueIndex = 1 To lValueIndexLast + lVal = lNewVals(lValueIndex) + If Not Double.IsNaN(lVal) Then + lNewVals(lValueIndex) += lSum + lSum = lNewVals(lValueIndex) + End If + Next + + 'Case "weight" + ' For valNum = 1 To NVALS + ' dataval(valNum) = 0 + ' argNum = 1 + ' While argNum < Nargs + ' GoSub SetCurArgVal + ' weightVal = curArgVal + ' argNum = argNum + 1 + ' GoSub SetCurArgVal + ' dataval(valNum) = dataval(valNum) + curArgVal * weightVal + ' argNum = argNum + 1 + ' End While + ' Next + 'Case "interpolate" + Case Else + ReDim lNewVals(-1) 'Don't create new timeseries + Err.Raise(vbObjectError + 512, , aOperationName & " not implemented") + End Select + + If lNewVals.GetUpperBound(0) >= 0 Then + Dim lNewTS As atcTimeseries = New atcTimeseries(Nothing) + lNewTS.Values = lNewVals + + If Not lTSFirst Is Nothing Then + lNewTS.Dates = lTSFirst.Dates + Else + Err.Raise(vbObjectError + 512, , "Did not get dates for new computed timeseries " & aOperationName) + End If + + If Not lTSgroup Is Nothing AndAlso lTSgroup.Count > 0 Then + If lTSgroup.Count = 1 Then + lNewTS.Attributes.SetValue("Original ID", lTSgroup.Item(0).OriginalParentID) + 'Else + ' lNewTS.Attributes.SetValue("Parent Timeseries Group", lTSgroup) + End If + End If + If lHaveNumber Then + lNewTS.Attributes.SetValue("Parent Constant", lNumber) + End If + + CopyBaseAttributes(lTSFirst, lNewTS, lNewTS.numValues + 1, 0, 0) + 'TODO: update attributes as appropriate! + + Dim lDateNow As Date = Now + lNewTS.Attributes.SetValue("Date Created", lDateNow) + lNewTS.Attributes.SetValue("Date Modified", lDateNow) + + Return lNewTS + End If + Return Nothing + End Function + + ''' + ''' Test whether aTimeseries contains provisional values by looking for P=True value attribute + ''' + Public Function HasProvisionalValues(ByVal aTimeseries As atcTimeseries) As Boolean + If aTimeseries.ValueAttributesExist Then + Dim lProvisionalAttribute As String = aTimeseries.Attributes.GetValue("ProvisionalValueAttribute", "P") + For lIndex As Integer = 0 To aTimeseries.numValues + If aTimeseries.ValueAttributesGetValue(lIndex, lProvisionalAttribute, False) Then + If Not Double.IsNaN(aTimeseries.Value(lIndex)) Then + Return True + End If + End If + Next + End If + Return False + End Function + + Public Sub SplitProvisional(ByVal aTimeseries As atcTimeseries, _ + ByRef aProvisionalTS As atcTimeseries, _ + ByRef aNonProvisionalTS As atcTimeseries) + aNonProvisionalTS = New atcTimeseries(Nothing) + aNonProvisionalTS.Dates = New atcTimeseries(Nothing) + aNonProvisionalTS.numValues = aTimeseries.numValues + aProvisionalTS = New atcTimeseries(Nothing) + aProvisionalTS.Dates = New atcTimeseries(Nothing) + aProvisionalTS.numValues = aTimeseries.numValues + + Dim lProvisionalNumValuesAdded As Integer = 0 + Dim lNonProvisionalNumValuesAdded As Integer = 0 + Dim lAddTo As atcTimeseries + Dim lAddIndex As Integer + Dim lProvisionalAttribute As String = aTimeseries.Attributes.GetValue("ProvisionalValueAttribute", "P") + + For lIndex As Integer = 1 To aTimeseries.numValues + If aTimeseries.ValueAttributesGetValue(lIndex, lProvisionalAttribute, False) Then + lAddTo = aProvisionalTS + lProvisionalNumValuesAdded += 1 + lAddIndex = lProvisionalNumValuesAdded + Else + lAddTo = aNonProvisionalTS + lNonProvisionalNumValuesAdded += 1 + lAddIndex = lNonProvisionalNumValuesAdded + End If + + lAddTo.Value(lAddIndex) = aTimeseries.Value(lIndex) + lAddTo.Dates.Value(lAddIndex) = aTimeseries.Dates.Value(lIndex) + If lAddIndex = 1 Then + lAddTo.Value(0) = pNaN + lAddTo.Dates.Value(0) = aTimeseries.Dates.Value(lIndex - 1) + End If + If aTimeseries.ValueAttributesExist(lIndex) Then + lAddTo.ValueAttributes(lAddIndex) = aTimeseries.ValueAttributes(lIndex) + End If + Next + aProvisionalTS.numValues = lProvisionalNumValuesAdded + aNonProvisionalTS.numValues = lNonProvisionalNumValuesAdded + + Dim lCopiedAttributes As atcDataAttributes = aTimeseries.Attributes.Copy + lCopiedAttributes.DiscardCalculated() + + aProvisionalTS.Attributes.ChangeTo(lCopiedAttributes) + aNonProvisionalTS.Attributes.ChangeTo(lCopiedAttributes) + aProvisionalTS.Attributes.SetValue("ParentSerial", aTimeseries.Serial) + aNonProvisionalTS.Attributes.SetValue("ParentSerial", aTimeseries.Serial) + End Sub +End Module