Skip to main content

Posts

Showing posts from March, 2017

programming - Searching linked lists that contain lists?

Following the advice I've read here and other sites, I've been trying to use the Mathematica equivalent of a linked lists... testList = {{a, b}, {{c, d}, {{e, f}, {}}}} Now, I want to see if {c,d} is a member of testList . How do I do that? MemeberQ doesn't transverse the list recursively and Flatten also nukes the sub lists. The following seems to work but I would expect there to be a cleaner simpler way... memberInLinkedList[{}, _] = False; memberInLinkedList[l_List, v_] := True /; First[l] == v; memberInLinkedList[l_List, v_] := memberInLinkedList[Last[l], v]; Is there a more eloquent or built-in way to do this? Perhaps a general idiom or package that handles this transparently? Answer MemberQ[testList, {c, d}, Infinity] True

calculus and analysis - finding an argument of a complex number

What is the simplest way to find the argument of the following function? ((1 - E^((I π (1 - α))/(β - α)) z)/(1 - E^(-((I π (1 - α))/(β - α))) z)) as I tried the polar way, but it is so complicated and I didn't reach the result yet. Thank you. Answer Here's one path... define your function and translate to trig form: f[x_, z_] := ExpToTrig[((1 - E^((I π (1 - α))/(β - α)) z)/(1 - E^(-((I π (1 - α))/(β - α))) z))]//. (π (1 - α))/(-α + β) -> x using a replacement of a new real variable x for the more complicated expression involving alphas and betas. This gives f[x,z] as (1 - z Cos[x] - I z Sin[x])/(1 - z Cos[x] + I z Sin[x]) Now break this apart so that it has real denominator (using a function from the help files for the Conjugate function) toRealDenominator[rat_] := With[{c = ComplexExpand[Conjugate[Denominator[rat]]]}, Expand[Numerator[rat] c]/Expand[Denominator[rat] c]] And so Simplify[toRealDenominator[f[x, z]]] gives a complicated expression. Bu

notebooks - NotebookEvaluate with InsertResults -> True from the command line

Suppose I have a notebook template.nb like this: and I want to evaluate this notebook from the command line. So I wrote this Mathematica script: UsingFrontEnd[NotebookEvaluate["C:\\Users\\delfinog\\Desktop\\template.nb", InsertResults -> True]] And I run the script like this (Windows 7): C:> "C:\Program Files\Wolfram Research\Mathematica\10.2\wolfram.exe" -script C:\Users\delfinog\Desktop\mma-script.wl My expectation is that I should be getting this: but instead, I get this: This is the complete output cell Graphics[{{{}, {}, {Directive[Opacity[1.], RGBColor[0.368417, 0.506779, 0.709798], AbsoluteThickness[1.6]], Line[{{2.040816326530612*^-8, 2.040816326530612*^-8}, {0.000306717908041361, 0.000306717908041361}, {0.0006134154079194566, 0.0006134154079194566}, {0.001226810407675648, 0.001226810407675648}, {0.002453600407188031, 0.002453600407188031}, {0.004907180406212797, 0.004907180406212797}, {0.009814340404262328, 0.0098143404

simplifying expressions - Separating exponential terms

Suppose I have a lot of expressions multiplied by factors such as: $$e^{-i\theta[1]-i\theta[2] - i\theta[3]-i\theta[4]-i\theta[5]}$$ I would like to separate this into a product of exponentials of the form $$e^{-i\theta[1]}e^{-i\theta[2]}...$$ before employing the function ExpToTrig and making substitutions to the result trigonometric functions. However, since I plan to apply the tangent half angle substitution (cf. my previous question Simplifying Expressions for FindMinimum ), I would like the arguments to involve only one variable at a time. In particular, I tried using ComplexExpand on the function to express the trigonometric functions as functions of a single variable, but it expands the entire function out. In short, I would like to keep the simplified form, but want to expand the exponential as per the above without having to expand the entire expression. For reference, here is my function (E^(-I θ[1] - I θ[2] - I θ[3] - I θ[4] - I (θ[5] - θ[6])) Abs[Sin[ϕ[6]]]^2 (1 - E^(I (θ

plotting - Animating a growing ListPlot

I stumbled upon this (rather contrived but interesting) integer sequence. As it exhibits quite different behaviour at different scales, I would like to generate an animated ListPlot of it, where I'm changing the domain and range at an exponential rate to zoom through the orders of magnitude. I've got something working but it's pretty glitchy and I'm having trouble getting the size of the points to shrink at a good proportional rate. seq[n_] := seq@n = Module[{b = 2, l}, While[! IntegerQ[l = Sqrt@Length@IntegerDigits[n, b]], ++b]; Flatten[Transpose@(IntegerDigits[n, b]~Partition~l)]~FromDigits~b ] plot[n_] := ListPlot[ seq /@ Range[n], PlotRange -> {{0, n + 1}, {0, n + 1}}, AspectRatio -> 1, ImageSize -> 400, PlotStyle -> PointSize[0.2/n] ] frames = Rasterize[#, "Image"] & /@ Table[plot[10^(n/25)], {n, 25, 100}]; ListAnimate[frames] or ultimately Export["sequence.gif", frames] which gives As you can see, des

dynamic - InputField as both in- and output fields with ContinuousAction

Many years ago, I made a handy little program in Flash. It consisted of a number of input fields, each representing a variable that was dependent on all the others. As soon as any field changed, the other followed, no matter which of them I changed. So they where effectively both in- and output fields. A simple algorithm kept track of which field would output the result, (usually the one which had experienced no change or with oldest edit). EDIT: Only one variable is calculated each time a value is changed. It may be partly exemplified by the following code. However, in this case only the last InputField "c-variable" is calculated, while the goal is to arbitrarily be able to chose which is to be calculated. The latter can be achieved either by a checkbox or algorithmically. Clear[a, b, c]; Row[{Labeled[ InputField[Dynamic[a], Number, ContinuousAction -> True, FieldSize -> Tiny], "a-variable", Top], Labeled[InputField[Dynamic[b], Number, Continuou

equation solving - Why don't I get numeric values from this Solve?

Solve[ a^2 + b^2 == c^2 && a < 100 && b < 100 && c < 100, {a, b, c}, Integers] gives me this result {{c -> ConditionalExpression[-Sqrt[ a^2 + b^2], ((a | b | c) ∈ Integers && Sqrt[10000 - a^2] - b > 0 && -99 <= a <= -1) || ((a | b | c) ∈ Integers && Sqrt[10000 - a^2] - b > 0 && 1 <= a <= 99) || ((a | b | c) ∈ Integers && Sqrt[10000 - a^2] + b <= 0 && -99 <= a <= -1) || ((a | b | c) ∈ Integers && Sqrt[10000 - a^2] + b <= 0 && 1 <= a <= 99) || ... ] }, ... } where I would expect something like {{x -> 3, y -> 4, z -> 5}, {x -> 4, y -> 3, z -> 5}, {x -> 5, y -> 12, z -> 13},...} What am I doing wrong? Answer This works (it's obvious the same will hold for negative integers): Reduce[a^2 + b^2 == c^2 && 0 < a < 100 && 0 < b <

graphics3d - How to draw a dodecahedron with each face modified to a pentagram?

I'd like to draw a dodecahedron with each face carved on the sides so it becomes a pentagram. I wonder how to start to do this kind of task in the Wolfram Language? Edit: The result should still be a completely enclosed polyhedron; i.e., the carved out parts should be connected by newly added faces. I don't want the result to have holes. Answer Solution from @chuy looks really nice. Although I think that it was a little bit of work around because it's a visualization only, but the defined structure doesn't really represent the carved dodecahedron. Here is my approach of carving a dodecahedron pumpkin into pentagrams. First we define a function that makes a pentagram from a pentagon. tau = (2 Sqrt[5])/(5 + Sqrt[5]); pentagram[pts_] := Riffle[pts, #] &@(pts[[# + 1]]*tau + (1 - tau)* pts[[1 + Mod[# + 2, 5]]] & /@ Range[0, 4, 1]); Then we apply this function to all faces of dodecahedron. ind = PolyhedronData["Dodecahedron", "FaceIndices&qu

symbolic - 1 is not the SameQ as Null, but why might 1 be Equal to Null?

The command SameQ[1, Null] returns False which is what I would expect, but the command Equal[1, Null] returns 1==Null Why is Mathematica agnostic as to whether 1 is equal to Null ? Surely it is not ? Answer === ( SameQ ) tests structural equality and is meant mainly for programming uses. Like nearly all functions named as ...Q , it evaluates immediately to either True or False . == both represents and tests mathematical equality, and is meant for symbolic algebra use. Thus when == is used with a symbol (or expression containing symbols) on either side, it will not evaluate. It stays unevaluated and it can be used to represent a mathematical statement. This is how we write equations in Mathematica, e.g. x^2 - 2 == 0 . Null has no meaning in symbolic algebra uses so here it is just treated as a symbol, which it is. Thus 1 == Null stays unevaluated the same way 1 == x does. Mathematica is loosely typed: everything is an expression. You may put just about anything on either side

equation solving - After NumberForm I cannot apply a Sine function. Why?

After NumberForm I cannot apply a Sine function. Why? This works: sol1 = x /. Solve[x^2 - 3 == 0, x] Sin[sol1] Output = $\{-Sin[\sqrt{3}],Sin[\sqrt{3}]\}$ Also this works: sol2 = x /. Solve[x^2 - 3 == 0, x] // N Sin[sol2] Output = $\{-0.987027,0.987027\}$ Then why doesn't this work? Meaning, why is Sin[] not applied to the elements of the list? sol3 = NumberForm[x /. Solve[x^2 - 3 == 0, x] // N, 6] Sin[sol3] Output = $Sin[\{-1.73205,1.73205\}]$ What can I do to make this work?

plotting - How to plot an implicit function?

Usually to plot an equation like $y=f(x)$, you do so by using Plot[f[x],{x,0,10}] However, my equation takes the form $f(x,y)=0$ and $y$ can't be separated to make an equation like $y=f(x)$. Is there a way to plot the values of $y$ by plotting $f(x,y)$ over $x$. Answer ContourPlot is probably the solution you are looking for. Here is an example using the function $f(x, y)=x^2 - y^2 - 1$: f[x_, y_] := x^2 - y^2 - 1 ContourPlot[f[x, y] == 0, {x, -3, 3}, {y, -3, 3}]

performance tuning - Faster alternatives for DayOfWeek

It has been noticed on several occasions that DayOfWeek function is rather slow when applied to a large list of dates, e.g. in this recent question . What faster alternatives do we have in such situations? Answer Just a literal implementation of a formula for the day of the week: Clear[dow]; dow[{year_, month_, day_, _ : 0, _ : 0, _ : 0}] := Module[{Y = If[month == 1 || month == 2, year - 1, year], m = Mod[month + 9, 12] + 1, y, c, s = {Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday}}, y = Mod[Y, 100]; c = Quotient[Y, 100]; s[[Mod[day + Floor[2.6 m - 0.2] + y + Quotient[y, 4] + Quotient[c, 4] - 2 c, 7] + 1]]]; Seems to give a 5-fold speed increase: d = RandomDates[100000]; DayOfWeek /@ d // Short // AbsoluteTiming dow /@ d // Short // AbsoluteTiming {19.5781250,{Thursday,Thursday,Sunday,Friday,<<99992>>,Tuesday,Saturday,Saturday,Thursday}} {3.7968750,{Thursday,Thursday,Sunday,Friday,<<99992>>,Tuesday,Saturday,Saturday,Th

precision - Abnormal behavior of RealDigits[x]

In the Details of the document of RealDigits writes the following line: RealDigits[x] normally returns a list of digits of length Round[Precision[x]] . Then when will RealDigits[x] abnormally return something and what will be returned? The details has shown us one of them: RealDigits[0.] gives {{0},-Floor[Accuracy[0.]]} . Are there more? The following is one I found today: x = 1.2``2; Round@Precision@x (* 2 *) Length@First@RealDigits@x (* 3 *) Is there a complete summary for the behaviors of RealDigits with only one valid argument? Does these abnormalities follow any unified rule?

graphics3d - Working with text in 3D graphics

I'd like to add text to the surfaces of a cuboid. I have tried Text and Epilog , and neither of them worked. Consider the following code: Graphics3D[ {{EdgeForm[{Thickness[.000001], GrayLevel @ 0}], Blue, Cuboid[{-4, 0, 0}, {4, 2.4, 1}]}, {EdgeForm[{Thickness[.000001], GrayLevel @ 0}], Blue, Cuboid[{-4, 3.4, 0}, {4, 3.6, 1}]}, {EdgeForm[{Thickness[.000001], GrayLevel @ 0}], Blue, Cuboid[{-4, 4.6, 0}, {4, 7, 1}]}, {EdgeForm[{Thickness[.000001], GrayLevel @ 0}], Blue, Cuboid[{-4, 0, 0}, {4, 7, -1}]}, {Cyan, Opacity[.95], Cuboid[{-4, 2.4, 0}, {4, 3.4, 1}]}, {Yellow, Opacity[.95], Cuboid[{-4, 3.6, 0}, {4, 4.6, 1}]}}, Boxed -> False, ImageSize -> 800] How can I add text to an arbitrary face of a cuboid, e.g., the yellow cuboid (the color must be adjusted so it is visible)? And more generally, how to add text to an arbitrary point in space? Answer An approach without using Texture : Use M.R.'s ImportString[ExportString[..., "PDF"], &q

list manipulation - Finding max value of each column of 4x4 Array

I have the following array in both MatrixForm and List form 0.474042 0.507508 0.4977 0.539773 0.473447 0.50765 0.483809 0.52489 0.46797 0.483669 0.494823 0.516956 0.467079 0.483509 0.478704 0.501286 A = {{ 0.474042, 0.507508, 0.4977, 0.539773}, { 0.473447, 0.50765, 0.483809, 0.52489 }, { 0.46797, 0.483669, 0.494823, 0.516956}, { 0.467079, 0.483509, 0.478704, 0.501286} } I want to get the max value of each column. I've tried the following for the first columns but no help: Max[A[[All, 1]]] Any comment will be greatly appreciated.

probability or statistics - Assign Error bars for y-intercept

I have some data (x,y) with error bars in y direction: {{{1/10, 4.92997}, ErrorBar[0.00875039]}, {{1/20, 4.90374}, ErrorBar[0.00912412]}, {{1/25, 4.89318}, ErrorBar[0.00707122]}, {{1/30, 4.89534}, ErrorBar[0.00870608]}, {{1/40, 4.87807}, ErrorBar[0.00829155]}, {{1/50, 4.84442}, ErrorBar[0.0226886]}, {{1/100, 4.83867}, ErrorBar[0.0973819]}} Now I am trying to find a linear fit to the data, and I want the y-intercept of this linear fit (when x=0). How do I get the uncertainty (error bar) for the y-intercept due to those error bars in the data? Answer Correction: I've corrected the description of the second model to match what Mathematica actually does as opposed to what I wanted to believe it did. Use the Weights option with the inverse of the square of the errors: data = {{{1/10, 4.92997}, ErrorBar[0.00875039]}, {{1/20, 4.90374}, ErrorBar[0.00912412]}, {{1/25, 4.89318}, ErrorBar[0.00707122]}, {{1/30, 4.89534}, ErrorBar[0.00870608]}, {{1/40, 4.87807}, ErrorBar[0

graphics3d - Custom Ticks for Image3D?

Is it possible to make user-defined ticks in an Image3D ? (Wizardly solutions will be appreciated, too.) With Image3D[Import["ExampleData/CTengine.tiff"], Boxed -> True, Axes -> True (*,Ticks -> {x,y,z}*) ] I get However, if I uncomment Ticks , I get a message Unknown option Ticks in Image3D[....] Ticks I prepared for something else, but can be used here. x = {{0, 0}, {75, Pi/4}, {150, Pi/2}, {225, 3 Pi/4}, {300, Pi}}; y = {{0, 0.0}, {75, 0.5}, {150, 1.0}, {225, 1.5}, {300, 2.0}}; z = Table[{i, i}, {i, 0, 8, 2}]; Answer mydata = Import["ExampleData/CTengine.tiff"]; Show[Image3D[mydata], Axes -> True, Ticks -> { {{0, 0}, {75, π/4}, {150, π/2}, {225, 3 π/4}, {300, π}}, {{0, 0.0}, {75, 0.5}, {150, 1.0}, {225, 1.5}, {300, 2.0}}, Table[{i, i}, {i, 0, 80, 20}] } ]

manipulate - Selection Limit on CheckboxBar

Is there an easy way to limit the number of selections in a CheckboxBar such that at any time you can choose only two options. I tried to use the "Enabled" option, but that grays out the whole checkboxBar. How can access individual Checkbox in CheckboxBar (so that, I can disable only those Checkboxes that are not selected) ? Manipulate[NumSelec, {NumSelec, {1, 2, 3, 4}, ControlType -> CheckboxBar, Enabled -> If[Length[NumSelec] >= 2, False, True]}] Answer Use the second argument to Dynamic . Example: DynamicModule[{NumSelec = {}}, Column[{ CheckboxBar[ Dynamic[NumSelec, (If[Length[#] > 2, NumSelec = #[[-2 ;;]], NumSelec = #]) &], {1, 2, 3, 4}], Dynamic[NumSelec] }] ]

labeling - Avoiding overcomplicated structure of groups, masks and splited text on vector format plot export

I'm trying to generate a template for exporting figures and plots in a consistent way that will allow easy editing in any vector based drawing software (such as illustrator). My problem is that exported figures in vector format have an (apparently) unnecessarily cumbersome structure. For instance p = Plot[x, {x, 0, 1} , Frame -> True , FrameLabel -> {"Abscissa [unit]", "Ordinate [a.u]"} , BaseStyle -> {FontSize -> 11, FontFamily -> "Helvetica", FontTracking -> "Plain", TextJustification -> 0, PrivateFontOptions -> {"OperatorSubstitution" -> False}} ] Export["test.svg",p,"SVG"] will generate an SVG file which code look like this: Abscissa [ unit ] See how each piece of text, and tick stroke has a group, a clipping mask and the text is split in several text instances. That code also is cumbersome to manipulate when opened in Illustrator The described problem also exists in

curated data - Using GraphData to generate all directed graphs with n vertices

Using Combinatorica, it was possible to generate unlabeled (non-isomorphic) directed graphs of $|V|=n$. Here the example is for $n=4$: Needs["Combinatorica`"] ShowGraph /@ ListGraphs[4,Directed]; Using GraphData, I know how to generate undirected ones: GraphData /@ GraphData[4] What's the trick to make it generate directed ones? Bonus point for directed and connected ones.

performance tuning - Speed up Flatten[] of a large nested list

I have a large jagged list, that is each sub-list has a different length. I would like to Flatten this list for Histogram purposes, but it seems to be taking an inordinate amount of time and memory jaggedList=Table[RandomReal[1,RandomSample[Range[400000,800000],1]],{n,100}]; Just to illustrate, length of each of elements of the main list ListPlot[Length/@jaggedList] Full Flatten takes a long time, my real data is several times larger, it gets painfully slow fullFlatten=Flatten@jaggedList;//AbsoluteTiming {10.0055,Null} I noticed flattening non-jagged sub-lists is not a problem partialFlatten=Flatten/@jaggedList;//AbsoluteTiming {0.289219,Null} Memory usage is huge on the final result of the full list, even though number of elements is the same: ByteCount/@{fullFlatten,partialFlatten,jaggedList} {1460378864,486808224,486808224} Would super appreciate any tips on what I can change to make this faster / more memory compact ! Answer Apply ing Join is much faster than Flatten : SeedRan

algorithm - Behavior of Graphics`Mesh`InPolygonQ with self-intersecting polygons

Playing around with some of the answers in the question How to check if a 2D point is in a polygon? I noticed that: Graphics`Mesh`InPolygonQ[poly,pt] Displays different behavior than the procedure that explicitly uses winding numbers (where a non-zero winding number implies polygon inclusion), for example the function in rm -rf♦'s answer to the aforementioned question: inPolyQ[poly_, pt_] := Graphics`Mesh`PointWindingNumber[poly, pt] =!= 0 We can see this in the case where we define a self-intersecting polygon that has a "hole" in it: PointWindingNumberInPolygonQ[poly_, pt_] := Graphics`Mesh`PointWindingNumber[poly, pt] =!= 0; numRandPoints = 10^4; testPolygon = {{65.4`, 439.5`}, {233.4`, 524.5`}, {364.40000000000003`, 433.5`}, {382.40000000000003`, 377.5`}, {354.40000000000003`, 293.5`}, {258.40000000000003`, 239.5`}, {94.4`, 207.5`}, {40.400000000000006`, 271.5`}, {18.400000000000002`, 356.5`}, {149.4`, 383.5`}, {187.4`, 330.5`}, {199.4`, 258.5`}, {136.4`, 130.5`}}; bo

linear algebra - Axis/Angle from rotation matrix

With r = RotationMatrix[a, {x, y, z}] I can compute a 3D rotation matrix from its axis/angle representation. Given a 3D rotation matrix r , how can I compute a and {x, y, z} ? Example: r = {{0.966496, -0.214612, 0.14081}, {0.241415, 0.946393, -0.214612}, {-0.0872034, 0.241415, 0.966496}} The result should be a = 20. Degree and {x, y, z} = {2, 1, 2}/3 (or equivalent). Edit: I am fine with any answer that gives the same r when applied to RotationMatrix . Answer There is no need to use Eigensystem or Eigenvectors to find the axis of a rotation matrix. Instead, you can read the axis vector components off directly from the skew-symmetric matrix $$a \equiv R^T-R$$ In three dimensions (which is assumed in the question), applying this matrix to a vector is equivalent to applying a cross product with a vector made up of the three independent components of $a$: {1, -1, 1}Extract[a, {{3, 2}, {3, 1}, {2, 1}}] This one-line method of finding the axis is applied in the following

Packages problems on version 9 under OS X

Using Version 9 on OS X, I've run into some problems with creating packages and accessing them. I've done the following: wrote all the function definitions in a notebook and tested that they all worked; created a package of the definitions. used Install to place the package in the FileNameJoin[{$UserBaseDirectory, "Applications"}] directory; For good measure I rebooted my computer and restarted Mathematica. Attempting to load the package gives me nothing, so I simplified everything to see if I'd still have a problem. I made a very simple package: BeginPackage["testPackage`"] f::usage = "f[x] returns 2x" Begin["`Private`"] f[x_] := 2 x End[ ] EndPackage[ ] I saved and installed it as I described above. Still nothing. << testPackage` Names["testPackage`*"] {} I have also tried each of the following: Get["testPackage`"] (* Doesn't appear to do anything or get any response from Mma *) Get[FileNameJoin[{$Use

numerics - Any way of solving this system of nonlinear equations with non integer powers?

I have a system of four nonlinear equations. Some of the exponents are fractions. I was wondering if this is what is causing NSolve to run for hours without giving any results. I first create a list of parameters that I eventually want to play around with to see how results change. This parameter list is "dat". I then specify the equations as follows: dat = {alpha -> 1/3, beta -> 1/3, sigma -> 1/3, gam -> 0.5, psy -> 0.5, delta -> 0.5, vu -> 0.5, a -> 1, A -> 1/3, B -> 1/3, C -> 1/3, Ls -> 10, T -> 10, mc -> 1.5} {p2 - w^psy pw^gam ((psy/gam)^gam + (gam/psy)^psy) == 0, Ls - (beta/w)^(alpha + sigma) (pw/(alpha (1 + a C r T)))^ alpha (r/sigma)^sigma (w Ls delta + r T A) - (pw psy/w gam)^ gam ((w Ls vu + r T B)/p2) == 0, T - (sigma/r)^(alpha + beta) (w/beta)^ beta (pw/(alpha (1 + a C r T)))^alpha (w Ls delta + r T A) == 0, pw - (((((1 + a C r T) alpha)/pw)^(beta + sigma) (w/beta)^ beta (r/sigma)^

plotting - Visualization of Bivariate Distributions

I know it is perfectly possible to show the bivariate probability distributions in MMA. But my question is can we show each dimension of distribution in 2D dimension while we are showing the 3D plot? The same as here: How we can have the 2D histograms in the sides and 3D histogram in between? Answer You can also try this: Generate yor data: data = RandomVariate[\[ScriptD] = MultinormalDistribution[{0, 0}, {{1, 0.9}, {0.9, 2}}], 10^4]; To improve a little bit the final image, you might want to introduce lighting vectors: lightSources = { {"Directional", White,Scaled[{1, 0, 1}]}, {"Directional", White,Scaled[{1, .5, 1}]}, {"Directional", White, Scaled[{.5, 0, 1}]} }; Create the 3D histogram G1 = Histogram3D[data, {0.25}, "PDF", ColorFunction -> "Rainbow", PlotRange -> {{-4, 4}, {-4, 4}, All}, ImageSize -> Medium, Boxed -> False, Lighting -> lightSources] Create the individual histograms G3 = Histogram[Transpose[d

list manipulation - Efficiently extracting an array subset given a separate array

I have two arrays. The first array consists of tens of millions of rows and three columns with a string, a number, and a string. array1 = {{string1, 145745, a}, {string2, 56546, a}, {string3, 56546, b}, {string3, 246, b}, {string7, 12355, a}, {string7, 12355, b}} The second array has hundreds of thousands of rows but also consists of three columns but with a string, a number, and a number. array2 = {{string1, 145745, 3.14324}, {string3, 56546, -0.34319}, {string7, 12355, 0.23535}} In array2 , the first two elements of each row matches the first two elements of a row (or, at most, two rows) in array1. In other words, array2[[All,{1,2}]] is a subset of array1[[All,{1,2}]] . The goal is to take from array1 all the rows that have matching rows in array2 (when comparing only the first two columns from each array). For example, from the two given arrays above, the final result would be result = {{string1, 145745, a},{string3, 56546, b},{string7, 12355, a},{string7, 12355, b}} Th

numerics - Leave out a term when summing

I'm calculating the Madelung constant $$\alpha = -\sum_{n_1,n_2,n_3}{\frac{(-1)^{n_1+n_2+n_3}}{(n_1^2+n_2^2+n_3^2)^{1/2}}}$$ Where $n_1,n_2,n_3$ are any element in the integer domain and they can't be zero simutaneously. How can I do this in Mathematica? Thanks! Answer These sums are conditionally convergent, so you have to specify a summation order that suits your purpose. See Wikipedia . Since the question seems to be focused on the issue of dropping a term in a sum, here is one way of doing it, without making any claim that the resulting sum is of any use: Chop[NSum[ If[i == j == k == 0, 0, (-1)^(i + j + k)/Sqrt[i^2 + j^2 + k^2]], {i, -Infinity, Infinity}, {j, -Infinity, Infinity}, {k, -Infinity, Infinity}, Method -> "AlternatingSigns"]]

mathlink or wstp - Set form of all output to InputForm

I try to interact with mathematica using MathLink for symbolic computations. By default it returns strings such as 2\012-1 + E\012-------\012 3\012 E if the input is Integrate[Exp[-x],{x,1,3}] . For better usability I would like it to print all output in InputForm which I could achieve by wrapping all input by a InputForm[] command (would this be bullet-proof for all possible input?). However it would be more elegant if I could define this once for all at the beginning of a session. Is there a way to do this? Furthermore the output seems to include the Out[#] labels which I know from Notebook files. I would prefer to suppress it as well. Obviously I could do it by cutting it manually from the returned string but there might be an elegant solution as well.

plotting - Export Plot3D in Mathematica 10.1 is Rasterized by default

When I use Export to export Plot3D to PDF format, I get different behaviour in Mathematica 10.1 compared to 10.0. In particular, version 10.1 Rasterize s the graphics by default: myFigure = Plot3D[x y, {x, 0, 1}, {y, 0, 1}] Export["Figure.pdf", myFigure] How can I turn off this rasterization? Can I set the default back to vector images? Answer Indeed, 3D plots like this were exported as vector graphics with generally huge numbers of polygons in version 8. But even then, the export was automatically rasterized whenever there were VertexColors present in the plot. I described this as a trick for getting smaller PDF files here , and also used it e.g. here . So in general, I think it's actually a good thing that PDF s generated from 3D graphics are rasterized, provided it's done at a resolution appropriate for the desired device. However, despite this change in version 10, the developers haven't gotten this automatic rasterization quite right yet. For example,

list manipulation - Efficient discrete Laplacian of a matrix

I would like to compute the discrete Laplacian of a real matrix (numeric values and full), using any method and targetting efficiency (I will call the Laplacian dozens of thousands of time). I naively defined the following function: laplacian[Z_] := Block[{Zcenter, Ztop, Zleft, Zbottom, Zright}, Zcenter = Z[[2 ;; -2, 2 ;; -2]]; Ztop = Z[[;; -3, 2 ;; -2]]; Zleft = Z[[2 ;; -2, ;; -3]]; Zbottom = Z[[3 ;;, 2 ;; -2]]; Zright = Z[[2 ;; -2, 3 ;;]]; Ztop + Zleft + Zbottom + Zright - 4*Zcenter ] It reduces the dimension of the input (because the Laplacian for the elements of the border of the array is not computed) but I am fine with that. I also tried writing the function in a compiled way: compileLaplacian = Compile[{{Z, _Real, 2}}, Module[{Zcenter = Z[[2 ;; -2, 2 ;; -2]], Ztop = Z[[;; -3, 2 ;; -2]], Zleft = Z[[2 ;; -2, ;; -3]], Zbottom = Z[[3 ;;, 2 ;; -2]], Zright = Z[[2 ;; -2, 3 ;;]]}, Ztop + Zleft + Zbottom + Zright - 4*Zcenter

list manipulation - How to partition MatrixPlot graphics?

Is there an easy approach - hopefully built-in - to partitioning MatrixPlot graphics into rows or columns (or both) of graphics sharing the same underlying options? For example, in the following graphic, the red rectangles indicate where partitions should occur, and the respective sub-Rasters (along with FrameTicks etc) can then be reorganized using Row This particular graph (excluding the rectangles which were generated in Epilog ) has Length 6, of which all but the first Part are related to options. But it's tedious to even list what parts of the partitions component correspond to which parts, which subsequently must be modified - for example FrameTicks are to be repositioned (reindexed). Obviously, because the "heatmap" color scale is shared among all the members of the desired partition, it's not feasible to partition the matrix prior and then mapping through MatrixPlot Answer To expand on my comment, I think the recent post I wrote for the Mathematica.SE b

notebooks - Include Headers on first page

I know it is possible to check the box "Include headers on first page" in the "Headers and Footers" dialog box of the Print Settings menu item, but is it also possible to check this using commands in the Notebook itself? It would be for the current notebook. Thanks for all help, as always! Answer SetOptions[EvaluationNotebook[], PrintingOptions -> {"FirstPageHeader" -> True}] You can open $InstallationDirectory/SystemFiles/FrontEnd/SystemResources/HeadersFootersDialog.nb as text file and find all possible options. For completeness I want add that with SetOptions[EvaluationNotebook[], PageHeaders -> {{"a1", "a2", "a3"}, {"a4", "a5", "a6"}}] you can set headers. See also: PageHeaders , PageFooters , PageHeaderLines , PageFooterLines .

numerical integration - Solving a second-order nonlinear differential equation

I am trying to solve a particular Cauchy problem given by I found from a particular paper that the solutions looks like For the auxiliary conditions For only specific values of $a_{i}$ I found from another paper that the problem can be solved with the Mathematica code Off[General::stop] createLargestRegion[h_, d_, mult_] := Block[{ bound = Min[mult*Abs[d]/h, 19], n = 1, result, previous }, While[Not[ Check[result[r_] := Evaluate[ First[\[Theta][r] /. NDSolve[{\[Theta]''[r] + (1/r ) \[Theta]'[r] - (0.5/(r^2)) Sin[ 2 \[Theta][r]] == ((h /2.0) Sin[\[Theta][r]] + (d /r) Sin[\[Theta][r]]^2 ), \[Theta][0.001] == Pi, \[Theta][bound] == 0.1}, \[Theta][r], r, "Method" -> {"Shooting", "StartingInitialConditions" -> { \[Theta][0.001] == Pi, \[Theta]'[0.001] == (-Pi/10)}}]]], False]] || FindMaximum[{result[t], t

boolean computation - Discrete Measure between Binary Vectors

I would like a discrete distance measure between two binary vectors (or strings). Like HammingDistance but I want the vectors to be considered closer if they have more matches that are separated by zeros (or a default value). For example: given the four vectors and distance measure thedistancemeasure vec1={1,0,0,0,0,1,0,1}; vec2={1,0,1,0,0,1,0,0}; vec3={1,0,0,0,1,1,0,0}; vec4={0,1,0,0,1,1,0,0}; such that. thedistancemeasure[vec1,vec2]< thedistancemeasure[vec3,vec4] True The measure likes small group of matches that are well separated versus a large group of matches that are "connected" or less seperated. The amount of zeros shouldn't matter, but if it does, I prefers more zeros to give a smaller measure. The more separated the better. If possible I also want the measure to give even closer distances for higher count of well separated correctly matched ones, for example. vec5={1,0,0,1,0,1,0,1}; vec6=