From 82338ab3f4584d9a2ca2d85c7f427bd439e01592 Mon Sep 17 00:00:00 2001 From: Jason Christopherson Date: Fri, 28 May 2021 12:51:20 -0500 Subject: [PATCH] Add more data_table functionallity --- src/collections.f90 | 199 ++++++++++++++++++++++++++++++++++++-- src/collections_data.f90 | 111 ++++++++++++++++++--- tests/test_fcore.f90 | 3 + tests/test_fcore_list.f90 | 88 +++++++++++++++++ 4 files changed, 381 insertions(+), 20 deletions(-) diff --git a/src/collections.f90 b/src/collections.f90 index 23050f6..8d64a0f 100644 --- a/src/collections.f90 +++ b/src/collections.f90 @@ -306,13 +306,7 @@ module collections type data_table private !> @brief The data table. - type(container), pointer, dimension(:,:) :: m_table => null() - - ! TO DO: - ! - Figure out how to access entire columns of data without making - ! copies. It would also be nice to access rows in a similar manner, - ! but not a hard requirement. - Use pointers - ! - Figure out how to efficiently access subtables as well - Use pointers + type(container), allocatable, dimension(:,:) :: m_table contains final :: dt_final !> @brief Clears the entire contents of the data_table. @@ -460,6 +454,146 @@ module collections !! number of items as the data_table has columns. !! - FCORE_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. procedure, public :: insert_row => dt_insert_row + !> @brief Inserts a series of columns into the data_table. + !! + !! @par Syntax + !! @code{.f90} + !! subroutine insert_columns(class(data_table) this, integer(int32) cstart, class(*) x(:,:), class(errors) err) + !! @endcode + !! + !! @param[in,out] this The data_table object. + !! @param[in] cstart The index of the column at which the insertion + !! begins. + !! @param[in] x An M-by-N matrix of items to insert into the table. The + !! number of rows (M) must be the same as the number of rows in + !! this table. A copy of each item is made, and the data_table takes + !! care of management of the memory occupied by each copy. + !! @param[in,out] err An optional errors-based object that if provided + !! can be used to retrieve information relating to any errors + !! encountered during execution. If not provided, a default + !! implementation of the errors class is used internally to provide + !! error handling. Possible errors and warning messages that may be + !! encountered are as follows. + !! - FCORE_INDEX_OUT_OF_RANGE_ERROR: Occurs if @p cstart is outside + !! the bounds of the table. + !! - FCORE_ARRAY_SIZE_ERROR: Occurs if @p x does not have the same + !! number of rows as the data_table. + !! - FCORE_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. + procedure, public :: insert_columns => dt_insert_columns + !> @brief Inserts a single column into the data_table. + !! + !! @par Syntax + !! @code{.f90} + !! subroutine insert_column(class(data_table) this, integer(int32) i, class(*) x(:), class(errors) err) + !! @endcode + !! + !! @param[in,out] this The data_table object. + !! @param[in] i The column index where @p x should be inserted into + !! the table. + !! @param[in] x The N-element array where N is equal to the number of + !! rows in this data_table. A copy of each item is made, and the + !! data_table takes care of management of the memory occupied by each + !! copy. + !! @param[in,out] err An optional errors-based object that if provided + !! can be used to retrieve information relating to any errors + !! encountered during execution. If not provided, a default + !! implementation of the errors class is used internally to provide + !! error handling. Possible errors and warning messages that may be + !! encountered are as follows. + !! - FCORE_INDEX_OUT_OF_RANGE_ERROR: Occurs if @p i is outside + !! the bounds of the table. + !! - FCORE_ARRAY_SIZE_ERROR: Occurs if @p x does not have the same + !! number of items as the data_table has rows. + !! - FCORE_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. + procedure, public :: insert_column => dt_insert_column + !> @brief Appends a series of rows onto the end of the table. + !! + !! @par Syntax + !! @code{.f90} + !! subroutine append_rows(class(data_table) this, class(*) x(:,:), class(errors) err) + !! @endcode + !! + !! @param[in,out] this The data_table object. + !! @param[in] x An M-by-N matrix of items to append onto the table. The + !! number of columns (N) must be the same as the number of columns in + !! this table. A copy of each item is made, and the data_table takes + !! care of management of the memory occupied by each copy. + !! @param[in,out] err An optional errors-based object that if provided + !! can be used to retrieve information relating to any errors + !! encountered during execution. If not provided, a default + !! implementation of the errors class is used internally to provide + !! error handling. Possible errors and warning messages that may be + !! encountered are as follows. + !! - FCORE_ARRAY_SIZE_ERROR: Occurs if @p x does not have the same + !! number of columns as the data_table. + !! - FCORE_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. + procedure, public :: append_rows => dt_append_rows + !> @brief Appends a single row onto the end of the data_table. + !! + !! @par Syntax + !! @code{.f90} + !! subroutine append_row(class(data_table) this, class(*) x(:), class(errors) err) + !! @endcode + !! + !! @param[in,out] this The data_table object. + !! @param[in] x The N-element array where N is equal to the number of + !! columns in this data_table. A copy of each item is made, and the + !! data_table takes care of management of the memory occupied by each + !! copy. + !! @param[in,out] err An optional errors-based object that if provided + !! can be used to retrieve information relating to any errors + !! encountered during execution. If not provided, a default + !! implementation of the errors class is used internally to provide + !! error handling. Possible errors and warning messages that may be + !! encountered are as follows. + !! - FCORE_ARRAY_SIZE_ERROR: Occurs if @p x does not have the same + !! number of items as the data_table has columns. + !! - FCORE_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. + procedure, public :: append_row => dt_append_row + !> @brief Appends a series of columns onto the end of the data_table. + !! + !! @par Syntax + !! @code{.f90} + !! subroutine append_columns(class(data_table) this, class(*) x(:,:), class(errors) err) + !! @endcode + !! + !! @param[in,out] this The data_table object. + !! @param[in] x An M-by-N matrix of items to insert into the table. The + !! number of rows (M) must be the same as the number of rows in + !! this table. A copy of each item is made, and the data_table takes + !! care of management of the memory occupied by each copy. + !! @param[in,out] err An optional errors-based object that if provided + !! can be used to retrieve information relating to any errors + !! encountered during execution. If not provided, a default + !! implementation of the errors class is used internally to provide + !! error handling. Possible errors and warning messages that may be + !! encountered are as follows. + !! - FCORE_ARRAY_SIZE_ERROR: Occurs if @p x does not have the same + !! number of rows as the data_table. + !! - FCORE_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. + procedure, public :: append_columns => dt_append_columns + !> @brief Appends a single column onto the end of the data_table. + !! + !! @par Syntax + !! @code{.f90} + !! subroutine append_column(class(data_table) this, class(*) x(:), class(errors) err) + !! @endcode + !! + !! @param[in,out] this The data_table object. + !! @param[in] x The N-element array where N is equal to the number of + !! rows in this data_table. A copy of each item is made, and the + !! data_table takes care of management of the memory occupied by each + !! copy. + !! @param[in,out] err An optional errors-based object that if provided + !! can be used to retrieve information relating to any errors + !! encountered during execution. If not provided, a default + !! implementation of the errors class is used internally to provide + !! error handling. Possible errors and warning messages that may be + !! encountered are as follows. + !! - FCORE_ARRAY_SIZE_ERROR: Occurs if @p x does not have the same + !! number of items as the data_table has rows. + !! - FCORE_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. + procedure, public :: append_column => dt_append_column end type ! ****************************************************************************** @@ -801,6 +935,57 @@ module subroutine dt_insert_row(this, i, x, err) class(*), intent(in), dimension(:) :: x class(errors), intent(inout), optional, target :: err end subroutine + + module subroutine dt_insert_columns(this, cstart, x, err) + class(data_table), intent(inout) :: this + integer(int32), intent(in) :: cstart + class(*), intent(in), dimension(:,:) :: x + class(errors), intent(inout), optional, target :: err + end subroutine + + module subroutine dt_insert_column(this, i, x, err) + class(data_table), intent(inout) :: this + integer(int32), intent(in) :: i + class(*), intent(in), dimension(:) :: x + class(errors), intent(inout), optional, target :: err + end subroutine + + module subroutine dt_append_rows(this, x, err) + class(data_table), intent(inout) :: this + class(*), intent(in), dimension(:,:) :: x + class(errors), intent(inout), optional, target :: err + end subroutine + + module subroutine dt_append_row(this, x, err) + class(data_table), intent(inout) :: this + class(*), intent(in), dimension(:) :: x + class(errors), intent(inout), optional, target :: err + end subroutine + + module subroutine dt_append_columns(this, x, err) + class(data_table), intent(inout) :: this + class(*), intent(in), dimension(:,:) :: x + class(errors), intent(inout), optional, target :: err + end subroutine + + module subroutine dt_append_column(this, x, err) + class(data_table), intent(inout) :: this + class(*), intent(in), dimension(:) :: x + class(errors), intent(inout), optional, target :: err + end subroutine + + + ! TO DO: + ! - append row(s), column(s) + ! - remove row(s), column(s) + ! - get row + ! - get column + ! - get sub-table + ! - get/set column headers + ! - contains + ! - find + ! - index of + ! - sort by column end interface ! ------------------------------------------------------------------------------ diff --git a/src/collections_data.f90 b/src/collections_data.f90 index 1a80999..d314ad6 100644 --- a/src/collections_data.f90 +++ b/src/collections_data.f90 @@ -12,7 +12,7 @@ module subroutine dt_clear(this) integer(int32) :: i, j ! Quick Return - if (.not.associated(this%m_table)) return + if (.not.allocated(this%m_table)) return ! Process do j = 1, size(this%m_table, 2) @@ -23,7 +23,6 @@ module subroutine dt_clear(this) end do end do deallocate(this%m_table) - nullify(this%m_table) end subroutine ! ------------------------------------------------------------------------------ @@ -36,7 +35,7 @@ module subroutine dt_final(this) pure module function dt_get_row_count(this) result(rst) class(data_table), intent(in) :: this integer(int32) :: rst - if (associated(this%m_table)) then + if (allocated(this%m_table)) then rst = size(this%m_table, 1) else rst = 0 @@ -47,7 +46,7 @@ pure module function dt_get_row_count(this) result(rst) pure module function dt_get_column_count(this) result(rst) class(data_table), intent(in) :: this integer(int32) :: rst - if (associated(this%m_table)) then + if (allocated(this%m_table)) then rst = size(this%m_table, 2) else rst = 0 @@ -120,7 +119,7 @@ module function dt_get(this, i, j, err) result(rst) end if ! Quick Return - if (.not.associated(this%m_table)) then + if (.not.allocated(this%m_table)) then nullify(rst) return end if @@ -157,6 +156,7 @@ module subroutine dt_set(this, i, j, x, err) ! Local Variables integer(int32) :: flag + class(*), pointer :: cpy class(errors), pointer :: errmgr type(errors), target :: deferr character(len = 256) :: errmsg @@ -169,7 +169,7 @@ module subroutine dt_set(this, i, j, x, err) end if ! Ensure we've got an array to work with - if (.not.associated(this%m_table)) then + if (.not.allocated(this%m_table)) then call errmgr%report_error("dt_set", "The data table has not " // & "yet been initialized.", FCORE_NULL_REFERENCE_ERROR) return @@ -197,12 +197,13 @@ module subroutine dt_set(this, i, j, x, err) if (associated(this%m_table(i,j)%item)) then deallocate(this%m_table(i,j)%item) end if - allocate(this%m_table(i,j)%item, source = x, stat = flag) + allocate(cpy, source = x, stat = flag) if (flag /= 0) then call errmgr%report_error("dt_set", & "Insufficient memory available.", FCORE_OUT_OF_MEMORY_ERROR) return end if + this%m_table(i, j)%item => cpy end subroutine ! ------------------------------------------------------------------------------ @@ -246,7 +247,7 @@ module subroutine dt_insert_rows(this, rstart, x, err) FCORE_INDEX_OUT_OF_RANGE_ERROR) return end if - if (associated(this%m_table) .and. size(x, 2) /= n) then + if (allocated(this%m_table) .and. size(x, 2) /= n) then write(errmsg, '(AI0AI0A)') "The input data set was expected " // & "to have ", n, " columns, but was found to have ", & size(x, 2), "." @@ -257,7 +258,7 @@ module subroutine dt_insert_rows(this, rstart, x, err) ! If the array is not allocated, allocate and store as the input array ! will define the table structure - if (.not.associated(this%m_table)) then + if (.not.allocated(this%m_table)) then call this%initialize(size(x, 1), size(x, 2), err = errmgr) if (errmgr%has_error_occurred()) return do j = 1, size(x, 2) @@ -332,7 +333,7 @@ module subroutine dt_insert_row(this, i, x, err) end if ! Check the length of x - if (associated(this%m_table) .and. & + if (allocated(this%m_table) .and. & size(x) /= this%get_column_count()) & then write(errmsg, '(AI0AI0A)') "The number of items in the array " // & @@ -388,7 +389,7 @@ module subroutine dt_insert_columns(this, cstart, x, err) FCORE_INDEX_OUT_OF_RANGE_ERROR) return end if - if (associated(this%m_table) .and. size(x, 1) /= m) then + if (allocated(this%m_table) .and. size(x, 1) /= m) then write(errmsg, '(AI0AI0A)') "The input data set was expected " // & "to have ", m, " rows, but was found to have ", & size(x, 1), "." @@ -399,7 +400,7 @@ module subroutine dt_insert_columns(this, cstart, x, err) ! If the array is not allocated, allocate and store as the input array ! will define the table structure - if (.not.associated(this%m_table)) then + if (.not.allocated(this%m_table)) then call this%initialize(size(x, 1), size(x, 2), err = errmgr) if (errmgr%has_error_occurred()) return do j = 1, size(x, 2) @@ -419,7 +420,7 @@ module subroutine dt_insert_columns(this, cstart, x, err) copy = this%m_table deallocate(this%m_table) - allocate(this%m_table(mnew, n), stat = flag) + allocate(this%m_table(m, nnew), stat = flag) if (flag /= 0) then ! Put copy back to m_table, and then handle the error this%m_table = copy @@ -457,6 +458,90 @@ module subroutine dt_insert_columns(this, cstart, x, err) return end subroutine +! ------------------------------------------------------------------------------ + module subroutine dt_insert_column(this, i, x, err) + ! Arguments + class(data_table), intent(inout) :: this + integer(int32), intent(in) :: i + class(*), intent(in), dimension(:) :: x + class(errors), intent(inout), optional, target :: err + + ! Local Variables + class(errors), pointer :: errmgr + type(errors), target :: deferr + character(len = 256) :: errmsg + + ! Set up error handling + if (present(err)) then + errmgr => err + else + errmgr => deferr + end if + + ! Check the length of x + if (allocated(this%m_table) .and. & + size(x) /= this%get_row_count()) & + then + write(errmsg, '(AI0AI0A)') "The number of items in the array " // & + "to insert ,", size(x), ", must match the number of " // & + "rows in the table ", this%get_row_count(), "." + call errmgr%report_error("dt_insert_column", trim(errmsg), & + FCORE_ARRAY_SIZE_ERROR) + return + end if + + ! Insert the array + call this%insert_columns(i, reshape(x, [size(x), 1]), err = errmgr) + end subroutine + +! ------------------------------------------------------------------------------ + module subroutine dt_append_rows(this, x, err) + ! Arguments + class(data_table), intent(inout) :: this + class(*), intent(in), dimension(:,:) :: x + class(errors), intent(inout), optional, target :: err + + ! Process + call this%insert_rows(this%get_row_count() + 1, x, err) + end subroutine + +! ------------------------------------------------------------------------------ + module subroutine dt_append_row(this, x, err) + ! Arguments + class(data_table), intent(inout) :: this + class(*), intent(in), dimension(:) :: x + class(errors), intent(inout), optional, target :: err + + ! Process + call this%insert_row(this%get_row_count() + 1, x, err) + end subroutine + +! ------------------------------------------------------------------------------ + module subroutine dt_append_columns(this, x, err) + ! Arguments + class(data_table), intent(inout) :: this + class(*), intent(in), dimension(:,:) :: x + class(errors), intent(inout), optional, target :: err + + ! Process + call this%insert_columns(this%get_column_count() + 1, x, err) + end subroutine + +! ------------------------------------------------------------------------------ + module subroutine dt_append_column(this, x, err) + ! Arguments + class(data_table), intent(inout) :: this + class(*), intent(in), dimension(:) :: x + class(errors), intent(inout), optional, target :: err + + ! Process + call this%insert_column(this%get_column_count() + 1, x, err) + end subroutine + +! ------------------------------------------------------------------------------ + +! ------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------ diff --git a/tests/test_fcore.f90 b/tests/test_fcore.f90 index b066d82..1667e56 100644 --- a/tests/test_fcore.f90 +++ b/tests/test_fcore.f90 @@ -62,6 +62,9 @@ program main local = test_linked_list_1() if (.not.local) overall = .false. + local = test_data_table_1() + if (.not.local) overall = .false. + ! End if (overall) then print '(A)', "FCORE: ALL TESTS PASSED" diff --git a/tests/test_fcore_list.f90 b/tests/test_fcore_list.f90 index 2757c5e..823438a 100644 --- a/tests/test_fcore_list.f90 +++ b/tests/test_fcore_list.f90 @@ -292,5 +292,93 @@ function test_linked_list_1() result(rst) end select end function +! ------------------------------------------------------------------------------ + function test_data_table_1() result(rst) + ! Arguments + logical :: rst + + ! Parameters + integer(int32), parameter :: nrows = 4 + integer(int32), parameter :: ncols = 8 + + ! Local Variables + type(data_table) :: tbl + integer(int32) :: i, j, k + integer(int32), allocatable :: newrows(:,:), newcols(:,:) + class(*), pointer :: ptr + + ! Initialization + rst = .true. + call tbl%initialize(nrows, ncols) + + ! Check the table size + if (tbl%get_row_count() /= nrows) then + rst = .false. + print '(AI0AI0A)', "TEST_DATA_TABLE_1 (Test 1); Expected:", nrows, & + ", but found: ", tbl%get_row_count(), "." + end if + if (tbl%get_column_count() /= ncols) then + rst = .false. + print '(AI0AI0A)', "TEST_DATA_TABLE_1 (Test 2); Expected: ", & + ncols, ", but found: ", tbl%get_column_count(), "." + end if + + ! Fill the table and check each value + k = 1 + do j = 1, tbl%get_column_count() + do i = 1, tbl%get_row_count() + call tbl%set(i, j, k) + k = k + 1 + end do + end do + + k = 1 + do j = 1, tbl%get_column_count() + do i = 1, tbl%get_row_count() + ptr => tbl%get(i, j) + select type (ptr) + type is (integer(int32)) + if (ptr /= k) then + rst = .false. + print '(AI0AI0AI0AI0A)', & + "TEST_DATA_TABLE_1 (Test 3); Expected: ", k, & + " at (", i, ", ", j, "), but found: ", ptr, "." + end if + k = k + 1 + end select + end do + end do + + ! Add a series of rows + allocate(newrows(5, tbl%get_column_count())) + do j = 1, size(newrows, 2) + do i = 1, size(newrows, 1) + newrows(i,j) = i * j + end do + end do + call tbl%append_rows(newrows) + if (tbl%get_row_count() /= nrows + size(newrows, 1)) then + rst = .false. + print '(AI0AI0A)', "TEST_DATA_TABLE_1 (Test 4); Expected:", & + nrows + size(newrows, 1), & + ", but found: ", tbl%get_row_count(), "." + end if + + ! Add a series of columns + allocate(newcols(tbl%get_row_count(), 5)) + do j = 1, size(newcols, 2) + do i = 1, size(newcols, 1) + newcols(i,j) = i * j + end do + end do + call tbl%insert_columns(ncols / 2, newcols) + if (tbl%get_column_count() /= ncols + size(newcols, 2)) then + rst = .false. + print '(AI0AI0A)', "TEST_DATA_TABLE_1 (Test 5); Expected: ", & + ncols + size(newcols, 2), ", but found: ", & + tbl%get_column_count(), "." + end if + end function + ! ------------------------------------------------------------------------------ end module