Skip to main content

fitting - Softmax Regression implementation 


a[t_List,x_List]:=E^(t.Prepend[x,1])
hypothethis[t_List, k_, x_]:= Table[a[t[[j]], x], {j, 1, k-1}]/(1 +Sum[a[t[[j]],x],{j, 1, k-1}])

indicatorFunc[eqn_]:=If[eqn,1,0]

SoftmaxRegression[x_List, y_List]:=Module[{J, vars, b, k, n},
    k = Length@Union[y];

    n = Length[Transpose[x]]+1;
    vars = Array[b, {k - 1, n}];
    J[t_]:= (-1/Length[y])*(Sum[indicatorFunc[y[[i]] == k]*Log[1/(1 +Sum[a[t[[j]],x[[i]]],{j, 1, k-1}])]+Sum[indicatorFunc[y[[i]] ==j]*Log[a[t[[j]],x[[i]]]/(1 + Sum[a[t[[j]],x[[i]]],{j, 1, k-1}])],{j,1,k-1}],{i, 1,Length[y]}])+Sum[Sum[t[[i,j]]^2,{j, 1, n}],{i, 1, k-1}];
    vars/.NMinimize[J[vars],Flatten@vars][[2]]
]

http://ufldl.stanford.edu/wiki/index.php/Softmax_Regression


I am trying to implement the softmax regression, which returns a list of coefficient for hypothethis function. And hypothethis function will gives the first n - 1 classes probability, which we can use to find the nth class's probability.


I used FisherIris data, in which there are 3 classes: virsicolor, verginica, setosa. I don't know why the 2nd class and the 3rd are combined somehow. There is something wrong in the implementation of my code but I don't know where is wrong.


iris = ExampleData[{"Statistics", "FisherIris"}];

rs = RandomSample[Range[150]];
n = Length[iris];
cut = Ceiling[0.8 n];
train = iris[[rs[[1 ;; cut]]]];
test = iris[[rs[[cut + 1 ;;]]]];
x = train[[All, 1 ;; 4]];
y = train[[All, -1]] /. {"setosa" -> 1, "versicolor" -> 2, "virginica" -> 3}

tList = SoftmaxRegression[x, y]


the result is:


 {{0.0268716, 0.0458991, 0.132301, -0.209938, -0.0960074}, {-0.00348727, -0.0128626, -0.0458174, 0.0371426, 0.00473217}}

p = hypothethis[tList, 3, #] & /@ test[[All, 1 ;; 4]]
{{0.218183, 0.390056}, {0.221959, 0.387587}, {0.251179, 
  0.367642}, {0.270846, 0.354952}, {0.452594, 0.249346}, {0.279229, 
  0.352813}, {0.220481, 0.385259}, {0.212727, 0.392914}, {0.433949, 
  0.25978}, {0.258379, 0.360879}, {0.264716, 0.362466}, {0.235144, 
  0.377701}, {0.450472, 0.249237}, {0.456505, 0.246573}, {0.199231, 
  0.401248}, {0.251868, 0.367067}, {0.194777, 0.399115}, {0.256978, 

  0.366888}, {0.200664, 0.399031}, {0.20611, 0.394495}, {0.190138, 
  0.407413}, {0.438089, 0.257827}, {0.450832, 0.249554}, {0.233257, 
  0.376698}, {0.247638, 0.372358}, {0.273605, 0.352006}, {0.208238, 
  0.392663}, {0.270954, 0.356693}, {0.202797, 0.394089}, {0.210708, 
  0.388326}}
AllClassProb[prob_List]:= Append[prob, 1 - Total[prob]]

probability = AllClassProb /@ p

We found the 3rd class's probability by the previous two.



{{0.218183, 0.390056, 0.391761}, {0.221959, 0.387587, 0.390454}, 
{0.251179, 0.367642, 0.381179}, {0.270846, 0.354952, 
0.374202}, {0.452594, 0.249346, 0.29806}, {0.279229, 0.352813, 
0.367959}, {0.220481, 0.385259, 0.39426}, {0.212727, 0.392914, 
0.394358}, {0.433949, 0.25978, 0.306271}, {0.258379, 0.360879, 
0.380741}, {0.264716, 0.362466, 0.372818}, {0.235144, 0.377701, 
0.387155}, {0.450472, 0.249237, 0.300291}, {0.456505, 0.246573, 
0.296921}, {0.199231, 0.401248, 0.399521}, {0.251868, 0.367067, 
0.381066}, {0.194777, 0.399115, 0.406108}, {0.256978, 0.366888, 
0.376134}, {0.200664, 0.399031, 0.400304}, {0.20611, 0.394495, 

0.399395}, {0.190138, 0.407413, 0.402448}, {0.438089, 0.257827, 
0.304084}, {0.450832, 0.249554, 0.299614}, {0.233257, 0.376698, 
0.390045}, {0.247638, 0.372358, 0.380003}, {0.273605, 0.352006, 
0.374389}, {0.208238, 0.392663, 0.399099}, {0.270954, 0.356693, 
0.372353}, {0.202797, 0.394089, 0.403113}, {0.210708, 0.388326, 
0.400966}}


augmentProb = MapThread[
Transpose[{#1, #2}] &, {Table[Range[Length[Transpose[probability]]], {Length[probability]}], probability}]


result = MaximalBy[#, Last] & /@ augmentProb

theoreticalResult = test /. {"setosa" -> 1, "versicolor" -> 2, "virginica" -> 3};
theoreticalResult[[All, -1]]
{3, 2, 2, 2, 1, 2, 3, 3, 1, 2, 2, 3, 1, 1, 3, 2, 3, 2, 3, 3, 3, 1, 1, 3, 2, 2, 3, 2, 3, 3}

exprimentalResult = Transpose[Flatten[result, 1]];
exprimentalResult[[1]]


{3, 3, 3, 3, 1, 3, 3, 3, 1, 3, 3, 3, 1, 1, 2, 3, 3, 3, 3, 3, 2, 1, 1, 3, 3, 3, 3, 3, 3, 3}


Comments

Post a Comment

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more