一段logistic回归分析的vba代码

相似文件 换一批

是 否 +2 论坛币

k人 参与回答

经管之家送您一份

应届毕业生专属福利!

求职就业群

赵安豆老师微信：zhaoandou666

经管之家联合CDA

送您一个全额奖学金名额~ !

立即领取

感谢您参与论坛问题回答

经管之家送您两个论坛币！

+2 论坛币

<p><u><font color="#0000ff">logit通过MLE方法和Newton法求logistic回归分析的参数：</font></u></p><p><u><font color="#0000ff">Option Explicit</font></u></p><p><u><font color="#0000ff">Function logit(y As Range, xraw As Range, Optional constant, Optional stats)</font></u></p><p><u><font color="#0000ff">If IsMissing(constant) Then constant = 1<br/>If IsMissing(stats) Then stats = 0<br/>'Count variables<br/>Dim i As Integer, j As Integer, jj As Integer</font></u></p><u><font color="#0000ff"><p><br/>'Read data dimensions<br/>Dim K As Integer, N As Integer<br/>N = y.Rows.Count<br/>K = xraw.Columns.Count + constant</p><p>'Some error checking<br/>If xraw.Rows.Count <> N Then MsgBox "error"</p><p><br/>'Adding a vector of ones to the x matrix if constant=1, name xraw=x from now on<br/>Dim x() As Double<br/>ReDim x(1 To N, 1 To K)<br/>For i = 1 To N<br/>    x(i, 1) = 1<br/>    For j = 1 + constant To K<br/>        x(i, j) = xraw(i, j - constant)<br/>    Next j<br/>Next i</p><p>  <br/>'Initializing the coefficient vector (b) and the score (bx)<br/>Dim b() As Double, bx() As Double, ybar As Double<br/>ReDim b(1 To K)<br/>ReDim bx(1 To N)</p><p>ybar = Application.WorksheetFunction.Average(y)<br/>If constant = 1 Then b(1) = Log(ybar / (1 - ybar))<br/>For i = 1 To N<br/>      bx(i) = b(1)<br/>Next i</p><p></p><p>'Defining the variables used in the Newton procedure<br/>Dim sens As Double, maxiter As Integer, iter As Integer, change As Double<br/>Dim lambda() As Double, lnL() As Double, dlnL() As Double, hesse() As Double, hinv(), hinvg()<br/>ReDim lambda(1 To N)</p><p>sens = 1 * 10 ^ (-11): maxiter = 50<br/>ReDim lnL(1 To maxiter)<br/>change = sens + 1: iter = 1: lnL(1) = 0</p><p>'Loop for Newton iteration<br/>Do While Abs(change) > sens And iter < maxiter<br/>    iter = iter + 1<br/>    <br/>    'reset derivative of log likelihood and Hessian<br/>    Erase dlnL, hesse<br/>    ReDim dlnL(1 To K): ReDim hesse(1 To K, 1 To K)</p><p>    'Compute prediction Lambda, gradient dlnl, Hessian hesse, and log likelihood lnl<br/>    For i = 1 To N<br/>        lambda(i) = 1 / (1 + Exp(-bx(i)))<br/>        For j = 1 To K<br/>            dlnL(j) = dlnL(j) + (y(i) - lambda(i)) * x(i, j)<br/>            For jj = 1 To K<br/>                hesse(jj, j) = hesse(jj, j) - lambda(i) * (1 - lambda(i)) * x(i, jj) * x(i, j)<br/>            Next jj<br/>        Next j<br/>        lnL(iter) = lnL(iter) + y(i) * Log(1 / (1 + Exp(-bx(i)))) + (1 - y(i)) * Log(1 - 1 / (1 + Exp(-bx(i))))<br/>    Next i<br/> <br/>    'Compute inverse Hessian (=hinv) and multiply hinv with gradient dlnl<br/>    hinv = Application.WorksheetFunction.MInverse(hesse)<br/>    hinvg = Application.WorksheetFunction.MMult(dlnL, hinv)<br/>    <br/>    change = lnL(iter) - lnL(iter - 1)<br/>      <br/>   'If convergence achieved, exit now and keep the b corresponding with the estimated hessian<br/>   If Abs(change) <= sens Then Exit Do<br/>   <br/>  ' Apply Newton's scheme for updating coefficients b<br/>    For j = 1 To K<br/>        b(j) = b(j) - hinvg(j)<br/>    Next j</p><p></p><p>    'Compute new score (bx)<br/>    For i = 1 To N<br/>        bx(i) = 0<br/>        For j = 1 To K<br/>            bx(i) = bx(i) + b(j) * x(i, j)<br/>        Next j<br/>    Next i</p><p>Loop</p><p><br/>'some error handling<br/>If iter > maxiter Then<br/> MsgBox "Maximum Number of Iteration exceeded. No convergence achieved. Exiting. Sorry."<br/>GoTo myend<br/>End If<br/> </p><p>'output<br/>Dim relogit()<br/>ReDim relogit(1 To 1, 1 To K)<br/>If stats = 1 Then ReDim relogit(1 To 7, 1 To K)</p><p>'Coefficients<br/>For j = 1 To K<br/> relogit(1, j) = b(j)<br/>Next j</p><p>'Additional statistics if requested<br/>If stats = 1 Then<br/>  For j = 1 To K<br/>   relogit(2, j) = Sqr(-hinv(j, j))<br/>   relogit(3, j) = relogit(1, j) / relogit(2, j)<br/>   relogit(4, j) = (1 - Application.WorksheetFunction.NormSDist(Abs(relogit(3, j)))) * 2<br/>   <br/>   relogit(5, j) = "#N/A"<br/>   relogit(6, j) = "#N/A"<br/>   relogit(7, j) = "#N/A"<br/> <br/>  Next j<br/> <br/> 'ln Likelihood of model with just a constant(lnL0)<br/> Dim lnL0 As Double<br/> lnL0 = N * (ybar * Log(ybar) + (1 - ybar) * Log(1 - ybar))</p><p><br/> relogit(5, 1) = 1 - lnL(iter) / lnL0      'McFadden R2<br/> relogit(5, 2) = iter - 1           'Number of iterations<br/> relogit(6, 1) = 2 * (lnL(iter) - lnL0)   'LR test<br/> relogit(6, 2) = Application.WorksheetFunction.ChiDist(relogit(6, 1), K - 1) 'p-value for LR<br/> relogit(7, 1) = lnL(iter)<br/> relogit(7, 2) = lnL0<br/> <br/>End If<br/> logit = relogit</p><p>GoTo myend</p><p>'Error Handler<br/>error:<br/>MsgBox ("Fatal Error. Reasons might be: y not {0,1}, not the same number of N for y and x's...or anything else")<br/>myend:<br/>End Function</p><p>Function XTRANS(defaultdata As Range, x As Range, numranges As Integer)<br/>Dim bound, numdefaults, obs, defrate, N, j, defsum, obssum, i<br/>ReDim bound(1 To numranges), numdefaults(1 To numranges)<br/>ReDim obs(1 To numranges), defrate(1 To numranges)</p><p>N = x.Rows.Count</p><p>'Determining number of defaults, observations and default rates for ranges<br/>For j = 1 To numranges<br/>    <br/>    bound(j) = Application.WorksheetFunction.Percentile(x, j / numranges)<br/>    <br/>    numdefaults(j) = Application.WorksheetFunction.SumIf(x, "<=" & bound(j), defaultdata) - defsum<br/>    defsum = defsum + numdefaults(j)</p><p>    obs(j) = Application.WorksheetFunction.CountIf(x, "<=" & bound(j)) - obssum<br/>    obssum = obssum + obs(j)<br/>    <br/>    defrate(j) = numdefaults(j) / obs(j)<br/>Next j</p><p>'Assigning range default rates in logistic transformation<br/>Dim transform<br/>ReDim transform(1 To N, 1 To 1)</p><p>For i = 1 To N<br/>    j = 1<br/>    While x(i) - bound(j) > 0<br/>        j = j + 1<br/>    Wend<br/>    transform(i, 1) = Application.WorksheetFunction.Max(defrate(j), 0.0000001)<br/>    transform(i, 1) = Log(transform(i, 1) / (1 - transform(i, 1)))<br/>Next i</p><p>XTRANS = transform<br/>End Function<br/>Function WINSOR(x As Range, level As Double)</p><p>Dim N As Integer, i As Integer<br/>N = x.Rows.Count</p><p>'Obtain percentiles<br/>Dim low, up<br/>low = Application.WorksheetFunction.Percentile(x, level)<br/>up = Application.WorksheetFunction.Percentile(x, 1 - level)</p><p>'Pull x to percentiles<br/>Dim result<br/>ReDim result(1 To N, 1 To 1)<br/>For i = 1 To N<br/>    result(i, 1) = Application.WorksheetFunction.Max(x(i), low)<br/>    result(i, 1) = Application.WorksheetFunction.Min(result(i, 1), up)<br/>Next i</p><p>WINSOR = result</p><p>End Function</p><p><a href="mailto:zhang.xue.zhi@citi.com"></a></p></font></u><a href="mailto:zhang.xue.zhi@citi.com"></a>

扫码加我 拉你入群

请注明：姓名-公司-职位

以便审核进群资格，未注明则拒绝

分享0 收藏0 回帖

关键词：Logistic回归分析 logistic回归 logistic ogistic logisti VBA 回归分析 logistic 代码

看不懂，呵呵

看不懂，呵呵

Investment Management.pdf

一个有用的文档，呵呵

一个有用的文档，呵呵

啥玩意啊？骗钱的，愿着上当？