Wow! What an awesome thing you guys got going on here!

It isn't necessary to click on the Get colour values button. All that is required is to sense the mouse up when the slider is released. Suggestions?

I think that an event handler would be the way to go. They are associated with their respective expression so the "MouseUp" event will only trigger when the mouse is over that expression. So putting one of these on each of the sliders does the trick. However, I don't know if you can directly manipulate the Manipulate sliders. An alternative is to skip the Manipulate function and implement your own sliders. I did that in the attached Notebook.

The code became:

DynamicModule[{saturation = 0.5, r = 1.0, g = 1.0, b = 1.0},
 Column[{
   Labeled[Slider[Dynamic[saturation], {0, 1}], "S: ", Left],
   Labeled[
    EventHandler[
     Slider[Dynamic[r], {0.75, 
       1}], {{"MouseUp", 
        1} :> (AppendTo[valsr, {1 - saturation, r (1 - saturation)}]; 
        r = 1.0; g = 1.0; b = 1.0; saturation = RandomReal[];)}, 
     PassEventsDown -> True], "R: ", Left],
   Labeled[
    EventHandler[
     Slider[Dynamic[g], {0.75, 
       1}], {{"MouseUp", 
        1} :> (AppendTo[valsg, {1 - saturation, g (1 - saturation)}]; 
        r = 1.0; g = 1.0; b = 1.0; saturation = RandomReal[];)}, 
     PassEventsDown -> True], "G: ", Left],
   Labeled[
    EventHandler[
     Slider[Dynamic[b], {0.75, 
       1}], {{"MouseUp", 
        1} :> (AppendTo[valsb, {1 - saturation, b (1 - saturation)}]; 
        r = 1.0; g = 1.0; b = 1.0; saturation = RandomReal[];)}, 
     PassEventsDown -> True], "B: ", Left],
   Row[{Column[{
       Button["Initialise", valsr = {};
        valsg = {}; valsb = {};],
       Button["Draw graphs", drawGraphs[valsr, valsg, valsb]]}],
     Dynamic[(image = 
        ImageData[
         RandomImage[{saturation, 1.0}, {100, 100}, 
          ColorSpace -> "RGB"]]; 
       ImageCompose[Image[image, ImageSize -> 200], 
        Image[Partition[
          Transpose[{r, g, b}*
            Transpose[Flatten[image[[25 ;; 75, 25 ;; 75, All]], 1]]], 
          50], ImageSize -> 200]])]}, Spacer[2]]}]]

Is there a reason why the red slider in your code went from 0 to 1 and all the others went from 0.75 to 1?

Best regards, Patrik

Attachments:

Eric,

How is this for a start?

Doug

tab1 = Table[{x, y}, {x, 100}, {y, 100}];
tab2 = tab1;
For[i = 1, i <= 100, i++, For[j = 1, j <= 100, j++, tab2[[i, j]] = {
    RandomReal[{RandomReal[], 1.0}],
    RandomReal[{RandomReal[], 1.0}],
    RandomReal[{RandomReal[], 1.0}]} ]]

For[i = 47, i <= 53, i++, For[j = 1, j <= 100, j++, tab2[[i, j]] = {
    RandomReal[{RandomReal[], 0.5}],
    RandomReal[{RandomReal[], 1.0}],
    RandomReal[{RandomReal[], 1.0}]} ]]

For[i = 1, i <= 100, i++, For[j = 47, j <= 53, j++, tab2[[i, j]] = {
    RandomReal[{RandomReal[], 0.5}],
    RandomReal[{RandomReal[], 1.0}],
    RandomReal[{RandomReal[], 1.0}]} ]]

Image[tab2, ImageSize -> {500, 500}]

Hi Hedwig,

Which version of Mathematica are you using? I recently bought a new computer to run Windows 11 and also installed version 14.1 of Mathematica. Could this computer be at fault?

I can't run the colorblind test, and it's been almost a decade, so I can't give you much help.

I remember that a datum can be removed by clicking on it in the graph. This is useful because outliers do occur, especially with inexperienced users.

What version of Mathematica are you using?

Eric

Hi,

Is it possible to have the final code? The test disapears when I put the slider and I don't see the graphs. I am ophthalmologist and interessed in a test that might provide more information than an Ishihara test. I realize I'm years behind, but you never know.

Hedwig

Hi Patrik,

Amazing! I also went to StackExchange and found some code that would have required a lot of finagling to accomplish anything.

This might be the final version. I did fix up the Initialize to set the vals to zero instead of empty.

When I said a "small editing menu," I was just leaving room for ideas that haven't yet occurred to me. Nothing comes to mind, though.

Thank you for your help. I'm curious; how did you learn Mathematica?

The slightly modified code is attached.

Eric

Attachments:

Hi Patrik,

Yup, it's really good code!

The constant scintillation wasn't really what I wanted, once I got used to it. The problem before was that you could only really see the inner square at low contrast when the mouse was moving. Here is some code with the Refresh[] image only while the mouse button is down. (In the attachment.)

I removed the inner braces and the 1 in {{"MouseUp", 1} :> (AppendTo[valsr,... What was your intention?

I've been trying all morning to find a way to edit the graphs with a mouse. Especially with the new automatic collection of data at a MouseUp, it's possible to get some erroneous data points. What I'd like to do is have a little editing menu (delete a graph point for now). The Tooltip knows when you are at a point in a ListPlot, but it doesn't return the point. Do you know of a way of accessing the graph like the Tooltip does?

Here is the effect of the scintillation while the mouse button is held down:

You can see the effect by the much smaller scatter in the red graph.

Eric

Attachments:

Hi Patrik and Doug,

Doug, this isn't a test in the sense of Ishihara. It's more like a visual field test.

Patrik, I love your code. Adding constant scintillation was quite easy using Refresh[]. I put the ranges of all sliders back to {0,1} but there isn't really enough room to move them accurately unless you use the alt key trick. Notebook attached.

Eric

Attachments:

Hi Doug,

I see you have a lot of scatter in the red, just like me. Maybe it's inherently hard to discern the square. I was looking through the demonstrations and came across a demo of a disk of random dots moving in a field of random dots. As soon as you stopped moving the disk, it just settled into the background and became invisible. Maybe if the inner square were moving, it would be easier to see. Something to try.

Here is a new, much easier version. I found out how to detect MouseUp events by using TrackingFunction[]. Now all you have to do is detect the inner square and release the mouse button. The three buttons have been turned into Reset buttons. If you aren't happy with one of the graphs, you can delete it and re-do it.

A notebook is attached.

Eric

Attachments:

Hi Doug,

Are we seeing the effect of the yellowing of your lenses in the waviness of your blue and green lines? I should add in my instructions that it's important to go close to the very ends of the saturation, otherwise the curves extrapolate in weird ways.

Are you normally aware of a red deficiency?

Eric

Hello everyone,

Here is a functional app to measure colour blindness.

Instructions

1) Click on Initialise to set the data collection arrays to zero.

2) A random saturation level for the image will be selected. Move one of the r, g, or b sliders until the central square appears. Keep adjusting the slider until the square is just visible. Click on the corresponding Get colour values button.

3) A new random saturation will appear. Continue until you have enough data points to generate smooth graphs.

4) Click on Draw graphs. A new notebook will appear with the graphs, data arrays, and the approximating equation.

5) Examine the graphs for regions that need more data. Go back to the tester and manually set the Saturation slider to the value needed. This can be done by positioning the slider visually so that it is matches the horizontal axis of the region needing data.

Discussion

This app is an implementation of a technique due to Douglas Youvan.

There is a significant improvement that eludes me, so I'm asking for help. It isn't necessary to click on the Get colour values button. All that is required is to sense the mouse up when the slider is released. Suggestions? I know that EventHandler[] is probably the way to go, but how do you relate the MouseUp to a particular slider?

It would be interesting to get some graphs from both normal and colour blind people. There are other types of colour blindness than red/green. (I always thought that my green vision must be defective, too. Not so.)

And suggestions for improvements and other features would be welcome.

A notebook is attached.

Eric

Attachments:

Eric,

Phenomenal! This belongs in a vision book that can display your work.

You are on a roll, so I don't want to divert you. But, could I suggest that you try "ortho" on an image that is invisible because of your deficit?

Although I pass Ishihara, Ortho should pick up images that I can't see either.

Also, I have yet to find any "Daltonization" algorithms.

Doug

Hey Eric,

Before I comment on your recent work, let me upload another program here.

This started at: http://et-al.com/pdf/document3.pdf . Look at Figure 5, panel F and the math that goes with it.

I re-wrote that code in Examples 3 and 4 in my Pseudocolor e-book in 2006: http://youvan.com/Examples/Example_4._Counterfeit_Detection_Based_on_Ink_Color.htm . Here, I've attached "otho 1" which is running in version 10.3. The main thing to note in the code is that on images with homogenous backgrounds the matrix will get identical pixel values and blow up from singularity. That's why you see me adding small random numbers.

I've now uploaded "ortho 2 click", and it is much easier to use. You get to pick three pixels (colors) and then orthonormalize the entire image.

Doug

Attachments:

Hi Doug,

Have you come up with anything? This morning I discovered RandomImage[], and in true MMA style, it's very fast. Instead of a cross in the square, I used a square inside a square. I also found an interesting thing about the saturation (correct term?) of the background image. When it is at full saturation, I can only barely see the interior square when r is at zero.

Here's the code:

        Manipulate[
           (
              imag=ImageData[RandomImage[{saturation,1.0},{100,100},ColorSpace->"RGB"]];
              ImageCompose[Image[imag,ImageSize->200],
              Image[Partition[Transpose[{r,g,b}*Transpose[Flatten[imag[[25;;75,25;;75,All]],1]]],51],ImageSize->200]]
            ),
            {{saturation,0.5},1,0},{{r,1.0},0.0,1.0},{{g,1.0},0.0,1.0},{{b,1.0},0.0,1.0}
        ]

The reason I can see the green and blue so well is that I have lens implants in both eyes. The ophthalmologist showed me a yellow glass lens that he keeps in his office to show his patients how discoloured the lens becomes with age. It took a few months to get over the extreme blueness of my new vision. But I also remembered how blue snow used to look when I was a child.

Eric

Attachments:

Erik,

I've now played with the test. You are better than me with G and B. However, R=0.4 is vivid Cyan to me.

The longer I look at the figure, the less confident I am.

Can you make the figure regenerate even when the sliders are not moving? That would eliminate bad random numbers and give more of an average for that value. Also, it might eliminate this saturation effect by distracting you with new images.

Doug

Hi Doug,

I played around with the colour blind test here: Ishihara. I can't see anything, even the one that red/green colour blinds are supposed to see. My wife could see everything.

Then I tried Color Arrangement Test and was rated as severely colour blind. So I tried it with my sunglasses on and was told I am not colour blind at all! Back to the Ishihara test with the sunglasses and I still couldn't see anything. So the sunglasses do provide some correction.

Here is your code with a manipulate for the red, green, and blue components.

tab1 = Table[{x, y}, {x, 100}, {y, 100}];
tab2 = tab1;
cbTest[r_, g_, b_] := 
  (For[i = 1, i <= 100, i++, 
    For[j = 1, j <= 100, j++, 
     tab2[[i, j]] = {RandomReal[{RandomReal[], 1.0}], 
       RandomReal[{RandomReal[], 1.0}], 
       RandomReal[{RandomReal[], 1.0}]}]]

   For[i = 47, i <= 53, i++, 
    For[j = 1, j <= 100, j++, 
     tab2[[i, j]] = {RandomReal[{RandomReal[], r}], 
       RandomReal[{RandomReal[], g}], RandomReal[{RandomReal[], b}]}]]

   For[i = 1, i <= 100, i++, 
    For[j = 47, j <= 53, j++, 
     tab2[[i, j]] = {RandomReal[{RandomReal[], r}], 
       RandomReal[{RandomReal[], g}], RandomReal[{RandomReal[], b}]}]]

   Image[tab2, ImageSize -> {400, 400}])

Manipulate[cbTest[r, g, b], 
    {{r, 1.0}, 0.0, 1.0}, {{g, 1.0}, 0.0, 1.0}, {{b, 1.0}, 0.0, 1.0}]

I can start to see the cross with red at 0.4 and the others at 1.0, but with my sunglasses on, 0.74

I can start to see the cross with green at 0.875 and the others at 1.0.

I can start to see the cross with blue at 0.833 and the others at 1.0.

Are you colour blind? If so, what values do you get?

See attached notebook for code.

Eric

Attachments: