Windows Analysis Report
XRealStats.xlam

Attribute VB_Name = "Analysis"
' Functions used by data analysis tools

Sub IsRange(ByVal sRangeAddress As String, ok As Boolean)
  Dim TestRange As Range
  ok = True
  On Error Resume Next
  Set TestRange = Range(sRangeAddress)
  If err.Number <> 0 Then ok = False
  err.Clear
  On Error GoTo 0
  Set TestRange = Nothing
End Sub

Sub GetRange(rg As Range, s As String, ByRef ok As Boolean)
    ' Get range with address s, set ok to true if this address is valid
    ok = True
    On Error GoTo ErrTrap
    Set rg = ActiveSheet.Range(s)
    Exit Sub
ErrTrap:
    ok = False
    Resume Next
End Sub

Sub GetOutputRange(rg As Range, s As String, ByRef ok As Boolean)
' Get output range with address s, set ok to true if this address is valid
' If s = "" then set rg to a new worksheet
    Dim ws As Worksheet
    ok = True
    On Error GoTo ErrTrap
    If s = "" Then
        Set ws = Sheets.Add
        Set rg = ws.Range("A1")
    Else
        Set rg = ActiveSheet.Range(s).Cells(1, 1)
    End If
    Exit Sub
ErrTrap:
    ok = False
    Resume Next
End Sub

Sub GetOptionalRange(rg As Range, s As String, ByRef ok As Boolean)
    ' Get range with address s, set ok to true if this address is valid, can also be empty
    ok = True
    On Error GoTo ErrTrap
    If s <> "" Then
        Set rg = ActiveSheet.Range(s)
    Else
        Set rg = Nothing
    End If
    Exit Sub
ErrTrap:
    ok = False
    Resume Next
End Sub

Sub ExtendRange(rg As Range, rg1 As Range)
' For a given range rg, return range rg1 which extends the first row of rg until a row of empty cells is found
' If first row of rg is empty then perform above on second row of rg
    
    On Error GoTo ErrTrap
    
    Dim n As Long
    n = rg.Columns.Count
    Dim ce As Range
    Dim ce1 As Range
    Set ce = rg.Cells(1, 1)
    Dim j As Long
    Dim ok As Boolean
    Do
        ok = True
        Set ce = ce.Offset(1, 0)
        While ce.Value <> ""
            Set ce = ce.Offset(1, 0)
        Wend
        Set ce1 = ce.Offset(0, 1)
        For j = 2 To n
            If ce1.Value <> "" Then
                ok = False
                Exit For
            End If
            Set ce1 = ce1.Offset(0, 1)
        Next
    Loop Until ok
    
ErrTrap:
    Set rg1 = rg.Cells(1, 1).Resize(ce.row - rg.Cells(1, 1).row, n)
End Sub

Sub ExtendRange2(rg As Range, rg1 As Range)
' perform ExtendRange but skip two blank rows
    
    Dim rg2 As Range
    Dim rg3 As Range
    Dim rg4 As Range
    Dim m As Long
    Dim n As Long
    
    Call ExtendRange(rg, rg2)
    
    m = rg2.Rows.Count
    n = rg2.Columns.Count
    
    Set rg3 = rg2.Cells(m + 3, 1).Resize(1, n)
    Call ExtendRange(rg3, rg4)
    
    Set rg1 = rg2.Cells(1, 1).Resize(m + rg4.Rows.Count + 2, n)
    
End Sub

' string routines

Sub SetRowLabels(rvector As Variant, s As String)
' set the values of the cells in row vector to the labels in string s
' s is a list of labels separated by commas
    Dim i As Long
    Dim n As Long
    n = UBound(rvector, 2)
    Dim size As Long
    size = Len(s)
    Dim p As Long
    Dim pp As Long
    i = 1
    p = 1
    Do
        pp = InStr(p, s, ",")
        If pp <= 0 Then
            rvector(1, i) = Mid$(s, p)
            Exit Do
        Else
            rvector(1, i) = Mid$(s, p, pp - p)
            i = i + 1
            p = pp + 1
        End If
    Loop Until p > size Or i > n
    
End Sub

Sub SetColLabels(cvector As Variant, s As String)
' set the values of the cells in column vector to the labels in string s
' s is a list of labels separated by commas
    Dim i As Long
    Dim n As Long
    n = UBound(cvector, 1)
    Dim size As Long
    size = Len(s)
    Dim p As Long
    Dim pp As Long
    i = 1
    p = 1
    Do
        pp = InStr(p, s, ",")
        If pp <= 0 Then
            cvector(i, 1) = Mid$(s, p)
            Exit Do
        Else
            cvector(i, 1) = Mid$(s, p, pp - p)
            i = i + 1
            p = pp + 1
        End If
    Loop Until p > size Or i > n
    
End Sub

Sub GetAlpha(s As String, ByRef alpha As Double)
' return alpha, which is s as a decimal number between 0 and .5 (or 0 and 50)
' if s is not a decimal number in this range then return -1.0

    On Error GoTo ErrTrap
    
    alpha = s
    If ThisWorkbook.Sheets("Config").Range("B4") <> "" Then alpha = alpha / 100
    If alpha > 0.5 Or alpha < 0# Then alpha = -1#
    Exit Sub
    
ErrTrap:
    alpha = -1#
End Sub

Sub GetNTests(s As String, ByRef ntests As Long)
' return ntests, which is s as a non-negative integer
' if s is not a non-negative integer then return -1

    On Error GoTo ErrTrap
    
    ntests = s
    Exit Sub
    
ErrTrap:
    ntests = -1#
End Sub

Sub GetPower(s As String, ByRef pow As Double)
' return power, which is s as a decimal number between 0 and 1 (or 0 and 100)
' if s is not a decimal number in this range then return -1.0

    On Error GoTo ErrTrap
    
    pow = s
    If ThisWorkbook.Sheets("Config").Range("B4") <> "" Then pow = pow / 100
    If pow > 1# Or pow <= 0# Then pow = -1#
    Exit Sub
    
ErrTrap:
    pow = -1#
End Sub

Sub GetCutoff(s As String, ByRef cutoff As Double)
' return cutoff, which is s as a decimal number between 0 and 1 (or 0 and 100)
' if s is not a decimal number in this range then return -1.0

    On Error GoTo ErrTrap
    
    cutoff = s
    If ThisWorkbook.Sheets("Config").Range("B4") <> "" Then cutoff = cutoff / 100
    If cutoff > 1# Or cutoff < 0# Then cutoff = -1#
    Exit Sub
    
ErrTrap:
    cutoff = -1#
End Sub

Sub GetNum(s As String, ByRef n As Double, ByRef ok As Boolean)
' return n, which is s as a number; if legal set ok = True

    On Error GoTo ErrTrap
    
    n = Val(s)
    ok = True
    Exit Sub
    
ErrTrap:
    ok = False
End Sub

Sub GetPosNum(s As String, ByRef n As Double)
' return n, which is s as a positive number; otherwise return -1.0

    On Error GoTo ErrTrap
    
    n = Val(s)
    If n <= 0 Then n = -1#
    Exit Sub
    
ErrTrap:
    n = -1#
End Sub

Sub GetNNeg(s As String, ByRef n As Double)
' return n, which is s as a non-negative number; otherwise return -1.0

    On Error GoTo ErrTrap
    
    n = Val(s)
    If n < 0 Then n = -1#
    Exit Sub
    
ErrTrap:
    n = -1#
End Sub

Sub GetPosInt(s As String, ByRef n As Long)
' return n, which is s as a positive integer; otherwise return -1

    On Error GoTo ErrTrap
    
    n = Int(Val(s))
    If n <= 0 Then n = -1
    Exit Sub
    
ErrTrap:
    n = -1
End Sub

Sub GetNNegInt(s As String, ByRef n As Long)
' return n, which is s as a non-negative integer; otherwise return -1.0

    On Error GoTo ErrTrap
    
    n = Int(Val(s))
    If n < 0 Then n = -1#
    Exit Sub
    
ErrTrap:
    n = -1#
End Sub

Sub GetNZeroNum(s As String, ByRef n As Double)
' return True if s is a non-zero number
    
    n = Val(s)
    
Exit Sub
errorHandler:
    n = 0#

End Sub

' Box Plots

Sub RunBoxPlotFull(rg As Range, ce As Range, b As Boolean, bexc As Boolean)
' draw box plot for the data in rg at location ce, b = true if rg contains headings
' bexc = true if QUARTILE.EXC is to be used                        *** Remove for Excel 2007
' must contain at least two data points per sample (i.e. rg.Rows.Count > 1)
' caution: no title is displayed

    On Error GoTo errorHandler
    
    Application.ScreenUpdating = False

    Dim m As Long       ' # of rows in rg
    m = rg.Rows.Count
    Dim n As Long       ' # of columns in rg
    n = rg.Columns.Count
    Dim rg0 As Range    ' rg if b = False and corrected rg if b = True
    Dim rg1 As Range    ' first row of rg (if b = True)
    Dim rg2 As Range    ' first column of rg0
    Dim rg3 As Range    ' working table range
    Dim rg4 As Range    ' all but last line of working table
    Dim rg5 As Range    ' last line of working table
    Dim ce1 As Range    ' cell on row where we are writing
    Dim ce0 As Range    ' cell for min of all the elements in rg
    Dim ce2 As Range    ' cell for where output to be graphed goes
    Dim i As Long       ' index
    Dim j As Long       ' index

    ' handle case where output is on a different worksheet from input
    Dim s As String
    s = ""
    If rg.Worksheet.Name <> ce.Worksheet.Name Then s = "'" & rg.Worksheet.Name & "'!"
       
   ' set rg0 based on whether b = True
    If b Then
        m = m - 1
        Set rg1 = rg.Rows(1)
        Set rg0 = rg.Cells(2, 1).Resize(m, n)
    Else
        Set rg0 = rg
    End If
    
    ' format column headings
    Set rg3 = ce.Offset(0, 1).Resize(1, n)
    rg3.HorizontalAlignment = xlCenter
    rg3.Font.Italic = True

    ' create working table column headings
    If b Then
        ce.Offset(0, 1).Formula = "=" & s & rg1.Cells(1, 1).Address(False, False)
        If n > 1 Then rg3.FillRight
    Else
        Dim vector As Variant   ' rg's headings
        ReDim vector(1 To 1, 1 To n)
        For i = 1 To n
            vector(1, i) = "Group " & CStr(i)
        Next
        rg3.Value = vector
    End If
    
    ' determine whether a negative correction is required
    Set ce0 = ce.Offset(15, 0)
    ce0.Value = "Grand Min"
    ce0.Offset(2, 0).Value = "Outliers"
    Set rg3 = ce.Offset(8, 1).Resize(1, n)
    ce0.Offset(0, 1).Formula = "=IF(MIN(" & rg3.Address(False, False) & ")>=0,0,MIN(" & rg3.Address(False, False) & "))"
    ce0.Offset(0, 1).BorderAround ColorIndex:=1, weight:=xlThin, LineStyle:=xlContinuous
    
    ' create first working table
    Set rg2 = rg0.Columns(1)
    Set ce1 = ce.Offset(8, 0)
    ce1.Value = "Min"
    ce1.Offset(1, 0) = "Q1"
    ce1.Offset(2, 0) = "Median"
    ce1.Offset(3, 0) = "Q3"
    ce1.Offset(4, 0) = "Max"
    ce1.Offset(5, 0) = "Mean"
    
    ce1.Offset(0, 1).FormulaArray = "=MIN(IF(ISBLANK(" & s & rg2.Address(False, False) & "),"""",IF(" &         s & rg2.Address(False, False) & ">=" & ce1.Offset(1, 1).Address(False, False) &         "-" & ce.Offset(-2, 1).Address(False, True) & "*(" & ce1.Offset(3, 1).Address(False, False) & "-" &         ce1.Offset(1, 1).Address(False, False) & ")," & s & rg2.Address(False, False) & ","""")))"
    If bexc Then
        ce1.Offset(1, 1).Formula = "=QUARTILE.EXC(" & s & rg2.Address(False, False) & ",1)"
    Else
        ce1.Offset(1, 1).Formula = "=QUARTILE.INC(" & s & rg2.Address(False, False) & ",1)"
    End If
    ce1.Offset(2, 1).Formula = "=MEDIAN(" & s & rg2.Address(False, False) & ")"
    If bexc Then
        ce1.Offset(3, 1).Formula = "=QUARTILE.EXC(" & s & rg2.Address(False, False) & ",3)"
    Else
        ce1.Offset(3, 1).Formula = "=QUARTILE.INC(" & s & rg2.Address(False, False) & ",3)"
    End If
    ce1.Offset(4, 1).FormulaArray = "=MAX(IF(ISBLANK(" & s & rg2.Address(False, False) & "),"""",IF(" &         s & rg2.Address(False, False) & "<=" & ce1.Offset(3, 1).Address(False, False) &         "+" & ce.Offset(-2, 1).Address(False, True) & "*(" & ce1.Offset(3, 1).Address(False, False) & "-" &         ce1.Offset(1, 1).Address(False, False) & ")," & s & rg2.Address(False, False) & ","""")))"
    ce1.Offset(5, 1).Formula = "=AVERAGE(" & s & rg2.Address(False, False) & ")"
    
    Call SetRange2(rg3, ce1.Offset(0, 1), 6, n)
    If n > 1 Then rg3.FillRight
    rg3.BorderAround ColorIndex:=1, weight:=xlThin, LineStyle:=xlContinuous
    
    ' create second working table
    Set ce2 = ce.Offset(1, 0)
    ce2.Value = "Min"
    ce2.Offset(1, 0) = "Q1-Min"
    ce2.Offset(2, 0) = "Med-Q1"
    ce2.Offset(3, 0) = "Q3-Med"
    ce2.Offset(4, 0) = "Max-Q3"
    ce2.Offset(5, 0) = "Mean"
        
    ce2.Offset(0, 1).Formula = "=" & ce1.Offset(0, 1).Address(False, False) & "-" & ce0.Offset(0, 1).Address(False, True)
    ce2.Offset(1, 1).Formula = "=MAX(" & ce1.Offset(1, 1).Address(False, False) & "-" & ce1.Offset(0, 1).Address(False, False) & ",0)"
    Set rg3 = ce2.Offset(1, 1).Resize(4, 1)
    rg3.FillDown
    ce2.Offset(5, 1).Formula = "=" & ce1.Offset(5, 1).Address(False, False) & "-" & ce0.Offset(0, 1).Address(False, True)
    
    Call SetRange2(rg3, ce2.Offset(0, 1), 6, n)
    If n > 1 Then rg3.FillRight
    rg3.BorderAround ColorIndex:=1, weight:=xlThin, LineStyle:=xlContinuous
    
    ' create chart
    Call SetRange2(rg4, ce, 5, n + 1)
    Call SetRange2(rg5, ce2.Offset(4, 1), 1, n)
    ActiveSheet.Shapes.AddChart.Select
    
    With ActiveChart
    
        .SetSourceData Source:=rg4
        .ChartType = xlColumnStacked
        .PlotBy = xlRows
        .SeriesCollection(1).FILL.Visible = False
        .SeriesCollection(2).FILL.Visible = False
        .SeriesCollection(2).HasErrorBars = True
        .SeriesCollection(2).ErrorBars.Select
        .SeriesCollection(2).ErrorBar Direction:=xlY, Include:=xlMinusValues, Type:=xlPercent, Amount:=100
        .SeriesCollection(4).HasErrorBars = True
        .SeriesCollection(4).ErrorBars.Select
        .SeriesCollection(4).ErrorBar Direction:=xlY, Include:=xlPlusValues, Type:=xlCustom, Amount:=rg5
        
        Set rg3 = ce2.Offset(5, 1).Resize(1, n)
        With .SeriesCollection.NewSeries
            .ChartType = xlXYScatter
            .Name = "m"
            .Values = rg3
            .MarkerStyle = xlMarkerStyleX
            .MarkerForegroundColor = rgb(0, 0, 0)
        End With

        Dim k As Long       ' count of outliers
        Dim jarr As Variant ' column number repeated for each outlier
        For j = 1 To n
            k = 0
            For i = 1 To m
                If IsNumeric(rg0.Cells(i, j).Value) And rg0.Cells(i, j).Value <> "" Then
                    If rg0.Cells(i, j).Value < ce1.Offset(0, j).Value Or rg0.Cells(i, j).Value > ce1.Offset(4, j).Value Then
                        k = k + 1
                        If ce0.Offset(0, 1) >= 0 Then
                            ce0.Offset(k + 1, j).Formula = "=" & s & rg0.Cells(i, j).Address(False, False)
                        Else
                            ce0.Offset(k + 1, j).Formula = "=" & s & rg0.Cells(i, j).Address(False, False) & "-" & ce0.Offset(0, 1).Address(False, False)
                        End If
                    End If
                End If
            Next
            If k > 0 Then
                Set rg3 = ce0.Offset(2, j).Resize(k, 1)
                ReDim jarr(1 To k)
                For i = 1 To k
                    jarr(i) = j
                Next
                With .SeriesCollection.NewSeries
                    .ChartType = xlXYScatter
                    .Name = "x"
                    .Values = rg3
                    .XValues = jarr
                    .MarkerStyle = xlMarkerStyleCircle
                    .MarkerForegroundColor = rgb(0, 0, 255)
                    .MarkerBackgroundColor = rgb(255, 255, 255)
                End With
            Else
                ce0.Offset(2, j).Value = "None"
            End If
        Next
        
        If ce0.Offset(0, 1).Value < 0 Then
            With .SeriesCollection.NewSeries
            .ChartType = xlXYScatter
            .Name = "s"
            .Values = 0
            .MarkerStyle = xlMarkerStyleNone
            .AxisGroup = xlSecondary
            End With
            .Axes(xlValue, xlSecondary).MinimumScale = .Axes(xlValue, xlPrimary).MinimumScale + ce0.Offset(0, 1).Value
            .Axes(xlValue, xlSecondary).MaximumScale = .Axes(xlValue, xlPrimary).MaximumScale + ce0.Offset(0, 1).Value
        End If
       
        .SetElement (msoElementLegendNone)
        .HasTitle = True
        .SetElement (msoElementChartTitleAboveChart)
        .ChartTitle.Text = "Box Plot with Outliers"
        
    End With
    
    Application.ScreenUpdating = True
    
Exit Sub
errorHandler:
    MsgBox "A run time error has occurred. The analysis tool will be aborted." & Chr(13) & Chr(10) & Error(err)
    Application.ScreenUpdating = True
    
End Sub

Sub RunDotPlot(rg As Range, ce As Range, b As Boolean)
' draw a dot plot for the data in rg, b = true if rg contains headings

    On Error GoTo errorHandler
    
    Application.ScreenUpdating = False

    Dim m As Long       ' # of rows in rg
    m = rg.Rows.Count
    Dim n As Long       ' # of columns in rg
    n = rg.Columns.Count
    Dim rg0 As Range    ' rg if b = False and corrected rg if b = True
    Dim rg1 As Range    ' first row of rg (if b = True)
    Application.ScreenUpdating = True
    
    ' handle case where output is on a different worksheet from input
    Dim s As String
    s = ""
    If rg.Worksheet.Name <> ce.Worksheet.Name Then s = "'" & rg.Worksheet.Name & "'!"
       
   ' set rg0 based on whether b = True
    If b Then
        Set rg1 = rg.Rows(1)
        m = m - 1
        Set rg0 = rg.Cells(2, 1).Resize(m, n)
    Else
        Set rg0 = rg
    End If
    
    Dim x As Variant    ' x values
    ReDim x(1 To m, 1 To 1)
    Dim i As Long
    Dim j As Long
    Dim zeros As Variant
    ReDim zeros(1 To n)
    For j = 1 To n
        zeros(j) = 0
    Next
    
    Set rg1 = rg.Cells(1, 1).Resize(2, n)
'    ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
    ActiveSheet.Shapes.AddChart.Select
    With ActiveChart
        .SetSourceData Source:=rg1
        .ChartType = xlColumnClustered
        .HasLegend = False
        .HasTitle = True
        .ChartTitle.Text = "Dot Plot"
        .SeriesCollection(1).Values = zeros
        .SeriesCollection.NewSeries
        .SeriesCollection(2).Values = "={1}"
        .ChartArea.Select
        .SeriesCollection(2).ChartType = xlXYScatter
        For i = 1 To m
            x(i, 1) = 1
        Next
        .SeriesCollection(2).XValues = x
        .SeriesCollection(2).Values = rg0.Columns(1)
        .SeriesCollection(2).MarkerStyle = xlMarkerStyleCircle
        
        For j = 2 To n
            .SeriesCollection.NewSeries
            .SeriesCollection(j + 1).ChartType = xlXYScatter
            For i = 1 To m
                x(i, 1) = j
            Next
            .SeriesCollection(j + 1).XValues = x
            .SeriesCollection(j + 1).Values = rg0.Columns(j)
            .SeriesCollection(j + 1).MarkerStyle = xlMarkerStyleCircle
        Next
    End With
    
Exit Sub
errorHandler:
    MsgBox "A run time error has occurred. The analysis tool will be aborted." & Chr(13) & Chr(10) & Error(err)
    Application.ScreenUpdating = True

End Sub

Sub RunBoxPlot(rg As Range, ce As Range, b As Boolean, bexc As Boolean)
' draw box plot for the data in rg at location ce, b = true if rg contains headings
' bexc = true if QUARTILE.EXC is to be used                        *** Remove for Excel 2007
' must contain at least two data points per sample (i.e. rg.Rows.Count > 1)
' caution: no title is displayed

    On Error GoTo errorHandler
    
    Application.ScreenUpdating = False

    Dim n As Long       ' # of columns in rg
    n = rg.Columns.Count
    Dim rg0 As Range    ' rg if b = False and corrected rg if b = True
    Dim rg1 As Range    ' first row of rg (if b = True)
    Dim rg2 As Range    ' first column of rg0
    Dim rg3 As Range    ' working table range
    Dim rg4 As Range    ' all but last line of working table
    Dim rg5 As Range    ' last line of working table
    Dim ce1 As Range    ' cell on row where we are writing
    Dim ce0 As Range    ' cell for min of all the elements in rg
    Dim i As Long       ' index

    ' handle case where output is on a different worksheet from input
    Dim s As String
    s = ""
    If rg.Worksheet.Name <> ce.Worksheet.Name Then s = "'" & rg.Worksheet.Name & "'!"
       
   ' set rg0 based on whether b = True
    If b Then
        Set rg1 = rg.Rows(1)
        Set rg0 = rg.Cells(2, 1).Resize(rg.Rows.Count - 1, n)
    Else
        Set rg0 = rg
    End If
    
    ' format column headings
    Set rg3 = ce.Offset(0, 1).Resize(1, n)
    rg3.HorizontalAlignment = xlCenter
    rg3.Font.Italic = True

    ' create working table column headings
    If b Then
        ce.Offset(0, 1).Formula = "=" & s & rg1.Cells(1, 1).Address(False, False)
        If rg.Columns.Count > 1 Then rg3.FillRight
    Else
        Dim vector As Variant   ' r