diff --git a/src/collections.f90 b/src/collections.f90 index 8d64a0f..ef7cc3e 100644 --- a/src/collections.f90 +++ b/src/collections.f90 @@ -594,6 +594,59 @@ module collections !! 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 + !> @brief Removes a series of rows from the data_table. + !! + !! @par Syntax + !! @code{.f90} + !! subroutine remove_rows(class(data_table) this, integer(int32) rstart, integer(int32) nrows, class(errors) err) + !! @endcode + !! + !! @param[in,out] this The data_table object. + !! @param[in] rstart The row index at which to start removing rows. + !! @param[in] nrows The number of rows to remove (must be greater than + !! 0). + !! @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_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. + !! - FCORE_UNINITIALIZED_OBJECT_ERROR: Occurs if the table has not + !! been initialized. + !! - FCORE_INVALID_INPUT_ERROR: Occurs if @p nrows is less than 1, or + !! if the @p nrows is too large resulting in removing more rows + !! than are available in the table. + !! - FCORE_INDEX_OUT_OF_RANGE_ERROR: Occurs if @p rstart is outside + !! the bounds of the table. + procedure, public :: remove_rows => dt_remove_rows + !> @brief Removes a series of columns from the data_table. + !! + !! @par Syntax + !! @code{.f90} + !! subroutine remove_columns(class(data_table) this, integer(int32) cstart, integer(int32) ncols, class(errors) err) + !! @endcode + !! + !! @param[in,out] this The data_table object. + !! @param[in] cstart The column index at which to start removing + !! columns. + !! @param[in] ncols The number of columns to remove (must be greater + !! than 0). + !! @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_OUT_OF_MEMORY_ERROR: Occurs if there is insufficient memory. + !! - FCORE_UNINITIALIZED_OBJECT_ERROR: Occurs if the table has not + !! been initialized. + !! - FCORE_INVALID_INPUT_ERROR: Occurs if @p ncols is less than 1, or + !! if the @p ncols is too large resulting in removing more columns + !! than are available in the table. + !! - FCORE_INDEX_OUT_OF_RANGE_ERROR: Occurs if @p cstart is outside + !! the bounds of the table. + procedure, public :: remove_columns => dt_remove_columns end type ! ****************************************************************************** @@ -973,11 +1026,21 @@ module subroutine dt_append_column(this, x, err) class(*), intent(in), dimension(:) :: x class(errors), intent(inout), optional, target :: err end subroutine + + module subroutine dt_remove_rows(this, rstart, nrows, err) + class(data_table), intent(inout) :: this + integer(int32), intent(in) :: rstart, nrows + class(errors), intent(inout), optional, target :: err + end subroutine + + module subroutine dt_remove_columns(this, cstart, ncols, err) + class(data_table), intent(inout) :: this + integer(int32), intent(in) :: cstart, ncols + 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 diff --git a/src/collections_data.f90 b/src/collections_data.f90 index d314ad6..54c9f56 100644 --- a/src/collections_data.f90 +++ b/src/collections_data.f90 @@ -539,8 +539,235 @@ module subroutine dt_append_column(this, x, err) end subroutine ! ------------------------------------------------------------------------------ + module subroutine dt_remove_rows(this, rstart, nrows, err) + ! Arguments + class(data_table), intent(inout) :: this + integer(int32), intent(in) :: rstart, nrows + class(errors), intent(inout), optional, target :: err + + ! Local Variables + integer(int32) :: i, j, k, m, n, mnew, flag + type(container), allocatable, dimension(:,:) :: copy + 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 + + ! Initialization + m = this%get_row_count() + n = this%get_column_count() + mnew = m - nrows + + ! Input Check + if (.not.allocated(this%m_table)) then + call errmgr%report_error("dt_remove_rows", & + "The table has not been initialized.", & + FCORE_UNINITIALIZED_OBJECT_ERROR) + return + end if + if (nrows < 1) then + call errmgr%report_error("dt_remove_rows", & + "It is expected that at least 1 row be removed when " // & + "calling this routine.", FCORE_INVALID_INPUT_ERROR) + return + end if + if (rstart < 1) then + call errmgr%report_error("dt_remove_rows", & + "The index of the row(s) to remove must be at least 1.", & + FCORE_INDEX_OUT_OF_RANGE_ERROR) + return + end if + if (mnew < 0) then + write(errmsg, '(AI0AI0A)') "The request to remove ", nrows, & + " exceeds the size of the table (", this%get_row_count(), ")." + call errmgr%report_error("dt_remove_rows", trim(errmsg), & + FCORE_INVALID_INPUT_ERROR) + return + end if + if (rstart > mnew) then + write(errmsg, '(AI0AI0AI0A)') & + "The combination of starting index (", rstart, & + ") and the number of rows to remove (", nrows, & + ") exceeds the number of rows in the current table (", & + this%get_row_count(), ")." + call errmgr%report_error("dt_remove_rows", trim(errmsg), & + FCORE_INDEX_OUT_OF_RANGE_ERROR) + return + end if + + ! Quick Return + if (mnew == 0) then + ! Wipe out the whole table + call this%clear() + return + end if + + ! Create a copy of the table + allocate(copy(m, n), stat = flag) + if (flag /= 0) go to 100 + copy = this%m_table + + deallocate(this%m_table) + allocate(this%m_table(mnew, n), stat = flag) + if (flag /= 0) then + ! Put copy back to m_table, and then handle the error + this%m_table = copy + go to 100 + end if + + ! Copy back the contents into m_table - also be sure to deallocate + ! memory associated with the removed items + do j = 1, n + do i = 1, rstart - 1 + this%m_table(i, j) = copy(i, j) + end do + + k = rstart + do i = 1, nrows + if (associated(this%m_table(k, j)%item)) then + deallocate(this%m_table(k, j)%item) + end if + k = k + 1 + end do + + k = rstart + nrows + do i = rstart, mnew + this%m_table(i, j) = copy(k, j) + k = k + 1 + end do + end do + + return + 100 continue + ! Handle any memory errors + call errmgr%report_error("dt_remove_rows", & + "Insufficient memory available.", FCORE_OUT_OF_MEMORY_ERROR) + return + end subroutine ! ------------------------------------------------------------------------------ + module subroutine dt_remove_columns(this, cstart, ncols, err) + ! Arguments + class(data_table), intent(inout) :: this + integer(int32), intent(in) :: cstart, ncols + class(errors), intent(inout), optional, target :: err + + ! Local Variables + integer(int32) :: i, j, k, m, n, nnew, flag + type(container), allocatable, dimension(:,:) :: copy + 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 + + ! Initialization + m = this%get_row_count() + n = this%get_column_count() + nnew = n - ncols + + ! Input Check + if (.not.allocated(this%m_table)) then + call errmgr%report_error("dt_remove_columns", & + "The table has not been initialized.", & + FCORE_UNINITIALIZED_OBJECT_ERROR) + return + end if + if (ncols < 1) then + call errmgr%report_error("dt_remove_columns", & + "It is expected that at least 1 column be removed " // & + "when calling this routine.", FCORE_INVALID_INPUT_ERROR) + return + end if + if (cstart < 1) then + call errmgr%report_error("dt_remove_columns", & + "The index of the column(s) to remove must be at least 1.", & + FCORE_INDEX_OUT_OF_RANGE_ERROR) + return + end if + if (nnew < 0) then + write(errmsg, '(AI0AI0A)') "The request to remove ", ncols, & + " exceeds the size of the table (", this%get_column_count(), & + ")." + call errmgr%report_error("dt_remove_columns", trim(errmsg), & + FCORE_INVALID_INPUT_ERROR) + return + end if + if (cstart > nnew) then + write(errmsg, '(AI0AI0AI0A)') & + "The combination of starting index (", cstart, & + ") and the number of columns to remove (", ncols, & + ") exceeds the number of columns in the current table (", & + this%get_column_count(), ")." + call errmgr%report_error("dt_remove_columns", trim(errmsg), & + FCORE_INDEX_OUT_OF_RANGE_ERROR) + return + end if + + ! Quick Return + if (nnew == 0) then + ! Wipe out the whole table + call this%clear() + return + end if + + ! Create a copy of the table + allocate(copy(m, n), stat = flag) + if (flag /= 0) go to 100 + copy = this%m_table + + ! Resize the table + deallocate(this%m_table) + 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 + go to 100 + end if + + ! Copy back the contents into m_table - also be sure to deallocate + ! memory associated with the removed items + do j = 1, cstart - 1 + do i = 1, m + this%m_table(i, j) = copy(i, j) + end do + end do + + k = cstart + do j = 1, ncols + do i = 1, m + if (associated(this%m_table(i, k)%item)) then + deallocate(this%m_table(i, k)%item) + end if + end do + k = k + 1 + end do + + do j = cstart, nnew + do i = 1, m + this%m_table(i, j) = copy(i, k) + end do + k = k + 1 + end do + + return + 100 continue + ! Handle any memory errors + call errmgr%report_error("dt_remove_rows", & + "Insufficient memory available.", FCORE_OUT_OF_MEMORY_ERROR) + return + end subroutine ! ------------------------------------------------------------------------------ diff --git a/tests/test_fcore_list.f90 b/tests/test_fcore_list.f90 index 823438a..4c27414 100644 --- a/tests/test_fcore_list.f90 +++ b/tests/test_fcore_list.f90 @@ -378,6 +378,22 @@ function test_data_table_1() result(rst) ncols + size(newcols, 2), ", but found: ", & tbl%get_column_count(), "." end if + + ! Remove a series of rows + call tbl%remove_rows(1, size(newrows, 1)) + if (tbl%get_row_count() /= nrows) then + rst = .false. + print '(AI0AI0A)', "TEST_DATA_TABLE_1 (Test 6); Expected: ", & + nrows, ", but found: ", tbl%get_row_count() + end if + + ! Remove a series of columns + call tbl%remove_columns(1, size(newcols, 2)) + if (tbl%get_column_count() /= ncols) then + rst = .false. + print '(AI0AI0A)', "TEST_DATA_TABLE_1 (Test 7); Expected: ", & + ncols, ", but found: ", tbl%get_column_count() + end if end function ! ------------------------------------------------------------------------------