PairwiseScatterPlot with histograms along the diagonal

Question

The built-in function PairwiseScatterPlot has been discussed for example here: Scatterplots for subsets of multivariate data [Updated]. However, I find it not very informative to plot the identity function along the diagonal of the matrix of plots: do you guys know how to plot a more informative histogram instead? Also, it is superfluous to plot the entries above the diagonal.

Here is an example:

Needs["StatisticalPlots`"]
Needs["MultivariateStatistics`"]
data = RandomReal[MultinormalDistribution[{0, 0, 0}, {{1, 1/2, -2/3}, {1/2, 5, 2}, {-2/3, 2, 20}}], 10^3];
PairwiseScatterPlot[data, DataTicks -> Automatic, DataLabels -> {"var1", "var2", "var3"}]

UPDATE: I have improved the code a user wrote as a possible solution (unfortunately that user deleted that entry). Basically I have fixed a bug and the labels. Here is what it does:

pspF3 = With[{dt = #, ca = ConstantArray[Null, {#, #} &@Dimensions[#][[2]]],
opts = Sequence[AspectRatio -> 1, Frame -> True]}, 
GraphicsGrid[ReplacePart[ca, {{i_, i_} :> Histogram[dt[[All, i]], Automatic, "PDF", opts, 
     If[i == Dimensions[dt][[2]], FrameLabel -> {"var" <> ToString[i], None}, FrameLabel -> None],
PlotRange -> All, Ticks -> Automatic],
{i_, j_} /; i > j :> ListPlot[dt[[All, {j, i}]], opts,
Which[i == Dimensions[dt][[2]] && j > 1, FrameLabel -> {{None, None}, {"var" <> ToString[j], None}}, i == Dimensions[dt][[2]] && j == 1, FrameLabel -> {{"var" <> ToString[i], None}, {"var" <> ToString[j], None}}, i > 1 && j == 1, FrameLabel -> {{"var" <> ToString[i], None}, {None, None}}, i > j, FrameLabel -> {None, None}],
RotateLabel -> True,PlotRange -> All]}], ImageSize -> 600]] &;
pspF3@data

However, the ticks are not aligned and the labels of the ticks are repeated when not necessary (they should appear only at the very bottom and on the left). Also, the size of the various frames is not constant and ideally there should not be gaps. PairwiseScatterPlot does all this automatically. Can you improve on this solution?

Answer 1

Update 3: Using the function pwScatterPlot from this answer

ClearAll[addHistograms, pwScatterPlot]       
addHistograms = Module[{diag = Diagonal[Partition[Cases[#, {dir_, ___Point} :> dir, All], 
    Round @ PlotRange[#][[1, 2]]]]}, 
 # /. {c : Alternatives @@ diag, p__Point} :> Module[{xy = Cases[{p}, Point[x_] :> x]}, 
   Inset[Histogram[xy[[All, 1]], ChartStyle->c, AspectRatio->1/GoldenRatio, Axes -> False], 
     Min /@ Transpose@xy, {Left, Bottom}, {.9, .9}]]] &; 

Needs["StatisticalPlots`"]
pwScatterPlot = addHistograms @* PairwiseScatterPlot;

To use this function on an input data with n series we need to use an n-by-n matrix of styles where the diagonal entries are different from off-diagonal entries.

data2 = RandomReal[MultinormalDistribution[{0, 1, 2}, 
    {{1, 1/2, 1/3}, {1/2, 2, 1/3}, {1/3, 1/3, 3}}], 10^3];
labels2 = "var" <> ToString[#] & /@ {1, 2, 3};
colors2 = {{Red, Blue, Green}, {Blue, Orange, Magenta}, {Green, Magenta, Purple}};

pwScatterPlot[data2, DataSpacing -> .1, DataTicks -> Automatic, 
   DataLabels -> labels2, ImageSize -> 500, PlotStyle -> colors2]

Original answer:

pspF = With[{dt=#,ca=ConstantArray[1,{#,#}&@Dimensions[#][[2]]],
             opts=Sequence[Axes->False,AspectRatio->1]},
           Grid[ReplacePart[ca, {{i_,i_}:>Histogram[dt[[All,i]],opts],
                {i_,j_}:>ListPlot[dt[[All,{i,j}]],opts]}],
               Dividers->All]]&;

 data1 = RandomReal[MultinormalDistribution[{0, 0}, {{1, 1/2}, {1/2, 1}}], 10^2];
 pspF@data1

data2 = RandomReal[MultinormalDistribution[{0, 0,0}, 
                   {{1, 1/2,1/3}, {1/2, 2,1/3},{1/3,1/3,3}}], 10^3];

pspF@data2

Update 1: Using DensityHistogram with the option Method -> {"DistributionAxes"->True}:

dhF=With[{dt=#,ca=ConstantArray[1,{#,#}&@Dimensions[#][[2]]],
          opts=Sequence[Axes->False,AspectRatio->1]},
       Grid[ReplacePart[ca, {{i_,i_}:>Histogram[dt[[All,i]],opts],
            {i_,j_}:>DensityHistogram[dt[[All,{i,j}]],opts,
                      Frame->False,Method->{"DistributionAxes"->True},
                      ChartElementFunction->"Point"]}],
            Dividers->All]]&; 

data2 = RandomReal[MultinormalDistribution[{0, 0,0},
                   {{1, 1/2,1/3}, {1/2, 2,1/3},{1/3,1/3,3}}], 10^3];

dhF@data2

Note: You can also use "BoxWhisker", "Histogram" or "SmoothHistogram" as the setting for the suboption "DistributionAxes".

Update 2: To include PlotLabels, FrameLabels, FrameTicks etc, add these options to Histogram and/or to ListPlot:

pspF2 = With[{dt = #, ca = ConstantArray[1, {#, #} &@Dimensions[#][[2]]], 
     pr = Through[{Min, Max}[#]], opts = Sequence[AspectRatio -> 1, Frame -> True]}, 
    Grid[ReplacePart[ca, 
        {{i_, i_} :> Histogram[dt[[All, i]], Automatic, "Count", opts, 
         PlotRange -> {pr, Automatic},
         FrameLabel -> {{"Count", None}, {"var" <> ToString[i], None}},
         PlotLabel -> ("var" <> ToString[i])], {i_, j_} :> 
        ListPlot[dt[[All, {i, j}]], opts, PlotRange -> {pr, pr}, 
         FrameLabel -> {{"var" <> ToString[i], None}, {"var" <> ToString[j], None}}, 
         PlotLabel -> ("var" <> ToString[i] <> "     versus   var" <> 
            ToString[j])]}], Dividers -> All]] &;

data2 = RandomReal[MultinormalDistribution[{0, 1, 2}, 
          {{1, 1/2, 1/3}, {1/2, 2, 1/3}, {1/3, 1/3, 3}}], 10^3];

pspF2@data2

Answer 2

Using the function VariableDependenceGrid from the package "MathematicaForPredictionUtilities.m":

data = RandomReal[MultinormalDistribution[{0, 0, 0}, {{1, 1/2, -2/3}, {1/2, 5, 2}, {-2/3, 2, 20}}], 10^3];
Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/MathematicaForPredictionUtilities.m"]
VariableDependenceGrid[data, "var" <> ToString[#] & /@ Range[3]]

(See also this answer.)