Hot answers tagged

10

First answer (extended comment actually) You have to define better your objective function. For example, the following works: ClearAll[mat, minev] SeedRandom[1] rm = RandomInteger[10, {40, 40, 3}]; mat[t_] := N[rm.{1, t, t^2}]; minev[t_?NumericQ] := First@Eigenvalues[mat[t], -1]; Take[Table[minev[t], {t, 0, 1, .01}], 3] (* {-0.864071 - 1.30548 I, ...


9

Here is a very short solution: qf = a x^2 + b y^2 + c z^2 + 2 d x y + 2 e x z + 2 f y z; 1/2 D[qf, {{x, y, z}, 2}] (* ==> {{a, d, e}, {d, b, f}, {e, f, c}} *) This is just an application of the answer to Quick Hessian matrix and gradient calculation.


8

If you have Mathematica 10.3 or above you can use DistanceMatrix: DistanceMatrix[dataset2, DistanceFunction -> NormalizedSquaredEuclideanDistance] I'm assuming the same data as defined by kglr, you have not given us an example. If you don't have Mathematica 10.3 there's still HierarchicalClustering`DistanceMatrix which is used in the same way.


8

I think you need CoefficientArrays: mat = Last@CoefficientArrays[qf, {x, y, z}, "Symmetric"->True]; {x, y, z}.mat.{x, y, z} == qf // Simplify (* True *)


7

With[{x = Array[x, Dimensions[mA]]}, Solve[mA .x - x. mB + mC == 0, Flatten@x]] Or With[{x = Array[x, Dimensions[mA]]}, x /. Solve[mA .x - x. mB + mC == 0, Flatten@x]] {{{3, 1}, {0, 3}}}


6

I wanted to be able to extract the path from your recursive memoized function, but I couldn't make it happen. But here is a function to find the minimum path from the upper left to the bottom right corners of an array of numbers, minimalpathsum[grid_] := Module[{dims, vertcoords, graph, weights, path, indices}, dims = Dimensions@grid; vertcoords = ...


5

Your cube file had a very large grid ( 117*117*130 = 1779570), and 2 million points is just far too many for testing a function. So I created cube files for the electron density and electrostatic potential for the molecule furan, using a much sparser grid (around 8000 grid points instead). Here they are: Density cube file Potential cube file Now that ...


5

I think this code answers the question: data = RandomInteger[{0, 1}, {120, 4}]; edges = DirectedEdge @@@ Partition[data, 2, 1]; Graph[edges, VertexLabels -> "Name"] Continuation... Because of a question in a comment here is some code that shows the derivation of graphs, spanning trees of those graphs, their disjoint union, and a highlighted ...


5

x[t_] = {a[t], b[t]} /. RSolve[{ a[t + 1] == r*a[t] + s*b[t], b[t + 1] == s*a[t] + r*b[t], a[0] == 30, b[0] == 5}, {a[t], b[t]}, t][[1]] Since 0 < s < r < 1 then 0 < r - s < 1 - s < 1 and for large t, (r -s)^t is approximately zero. x[t] /. (r - s)^t -> 0 i.e., a[t] ≈ b[t] for large t Plot[ Evaluate[{ x[t] ...


5

Here is a way that yields symmetric matrix (for this example you could just write it down): m=Module[{r = {x -> 1, y -> 2, z -> 3}, tu = Tuples[{x, y, z}, 2]}, Normal@SparseArray[(## /. r) -> Coefficient[qf, Times @@ ##]/(2 - Boole[#[[1]] === #[[2]]]) & /@ tu, {3, 3}]] yields: {{a, d, e}, {d, b, f}, {e, f, c}} Check: ...


4

You simply need to simplify your result using Simplify (dimensions < 4) or FullSimplify (larger), as appropriate: Inverse@FourierMatrix[3].FourierMatrix[3] // Simplify (* Out: {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}} *) FullSimplify[Inverse@FourierMatrix[7].FourierMatrix[7]] == IdentityMatrix[7] (* Out: True *) As you can see, an identity matrix is obtained ...


4

ClearAll["Global`*"] T = Table[0, {i, 1, 3}, {j, 1, 3}, {k, 1, 3}]; Part[Part[Part[T, 1], 1], 1] = E^(3 (KK + h)); Part[Part[Part[T, 1], 3], 3] = 3 E^(-KK + h); Part[Part[Part[T, 2], 2], 2] = E^(3 (KK - h)); Part[Part[Part[T, 2], 3], 3] = 3 E^-(KK + h); T = Normal[Symmetrize[T]]; h = 0; KK = 10; im = Partition[Flatten[TensorContract[TensorProduct[T, T], ...


4

dataset2 = RandomReal[1, {5, 7}]; (* this stands for dataset[[All,2;;]] in your case*) dataset2 // MatrixForm output = Outer[NormalizedSquaredEuclideanDistance, dataset2, dataset2, 1]; output // MatrixForm


4

The answer is as you suspect - when you evaluate Dot[m1, m2, m3, m4, m5, ......m1000] the process is something like this: Look at the input: Dot[m1, m2, m3, m4, m5, ......m1000] Evaluate the first matrix product, m12=m1.m2 Look at the input: Dot[m12, m3, m4, m5, ......m1000] Evaluate the first matrix product, m123=m12.m3 Look at the input: Dot[m123, m4, ...


4

cm = ToeplitzMatrix[{c0, c1, c2, c3}, RotateRight[Reverse[{c0, c1, c2, c3}]]]; cm // MatrixForm


4

Reverse /@ Partition[ {c1, c2, c3, c0}, 4, 1, {1, 1}, {c1, c2, c3, c0}] Edit or more simple : Reverse /@ Partition[{c1, c2, c3, c0}, 4, 1, {1, 1}]


3

Array size/shape agnostic, takes care of edge cases automagically, call with player identifier, position, and current array, returns changed array: fn = With[{cv = #1, cp = #2, cm = #3}, ReplacePart[cm, Select[Position[cm, cv], ChessboardDistance[#, cp] <= 1 &] -> 0]] &; Use example: fn[a, {5, 3}, mat]


3

Clear[arrayH] arrayH[n_Integer] := Partition[ Flatten[Array[H, {n + 1, n + 1, n + 1, n + 1}, {0, 0, 0, 0}]], (n + 1)^2 ] arrayH[3] Then define an appropriate function H that calculates the value of each item using the indices. By way of example, if you had defined a function: Clear[H] H[i_, j_, k_, l_] := StringJoin @@ (ToString /@ {i, j, k, l}) ...


3

You can't change the arguments inside the function, like you can with a subroutine in other programming languages. Make a local copy, use it, return it: multiQubitize[operator_, totalQubits_] := Module[{optmp = operator}, Do[optmp = KroneckerProduct[optmp, optmp], {i, totalQubits}]; optmp]; A cleaner way is to use Nest: multiQubitize2[operator_, ...


3

The way to answer this generically is via eigenvalues. Set up your matrix and take its eigenvalues: mat = {{r, s}, {s, r}}; Eigenvalues[mat] {r - s, r + s} If either r-s or r+s is greater than 1 (in magnitude) then the system will be unstable. If both are less than one, it will decay to zero. For your values r=0.8 and s=0.32, you have instability, which ...


3

RandomVariate takes the option WorkingPrecision. Any residual artifact can be removed with Chop. testvector = RandomVariate[NormalDistribution[], 5, WorkingPrecision -> 20]; testunitvector = UnitVector[5, 1]; basisrotation = Transpose[RotationMatrix[{testunitvector, testvector}]]; Note that I corrected typo in definition of basisrotation output = ...


3

Do you really need to use ToeplitzMatrix? What about following? MatrixForm@Transpose@NestList[RotateRight, #, Length[#]-1] &@{1, 2, 3, 4}


3

ClearAll[mat, minev] SeedRandom[1] rm = RandomInteger[10, {400, 400, 3}]; mat[t_] := rm.{1, t, t^2}; minev[t_?NumericQ] := Eigenvalues[mat[t], -1]; DiscretePlot[Evaluate[minev[t]], {t, 0, 1, .01}]


3

Start data First let us get some images. I am going to use the MNIST dataset for clarity. (And because I experimented with similar data some time ago.) MNISTdigits = ExampleData[{"MachineLearning", "MNIST"}, "TestData"]; testImages = RandomSample[Cases[MNISTdigits, (im_ -> 0) :> im], 100] Let us convince ourselves that all images have the same ...


2

MapThread[Map[t \[Function] {#1, t}, #2] &, {v, a}]


2

You can achieve the desired result in many ways with Mathematica. Just some variants in addition: MapThread[Thread[{##}] &, {v, a}] Inner[Thread[{#1, #2}] &, v, a, List] g[x_, y_] := Prepend[{#}, y] & /@ x; h[x_, y_] := {y, #} & /@ x; t = Thread[{a, v}]; g @@@ t h @@@ t


2

Here's a quick way to get there, Thread /@ Transpose@{v, a} (* {{{10, 1}, {10, 2}, {10, 3}}, {{11, 4}, {11, 5}, {11, 6}}, {{12, 7}, {12, 8}, {12, 9}}} *) The point here is that Transpose@{v, a} gives {{10, {1, 2, 3}}, {11, {4, 5, 6}}, {12, {7, 8, 9}}}, and you can use Thread on the individual elements.


2

There is probably a better solution, but this should work. Example: a={{1,2,3},{4,5,6},{7,8,9}} v={10,11,12} Thread[List[v[[#]], a[[#]]]] & /@ Range @ Length @ v Alternative: MapThread[Thread[{##}] &, {v, a}] Output: (*{{{10, 1}, {10, 2}, {10, 3}}, {{11, 4}, {11, 5}, {11, 6}}, {{12, 7}, {12, 8}, {12, 9}}}*)


2

Here is the code converted to function + some corrections: function[arrays : {__?ArrayQ}] := Module[{ temp1, temp2, temp3 }, temp1 = Join @@ arrays[[{1, 2}]]; temp2 = Join @@ arrays[[{4, 5}]]; temp3 = Transpose[{ temp1[[;; , 1]], temp1[[;; , 2]] - temp2[[;; 2]] }]; {temp1, temp2, temp3} ] There is no check if appropriate ...


2

With a slight modification of your MinPath function so that it takes a matrix as input ClearAll[MinPathF, nextF] MinPathF[mat_][i_, j_] := MinPathF[mat][i, j] = mat[[i, j]] + Piecewise[{{Min[MinPathF[mat][i + 1, j], MinPathF[mat][i, j + 1]], i < Length[mat] && j < Length[mat[[i]]]}, {MinPathF[mat][i + 1, j], i < ...



Only top voted, non community-wiki answers of a minimum length are eligible