0
$\begingroup$

I have a simple calculation which I am trying to use if condition to evaluate summation of some values, here's a code;

ClearAll[lst, n, k, i, t, L, s]; ClearAll[f, G, OS, SI, p, delta];
<< Combinatorica`;
Block[{$ContextPath}, Needs["Combinatorica`"]];
L = 10;
lst = Range@L;
f[i_, j_] := -1/(L*Sin[Pi* (0.5 - (i - j))/L]);
G = SetPrecision[Array[f, {L, L}], 100];
OS = SetPrecision[(G + IdentityMatrix[L]).Inverse[
     G - IdentityMatrix[L]], 100];
s = SetPrecision[Det[(IdentityMatrix[L] - G)/2], 100];
Do[
  config = {NthSubset[i, lst]};
  Prob1 = SetPrecision[s*Det[-OS[[#, #]]] & /@ config, 100]//Chop;
  If[Prob1>0,Sh1=-Prob1*Log[Prob1]+Sh1,Sh1=0+Sh1]
  , {i, 1, 2^L - 1}];

The Prob1 values are too small and sometimes Mathematica gives even negative values which I suppose are numerical issues. I tried to use Chop to covert the small values to be zero. The problem is that, the if condition return only zero value for Sh1; I am thinking that the condition term might not set correctly but tried different things such as considering delta=N[10^-100,100] and changing the condition to if Prob1>delta, but still it did not fix the problem. I am trying to find a way to not include terms that are very small(almost zero) in Sh1, as the Log function will not be valid.

$\endgroup$
5
  • $\begingroup$ I can not understand the question. It is better to explain the problem more clearly. $\endgroup$ – Kattern Jul 6 '15 at 5:01
  • 1
    $\begingroup$ It seems to me that Chop is actually not doing anything in your code: in fact, it is applied to the value returned by SetPrecision, but then the chopped value returned by Chop is not assigned to anything and discarded. More generally, it is hard to suggest alternatives, since we don't know what $A$ looks like. Show us an example of a matrix A that is giving you this trouble. $\endgroup$ – MarcoB Jul 6 '15 at 5:35
  • $\begingroup$ A better approach would probably be to increase the precision of $A$ before calculating its determinant: SetPrecision[A, 100]; Det[A]. $\endgroup$ – MarcoB Jul 6 '15 at 5:40
  • $\begingroup$ Hi all, thanks for the comments, I have included the entire code, hope that clarifies what's the problem... $\endgroup$ – setareh Jul 6 '15 at 15:51
  • $\begingroup$ @MarcoB: well actually Chop makes the small values to be zero, so if you print the Prob1 values, it return zero, but if you run the code for L=2, one should get 3 different value for Prob1, which two of them are small and using Chop becomes zero, while the last one is nonzero, but the if statement is not picking it up correctly to evaluate Sh1.... $\endgroup$ – setareh Jul 6 '15 at 15:56
2
$\begingroup$

I see at least two problems here:

  1. As written Prob1 is a List; you need to add // First (or similar) to extract a scalar value.

  2. You failed to define a starting value for Sh1 therefore Sh1 = 0 + Sh1 leads to an infinite recursion when the first scalar value is Equal to zero.

Additionally some more improvements to be made:

  1. You should avoid starting user Symbol names with capital letters as these can conflict with built-in Symbols, now or in the future.

  2. If you use the Block[{$ContextPath}, Needs["Combinatorica`"]]; method to load a package, which avoids name collisions with built-ins, you must use the fully qualified Symbol name i.e. Combinatorica`NthSubset

  3. You do not need to Clear (or ClearAll) Symbols that are automatically scoped, such as the iterators in Table or Do, or the named patterns in SetDelayed definition.

Please try this corrected code:

ClearAll[lst, L, s, f, G, OS, Sh1];
Block[{$ContextPath}, Needs["Combinatorica`"]];
L = 10;
lst = Range@L;
Sh1 = 0;
f[i_, j_] := -1/(L*Sin[Pi*(0.5 - (i - j))/L]);
G = SetPrecision[Array[f, {L, L}], 100];
OS = SetPrecision[(G + IdentityMatrix[L]).Inverse[G - IdentityMatrix[L]], 100];
s = SetPrecision[Det[(IdentityMatrix[L] - G)/2], 100];
Sh1 = 0;
Table[config = {Combinatorica`NthSubset[i, lst]};
 Prob1 = SetPrecision[s*Det[-OS[[#, #]]] & /@ config, 100] // Chop // First;
 If[Prob1 > 0, Sh1 = -Prob1*Log[Prob1] + Sh1, Sh1 = 0 + Sh1], {i, 1, 15}]
{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \
0.0952856207535585793016515229466126554372936253348646458714971829904110083411868873783286\
879820719374, \
0.1371358135588219698181323018199619290787744170242196837830561691794638477201529409957301\
221643260420, \
0.1632814770187687378199737037502485650708018419669883525362593712541985364932168134291927\
092279558416, \
0.1836470890833755146813189437480932594392323723454910200488230378591086476594094808479099\
827660495069, \
0.2024683540498089018172816005444165590397928145912900060100283014029753978526867758471922\
616280113787}

(I used a Table range of one through 15 simply to limit the size of output for this post.)

$\endgroup$
1
  • $\begingroup$ Thanks for helping, I found your answer very helpful and also learned new things as I am not expert in Mathematica. $\endgroup$ – setareh Jul 6 '15 at 18:48

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.