How to set up and minimize a large system of equations to resolve the individual components

Question

I am trying to set up a system of 400*N equations to deconvolute spectral data for four different compounds.

I monitored 400 different wavelengths in N solvents (3 solvents in this case). In order to do this, I want to try to minimize the following function:

$A_{\lambda_i, N_i} - (\epsilon_{1 (\lambda_i, N_i)}C_1 + \epsilon_{2 (\lambda_i, N_i)}C_2 + \epsilon_{3 (\lambda_i, N_i)}C_3 + \epsilon_{4 (\lambda_i, N_i)}C_4 = 0 $

Here $A$ is the absorbance of the spectrum I want to deconvolute at specified wavelength ($\lambda$) in solvent ($N$).
$\epsilon$ is the molar extinction coefficient for each different compound that corresponds to the absorbance at the given wavelength and solvent. Then unknown quantities are $C_1$ to $C_4$

https://drive.google.com/folderview?id=0B5gGZ4-SD7-ZdHFveVY5b2J3OTQ&usp=sharing

My data is organized as follows.

Each row has 5 entries and I have 400 rows one (for each wavelength) [$A \; \epsilon_1 \; \epsilon_2 \; \epsilon_3 \; \epsilon_4$]

Each solvent has a table organized just like this one. How do I used mathematica to set up this system of equations and get the error associated with the minimization? Also, the solution needs to be constrained such that C$_n$ is positive.

Import the data (uploaded on google drive)

phosBB = Import["/home/marco/LatexDocs/analytical/uvvis/PHOS_BB.CSV"];
phosMR = Import["/home/marco/LatexDocs/analytical/uvvis/PHOS_MR.CSV"];
phosPT = Import["/home/marco/LatexDocs/analytical/uvvis/PHOS_PT.CSV"];
phosTB = Import["/home/marco/LatexDocs/analytical/uvvis/PHOS_TB.CSV"];
phosUI = Import["/home/marco/LatexDocs/analytical/uvvis/PHOS_UI.CSV"];

PreProcess data to get rid of headings:

phosBB = Delete[phosBB, 1];
phosMR = Delete[phosMR, 1];
phosPT = Delete[phosPT, 1];
phosTB = Delete[phosTB, 1];
phosUI = Delete[phosUI, 1];

Calculate $\epsilon$ from the known solutions (BB-TB):

\[Epsilon]PhosBB = phosBB[[All, 2]]/concPhosBB;
\[Epsilon]PhosMR = phosMR[[All, 2]]/concPhosMR;
\[Epsilon]PhosPT = phosPT[[All, 2]]/concPhosPT;
\[Epsilon]PhosTB = phosTB[[All, 2]]/concPhosTB;

Setup data table [$A_{unk} \; \epsilon_1 \; \epsilon_2 \; \epsilon_3 \; \epsilon_4$]

phosDataTable = 
  Transpose[{phosUI[[All, 1]], \[Epsilon]PhosBB, \[Epsilon]PhosMR, \[Epsilon]PhosPT, \[Epsilon]PhosTB}];

Answer 1

Import the data and filenames, cull the datasets of information that is not useful:

data = Import /@ FileNames["*.csv"];
filenames = FileNames["*.csv"];
data = data[[All, 2 ;;, {1, 2}]];
ListLinePlot[data, PlotLegends -> filenames]

Looks like PT data was either incorrectly collected or is effectively transparent in the region of interest. The question currently is missing concentration information, so I will assume each standard is 0.1 M just for pedagogical purposes. Convert the standard ordinates to molar absorptivities.

conc = {0.1, 0.1, 0.1, 0.1};
MapIndexed[(data[[#2, All, 2]] /= #1) &, conc];

Now solve the linear system. Here I'm using the definition of the linear lease squares just for fun.

soln = With[{A = data[[1 ;; 4, All, 2]]}, 
  Solve[A.Transpose@A.{c1, c2, c3, c4} == A.data[[5, All, 2]], 
  {c1, c2, c3, c4}]]
(* {{c1 -> 0.059183, c2 -> 0.00586333, c3 -> 0.0171604, c4 -> 0.0195068}} *)

(* Note, I would have liked to replace {c1, c2, c3, c4} with the actual filenames but they are not valid mathematica symbols *)

The above expression can also (should also?) be entered as LeastSquares[Transpose@data[[1 ;; 4, All, 2]], data[[5, All, 2]]] which yields the same result as a list of coefficients rather than a list of rules.

Create the theoretical curve and compare it to the original

theoretical = Transpose[{data[[1, All, 1]], 
   {c1, c2, c3, c4}.data[[1 ;; 4, All, 2]] /. First@soln}];
ListLinePlot[{theoretical, data[[5]]}]

If you are interested in parameter errors, then use LinearModelFit.

lm = LinearModelFit[{Transpose@data[[1 ;; 4, All, 2]], data[[5, All, 2]]}];
lm["ParameterTable"]

Not surprisingly, the third variable, corresponding to PT, has the largest error.

Answer 2

Here is the final result if you are interested.

 data = Import /@ 
   FileNames["/home/marco/LatexDocs/analytical/uvvis/PHOS_*.CSV"];
data = data[[All, 2 ;;, {1, 2}]];
ListLinePlot[data, PlotLegends -> {"BB", "MR", "PT", "TB", "UI"}, 
 AxesLabel -> {Style["wavelength (nm)"  , FontSize -> 16], 
   Style["Absorbance", FontSize -> 16]}, 
 PlotRange -> {{400, 750}, {0, 0.9}}]
concBB = 1.6*10^(-5);
concMR = 37.1  * 10^(-5);
concPT = 31.4 * 10^(-5);
concTB =  21.4 * 10^(-5);
conc = {concBB, concMR, concPT, concTB};
MapIndexed[(data[[#2, All, 2]] /= #1) &, conc];
soln = With[{A = data[[1 ;; 4, All, 2]]}, 
   Solve[A.Transpose@A.{c1, c2, c3, c4} == A.data[[5, All, 2]], {c1, 
     c2, c3, c4}]];

theoretical = 
  Transpose[{data[[1, All, 
      1]], {c1, c2, c3, c4}.data[[1 ;; 4, All, 2]] /. First@soln}];
ListLinePlot[{theoretical, data[[5]]}, 
 AxesLabel -> {Style["wavelength (nm)"  , FontSize -> 16], 
   Style["Absorbance", FontSize -> 16]}]

lm = LinearModelFit[{Transpose@data[[1 ;; 4, All, 2]], 
    data[[5, All, 2]]}];
error1 = Total[(#^2) & @  lm["FitResiduals"]];




data2 = Import /@ 
   FileNames["/home/marco/LatexDocs/analytical/uvvis/CARB_*.CSV"];
data2 = data2[[All, 2 ;;, {1, 2}]];
ListLinePlot[data2, PlotLegends -> {"BB", "MR", "PT", "TB", "UI"}, 
 AxesLabel -> {Style["wavelength (nm)"  , FontSize -> 16], 
   Style["Absorbance", FontSize -> 16]}, 
 PlotRange -> {{400, 750}, {0, 0.9}}]

MapIndexed[(data2[[#2, All, 2]] /= #1) &, conc];
soln2 = With[{A = data2[[1 ;; 4, All, 2]]}, 
   Solve[A.Transpose@A.{c1, c2, c3, c4} == A.data2[[5, All, 2]], {c1, 
     c2, c3, c4}]];

theoretical = 
  Transpose[{data2[[1, All, 
      1]], {c1, c2, c3, c4}.data2[[1 ;; 4, All, 2]] /. First@soln}];
ListLinePlot[{theoretical, data2[[5]]}]
lm2 = LinearModelFit[{Transpose@data2[[1 ;; 4, All, 2]], 
    data2[[5, All, 2]]}];
error2 = Total[(#^2) & @  lm2["FitResiduals"]];

data3 = Import /@ 
   FileNames["/home/marco/LatexDocs/analytical/uvvis/KHP_*.CSV"];
data3 = data3[[All, 2 ;;, {1, 2}]];
ListLinePlot[data3, PlotLegends -> {"BB", "MR", "PT", "TB", "UI"}, 
 AxesLabel -> {Style["wavelength (nm)"  , FontSize -> 16], 
   Style["Absorbance", FontSize -> 16]}, 
 PlotRange -> {{400, 750}, {0, 0.9}}]

MapIndexed[(data3[[#2, All, 2]] /= #1) &, conc];
soln3 = With[{A = data3[[1 ;; 4, All, 2]]}, 
   Solve[A.Transpose@A.{c1, c2, c3, c4} == A.data3[[5, All, 2]], {c1, 
     c2, c3, c4}]];

theoretical = 
  Transpose[{data3[[1, All, 
      1]], {c1, c2, c3, c4}.data3[[1 ;; 4, All, 2]] /. First@soln}];
ListLinePlot[{theoretical, data3[[5]]}, 
 AxesLabel -> {Style["wavelength (nm)"  , FontSize -> 16], 
   Style["Absorbance", FontSize -> 16]}]
lm3 = LinearModelFit[{Transpose@data3[[1 ;; 4, All, 2]], 
    data3[[5, All, 2]]}];
error3 = Total[(#^2) & @  lm3["FitResiduals"]];

dataSummary = {c1, c2, c3, c4} /. {soln, soln2, soln3}
errorSummary = {error1, error2, error3}

Mean Concentration Molar

{{0.000469681, 0.00678397, 0.0169567, 0.0012554}}

Plots: each set of three corresponds to: (spectrum, theoretical, plot of residuals)