Skip to main content
replaced http://mathematica.stackexchange.com/ with https://mathematica.stackexchange.com/
Source Link

Here, finally, is the direct analog of newVisibleSpectrum from this answerthis answer, which can be used to replace ColorData["BlackBodySpectrum"].

ChromaticityPlot; (* pre-load internals *)

newBlackBodySpectrum[t_?NumericQ] :=
   With[{planck = 1/((Exp[1.43877696*^7/(# t)] - 1) #^5) &}, 
        XYZColor @@ ({{1.0478112, 0.022886602, -0.050126976}, (* Bradford D65 -> D50 *)
                      {0.029542398, 0.9904844, -0.017049096},
                      {-0.0092344897, 0.015043617, 0.75213163}} .
                     Normalize[planck[Image`ColorOperationsDump`$wavelengths] .
      Image`ColorOperationsDump`tris, #[[2]] &])]

The Bradford chromatic adaptation matrix was needed here since Mathematica assumes a D50 whitepoint for XYZColor[] (see the docs for ColorConvert[]).

Now, 6500 K corresponds to white, as it is supposed to be for D65:

ColorConvert[newBlackBodySpectrum[6500], RGBColor]

Graphics[{newBlackBodySpectrum[6500], Disk[]}]

practically white

Compare:

GraphicsColumn[{DensityPlot[x, {x, 1000, 10000}, {y, 0, 1500}, 
                            AspectRatio -> Automatic, PlotPoints -> {200, 3},
                            ColorFunction -> "BlackBodySpectrum", 
                            ColorFunctionScaling -> False, 
                            PlotLabel -> "BlackBodySpectrum"], 
                DensityPlot[x, {x, 1000, 10000}, {y, 0, 1500}, 
                            AspectRatio -> Automatic, PlotPoints -> {200, 3},
                            ColorFunction -> newBlackBodySpectrum,
                            ColorFunctionScaling -> False,
                            PlotLabel -> "newBlackBodySpectrum"]}]

blackbody spectrum comparison

Here, finally, is the direct analog of newVisibleSpectrum from this answer, which can be used to replace ColorData["BlackBodySpectrum"].

ChromaticityPlot; (* pre-load internals *)

newBlackBodySpectrum[t_?NumericQ] :=
   With[{planck = 1/((Exp[1.43877696*^7/(# t)] - 1) #^5) &}, 
        XYZColor @@ ({{1.0478112, 0.022886602, -0.050126976}, (* Bradford D65 -> D50 *)
                      {0.029542398, 0.9904844, -0.017049096},
                      {-0.0092344897, 0.015043617, 0.75213163}} .
                     Normalize[planck[Image`ColorOperationsDump`$wavelengths] .
      Image`ColorOperationsDump`tris, #[[2]] &])]

The Bradford chromatic adaptation matrix was needed here since Mathematica assumes a D50 whitepoint for XYZColor[] (see the docs for ColorConvert[]).

Now, 6500 K corresponds to white, as it is supposed to be for D65:

ColorConvert[newBlackBodySpectrum[6500], RGBColor]

Graphics[{newBlackBodySpectrum[6500], Disk[]}]

practically white

Compare:

GraphicsColumn[{DensityPlot[x, {x, 1000, 10000}, {y, 0, 1500}, 
                            AspectRatio -> Automatic, PlotPoints -> {200, 3},
                            ColorFunction -> "BlackBodySpectrum", 
                            ColorFunctionScaling -> False, 
                            PlotLabel -> "BlackBodySpectrum"], 
                DensityPlot[x, {x, 1000, 10000}, {y, 0, 1500}, 
                            AspectRatio -> Automatic, PlotPoints -> {200, 3},
                            ColorFunction -> newBlackBodySpectrum,
                            ColorFunctionScaling -> False,
                            PlotLabel -> "newBlackBodySpectrum"]}]

blackbody spectrum comparison

Here, finally, is the direct analog of newVisibleSpectrum from this answer, which can be used to replace ColorData["BlackBodySpectrum"].

ChromaticityPlot; (* pre-load internals *)

newBlackBodySpectrum[t_?NumericQ] :=
   With[{planck = 1/((Exp[1.43877696*^7/(# t)] - 1) #^5) &}, 
        XYZColor @@ ({{1.0478112, 0.022886602, -0.050126976}, (* Bradford D65 -> D50 *)
                      {0.029542398, 0.9904844, -0.017049096},
                      {-0.0092344897, 0.015043617, 0.75213163}} .
                     Normalize[planck[Image`ColorOperationsDump`$wavelengths] .
      Image`ColorOperationsDump`tris, #[[2]] &])]

The Bradford chromatic adaptation matrix was needed here since Mathematica assumes a D50 whitepoint for XYZColor[] (see the docs for ColorConvert[]).

Now, 6500 K corresponds to white, as it is supposed to be for D65:

ColorConvert[newBlackBodySpectrum[6500], RGBColor]

Graphics[{newBlackBodySpectrum[6500], Disk[]}]

practically white

Compare:

GraphicsColumn[{DensityPlot[x, {x, 1000, 10000}, {y, 0, 1500}, 
                            AspectRatio -> Automatic, PlotPoints -> {200, 3},
                            ColorFunction -> "BlackBodySpectrum", 
                            ColorFunctionScaling -> False, 
                            PlotLabel -> "BlackBodySpectrum"], 
                DensityPlot[x, {x, 1000, 10000}, {y, 0, 1500}, 
                            AspectRatio -> Automatic, PlotPoints -> {200, 3},
                            ColorFunction -> newBlackBodySpectrum,
                            ColorFunctionScaling -> False,
                            PlotLabel -> "newBlackBodySpectrum"]}]

blackbody spectrum comparison

Source Link

Here, finally, is the direct analog of newVisibleSpectrum from this answer, which can be used to replace ColorData["BlackBodySpectrum"].

ChromaticityPlot; (* pre-load internals *)

newBlackBodySpectrum[t_?NumericQ] :=
   With[{planck = 1/((Exp[1.43877696*^7/(# t)] - 1) #^5) &}, 
        XYZColor @@ ({{1.0478112, 0.022886602, -0.050126976}, (* Bradford D65 -> D50 *)
                      {0.029542398, 0.9904844, -0.017049096},
                      {-0.0092344897, 0.015043617, 0.75213163}} .
                     Normalize[planck[Image`ColorOperationsDump`$wavelengths] .
      Image`ColorOperationsDump`tris, #[[2]] &])]

The Bradford chromatic adaptation matrix was needed here since Mathematica assumes a D50 whitepoint for XYZColor[] (see the docs for ColorConvert[]).

Now, 6500 K corresponds to white, as it is supposed to be for D65:

ColorConvert[newBlackBodySpectrum[6500], RGBColor]

Graphics[{newBlackBodySpectrum[6500], Disk[]}]

practically white

Compare:

GraphicsColumn[{DensityPlot[x, {x, 1000, 10000}, {y, 0, 1500}, 
                            AspectRatio -> Automatic, PlotPoints -> {200, 3},
                            ColorFunction -> "BlackBodySpectrum", 
                            ColorFunctionScaling -> False, 
                            PlotLabel -> "BlackBodySpectrum"], 
                DensityPlot[x, {x, 1000, 10000}, {y, 0, 1500}, 
                            AspectRatio -> Automatic, PlotPoints -> {200, 3},
                            ColorFunction -> newBlackBodySpectrum,
                            ColorFunctionScaling -> False,
                            PlotLabel -> "newBlackBodySpectrum"]}]

blackbody spectrum comparison