'#Reference {C9E29001-3D45-11D4-9FF4-00C04FA0D540}#1.0#0#C:\PROGRAM FILES\STATSOFT\STATISTICA 6\stl_mgra.dll#STATISTICA 6.0 Graphics Type Library
'***************************************************************************************************
'"This program will estimate the maximum likelihood lambda for the Box-Cox transformation of
'the dependent variable."
'***************************************************************************************************

Option Base 1
Option Explicit

'#Uses "*STB.SVX"
'#Uses "*GRAPHICS.SVX"

	Public mtrx As MatrixObject
	Public YTRANSF() As Double
	Public Errora() As Double
	Public B() As Double
	Public XX() As Double
	Public X() As Double
	Public VAR() As Double
	Public YPLOT2() As Double
	Public YPLOT1() As Double
	Public ERROR0() As Double
	Public YHAT() As Double
	Public L() As Double
	Public XPLOT2() As Double
	Public TABLE() As Double
	Public XPLOT1() As Double

	Dim ADS As Spreadsheet
	Dim STBReport As Report
	Dim DELTA As Double
	Dim MAXC As Double
	Dim MAXV As Double
	Dim MAXITER As Double
	Dim IRET As Double
	Dim IPRINT As Double
	Dim J As Double
	Dim SHANDLE As Double
	Dim YGEOMETRICMEAN As Double
	Dim N As Double
	Dim GRAPH2 As Double
	Dim GRAPH1 As Double
	Dim I As Double
	Dim SIGMA As Double
	Dim COLNAM As String
	Dim Graph As Double
	Dim IMETHOD As Double
	Dim MAXTABLE As Double
	Dim DV As Double
	Dim TOLER As Double
	Dim SIGMA1 As Double
	Dim ROWNAM As String
	Dim LAM As Double
	Dim LINE09 As String

	Const NUMBOX1 As String = "Range of lambda"
	Const NUM1PARAM As String = "Lower limit:|Upper limit:"
	Const MBOX1 As String = "Invalid lower lambda"
	Const MBOX1ERR As String = "Lower lambda value must < -.05."
	Const MBOX2 As String = "Invalid upper lambda"
	Const MBOX2ERR As String = "Upper lambda value must > .05."
	Const MBOX3 As String = "Invalid lambda values"
	Const MBOX3ERR As String = "User-specified lambda values too large."
	Const MBOX4 As String = "Missing Data"
	Const MBOX4ERR As String = "Some cases have missing data; this program requires that all cases are complete; use the missing data replacement facilities to remove missing data values."
	Const MBOX5 As String = "Invalid Y Values"
	Const MBOX5ERR As String = "Some y<=0; all dependent variable values must be greater than 0."
	Const LINE01 As String = "Searching for smallest lambda"
	Const VAR1 As String = "Lambda"
	Const VAR2 As String = "SSE"
	Const GRAPHANAME As String = "Lambda versus SSE(lambda)"
	Const TITLE1A As String = "SSE(lambda)"
	Const TITLE2A As String = "Dependent variable: "
	Const LINE02 As String = "Indep.: "
	Const TITLE3A As String = "The intersection of the 95% C.I line with the SSE line"
	Const TITLE3AB As String = " marks the 95% confidence limits For the best lambda"
	Const CUSTOMSV As String = "95% C.I."
	Const S2NAME As String = "Smallest Lambda"
	Const MBOX6 As String = "This program will estimate the maximum likelihood lambda for the Box-Cox transformation of the dependent variable."
	Const MBOX6NAME As String = "Box-Cox Transformation"
	Const SELVARS1 As String = "Select Variables"
	Const DEPVAR As String = "Dependent variable:"
	Const INDVAR As String = "Independent variables:"
	Const BBOX1 As String = "Select a Search Method"
	Const BBOX1PARM As String = "Manual/visual search (graph of lambda vs. SSE)|Iterative optimization(golden search)"
	Const NUMINBOX As String = "Specify lambda value"
	Const S3NAME As String = "Summary Statistics for Box-Cox Lambda"
	Const S3VNAME1 As String = "lambda"
	Const S3VNAME2 As String = "SSE(l)"
	Const S3VNAME3 As String = "ChiČ(1)"
	Const S3VNAME4 As String = "p"
	Const S3CASE1 = "Final Statistics"
	Const GRAPHXNAME As String = "Lambda=1 (No Transformation)"
	Const TITLE2X As String = "Residuals"
	Const TITLE3X As String = "Observed Values"
	Const GRAPHYN As String = "Lambda="
	Const TITLE1Y As String = "Observed Values,transformed"
	Const GRAPHZ1 As String = "Observed vs. Residual Values"
	Const GRAPHZ2 As String = "Dependent Variable: "
	Const ZVAL As String = "z-Value"
	Const RESID As String = "Residual"
	Const LAMB As String = "Lambda="
	Const MERGEGRAPH1 As String = "Normal Probability Plots of Residuals"
	Const SUBTITL As String = "Dependent Variable: "
	Const CNAME As String = "Lambda| SSE "
	Const LINE9A As String = "INDP.:"

Sub BCTRANSFORM (YGEOMETRICMEAN, YHAT() As Double, NC, LAM)
	ReDim Preserve YHAT(1 To NC) As Double
	Dim I As Double
	For I = 1 To NC
		If Abs(LAM) < DELTA Then
			YHAT(I) = Log(YHAT(I)) * YGEOMETRICMEAN
		Else
			YHAT(I) = (YHAT(I)^LAM - 1) / (LAM * YGEOMETRICMEAN^(LAM - 1))
		End If
	Next I
End Sub

Function GETBRACKETSFORSEARCH (L() As Double)
	ReDim Preserve L(1 To 2) As Double
	Dim IRET As Double
	L(1) = -2
	L(2) = 2
	IRET = 0
	If DisplayNumericInputBox(NUMBOX1,NUM1PARAM,L) = 0 Then
		IRET = 1
		GoTo THATSIT
	End If
	If L(1) > -0.05 Then
		DisplayMessageBox(MB_ICONSTOP,MBOX1,MBOX1ERR)
		IRET = 1
	End If
	If L(2) < 0.05 Then
		DisplayMessageBox(MB_ICONSTOP,MBOX2,MBOX2ERR)
		IRET = 1
	End If
	If (Abs(L(1)) > 10) Or (Abs(L(2)) > 10) Then
		DisplayMessageBox(MB_ICONSTOP,MBOX3,MBOX3ERR)
		IRET = 1
	End If
	THATSIT:
	GETBRACKETSFORSEARCH = IRET
End Function

Function MISSINGDATAORYMINLTZERO (NC, VAR() As Double, N, DV)
	ReDim Preserve VAR(1 To N) As Double
	Dim IFLAG As Double
	Dim I As Double
	Dim J As Double
	Dim YMIN As Double
	MISSINGDATAORYMINLTZERO = 0
	IFLAG = 0
	For I = 1 To N
		J = ValCount(ADS.VData(VAR(I)),1,ADS.NumberOfCases)
		If J < ADS.NumberOfCases Then
			IFLAG = 1
		End If
	Next I
	J = ValCount(ADS.VData(DV),1,ADS.NumberOfCases)
	If J < ADS.NumberOfCases Then
		IFLAG = 1
	End If
	If IFLAG = 1 Then
		DisplayMessageBox(MB_ICONSTOP,MBOX4,MBOX4ERR)
		MISSINGDATAORYMINLTZERO = 1
		GoTo THATSIT
	End If
	YMIN = GetMin(ADS.VData(DV))
	If YMIN <= 0 Then
		DisplayMessageBox(MB_ICONSTOP,MBOX5,MBOX5ERR)
		MISSINGDATAORYMINLTZERO = 1
	End If
	THATSIT:
End Function

Sub REGRESSION (X() As Double, NC, MAXV, VAR() As Double, N, YHAT() As Double, XX() As Double, DV, LAM, DELTA, YGEOMETRICMEAN)
	ReDim Preserve YHAT(1 To NC) As Double
	ReDim Preserve X(1 To NC,1 To MAXV) As Double
	ReDim Preserve XX(1 To MAXV,1 To MAXV) As Double
	ReDim Preserve VAR(1 To MAXV) As Double
	Dim I As Double
	mtrx.MatrixFill(1,X,1,1,NC,1)
	For I = 1 To N
		mtrx.MatrixCopy(ADS.Data,1,VAR(I),NC,1,X,1,I + 1)
	Next I
	mtrx.MatrixCopy(ADS.Data,1,DV,ADS.NumberOfCases,1,YHAT,1,1)
	Call BCTRANSFORM(YGEOMETRICMEAN,YHAT,ADS.NumberOfCases,LAM)
	mtrx.MatrixCopy(YHAT,1,1,NC,1,X,1,N + 1 + 1)
	mtrx.MatrixCrossProductOfDev(X,0,XX)
	mtrx.MatrixSweep(XX,1,N + 1,1)
End Sub

Sub GRIDSEARCH (MAXITER, X() As Double, MAXV, VAR() As Double, N, YHAT() As Double, XX() As Double, L() As Double, ByRef LAM, ByRef YGEOMETRICMEAN, DV, DELTA, IPRINT, XPLOT1() As Double, XPLOT2() As Double, YPLOT1() As Double, YPLOT2() As Double)
	ReDim Preserve XPLOT1(1 To 20) As Double
	ReDim Preserve YPLOT1(1 To 20) As Double
	ReDim Preserve XPLOT2(1 To 2) As Double
	ReDim Preserve YPLOT2(1 To 2) As Double
	ReDim Preserve YHAT(1 To ADS.NumberOfCases) As Double
	ReDim Preserve X(1 To ADS.NumberOfCases,1 To MAXV) As Double
	ReDim Preserve XX(1 To MAXV,1 To MAXV) As Double
	ReDim Preserve VAR(1 To MAXV) As Double
	ReDim Preserve L(1 To 2) As Double
	Dim I As Double
	Dim COLNAM$
	Dim BESTSS As Double
	Dim BESTLAM As Double
	Dim ITER As Double
	Dim SIGMA As Double
	Dim SHANDLE As Double
	Dim Graph As Double
	Dim DF As Double
	Dim T As Double
	mtrx.MatrixCopy(ADS.Data,1,DV,ADS.NumberOfCases,1,YHAT,1,1)
	YGEOMETRICMEAN = 0
	For I = 1 To ADS.NumberOfCases
		YGEOMETRICMEAN = YGEOMETRICMEAN + Log(YHAT(I))
	Next I
	YGEOMETRICMEAN = Exp(YGEOMETRICMEAN / ADS.NumberOfCases)

	COLNAM$ = CNAME
	BESTSS = 1e+030
	BESTLAM = 0
	For ITER = 1 To 20
		LAM = L(1) + (ITER - 1) * (L(2) - L(1)) / 19
		Call REGRESSION(X,ADS.NumberOfCases,MAXV,VAR,N,YHAT,XX,DV,LAM,DELTA,YGEOMETRICMEAN)
		SIGMA = XX(N + 2,N + 2)
		XPLOT1(ITER) = LAM
		YPLOT1(ITER) = SIGMA
		TABLE(ITER,1) = LAM
		TABLE(ITER,2) = SIGMA
		If SIGMA < BESTSS Then
			BESTSS = SIGMA
			BESTLAM = LAM
		End If
	Next ITER

	Dim tabletemp() As Double
	ReDim tabletemp(1 To 20,1 To 2)
	mtrx.MatrixCopy(TABLE,1,1,20,2,tabletemp,1,1)
	Dim s1 As Spreadsheet
	Set s1 = Spreadsheets.New(LINE01)
	s1.SetSize(ITER-1,2)
	s1.VariableName(1) = VAR1
	s1.VariableName(2) = VAR2
	s1.Data() = tabletemp
	s1.InputSpreadsheet = False
	s1.Visible = True

	Dim graphA As Graph
	Set graphA = Graphs.New(GRAPHANAME)
	Dim L1 As Layout2D
	Set L1 = graphA.GraphObject.CreateContent(scg2DGraph)
	L1.Plots.Add(scgLinePlot,s1.NumberOfCases)
		For I = 1 To s1.NumberOfCases
			If L1.Plots(1).Variable(1).ValuesCount = s1.NumberOfCases And L1.Plots(1).Variable(2).ValuesCount = s1.NumberOfCases Then
				L1.Plots(1).Variable(1).Value(I) = XPLOT1(I)
				L1.Plots(1).Variable(2).Value(I) = YPLOT1(I)
			End If
		Next I

	graphA.Titles.Add(scgMainTitle,GRAPHANAME)
	graphA.Titles.Add(scgLeftTitle,TITLE1A)
	graphA.Titles.Add(scgFootnote,VAR1)
	graphA.Titles.Add(scgSubTitle,TITLE2A + ADS.VariableName(DV))

	LINE09 = LINE9A
	For I = 1 To Min(N,6)
		LINE09 = LINE09 + ADS.VariableName(VAR(I)) + " "
		Next I
	If N > 6 Then
		LINE09 = LINE09 + "..."
	End If
	graphA.Titles.Add(scgSubTitle,LINE09)
	graphA.Titles.Add(scgSubTitle,TITLE3A & vbCrLf & TITLE3AB)
	DF = ADS.NumberOfCases - N - 1
	T = VStudent(0.95,DF)
	XPLOT2(1) = L(1)
	YPLOT2(1) = BESTSS * (1 + T * T / DF)
	XPLOT2(2) = L(2)
	YPLOT2(2) = YPLOT2(1)
	L1.Plots.Add(scgLinePlot,2)
	For I = 1 To 2
		If L1.Plots(2).Variable(1).ValuesCount = 2 And L1.Plots(2).Variable(2).ValuesCount = 2 Then
			L1.Plots(2).Variable(1).Value(I) = XPLOT2(I)
			L1.Plots(2).Variable(2).Value(I) = YPLOT2(I)
		End If
	Next I

	L1.Plots(2).DisplayMarkers = False
	L1.Axes.RYAxis.CustomScaleValues.Add
	L1.Axes.RYAxis.CustomScaleValues(1).Value = YPLOT2(1)
	L1.Axes.RYAxis.CustomScaleValues(1).Label = CUSTOMSV
	L1.Axes.RYAxis.DisplayCustomLabels = True

	graphA.Visible = True

	LAM = BESTLAM
End Sub

Sub GOLDENSEARCH (MAXITER, X() As Double, MAXV, VAR() As Double, N, YHAT() As Double, XX() As Double, L() As Double, ByRef LAM, ByRef YGEOMETRICMEAN, DV, DELTA, IPRINT)
	ReDim Preserve YHAT(1 To ADS.NumberOfCases) As Double
	ReDim Preserve X(1 To ADS.NumberOfCases,1 To MAXV) As Double
	ReDim Preserve XX(1 To MAXV,1 To MAXV) As Double
	ReDim Preserve VAR(1 To MAXV) As Double
	ReDim Preserve L(1 To 2) As Double
	Dim II As Double
	Dim R As Double
	Dim C As Double
	Dim X0 As Double
	Dim X3 As Double
	Dim X2 As Double
	Dim X1 As Double
	Dim LAMOLD As Double
	Dim I As Double
	Dim LINE01$
	Dim COLNAM$
	Dim ITER As Double
	Dim SIGMA As Double
	Dim FL As Double
	Dim IROW As Double
	Dim ROWNAM$
	Dim SHANDLE As Double
	Dim F1 As Double
	Dim F2 As Double
	Dim F0 As Double
	Dim F3 As Double
	II = 0
	R = 0.61803399
	C = 1 - R
	X0 = L(1)
	X3 = L(2)
	X2 = 0
	If Abs(L(2)) > Abs(L(1)) Then
		X1 = 0
		X2 = C * L(2)
	Else
		X2 = 0
		X1 = C * L(1)
	End If
	LAMOLD = 0
	mtrx.MatrixCopy(ADS.Data,1,DV,ADS.NumberOfCases,1,YHAT,1,1)
	YGEOMETRICMEAN = 0
	For I = 1 To ADS.NumberOfCases
		YGEOMETRICMEAN = YGEOMETRICMEAN + Log(YHAT(I))
	Next I
	YGEOMETRICMEAN = Exp(YGEOMETRICMEAN / ADS.NumberOfCases)

	For ITER = 1 To MAXITER
		If ITER = 1 Then
			LAM = X1
		End If
		If ITER = 2 Then
			LAM = X2
		End If
		Call REGRESSION(X,ADS.NumberOfCases,MAXV,VAR,N,YHAT,XX,DV,LAM,DELTA,YGEOMETRICMEAN)
		SIGMA = XX(N + 2,N + 2)
		FL = SIGMA
		IROW = ITER
		If ITER > MAXTABLE Then
			mtrx.MatrixCopy(TABLE,2,1,MAXTABLE - 1,2,TABLE,1,1)
			IROW = MAXTABLE
		End If
		TABLE(IROW,1) = LAM
		TABLE(IROW,2) = SIGMA

		If ITER = 1 Then
			F1 = FL
		End If
		If ITER = 2 Then
			F2 = FL
		End If
		If ITER > 2 Then
			If II = 1 Then
				F2 = FL
			End If
			If II = 2 Then
				F1 = FL
			End If

			If Abs(X3 - X0) > TOLER * (Abs(X1) + Abs(X2)) Then
				If F2 < F1 Then
					X0 = X1
					X1 = X2
					X2 = R * X1 + C * X3
					F0 = F1
					F1 = F2
					LAM = X2
					II = 1
				Else
					X3 = X2
					X2 = X1
					X1 = R * X2 + C * X0
					F3 = F2
					F2 = F1
					LAM = X1
					II = 2
				End If
			Else
				LAM = X2
				If F1 < F2 Then
					LAM = X1
				End If
				GoTo THATSIT
			End If
		End If
	Next ITER


	THATSIT:
	Dim s2 As Spreadsheet
	Set s2 = Spreadsheets.New(S2NAME)
	s2.SetSize(IROW,2)
	Dim tabletemp() As Double
	ReDim tabletemp(1 To IROW,1 To 2) As Double
	mtrx.MatrixCopy(TABLE,1,1,IROW,2,tabletemp,1,1)
	s2.Data() = tabletemp
	s2.VariableName(1) = VAR1
	s2.VariableName(2) = VAR2
	s2.Visible = True
End Sub

Sub Main
	Dim grpharr(1 To 2) As Graph
	Set mtrx = MatrixObject
	Set ADS = ActiveDataSet
	Set STBReport = Reports.New
	DELTA = 1e-010
	TOLER = 0.001
	MAXTABLE = 30
	ReDim Preserve TABLE(1 To MAXTABLE,1 To 6) As Double
	MAXC = ADS.NumberOfCases
	MAXV = 10
	MAXITER = 40
	ReDim Preserve L(1 To 2) As Double
	ReDim Preserve XPLOT1(1 To 20) As Double
	ReDim Preserve YPLOT1(1 To 20) As Double
	ReDim Preserve XPLOT2(1 To 2) As Double
	ReDim Preserve YPLOT2(1 To 2) As Double
	ReDim Preserve B(1 To MAXV) As Double
	ReDim Preserve YHAT(1 To ADS.NumberOfCases) As Double
	ReDim Preserve YTRANSF(1 To ADS.NumberOfCases) As Double
	ReDim Preserve Errora(1 To ADS.NumberOfCases) As Double
	ReDim Preserve ERROR0(1 To ADS.NumberOfCases) As Double
	ReDim Preserve X(1 To ADS.NumberOfCases,1 To MAXV) As Double
	ReDim Preserve XX(1 To MAXV,1 To MAXV) As Double
	ReDim Preserve VAR(1 To MAXV) As Double
	MsgBox(MBOX6,vbInformation,MBOX6NAME)

	If SelectVariables2(ADS,SELVARS1,1,1,DV,I,DEPVAR,1,MAXV - 1 - 1,VAR,N,INDVAR) = 0 Then
		End
	End If
	If MISSINGDATAORYMINLTZERO(ADS.NumberOfCases,VAR,N,DV) Then
		End
	End If
	If GETBRACKETSFORSEARCH(L) Then
		End
	End If
	IMETHOD = DisplayButtonBox(BBOX1,BBOX1PARM)
	If IMETHOD = 0 Then
		End
	End If
	If IMETHOD = 2 Then
		Call GOLDENSEARCH(MAXITER,X,MAXV,VAR,N,YHAT,XX,L,LAM,YGEOMETRICMEAN,DV,DELTA,IPRINT)
	Else
		Call GRIDSEARCH(MAXITER,X,MAXV,VAR,N,YHAT,XX,L,LAM,YGEOMETRICMEAN,DV,DELTA,IPRINT,XPLOT1,XPLOT2,YPLOT1,YPLOT2)
	End If
	If (DisplayNumericInputBox(NUMINBOX,VAR1,LAM) = 0) Then
		End
	End If
	mtrx.MatrixFill(1,X,1,1,ADS.NumberOfCases,1)
	For I = 1 To N
		mtrx.MatrixCopy(ADS.Data,1,VAR(I),ADS.NumberOfCases,1,X,1,I + 1)
	Next I
	mtrx.MatrixCopy(ADS.Data,1,DV,ADS.NumberOfCases,1,X,1,N + 1 + 1)
	mtrx.MatrixCrossProductOfDev(X,0,XX)
	mtrx.MatrixSweep(XX,1,N + 1,1)
	SIGMA1 = XX(N + 2,N + 2)
	For I = 1 To ADS.NumberOfCases
		YHAT(I) = 0
		For J = 1 To N + 1
			YHAT(I) = YHAT(I) + X(I,J) * XX(N + 2,J)
		Next J
	Next I
	mtrx.MatrixSubtract(ADS.VData(DV),YHAT,ERROR0)
	mtrx.MatrixFill(1,X,1,1,ADS.NumberOfCases,1)
	For I = 1 To N
		mtrx.MatrixCopy(ADS.Data,1,VAR(I),ADS.NumberOfCases,1,X,1,I + 1)
	Next I
	mtrx.MatrixCopy(ADS.Data,1,DV,ADS.NumberOfCases,1,YHAT,1,1)
	Call BCTRANSFORM(YGEOMETRICMEAN,YHAT,ADS.NumberOfCases,LAM)
	mtrx.MatrixCopy(YHAT,1,1,ADS.NumberOfCases,1,X,1,N + 1 + 1)
	mtrx.MatrixCrossProductOfDev(X,0,XX)
	mtrx.MatrixSweep(XX,1,N + 1,1)
	SIGMA = XX(N + 2,N + 2)
	TABLE(1,1) = LAM
	TABLE(1,2) = SIGMA
	TABLE(1,3) = -2 * Log((SIGMA / SIGMA1)^(ADS.NumberOfCases / 2))
	TABLE(1,4) = 1 - IChi2(TABLE(1,3),1)
	TABLE(1,5) = 0
	TABLE(1,6) = 0

	LINE09 = LINE9A
	For I = 1 To Min(N,5)
		LINE09 = LINE09 + " " + ADS.VariableName(VAR(I))
	Next I
	If N > 5 Then
		LINE09 = LINE09 + "..."
	End If
	Dim s3 As Spreadsheet
	Set s3 = Spreadsheets.New(S3NAME)
	s3.SetSize(1,4)
	Dim tmparr() As Double
	ReDim tmparr(1 To 1, 1 To 4) As Double
	mtrx.MatrixCopy(TABLE,1,1,1,4,tmparr(),1,1)
	s3.Data = tmparr
	s3.VariableName(1) = S3VNAME1
	s3.VariableName(2) = S3VNAME2
	s3.VariableName(3) = S3VNAME3
	s3.VariableName(4) = S3VNAME4
	s3.CaseName(1) = S3CASE1
	s3.EntireRange.AutoFit
	s3.AutoFitCase
	s3.InputSpreadsheet = False
	s3.Visible = True

	mtrx.MatrixFill(1,X,1,1,ADS.NumberOfCases,1)
	For I = 1 To N
		mtrx.MatrixCopy(ADS.Data,1,VAR(I),ADS.NumberOfCases,1,X,1,I + 1)
	Next I
	mtrx.MatrixCopy(ADS.Data,1,DV,ADS.NumberOfCases,1,YHAT,1,1)
	For I = 1 To ADS.NumberOfCases
		If Abs(LAM) < DELTA Then
			YHAT(I) = Log(YHAT(I))
		Else
			YHAT(I) = YHAT(I)^LAM
		End If
	Next I
	mtrx.MatrixCopy(YHAT,1,1,ADS.NumberOfCases,1,X,1,N + 1 + 1)
	mtrx.MatrixDuplicate(YHAT,YTRANSF)
	mtrx.MatrixCrossProductOfDev(X,0,XX)
	mtrx.MatrixSweep(XX,1,N + 1,1)
	SIGMA = XX(N + 2,N + 2)
	For I = 1 To NCASES(ADS)
		YHAT(I) = 0
		For J = 1 To N + 1
			YHAT(I) = YHAT(I) + X(I,J) * XX(N + 2,J)
		Next J
	Next I
	mtrx.MatrixSubtract(YTRANSF,YHAT,Errora)

	Dim Graphx As Graph
	Set Graphx = Graphs.New(GRAPHXNAME)
	Dim L1 As Layout2D
	Set L1 = Graphx.GraphObject.CreateContent(scg2DGraph)
	L1.Plots.Add(scgScatterPlot,ADS.NumberOfCases)
		For I = 1 To ADS.NumberOfCases
			If L1.Plots(1).Variable(1).ValuesCount = ADS.NumberOfCases And L1.Plots(1).Variable(2).ValuesCount = ADS.NumberOfCases Then
				L1.Plots(1).Variable(1).Value(I) = ADS.Value(I,DV)
				L1.Plots(1).Variable(2).Value(I) = ERROR0(I)
			End If
		Next I
	L1.Plots(1).Fits.Add
	L1.Plots(1).Fits(1).FitType = scgFit2DLinear
	L1.Plots(1).Fits(1).Line.ForegroundColor = RGB(255,0,0)
	Graphx.Titles.Add(scgMainTitle,GRAPHXNAME)
	Graphx.Titles.Add(scgLeftTitle,TITLE2X)
	Graphx.Titles.Add(scgFootnote,TITLE3X)

	Set grpharr(1) = Graphx
	Dim Graphy As Graph
	Set Graphy = Graphs.New(GRAPHYN + Str(LAM))

	Set L1 = Graphy.GraphObject.CreateContent(scg2DGraph)
	L1.Plots.Add(scgScatterPlot,ADS.NumberOfCases)
		For I = 1 To ADS.NumberOfCases
			If L1.Plots(1).Variable(1).ValuesCount = ADS.NumberOfCases And L1.Plots(1).Variable(2).ValuesCount = ADS.NumberOfCases Then
				L1.Plots(1).Variable(1).Value(I) = YTRANSF(I)
				L1.Plots(1).Variable(2).Value(I) = Errora(I)
			End If
		Next I
	L1.Plots(1).Fits.Add
	L1.Plots(1).Fits(1).FitType = scgFit2DLinear
	L1.Plots(1).Fits(1).Line.ForegroundColor = RGB(255,0,0)
	Graphy.Titles.Add(scgMainTitle,GRAPHYN + Str(LAM))
	Graphy.Titles.Add(scgLeftTitle,TITLE2X)
	Graphy.Titles.Add(scgFootnote,TITLE1Y)
	Set grpharr(2) = Graphy

	Dim graphz As Graph
	Set graphz = CreateMultipleGraphs(grpharr(),2,,,scIsotropic,GRAPHZ1,GRAPHZ2 + ADS.VariableName(DV) & vbCrLf & LINE09)
	graphz.Visible =True
	SortArrayAscending(ERROR0())
	'VectorSort(ERROR0,SORT_ASCENDING)
	mtrx.MatrixDuplicate(ERROR0,YHAT)
	VectorRank(YHAT,SORT_ASCENDING,RANK_MEAN)
	For I = 1 To NCASES(ADS)
		YHAT(I) = (3 * YHAT(I) - 1) / (3 * NCASES(ADS) + 1)
		YHAT(I) = VNormal(YHAT(I),0,1)
	Next I


	Dim Graphj As Graph
	Set Graphj = Graphs.New(GRAPHXNAME)

	Set L1 = Graphj.GraphObject.CreateContent(scg2DGraph)
	L1.Plots.Add(scgScatterPlot,ADS.NumberOfCases)
		For I = 1 To ADS.NumberOfCases
			If L1.Plots(1).Variable(1).ValuesCount = ADS.NumberOfCases And L1.Plots(1).Variable(2).ValuesCount = ADS.NumberOfCases Then
				L1.Plots(1).Variable(1).Value(I) = ERROR0(I)
				L1.Plots(1).Variable(2).Value(I) = YHAT(I)
			End If
		Next I
	L1.Plots(1).Fits.Add
	L1.Plots(1).Fits(1).FitType = scgFit2DLinear
	L1.Plots(1).Fits(1).Line.ForegroundColor = RGB(255,0,0)
	Graphj.Titles.Add(scgMainTitle,GRAPHXNAME)
	Graphj.Titles.Add(scgLeftTitle,ZVAL)
	Graphj.Titles.Add(scgFootnote,RESID)
	Set grpharr(1) = Graphj
	SortArrayAscending(Errora())
	'VectorSort(Errora,SORT_ASCENDING)
	mtrx.MatrixDuplicate(Errora,YHAT)
	VectorRank(YHAT,SORT_ASCENDING,RANK_MEAN)
	For I = 1 To ADS.NumberOfCases
		YHAT(I) = (3 * YHAT(I) - 1) / (3 * NCASES(ADS) + 1)
		YHAT(I) = VNormal(YHAT(I),0,1)
	Next I

	Dim Graphk As Graph
	Set Graphk = Graphs.New(LAMB + Str(LAM))

	Set L1 = Graphk.GraphObject.CreateContent(scg2DGraph)
	L1.Plots.Add(scgScatterPlot,ADS.NumberOfCases)
		For I = 1 To ADS.NumberOfCases
			If L1.Plots(1).Variable(1).ValuesCount = ADS.NumberOfCases And L1.Plots(1).Variable(2).ValuesCount = ADS.NumberOfCases Then
				L1.Plots(1).Variable(1).Value(I) = Errora(I)
				L1.Plots(1).Variable(2).Value(I) = YHAT(I)
			End If
		Next I
	L1.Plots(1).Fits.Add
	L1.Plots(1).Fits(1).FitType = scgFit2DLinear
	L1.Plots(1).Fits(1).Line.ForegroundColor = RGB(255,0,0)
	Graphk.Titles.Add(scgMainTitle,LAMB + Str(LAM))
	Graphk.Titles.Add(scgLeftTitle,ZVAL)
	Graphk.Titles.Add(scgFootnote,RESID)
	Set grpharr(2) = Graphk
	Dim Graphl As Graph
	Set Graphl = CreateMultipleGraphs(grpharr,2,,,scIsotropic,MERGEGRAPH1,SUBTITL + ADS.VariableName(DV) & vbCrLf & LINE09)
	Graphl.Visible = True

End Sub

Function GetMin(Vector() As Double) As Double

	Dim	CurrentMin As Double
	CurrentMin = Vector(1)
	Dim I As Integer
	For I = LBound(Vector()) To UBound(Vector())
		If CurrentMin > Vector(I) Then
			CurrentMin = Vector(I)
		End If
	Next I

	GetMin = CurrentMin

End Function
Sub SortArrayAscending(ByRef Vector() As Double)

	Dim I As Integer, Outer As Integer, Temp As Double
	For Outer =  UBound(Vector()) - 1 To 1 Step -1
		For I = 1 To Outer
			'ascending order (low-high)
				If Vector(I) > Vector(I + 1) Then
					Temp = Vector(I + 1)
					Vector(I + 1) = Vector(I)
					Vector(I) = Temp
				End If
		Next I
	Next Outer

End Sub

'STATISTICA MACRO FILE VERSION 4
'BEGINPROPERTIES
'NAME=BoxCox
'DESCRIPTION=
'LANGUAGE=0
'ENDPROPERTIES