Attribute VB_Name = "Module1"

Const ProgID = "MYRLIN#2 1.01"

Sub MakeD95List()
'----------------------------------------------------------------
'Produces a list of species groups with their D95 diameters
'from a set of inventory data.  Uses MYRLIN#1 format for
'inventory.
'This routine is part of the MYRLIN toolkit.
'For information and conditions of use see http://www.myrlin.org.
'
'Revision history:
'  17-Nov-01    Plot area of -1 allows point sample data
'----------------------------------------------------------------
'
'************ variable declarations ************
Dim Wbk As Workbook         'workbook with inventory data
Dim Spl As Worksheet        'species list sheet
Dim Inv As Worksheet        'inventory data sheet
Dim Tbl As Worksheet        'stand table output sheet
Dim Ash As Worksheet        'sheet with areas
Dim kStr As Integer         'column with stratum id
Dim kBlk As Integer         'column with block id if stock survey data
Dim kPlt As Integer         'column with plot id
Dim kDbh As Integer         'column with dbh
Dim kSpp As Integer         'column with species codes (data sheet)
Dim kSpl As Integer         'column with species codes (species sheet)
Dim kGrp As Integer         'column with group ID
Dim Grps As Variant         'species group codes
Dim k As Integer            'a cell column index
Dim j As Integer            'a cell row index
Dim d As Single             'a diameter value
Dim i As Integer            'a diameter class index
Dim L As Integer            '1 for stock tree, 2 for plot tree
Dim np As Integer           'plot count within a stratum
Dim r As Integer            'output row index
Dim rT As String            'row number as trimmed string
Dim r0 As Integer           'initial output row for a table
Dim spp As Variant           'species code
Dim spg As String           'species group code
Dim g As Integer            'a group index
Dim Ng As Integer           'number of groups
Dim Fdis() As Single        'frequency distribution by 1-cm classes
Dim Ftot() As Single        'frequency totals
Dim AvD95 As Single         'average D95 value
Dim sFtot As Single         'sum of frequency totals across groups
Dim AreaB As Double         'block area for stock survey data
Dim AreaP As Double         'main plot area, ha
Dim AreaS As Double         'sub-plot area
Dim DiamL As Single         'diameter limit
Dim Awt As Double           'trees per ha represented by one tree
Dim kAwt As Integer         'area weight column for point sampling
Dim StockData As Boolean    'true if Stock survey data found
Dim ErrN As Integer         'error code
Dim OK As Boolean
Application.StatusBar = ProgID
'************ initial settings ************
'find inventory workbook
OK = Application.Dialogs(xlDialogOpen).Show
If Not OK Then End
Set Wbk = ActiveWorkbook
Sheets("Options").Activate
Set Spl = Sheets([b3].Text)
Set Inv = Sheets([b5].Text)
Set Tbl = ThisWorkbook.Sheets("Table")
Set Ash = Sheets("Areas")
'column settings for data and species list
kGrp = [b4]
kStr = [b6]
kPlt = [b7]
kSpp = [b8]
kDbh = [b9]
AreaP = [b10]
AreaS = [b11]
DiamL = [b12]
kAwt = [b16]
'save name of workbook used
Tbl.Cells(2, 2) = ActiveWorkbook.FullName
'************ main program code ************
'read diameter class settings from StandTable sheet
Tbl.Activate
'ensure data sheet sorted by stratum and plot
Inv.UsedRange.Sort key1:=Inv.Cells(1, kStr), key2:=Inv.Cells(1, kPlt), header:=xlYes
'work through to end of data
j = 2: r = 3
ReDim Fdis(1 To 2, 1 To 200, 1 To 1)
Do While Inv.Cells(j, kStr) > ""
    'get current tree data and add to internal table
    spp = Inv.Cells(j, kSpp)
    On Error Resume Next
    spg = WorksheetFunction.VLookup(spp, Spl.UsedRange, kGrp, False)
    ErrN = Err.Number
    On Error GoTo 0
    'only process trees with valid species lookups
    If ErrN = 0 Then
        g = FindA(spg, Grps)
        If g > UBound(Fdis, 3) Then
            ReDim Preserve Fdis(1 To 2, 1 To 200, 1 To g)
        End If
        d = Inv.Cells(j, kDbh)
        'get area weight according to sampling design
        'if no plot code, then this is a stock tree
        If Inv.Cells(j, kPlt).Text = "" Then
            Awt = 1
            L = 1
            StockData = True
        Else
            If AreaP > 0 Then
                'sample plot data - area weight depends on sub-plot
                L = 2
                If d < DiamL Then Awt = 1 / AreaS Else Awt = 1 / AreaP
            Else
                'point sampling data - area wight column must be filled in
                L = 2
                Awt = Inv.Cells(j, kAwt)
            End If
        End If
        'get diameter class (anything over 200 goes to 200)
        If d > 200 Then k = 200 Else k = d
        If k > 0 Then Fdis(L, k, g) = Fdis(L, k, g) + Awt
    End If
    'if next row is a different plot, increment plot counter
    If Inv.Cells(j, kPlt) <> Inv.Cells(j + 1, kPlt) Or _
        Inv.Cells(j, kStr) <> Inv.Cells(j + 1, kStr) Then np = np + 1
    'if next row is a different stratum, total areas
    If Inv.Cells(j, kStr) <> Inv.Cells(j + 1, kStr) Then
        'get area of stratum if required
        If StockData Then
            AreaB = AreaB + WorksheetFunction.VLookup(Inv.Cells(j, kStr), Ash.UsedRange, 3, False)
        End If
    End If
    j = j + 1
Loop
'adjust frequencies for plot count and stock survey area
'and add up totald
Ng = UBound(Grps) + 1
ReDim Ftot(1 To Ng)
For g = 1 To Ng
    For k = 1 To 200
        'convert plot stand table totals to averages
        If np > 0 Then
            Fdis(2, k, g) = Fdis(2, k, g) / np
        End If
        'add in stock data corrected for area
        If StockData And AreaB > 0 Then
            Fdis(1, k, g) = Fdis(1, k, g) / AreaB
            Fdis(2, k, g) = Fdis(2, k, g) + Fdis(1, k, g)
        End If
        Ftot(g) = Ftot(g) + Fdis(2, k, g)
    Next k
Next g
'convert frequencies to cumulative percentiles
For g = 1 To Ng
    For k = 1 To 200
        Fdis(2, k, g) = Fdis(2, k, g) / Ftot(g)
        If k > 1 Then
            Fdis(2, k, g) = Fdis(2, k, g) + Fdis(2, k - 1, g)
        End If
    Next k
Next g
'clear existing table
r = 5
j = Tbl.UsedRange.Rows.Count
k = Tbl.UsedRange.Columns.Count
Tbl.Range(Tbl.Cells(r, 1), Tbl.Cells(j, k)).ClearContents
'output group names and 95% diameters
For g = 1 To Ng
    Tbl.Cells(r, 1) = Grps(g - 1)
    Tbl.Cells(r, 2) = Format(Ftot(g), "0.0")
    For k = 2 To 200
        If Fdis(2, k, g) >= 0.95 And Fdis(2, k - 1, g) <= 0.95 Then
            Tbl.Cells(r, 3) = k
            AvD95 = AvD95 + Ftot(g) * k
            sFtot = sFtot + Ftot(g)
            Tbl.Cells(r, 4) = k ^ 2 * 0.00007854 * Ftot(g)  'BA weight
            rT = Trim(CStr(r))
            Tbl.Cells(r, 5) = "=(alpha+beta*C" + rT + "/D95p)*Id"
            Tbl.Cells(r, 6) = "=(1-0.05^(E" + rT + "/C" + rT + "))"
            Exit For
        End If
    Next k
    r = r + 1
Next g
'write average D95 at bottom of table
AvD95 = AvD95 / sFtot
Tbl.Cells(r + 1, 1) = "Weighted mean"
Tbl.Cells(r + 1, 3) = Format(AvD95, "0.0")
'update data labels
UpdateLabels
End Sub

Private Function FindA(e As String, a As Variant) As Integer
'----------------------------------------------------------------
'Searches for index of item e in array a and returns its
'index.  Adds it to the list if not already in.
'This routine is part of the MYRLIN toolkit.
'For information and conditions of use see http://www.myrlin.org.
'----------------------------------------------------------------
Dim i As Integer
If Not IsArray(a) Then
    'list not yet started - add e as first item
    a = Array(e)
    FindA = 1
Else
    For i = 0 To UBound(a)
        If a(i) = e Then
            FindA = i + 1
            Exit Function
        End If
    Next i
    'not yet in list - add it
    i = UBound(a) + 1
    ReDim Preserve a(i)
    a(i) = e
    FindA = i + 1
End If
End Function

Sub UpdateLabels()
'----------------------------------------------------------------
'Labels the series {Data} on sheet {Fig1}
'This routine is part of the MYRLIN toolkit.
'For information and conditions of use see http://www.myrlin.org.
'----------------------------------------------------------------
Dim LblAddr As String
Dim sht As Object          'data sheet reference
Dim sr As Series           'series being labelled
Dim s As Variant           'index for series
Dim r As Integer          'row counter in data table
Dim fr As Integer          'first row in data table
Dim lr As Integer          'last row in data table
Application.StatusBar = ProgID
On Error GoTo LabelSeriesError
Application.ScreenUpdating = False
'find series {Data} (sr will be Nothing if not found)
Sheets("Fig1").Activate
For Each s In ActiveChart.SeriesCollection
   If s.Name = "Data" Then Set sr = s
Next s
If sr Is Nothing Then
   Err.Raise 911, "UpdateSeries", "Series {Data} not found"
End If
'get last row of data
Set sht = Sheets("Table")
fr = 5
lr = sht.Cells(5, 1).End(xlDown).Row
sr.XValues = sht.Range(sht.Cells(fr, 3), sht.Cells(lr, 3))
sr.Values = sht.Range(sht.Cells(fr, 5), sht.Cells(lr, 5))
sr.HasDataLabels = True
For Each pt In sr.Points
   pt.DataLabel.Text = sht.Cells(fr, 1).Offset(r, 0).Text
   r = r + 1
Next pt
Application.ScreenUpdating = True
Exit Sub

LabelSeriesError:
Application.ScreenUpdating = True
If MsgBox("Unable to label points for series {Data} on chart {Fig1}." + _
       "Error '" + Err.Description + "' occurred." + Chr(13) + Chr(13) + _
       "Click {Retry} to debug, {Cancel} to terminate.", _
       vbRetryCancel + vbInformation, "MYRLIN#2") = vbRetry Then
   On Error GoTo 0
   Resume               '{Retry} with debugging
Else
   End                  '{Cancel} terminates
End If
End Sub