0
$\begingroup$

Sorry for the length of the code but the question is only on the Manipulate part.

Here are some functions to evaluate apportionment methods

hamapp[v_, s_] := Module[{vv = v, ss = s}, d = Total[vv]/ss;
   q = N[vv/d];
  qq = \[LeftFloor]q\[RightFloor];
  res = q - qq;(*reste*)
  raa = ss - Total[qq];(*reste à attribuer*)
  raa1 = Table[1, {i, Length[vv]}];
  res1 = Table[
    If[MemberQ[Ordering[res, raa, #1 > #2 &], i], qq[[i]] + raa1[[i]],
      qq[[i]]], {i, Length[qq]}]]
jeffapp[v_List, s_Integer] := 
 Module[{x}, 
  Floor[v/x] /. FindRoot[Total@Floor[v/x] == s, {x, 1, Total[v]}]]
lownapp[v_List, s_] := Module[{vv = v, ss = s},
  If[Length[vv] > ss, 
   Print[Style[
     "Number of seat is lower than the number of group -> \
Unapplicable method", 18, Red, Bold]],
    al0 = N[(vv/Total[vv]) ss];(* q *)
   al1 = \[LeftFloor]al0\[RightFloor];(* \[LeftFloor]q\[RightFloor] *)


   pos = Position[al1, 
     0];(*position des groupes qui ont un \[LeftFloor]q\[RightFloor] \
nul *)
   al2 = Table[If[MemberQ[pos, {i}], 1, al1[[i]]], {i, Length[al1]}];(* 
   On donne un bien à tous les groupe dont \[LeftFloor]q\[RightFloor] \
= 0*)
   decpart = 
    Table[If[al1[[i]] > 0, al0[[i]] - al1[[i]], 0], {i, 
      Length[al0]}];(* 
   On calcule le vecteur des restes décimaux q-\[LeftFloor]q\
\[RightFloor] et remplace cette valeur par 0 pour tous les groupes \
qui ont reçu un objet dans l'étape précédente pour se garantir qu'on \
ne leur en donnera pas un autre *) 
   rest = ss - Total[al2]; (* 
   on évalue le nombre d'objets qui n'ont pas encore été alloués *)
   al3 = Table[1, {i, Length[al0]}]; (* on forme un vecteur de 1 *)
   al4 = Table[
     If[MemberQ[Ordering[decpart, rest, #1 > #2 &], i], 
      al2[[i]] + al3[[i]], al2[[i]]], {i, Length[al1]}]
   (* On trie dans l'ordre décroissant decpart et on sélectionne \
uniquement les rest premiers termes par leur numéro d'ordre dans \
decpart. Puis on alloue un objet supplémentaire aux groupes qui ont \
été sélectionnés *)
   ]]

adamsapp[v_List, s_Integer] := 
 Module[{x}, 
  Ceiling[v/x] /. 
   FindRoot[Total@Ceiling[v/x] == s, {x, Total[v]/s, Total[v]}]]
hillhungapp[v_, s_] := Module[{vv = v, ss = s, x},
  xhh = FindRoot[
    Total@Table[
        With[{i = i}, 
         If[(vv[[i]]/x) > 
           Sqrt[Floor[(vv[[i]]/x)] Ceiling[(vv[[i]]/x)]], 
          Ceiling[(vv[[i]]/x)], Floor[(vv[[i]]/x)]]], {i, 
         Length[vv]}] - ss == 0, {x, 1, Total[vv]}];
  Table[With[{i = i}, 
     If[(vv[[i]]/x) > Sqrt[Floor[(vv[[i]]/x)] Ceiling[(vv[[i]]/x)]], 
      Ceiling[(vv[[i]]/x)], Floor[(vv[[i]]/x)]]], {i, Length[vv]}] /. 
   xhh]
deanapp[v_, s_] := Module[{vv = v}, ww = DeleteCases[vv, 0];
  var = Array[x, Length[ww]];
  obj = Total[
    Table[Log[(x[i]!)^3 2^(x[i] - 
           1)/(x[i]^2 ww[[i]]^(x[i] - 1) ((2 x[i] - 1)!))], {i, 
      Length[ww]}]];
  const = Total[var];
  cons1 = And @@ Thread[var > 0];
  int = var \[Element] Integers;
  argmin = ArgMin[{obj, const == s && cons1 && int}, var];
  zer = ConstantArray[0, Length[vv] - Length[ww]];
  fin = Flatten[{argmin, zer}];
  Fold[Insert[#1, 0, #2] &, DeleteCases[fin, 0], Position[vv, 0]]]
websterapp[v_, s_] := Module[{vv = v, ss = s, x},
  xweb = FindRoot[
    Total@Table[
        With[{i = i}, 
         If[(vv[[i]]/x) > 
           0.5 (Floor[(vv[[i]]/x)] + Ceiling[(vv[[i]]/x)]), 
          Ceiling[(vv[[i]]/x)], Floor[(vv[[i]]/x)]]], {i, 
         Length[vv]}] - ss == 0, {x, 1, Total[vv]}];
  Table[With[{i = i}, 
     If[(vv[[i]]/x) > 0.5 (Floor[(vv[[i]]/x)] + Ceiling[(vv[[i]]/x)]),
       Ceiling[(vv[[i]]/x)], Floor[(vv[[i]]/x)]]], {i, 
     Length[vv]}] /. xweb]
qbpy[n_, v_, as_] := 
 Block[{x = v, y = as, h = n}, r = Range[Length[x]];
  qq = N[v/Total[v] h];
  t = Table[{r[[i]], 
     If[(y + 1)[[i]] > \[LeftCeiling]qq\[RightCeiling][[i]], -1, 
      N[v[[i]]/(y[[i]] + 1)]]}, {i, Length[y]}];
  pt = Sort[t, #1[[2]] > #2[[2]] &];
  ttt = Table[
    If[i == pt[[1, 1]], y[[i]] = y[[i]] + 1, y[[i]]], {i, Length[as]}]]
balyouapp[v_, s_] := 
 Fold[qbpy[#2, v, #] &, ConstantArray[0, Length[v]], Range[s]]

Sorry for the french commentaries.

Then

SetOptions[Manipulator, Appearance -> Labeled]
Pane[Panel[
  Style[Framed[
    Manipulate[(vv = {v[1], v[2], v[3]}; s = sn; 
      Grid[{{Style["Hamilton", Blue], "", 
         hamapp[vv, s]}, {Style["Jefferson", Blue], "", 
         jeffapp[vv, s]}, {Style["Lowndes", Blue], "", 
         lownapp[vv, s]}, {Style["Adams", Blue], "", 
         adamsapp[vv, s]}, {Style["Hill-Huntington", Blue], "", 
         hillhungapp[vv, s]}, {Style["Webster", Blue], "", 
         websterapp[vv, s]}, {Style["Dean", Blue], "", 
         deanapp[vv, s]}, {Style["Balinski-Young", Blue], "", 
         balyouapp[vv, s]}}, 
       Background -> {{LightYellow, LightYellow, LightYellow}}]), {{v[
        1], 50}, 1, 10000, 1, Appearance -> "Labelled"}, { {v[2], 50},
       1, 10000, 1}, {{ v[3], 50}, 1, 10000, 1, 
      Appearance -> "Labelled"}, {{ sn, 5}, 4, 45, 1, 
      Appearance -> "Labelled"}, 
     FrameLabel -> {{"", 
        ""}, {Style["Méthode de Répartition de Biens Indivisibles", 
         Red, Bold, 16, FontFamily -> "Bell MT"], ""}}],
    FrameMargins -> 30, RoundingRadius -> 10], 
   DefaultOptions -> {Panel -> {Background -> LightYellow}}]], Full, 
 Alignment -> Center]

If I have made no errors in copying the code here is the result.enter image description here

As you can see it looks like if there is an error. So I have tried to define the two cells as initialization cell. But after I can't move the sliders.

Then I ask the sliders to be labeled and obviously they are'nt.

At last I would like all the background yellow and the labels in the same font than the text.

Thanks for the help.

$\endgroup$
  • 1
    $\begingroup$ You want to map "Labelled" $\to$ "Labeled" for Appearance (three times, maybe four if you add to $v[2]$). $\endgroup$ – John Joseph M. Carrasco Aug 25 '17 at 10:54
  • $\begingroup$ Use SetOptions[Manipulator, Appearance -> "Labeled"] $\endgroup$ – m_goldberg Aug 25 '17 at 13:46
  • $\begingroup$ Thanks both for the help. The Only thing is how to colorize the white part ? $\endgroup$ – cyrille.piatecki Aug 25 '17 at 13:55
1
$\begingroup$

Take FrameLabel out of your Manipulate expression and don't try to move manipulators with a range of 1 to 10000 by 1 unit (that is less than one pixel of movement).

The error is from FindRoot (as is clearly indicated). That's not a Manipulate problem and I don't address it.

This version of your Manipulate expression works.

SetOptions[Manipulator, Appearance -> "Labeled"];
Manipulate[
 vv = {v[1], v[2], v[3]};
 s = sn;
 Grid[{{Style["Hamilton", Blue], "", 
    hamapp[vv, s]}, {Style["Jefferson", Blue], "", 
    jeffapp[vv, s]}, {Style["Lowndes", Blue], "", 
    lownapp[vv, s]}, {Style["Adams", Blue], "", 
    adamsapp[vv, s]}, {Style["Hill-Huntington", Blue], "", 
    hillhungapp[vv, s]}, {Style["Webster", Blue], "", 
    websterapp[vv, s]}, {Style["Dean", Blue], "", 
    deanapp[vv, s]}, {Style["Balinski-Young", Blue], "", 
    balyouapp[vv, s]}}, 
  Background -> {{LightYellow, LightYellow, LightYellow}}],
 {{v[1], 50}, 50, 10000, 50},
 {{v[2], 50}, 50, 10000, 50},
 {{v[3], 50}, 50, 10000, 50},
 {{sn, 5}, 4, 45, 1}]

demo

| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.