Veritcal / Perpendicular Offset에 따른 일괄 선형회귀 / Linear fitting 매크로 (2)

'-------------------------------------------

Sub LinearFit()
  On Error Resume Next
  Dim tSh As Worksheet, tRange As Range, tN As Long, tSh2 As Worksheet, tStr As String, tMode As Integer, tCN As Integer
  Dim tXCol() As Range, tYCol() As Range, tHN As Integer
  Dim tXY() As Range, tX As Range, tY As Range, tStrX As String, tStrY As String, tValX(), tValY()
  Dim tA As Range, tB As Range, tRSq As Range, tStrA As String, tSign As String, tValA, tValB, i As Long
  Dim tXFit As Range, tYFit As Range, tRes As Range, tValRes(), tStrRes As String
  Dim tChart As Chart
  

  Set tSh = ActiveSheet
  '반복된 X, Y열 데이터가 있다고 하면, X, Y쌍을 지정해줍니다.

  If SelectedColIntoXYPair(tXCol, tYCol, tHN) < 1 Then GoTo ErrorHandler
  

  'Offset 종류와 fitting 식을 선택합니다. 여기에서는 총 4가지 종류로 fitting하도록 합니다.
  tStr = InputBox("Fitting mode를 선택하세요." & vbCrLf & "1 : Vertical Offset / Y=aX+b" & vbCrLf & "2 : Vertical Offset / Y=aX" & vbCrLf & "3 : Perpedicular Offset / Y=aX+b" & vbCrLf & "4 : Perpedicular Offset / Y=aX", "Fitting Mode 선택", 1)
  tMode = Int(Val(tStr))
  If StrPtr(tStr) = 0 Or (tMode < 1 Or tMode > 4) Then Exit Sub

  '원데이터를 복사하고 fitting 결과를 출력할 시트를 만들어준 후 시트명을 적당하게 지정해줍니다. 또한, fitting 종류를 표기해주고, 기울기, 절편, R-Sq를 출력할 위치를 지정합니다. 또한, 차트에 fitting 결과를 그리기 위한 2개의 점을 출력할 위치도 지정해둡니다.

  Set tSh2 = ActiveWorkbook.Sheets.Add(After:=tSh)
  With tSh2
    .Name = NewSheetName(tSh.Name & "_LF", tSh2.Index)
    .Tab.ColorIndex = 8
    .Activate
    .Cells(1, 1).Value = "Fitting Mode: "
    Select Case tMode
      Case 1
        .Cells(1, 2).Value = "Vertical Offset / Y=aX+b"
      Case 2
        .Cells(1, 2).Value = "Vertical Offset / Y=aX"
      Case 3
        .Cells(1, 2).Value = "Perpedicular Offset / Y=aX+b"
      Case 4
        .Cells(1, 2).Value = "Perpedicular Offset / Y=aX"
    End Select
    .Cells(2, 1).Value = "a="
    .Cells(3, 1).Value = "b="
    .Cells(4, 1).Value = "R_Sq="
    .Cells(6, 1).Value = "(X1,Y1) :"
    .Cells(7, 1).Value = "(X2,Y2) :"
  End With

  Call CalcModeOn(True)

  For i = 1 To UBound(tYCol)

  'Y 데이터 갯수에 해당하는 만큼 반복하되, X, Y 데이터와 잔차를 함께 출력하도록 3개 열마다 반복해서 출력합니다.

  '기울기를 출력하는 위치(tA)를 지정한 후, 나머지 출력위치는 모두 .Offset으로 지정해줍니다. 이렇개 해두면, tA 위치를 바꾸면 나머지 위치들이 모두 상대위치로 지정되기 때문에 변경할 필요가 없습니다.

    Set tA = tSh2.Cells(2, 3 * (i - 1) + 2)
    Set tB = tA.Offset(1, 0)
    Set tRSq = tB.Offset(1, 0)
    Set tXFit = tSh2.Range(tRSq.Offset(2, 0), tRSq.Offset(3, 0))
    Set tYFit = tXFit.Offset(0, 1)
    

  'X, Y 데이터를 미리 만들어둔 함수를 이용해서 header 부분을 제외한 데이터 영역 중 X, Y 데이터가 모두 있는 영역만 복사해옵니다. header가 있다면 header도 가져와서 출력하도록 합니다.
    tXY = TrimXYRange(tXCol(i), tYCol(i), tHN, True)
    Set tRange = tSh2.Range(tSh2.Cells(9, 3 * (i - 1) + 2), tSh2.Cells(9, 3 * (i - 1) + 4))
    tRange.Value = Array("X" & i, "Y" & i, "Residue" & i)
    If tHN > 0 Then
      CopyValues tSh.Range(tXCol(i).Cells(1, 1), tXCol(i).Cells(tHN, 1)), tRange.Cells(1, 1).Offset(1, 0)
      CopyValues tSh.Range(tYCol(i).Cells(1, 1), tYCol(i).Cells(tHN, 1)), tRange.Cells(1, 2).Offset(1, 0)
    End If
    Set tX = CopyValues(tXY(1), tRange.Cells(1, 1).Offset(1, 0).Offset(tHN, 0))
    Set tY = CopyValues(tXY(2), tRange.Cells(1, 2).Offset(1, 0).Offset(tHN, 0))
    Set tRes = tY.Offset(0, 1)
    

  'X, Y, A, B가 기록될 주소를 변수에 지정해둡니다. "$"를 삭제하는 것은 상대주소로 변환하기 위한 것으로 결과에는 영향을 미치지 않습니다만, 작업이 완료된 후 엑셀 시트에서 셀 함수 복사하기를 이용하여 다른 영역의 fitting이 가능하도록 상대 주소가 입력해줍니다.

    tStrX = Replace(tX.Address, "$", "")
    tStrY = Replace(tY.Address, "$", "")
    tStrA = Replace(tA.Address, "$", "")
    tStrB = Replace(tB.Address, "$", "")

  'Fitting mode에 따라 기울기 A, 절편 B 셀에 아래와 같이 함수가 입력되도록 합니다. 엑셀의 내장함수를 그대로 활용하는 것으로 문자열을 조합하여 해당 셀의 수식(formula)에 대입해줍니다. 각 식은 이전 글들에서 다 계산해두었기 때문에 그대로 만들어주기만 하면 됩니다. 평균(Average), 제곱합(SumSq), 분산(Var.P), 공분산(Covar), 곱 합치기(SumProduct) 등... 엑셀의 수식 입력란에 사용할 수 있는 함수를 그대로 사용합니다.

    Select Case tMode
      Case 1
        tA.Formula = "=COVAR(" & tStrX & "," & tStrY & ")/VAR.P(" & tStrX & ")"
        tB.Formula = "=AVERAGE(" & tStrY & ")-" & tStrA & "*AVERAGE(" & tStrX & ")"
      Case 2
        tA.Formula = "=SUMPRODUCT(" & tStrX & "," & tStrY & ")/SUMSQ(" & tStrX & ")"
        tB.Value = 0
      Case 3
        If Application.WorksheetFunction.Covar(tX, tY) >= 0 Then tSign = "+" Else tSign = "-"
        tA.Formula = "=((VAR.P(" & tStrY & ")-VAR.P(" & tStrX & "))" & tSign & "SQRT((VAR.P(" & tStrY & ")-VAR.P(" & tStrX & "))^2+4*COVARIANCE.P(" & tStrX & "," & tStrY & ")^2))/(2*COVARIANCE.P(" & tStrX & "," & tStrY & "))"
        tB.Formula = "=AVERAGE(" & tStrY & ")-" & tStrA & "*AVERAGE(" & tStrX & ")"
      Case 4
        If Application.WorksheetFunction.SumProduct(tX, tY) >= 0 Then tSign = "+" Else tSign = "-"
        tA.Formula = "=((SUMSQ(" & tStrY & ")-SUMSQ(" & tStrX & "))" & tSign & "SQRT((SUMSQ(" & tStrY & ")-SUMSQ(" & tStrX & "))^2+4*SUMPRODUCT(" & tStrX & "," & tStrY & ")^2))/(2*SUMPRODUCT(" & tStrX & "," & tStrY & "))"
        tB.Value = 0
    End Select
    

  'A, B 수식으로부터 구한 값을 이용하여 잔차(Residue)와 함께 R-Sq값을 구해줍니다.

    tValA = tA.Value
    tValB = tB.Value
    tValX = tX.Value
    tValY = tY.Value
    tValRes = tRes.Value
    tStrRes = Replace(tRes.Address, "$", "")
    Select Case tMode
      Case 1, 2
        For j = 1 To tRes.Rows.Count
          tValRes(j, 1) = tValY(j, 1) - (tValA * tValX(j, 1) + tValB)
        Next
        tRes.Value = tValRes
        tRSq.Formula = "=1-SUMSQ(" & tStrRes & ")/(COUNT(" & tStrRes & ")*VAR.P(" & tStrY & "))"
      Case 3, 4
        For j = 1 To tRes.Rows.Count
          tValRes(j, 1) = (tValA * tValX(j, 1) + tValB - tValY(j, 1)) / Sqr(tValA * tValA + 1)
        Next
        tRes.Value = tValRes
        tRSq.Formula = "=1-2*SUMSQ(" & tStrRes & ")/(COUNT(" & tStrRes & ")*(VAR.P(" & tStrX & ")+VAR.P(" & tStrY & ")))"
    End Select

  'Fitting한 결과를 직선으로 그리기 위해, X의 최소, 최대값에서 Y값을 구해서 fitting 결과 출력 셀 아래에 입력해줍니다.

    tXFit.Cells(1, 1).Formula = "=MIN(" & tStrX & ")"
    tXFit.Cells(2, 1).Formula = "=MAX(" & tStrX & ")"
    tYFit.Cells(1, 1).Formula = "=" & tStrA & "*" & tXFit.Cells(1, 1).Address & "+" & tStrB
    tYFit.Cells(2, 1).Formula = "=" & tStrA & "*" & tXFit.Cells(2, 1).Address & "+" & tStrB
    

  'X, Y 원데이터를 점 분산차트를 그리고, fitting 결과를 선 차트로 추가하여 그려준 후, 해당 Y열 위치로 옮겨줍니다.
    Set tChart = ScatterChart_New(tX, tY, 0, xlXYScatter)
    Set tChart = ScatterChart_Add(tChart, tXFit, tYFit, 0, xlXYScatterLinesNoMarkers)
    tChart.SeriesCollection(2).Format.Line.Weight = 2
    With tChart.ChartArea
      .Top = tY.Cells(5, 1).Top
      .Left = tY.Cells(5, 1).Left
    End With
  Next
ErrorHandler:
  Call CalcModeOn(False)
  Erase tXCol, tYCol, tXY, tValX, tValY, tValRes
End Sub

'-------------------------------------------

위의 매크로를 이용하여 일괄적으로 linear fitting한 결과는 아래 그림과 같습니다. 

일일이 차트를 그리고, 직선으로 fitting하는 작업을 반복하는 것보다는 빠르게 진행될 수 있으며, 차트를 확인하여 상관관계가 있는 데이터를 빠르게 찾아낼 수 있으며, 적당히 수정하면 통계 소프트웨어에서처럼 MatrixPlot도 가능할 것입니다.