Ensure the actual dropout rate == requested dropout rate in most cases

Author: milancurcic

src/nf/nf_dropout_layer_submodule.f90

@@ -1,4 +1,5 @@
 submodule (nf_dropout_layer) nf_dropout_layer_submodule
+  use nf_random, only: shuffle
   !! This submodule implements the procedures defined in the
   !! nf_dropout_layer module.
 
@@ -37,12 +38,13 @@ module subroutine forward(self, input)
     ! Generate random mask for dropout, training mode only
     if (self % training) then
 
-      call random_number(self % mask)
-      where (self % mask < self % dropout_rate)
-        self % mask = 0
-      elsewhere
-        self % mask = 1
-      end where
+      ! Set the first dropout_rate number of elements to 0, the rest to 1,
+      ! and shuffle. Note that the selection of the elements rounds down to
+      ! the nearest integer, so in cases where size(input) * dropout_rate is
+      ! not an integer, the actual dropout rate will be slightly lower.
+      self % mask = 1
+      self % mask(:int(size(self % mask) * self % dropout_rate)) = 0
+      call shuffle(self % mask)
 
       ! Scale factor to preserve the input sum
       self % scale = sum(input) / sum(input * self % mask)

src/nf/nf_random.f90

@@ -1,12 +1,12 @@
 module nf_random
 
-  !! Provides a random number generator with
-  !! normal distribution, centered on zero.
+  !! Provides a random number generator with normal distribution,
+  !! centered on zero, and a Fisher-Yates shuffle.
 
   implicit none
 
   private
-  public :: random_normal
+  public :: random_normal, shuffle
 
   real, parameter :: pi = 4 * atan(1.d0)
 
@@ -23,4 +23,22 @@ impure elemental subroutine random_normal(x)
     x = sqrt(- 2 * log(u(1))) * cos(2 * pi * u(2))
   end subroutine random_normal
 
+
+  subroutine shuffle(x)
+    !! Fisher-Yates shuffle.
+    real, intent(in out) :: x(:)
+      !! Array to shuffle
+    integer :: i, j
+    real :: r, temp
+
+    do i = size(x), 2, -1
+      call random_number(r)
+      j = floor(r * i) + 1
+      temp = x(i)
+      x(i) = x(j)
+      x(j) = temp
+    end do
+
+  end subroutine shuffle
+
 end module nf_random

test/test_dropout_layer.f90

@@ -75,6 +75,40 @@ program test_dropout_layer
 
   end select
 
+  ! Test that the generated dropout mask matches the requested dropout rate.
+  test_mask: block
+    integer, parameter :: input_sizes(3) = [10, 100, 1000]
+    real, parameter :: dropout_rates(5) = [0., 0.2, 0.5, 0.8, 1.]
+    real, allocatable :: input_data(:)
+    integer :: i, j
+
+    do i = 1, size(input_sizes)
+      do j = 1, size(dropout_rates)
+
+        net = network([ &
+          input(input_sizes(i)), &
+          dropout(dropout_rates(j)) &
+        ])
+
+        if (allocated(input_data)) deallocate(input_data)
+        allocate(input_data(input_sizes(i)))
+        call random_number(input_data)
+
+        call net % forward(input_data)
+
+        select type(layer1_p => net % layers(2) % p)
+          type is(dropout_layer)
+            if (abs(sum(layer1_p % mask) / size(layer1_p % mask) - (1 - dropout_rates(j))) > 1e-6) then
+              ok = .false.
+              write(stderr, '(a)') 'actual dropout rate is equal to requested.. failed'
+            end if
+        end select
+      end do
+    end do
+
+  end block test_mask
+
+
   ! Now we're gonna run the forward pass and check that the dropout indeed
   ! drops according to the requested dropout rate.
   forward_pass: block